Just goofing around as usual.  

Screen _NewImage(800, 600, 32)

_Limit 2000

Do

    tilt = 1

    r = 50

    g = 100

    b = 50

    For t = 1 To 200000 Step .01

        If t / 60 = Int(t / 60) Then

            If tilt < 12 Then

                tilt = tilt + .005

                g = g + .025

            Else

                tilt = tilt + 1

            End If

        End If



        seconds = (t - 60)

        s = (60 - seconds) * 6 + 180

        x = Int(Sin(s / 180 * 3.141592) * 125) + 250

        y = Int(Cos(s / 180 * 3.141592) * 125) / tilt + 300



        PSet (x, y), _RGB32(r, g, b)

        PSet (x + 300, y), _RGB32(r, g, b)

    Next t



    tilt = 1

    r = 100

    g = 50

    b = 50

    For t = 1 To 200000 Step .01

        If t / 60 = Int(t / 60) Then

            If tilt < 12 Then

                tilt = tilt + .005

                r = r + .025

            Else

                tilt = tilt + 1

            End If

        End If



        seconds = (t - 60)

        s = (60 - seconds) * 6 + 180

        x = Int(Sin(s / 180 * 3.141592) * 125) / tilt + 250

        y = Int(Cos(s / 180 * 3.141592) * 125) + 300



        PSet (x, y), _RGB32(r, g, b)

        PSet (x + 300, y), _RGB32(r, g, b)

    Next t

Loop Until InKey$ = Chr$(27)

I'd posted this information back at the old forums back in 2019 and I'd thought that I'd copied it over here for everyone, but I couldn't find it.  Here is everything you ever wanted to know about RND and RANDOMIZE. 

First, a link to the original I posted: https://qb64forum.alephc.xyz/index.php?t...#msg105988

Then a quick copy of the info in case that site ever goes down for whatever reason:

Hey all. I know _CLEARCOLOR can be used multiple times if you want more than one color transparent, but is there a way to -quickly- copy only pixels of a given color to another image? This would need to be fast, like for animation. I think a command like "_CLEARCOLOR ExceptColor~&" would be useful for this. Or do we just have to compare POINT for every pixel?

This program deals with dithering. The program loads the file ara.png and then displays it using internal dithering (LoadImage with parameter 256), then better (LoadImage with parameter 257), then displays the original 32 bit version and finally performs Floyd Stenberg's own (slow) dithering method with the MedianCut method, but the own version is really very slow. I don't intend to speed it up - I think LoadImage with parameter 257 returns super fast output with acceptable color rendition.

' ====================================================================================================

' QB64PE Dithering with Median Cut palette (Floyd-Steinberg); extremly SLOW, but best graphical output

' ====================================================================================================



DefInt A-Z



Type BoxRange

    startIndex As Long

    endIndex As Long

    minR As Long

    maxR As Long

    minG As Long

    maxG As Long

    minB As Long

    maxB As Long

End Type



' Globální proměnné pro QuickSort a Median Cut

Dim Shared compareComponent As Long

Dim Shared srcR, srcG, srcB As Long

Dim Shared Boxes As BoxRange





' =============================================================================

'                          Hlavní program

' =============================================================================

Screen 0

Cls

_FullScreen

Dim sourceImg As Long, targetImg As Long

Dim w As Long, h As Long



' Load 32bit image

Dim As String SourceImage32

SourceImage32 = "ara.png"



sourceImg = _LoadImage(SourceImage32, 32)

If sourceImg = 0 Then

    Print "Error loading 32bit image!"

    Sleep 2

    End

End If



image8QB64PE = _LoadImage(SourceImage32, 256)

Screen image8QB64PE

Print "QB64PE: LoadImage 256 dithering. Press any key to continue..."

Sleep

Screen 0

_Delay .5

_FreeImage image8QB64PE

image8QB64PE = _LoadImage(SourceImage32, 257)

Screen image8QB64PE

Print "QB64PE: LoadImage 257 dithering. Press any key to continue..."

Sleep





w = _Width(sourceImg)

h = _Height(sourceImg)



' Vytvoř 8bitový cílový obrázek (paleta 256 barev)

' Create 8bit target image (palette 256 colors)

targetImg = _NewImage(w, h, 256)



' Přepni se na zdrojový 32bitový screen, abys mohl(a) číst pixelová data

' Show 32bit image

Screen sourceImg

Print "Original 32bit image..."



' --- 1) Uložit zdrojové barvy do polí (pro dithering) pouzijeme SINGLE ---

' --- 2) save source colors to arrays for dithering (Single type)

ReDim Shared dataR!(0 To w - 1, 0 To h - 1)

ReDim Shared dataG!(0 To w - 1, 0 To h - 1)

ReDim Shared dataB!(0 To w - 1, 0 To h - 1)



' --- 2) Uložit barvy do polí pro Median Cut (0..255, typ LONG) ---

' --- 2) save colors to arrays for Median Cut (0 to 255, LONG type)

ReDim Shared srcR(0 To w * h - 1) As Long

ReDim Shared srcG(0 To w * h - 1) As Long

ReDim Shared srcB(0 To w * h - 1) As Long

ReDim Shared Boxes(0 To 0) As BoxRange



'Print "Načítám barvy do paměti..."

'Print "Loading 32bit colors to RAM..."

Dim p As Long: p = 0

Dim x As Long, y As Long

Dim c As _Unsigned Long

Dim rByte As _Unsigned _Byte, gByte As _Unsigned _Byte, bByte As _Unsigned _Byte



Dim m As _MEM

m = _MemImage(sourceImg)

c = 0

x = 0: y = 0



Do While c < m.SIZE

    bByte = _MemGet(m, m.OFFSET + c, _Unsigned _Byte)

    gByte = _MemGet(m, m.OFFSET + c + 1, _Unsigned _Byte)

    rByte = _MemGet(m, m.OFFSET + c + 2, _Unsigned _Byte)



    ' Uložíme do Single polí pro dithering:

    ' Save image colors to arrays for dithering

    dataR!(x, y) = rByte

    dataG!(x, y) = gByte

    dataB!(x, y) = bByte



    ' Uložíme do polí pro Median Cut:

    ' Save image colors for Median Cut

    srcR(p) = rByte

    srcG(p) = gByte

    srcB(p) = bByte

    p = p + 1



    x = x + 1

    If x = w Then

        x = 0

        y = y + 1

    End If

    c = c + 4

Loop



' --- 3) Vytvořit 256barevnou paletu metodou Median Cut ---

' --- 3) Build 256 colors palette with Median Cut method

Dim PalR(255) As Long, PalG(255) As Long, PalB(255) As Long

BuildPaletteMedianCut srcR(), srcG(), srcB(), w * h, 256, PalR(), PalG(), PalB()



' Nastavit vytvořenou paletu do cílového 8bitového obrazu

' Set 8 bit created palette to target 8bit image

Dim i As Long

For i = 0 To 255

    _PaletteColor i, _RGB32(PalR(i), PalG(i), PalB(i)), targetImg

Next i



' --- 4) Floyd-Steinberg dithering ---

'Print "Provádím Floyd-Steinberg dithering..."

'Print "Processing Floyd-Steinberg dithering..."



FloydSteinbergDither dataR!(), dataG!(), dataB!(), w, h, PalR(), PalG(), PalB(), targetImg



' --- Zobrazit výsledek ---

Screen targetImg

Print "Hotovo!"

Print "Done! - own dithering"

Sleep



' =============================================================================

'                          SUBs and FUNCTIONs

' =============================================================================



' ========================================================================

' SUB BuildPaletteMedianCut

' Vytvoří paletu 256 barev metodou Median Cut ze zdrojových polí (srcR, srcG, srcB)

' Create palette in 256 colors unsing Median Cut method from arrays srcR, srcG, srcB

' ========================================================================





Sub BuildPaletteMedianCut (sourceR() As Long, sourceG() As Long, sourceB() As Long, totalPixels As Long, desiredColors As Long, paletteR() As Long, paletteG() As Long, paletteB() As Long)

    ' 1) Připrav pole indexů všech pixelů

    ' 2) Create indexes array all pixels



    ReDim pixelIndices(totalPixels - 1) As Long

    Dim i As Long

    For i = 0 To totalPixels - 1

        pixelIndices(i) = i

    Next i



    ' 2) Najdi celkové min/max R, G, B

    ' find total min/maX R,G,B

    Dim minValR As Long, maxValR As Long

    Dim minValG As Long, maxValG As Long

    Dim minValB As Long, maxValB As Long

    minValR = 255: maxValR = 0

    minValG = 255: maxValG = 0

    minValB = 255: maxValB = 0



    Dim ir As Long, ig As Long, ib As Long

    For i = 0 To totalPixels - 1

        ir = sourceR(i)

        ig = sourceG(i)

        ib = sourceB(i)

        If ir < minValR Then minValR = ir

        If ir > maxValR Then maxValR = ir

        If ig < minValG Then minValG = ig

        If ig > maxValG Then maxValG = ig

        If ib < minValB Then minValB = ib

        If ib > maxValB Then maxValB = ib

    Next i



    ' 3) První box - celý rozsah

    ' first box - complete range

    ReDim Boxes(0) As BoxRange

    Boxes(0).startIndex = 0

    Boxes(0).endIndex = totalPixels - 1

    Boxes(0).minR = minValR

    Boxes(0).maxR = maxValR

    Boxes(0).minG = minValG

    Boxes(0).maxG = maxValG

    Boxes(0).minB = minValB

    Boxes(0).maxB = maxValB



    Dim boxCount As Long: boxCount = 1

    Dim largestBoxIndex As Long, largestDimension As Long



    ' 4) Rozdělení boxů

    ' boxes distribution

    Do While boxCount < desiredColors

        largestBoxIndex = -1

        largestDimension = -1

        Dim idxBox As Long

        For idxBox = 0 To boxCount - 1

            Dim rSize As Long, gSize As Long, bSize As Long

            rSize = Boxes(idxBox).maxR - Boxes(idxBox).minR

            gSize = Boxes(idxBox).maxG - Boxes(idxBox).minG

            bSize = Boxes(idxBox).maxB - Boxes(idxBox).minB

            Dim maxDim As Long: maxDim = rSize

            If gSize > maxDim Then maxDim = gSize

            If bSize > maxDim Then maxDim = bSize

            If maxDim > largestDimension Then

                largestDimension = maxDim

                largestBoxIndex = idxBox

            End If

        Next idxBox



        If largestBoxIndex < 0 Then Exit Do



        Dim b As BoxRange

        b = Boxes(largestBoxIndex)



        ' Určení, podle které složky třídit

        ' Determine which folder to sort by

        Dim dimR As Long, dimG As Long, dimB As Long

        dimR = b.maxR - b.minR

        dimG = b.maxG - b.minG

        dimB = b.maxB - b.minB

        If dimR >= dimG And dimR >= dimB Then

            compareComponent = 0

        ElseIf dimG >= dimR And dimG >= dimB Then

            compareComponent = 1

        Else

            compareComponent = 2

        End If



        ' Setřiď pixelIndices v rozsahu boxu

        ' Sort pixelIndices in box range



        QuickSortIndices pixelIndices(), b.startIndex, b.endIndex



        ' Rozdělení boxu na dvě části

        ' Dividing the box into two parts

        Dim middle As Long: middle = (b.startIndex + b.endIndex) \ 2

        Dim box1 As BoxRange, box2 As BoxRange

        box1.startIndex = b.startIndex

        box1.endIndex = middle

        box2.startIndex = middle + 1

        box2.endIndex = b.endIndex



        ' Výpočet min/max pro box1

        ' Calculate min/max for box1



        Dim j As Long

        Dim rr As Long, gg As Long, bb As Long

        Dim minr As Long, maxr As Long, ming As Long, maxg As Long, minb As Long, maxb As Long

        minr = 255: maxr = 0: ming = 255: maxg = 0: minb = 255: maxb = 0

        For j = box1.startIndex To box1.endIndex

            idxBox = pixelIndices(j)

            rr = sourceR(idxBox)

            gg = sourceG(idxBox)

            bb = sourceB(idxBox)

            If rr < minr Then minr = rr

            If rr > maxr Then maxr = rr

            If gg < ming Then ming = gg

            If gg > maxg Then maxg = gg

            If bb < minb Then minb = bb

            If bb > maxb Then maxb = bb

        Next j

        box1.minR = minr: box1.maxR = maxr

        box1.minG = ming: box1.maxG = maxg

        box1.minB = minb: box1.maxB = maxb



        ' Výpočet min/max pro box2

        ' Calculate min/max for box2



        minr = 255: maxr = 0: ming = 255: maxg = 0: minb = 255: maxb = 0

        For j = box2.startIndex To box2.endIndex

            idxBox = pixelIndices(j)

            rr = sourceR(idxBox)

            gg = sourceG(idxBox)

            bb = sourceB(idxBox)

            If rr < minr Then minr = rr

            If rr > maxr Then maxr = rr

            If gg < ming Then ming = gg

            If gg > maxg Then maxg = gg

            If bb < minb Then minb = bb

            If bb > maxb Then maxb = bb

        Next j

        box2.minR = minr: box2.maxR = maxr

        box2.minG = ming: box2.maxG = maxg

        box2.minB = minb: box2.maxB = maxb



        ' Nahrazení původního boxu a přidání druhého

        ' Replacing the original box and adding a second one



        Boxes(largestBoxIndex) = box1

        ReDim _Preserve Boxes(boxCount) As BoxRange

        Boxes(boxCount) = box2

        boxCount = boxCount + 1

        If boxCount >= desiredColors Then Exit Do

    Loop



    ' 5) Pro každý box vypočítat průměrnou barvu a uložit do palety

    ' 5) Calculate the average color for each box and save it to the palette



    Dim cIndex As Long: cIndex = 0

    Dim sumR As Long, sumG As Long, sumB As Long, count As Long

    For i = 0 To boxCount - 1

        sumR = 0: sumG = 0: sumB = 0

        count = Boxes(i).endIndex - Boxes(i).startIndex + 1

        If count < 1 Then

            paletteR(cIndex) = 0: paletteG(cIndex) = 0: paletteB(cIndex) = 0

            cIndex = cIndex + 1

            If cIndex > 255 Then Exit For

        Else

            For j = Boxes(i).startIndex To Boxes(i).endIndex

                idxBox = pixelIndices(j)

                sumR = sumR + sourceR(idxBox)

                sumG = sumG + sourceG(idxBox)

                sumB = sumB + sourceB(idxBox)

            Next j

            paletteR(cIndex) = sumR \ count

            paletteG(cIndex) = sumG \ count

            paletteB(cIndex) = sumB \ count

            cIndex = cIndex + 1

            If cIndex > 255 Then Exit For

        End If

    Next i



    ' Doplnění zbylých barev nulou

    ' Fill remaining colors with zero



    Dim fillColor As Long

    For fillColor = cIndex To 255

        paletteR(fillColor) = 0

        paletteG(fillColor) = 0

        paletteB(fillColor) = 0

    Next fillColor

End Sub



' ========================================================================

' SUB FloydSteinbergDither

' Provádí Floyd-Steinberg dithering – používá dataR!(), dataG!(), dataB!() jako SINGLE

' ========================================================================

Sub FloydSteinbergDither (dataR() As Single, dataG() As Single, dataB() As Single, w As Long, h As Long, paletteR() As Long, paletteG() As Long, paletteB() As Long, targetHandle As Long)

    Screen targetHandle

    Dim x As Long, y As Long



    ' Deklarace proměnných jako SINGLE

    Dim oldR!, oldG!, oldB!

    Dim newR!, newG!, newB!

    Dim errR!, errG!, errB!

    Dim idx As Long



    For y = 0 To h - 1

        For x = 0 To w - 1

            oldR! = dataR!(x, y)

            oldG! = dataG!(x, y)

            oldB! = dataB!(x, y)



            idx = FindNearestColorIndex%(oldR!, oldG!, oldB!, paletteR(), paletteG(), paletteB())



            ' Vykreslíme paletový index

            ' Draw palette index

            PSet (x, y), idx



            newR! = paletteR(idx)

            newG! = paletteG(idx)

            newB! = paletteB(idx)



            errR! = oldR! - newR!

            errG! = oldG! - newG!

            errB! = oldB! - newB!



            ' Rozdistribuování chyby

            ' distribute colors error

            If (x + 1) < w Then

                dataR!(x + 1, y) = dataR!(x + 1, y) + errR! * (7.0! / 16.0!)

                dataG!(x + 1, y) = dataG!(x + 1, y) + errG! * (7.0! / 16.0!)

                dataB!(x + 1, y) = dataB!(x + 1, y) + errB! * (7.0! / 16.0!)

            End If

            If (x - 1) >= 0 And (y + 1) < h Then

                dataR!(x - 1, y + 1) = dataR!(x - 1, y + 1) + errR! * (3.0! / 16.0!)

                dataG!(x - 1, y + 1) = dataG!(x - 1, y + 1) + errG! * (3.0! / 16.0!)

                dataB!(x - 1, y + 1) = dataB!(x - 1, y + 1) + errB! * (3.0! / 16.0!)

            End If

            If (y + 1) < h Then

                dataR!(x, y + 1) = dataR!(x, y + 1) + errR! * (5.0! / 16.0!)

                dataG!(x, y + 1) = dataG!(x, y + 1) + errG! * (5.0! / 16.0!)

                dataB!(x, y + 1) = dataB!(x, y + 1) + errB! * (5.0! / 16.0!)

            End If

            If (x + 1) < w And (y + 1) < h Then

                dataR!(x + 1, y + 1) = dataR!(x + 1, y + 1) + errR! * (1.0! / 16.0!)

                dataG!(x + 1, y + 1) = dataG!(x + 1, y + 1) + errG! * (1.0! / 16.0!)

                dataB!(x + 1, y + 1) = dataB!(x + 1, y + 1) + errB! * (1.0! / 16.0!)

            End If

        Next x

    Next y

End Sub



' ========================================================================

' FUNCTION FindNearestColorIndex%

' Vrací index paletové barvy, která je nejblíže zadaným hodnotám (r, g, b)

' Returns the index of the palette color that is closest to the specified values ??(r, g, b)

' ========================================================================

Function FindNearestColorIndex% (r!, g!, b!, paletteR() As Long, paletteG() As Long, paletteB() As Long)

    Dim bestIndex As Long, i As Long

    Dim bestDist As Single

    bestDist! = 1E+20



    For i = 0 To 255

        Dim dr!, dg!, db!, dist!

        dr! = r! - paletteR(i)

        dg! = g! - paletteG(i)

        db! = b! - paletteB(i)

        dist! = dr! * dr! + dg! * dg! + db! * db!

        If dist! < bestDist! Then

            bestDist! = dist!

            bestIndex = i

        End If

    Next i



    FindNearestColorIndex% = bestIndex

End Function



' ========================================================================

' SUB QuickSortIndices

' Rychlé řazení pole indexů podle hodnoty pixelu (podle compareComponent)

' Quickly sort an array of indices by pixel value (by compareComponent)

' ========================================================================

Sub QuickSortIndices (arr() As Long, left As Long, right As Long)

    If left >= right Then Exit Sub



    Dim pivot As Long

    pivot = arr((left + right) \ 2)



    Dim i As Long, j As Long

    i = left: j = right



    Do

        Do While ComparePixels(arr(i), pivot) < 0

            i = i + 1

        Loop

        Do While ComparePixels(arr(j), pivot) > 0

            j = j - 1

        Loop



        If i <= j Then

            Dim t As Long

            t = arr(i)

            arr(i) = arr(j)

            arr(j) = t

            i = i + 1

            j = j - 1

        End If

    Loop While i <= j



    If left < j Then QuickSortIndices arr(), left, j

    If i < right Then QuickSortIndices arr(), i, right

End Sub



' ========================================================================

' FUNCTION ComparePixels&

' Porovná dva pixely (indexy v srcR(), srcG(), srcB()) podle nastavené složky (R/G/B)

' Compares two pixels (indexes in srcR(), srcG(), srcB()) according to the set component (R/G/B)

' ========================================================================

Function ComparePixels& (idxA As Long, idxB As Long)

    Select Case compareComponent

        Case 0: ComparePixels& = srcR(idxA) - srcR(idxB)

        Case 1: ComparePixels& = srcG(idxA) - srcG(idxB)

        Case 2: ComparePixels& = srcB(idxA) - srcB(idxB)

    End Select

End Function

Attached Files

Thumbnail(s)
   

I am using linux mint and version 4.1 of QB64PE

my problem is QB64pe seems to ignore the default button, does not highlight anything and selects [yes] 1 as the default.

Dim As Long q

q = _MessageBox("caution", "lose edits?", "yesno", "question", 0)
Print q

I've tried loading a 32 bit image and saving it as an 8bit image, but it doesn't seem to work.  Image editors like Graphics Gale can't seem to open it, and when I try to reload it that fails also.

''Test loading a 32bit image and saving it to 8 bit

Option _Explicit



Screen _NewImage(320,240,256)



Dim img32& : img32& = _LoadImage("img32.png", 256)

Dim img8bit& : img8bit& = _NewImage(64, 64, 256)

_PutImage (0,0),img32&, img8bit&



_SaveImage "img8bit.bmp", img8bit&

_FreeImage(img32&)

_FreeImage(img8bit&)



Sleep

End

''Load and check an image

Dim img8& : img8& = _LoadImage("img8bit&.bmp", 256)



Screen _NewImage(320, 240, 256)



_PutImage (0,0), img8&



_FreeImage(img8&)

sleep

end

This code tries to assign a large arrays of memory..

If you have an upper range of memory, say, 32GB with 8GB free this may work:

In QB45 the "Out of memory" (error 7) would be displayed.
However, in QB64 the memory box will be displayed.

This the memory mem.h file:

Anybody know how to make this work?  Maybe a 'Not InStr Xor InStr'?   My problem is InStr doesn't return true or false, but the position of the substring inside the string.  Maybe I need to rethink the whole structure.  I want to be able to default to -sh (run CreateSheet) if no option is given.

If InStr(LCase$(opt$), "-sh") And InStr(LCase$(opt$), "-st") Then

    Print "-sh -st"

    CreateSheet sheet&, f_names$(), n_count&, bpp&

    CreateStrip strip&, f_names$(), n_count&, bpp&

ElseIf InStr(LCase$(opt$), "-st") Then

    Print "-st"

    CreateStrip strip&, f_names$(), n_count&, bpp&

Else

    CreateSheet sheet&, f_names$(), n_count&, bpp&

End If

Has anyone had issues with _connectionaddress?

I am connecting from one computer to another computer and the computer connecting is using "tcp/ip:50064:radpberrypi"

And the pi accepts the connection but then connectionaddress returns the ip and random port numbers...

First, what is the numerical limit to the position number returned by INSTR? I think I might be getting an overflow that is producing wrong results.

Second, how does INSTR work internally? Previously I was using a FOR NEXT loop with a MID inside it to search though a line of 1 billion numerals of pi and it was pretty slow. Then I realised I should have been using INSTR instead and this sped things up by about 30 times! So how does INSTR actually work?