+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Prolific Programmers (https://qb64phoenix.com/forum/forumdisplay.php?fid=26)
+---- Forum: Petr (https://qb64phoenix.com/forum/forumdisplay.php?fid=52)
+---- Thread: Relax game - Puzzle (/showthread.php?tid=3086)
Relax game - Puzzle - Petr - 09-29-2024
Hi.
When I was working on the free-select image program, I didn't know that it would have consequences. An idea came during development.
And so this game was born. It's meant to be a relaxing puzzle. It contains 19 photos, some are from my private collection, but there is nothing personal, some are downloaded from the Internet. The principle of the game is simple.
The program uses the photo as if it were a painting on glass and breaks it like you break glass. The resulting pieces then player put together to create the original image. No score, nothing like that, it's not a competition. Really small parts are banned because no one wants to mouse hunt a 4x3 pixel piece...
Tell us what you think about it.
Finally.... you know how a relaxing game turns into a hellish game? Quite simply, I could write a novel about memory leak detection.
But of course it is fixed in this version.
Code: (Select All)
'Puzzle / Relax Game writed Petr Preclik 09-27-2024 to 09-29-2024
Dim As Long Img, Mask ' Img is image (from directory images), Mask is NewImage image
' easyest loader...too lasy to implant here direntry...
' +---------------------------------------+
' | Create images names to array ImaArray |
' +---------------------------------------+
Dim ImaArray(19) As String ' 19 images in images folder
imgIndex = 0 ' start from zero (0.jpg)
For fillIma = 19 To 0 Step -1
Path$ = ".\images\" + LTrim$(Str$(fillIma)) + ".jpg"
ImaArray(fillIma) = Path$
Next
Screen _NewImage(_DesktopWidth, _DesktopHeight, 32)
Mask& = _NewImage(_DesktopWidth, _DesktopHeight, 32)
' +-----------------------------------------+
' |My Screen and Mask virtual screen declare|
' +-----------------------------------------+
restart: ' here is used.... GoTo if player's chioce is try next image
Cls
_FullScreen
ReDim Shared G(0) As Long ' Graphic array (contains indexes array P and this set images order on screen. Ubound is always visible (get to screen as last)
' previous image IMG is deleted from memory in row 316 and IMG is set to 0 if next image is played
Img = _LoadImage(ImaArray(imgIndex), 32)
Text1$ = "Generating Puzzle, please wait..."
CenterX = _Width \ 2 - _PrintWidth(Text1$) \ 2
CenterY = _Height \ 2 - 16
_PrintString (CenterX, CenterY), Text1$
'
' 1) Mask border is painted as white line
_Dest Mask&
Cls ' mask must have black background
Line (0, 1)-(_Width(Mask&) - 1, _Height(Mask&) - 1), _RGB32(255), B
' 2) To mask is genereated some random form in white color
Dim f As _Unsigned _Byte
For form = 0 To 3
Randomize Timer
f = 1 + Rnd * 7
PlaceForm f, Mask&, _RGB32(255) 'PlaceForm create some white forms
Next form
PlaceForm 7, Mask&, _RGB32(255)
PlaceForm 7, Mask&, _RGB32(255)
' +-----------------------------------------+
' | My game declare, arrays and variables |
' +-----------------------------------------+
' 3) define the Puzzle type, scan the screen, write the shapes in the field and color the individual shapes.
Type Puzz
As Integer X, Y, pX, pY ' X, Y is real position in image (left upper corner which contains non zero pixel), pX, pY is position on the screen
As _Unsigned _Byte R, G, B ' mask color - used in program begining (row 83)
As Long Handle ' image handle (part of complete image)
As _Byte Locked ' if is image moved to correct place, is this 1 else is 0. If is set to 1, player can't moving this part
' default angle is always 0 in this version, rotation is not used in this first version
End Type
ReDim Shared P(0) As Puzz ' Game array
' 4) searching and coloring individual parts of the mask
_Source Mask&
_Dest Mask& ' Part image size is not set here, but on row 528, 529 in SUB GiveForm
B = 150
R = 127
For Y = 0 To _Height(Mask&)
For X = 0 To _Width(Mask&)
p~& = Point(X, Y)
If p~& = _RGB32(0) Then
B = B + 1
If B > 255 Then B = 0: G = G + 1
If G > 255 Then G = 0: R = R + 1
Paint (X, Y), _RGB32(R, G, B), _RGB32(255)
UbP = UBound(P)
P(UbP).R = R
P(UbP).G = G
P(UbP).B = B
UbP = UbP + 1
ReDim _Preserve P(UbP) As Puzz
End If
Next X
Next Y
_Dest 0
' +---------------------+
' | Call GiveForm SUB |
' +---------------------+
' 5) the GiveForm SUB does all of the above:
' 1) place one concrete shape on the virtual screen
' 2) find the dimensions of the shape (width and height)
' 3) create a suitable virtual screen and copies the shape onto it and then closes the original virtual screen
' 4) return the image descriptor of this shape in P().handle
GiveForm Mask&, Img, P()
' GiveForm (Mask image contains colored parts, always one part = one color; IMG is loaded image file, P() is game array)
' +---------------------+
' | Level logic |
' +---------------------+
' 5b) calculate how many pieces will be generated (small pieces are not generated) - i try it, but.... move part 1x3 pixels.... NO! NO! NO!
' not all .Handle contains image descriptor. If is image too small, here is 0, this image is not used in game and therefore must be real number calculated.
TotalPieces = 0
For a = 0 To UBound(P) - 1
If P(a).Handle < -1 Then TotalPieces = TotalPieces + 1
Next a
' 6) Generate parts start position on the screen - you can delete it, then all parts in game are in left upper corner
For s = 0 To UBound(P)
imgX = Rnd * _Width
If imgX > _Width(0) - _Width(P(s).Handle) Then imgX = _Width(0) - _Width(P(s).Handle)
imgY = Rnd * _Height
If imgY > _Height(0) - _Height(P(s).Handle) Then imgY = _Height(0) - _Height(P(s).Handle)
P(s).pX = imgX
P(s).pY = imgY
Next s
' +---------------------+
' | Sort Sub |
' +---------------------+
Sort ' It calculates the area of ??individual images according to the width and height in the P().Handle array and
' arranges them in the G array so that the largest are below and the smallest above. The smallest part is then
' rendered last. But.... (keep reading it)
Cls , _RGB32(200)
Show
' Show displays parts by field G. Image in UBOUND field G is shown last
Completed = 0 ' Number parts placed to correct image area
Do Until k& = 27
Show
k& = _KeyHit ' You read source code? You are doing good, keep it up!
While _MouseInput: Wend
MX = _MouseX
MY = _MouseY
LB = _MouseButton(1)
For T = UBound(P) - 1 To 0 Step -1
Id = T
If P(Id).Handle < 0 Then ' if Handle is valid,
If LB = -1 Then ' if left mouse button is pressed,
s = _Source
_Source P(Id).Handle
sc~& = Point(MX - P(Id).pX, MY - P(Id).pY)
If _Alpha32(sc~&) > 0 Then ' if mouse is placed on visible area on the part,
Xs = P(Id).pX
Ys = P(Id).pY
Xe = Xs + _Width(P(Id).Handle) - 1
Ye = Ys + _Height(P(Id).Handle) - 1
If MX >= Xs And MX <= Xe Then
If MY >= Ys And MY <= Ye Then
If P(T).Locked = 0 Then ' if part is not moved on the screen in correct place (if locked is 1, is not possible moving it)
Do Until LB = 0 ' LOOP until left mouse button is pressed
While _MouseInput
Wend
MX = _MouseX
MY = _MouseY
LB = _MouseButton(1)
If P(T).Locked = 0 Then 'if part is not moved on the screen in correct place (if locked is 1, is not possible moving it)
MyT = T
If posX = 0 Then ' calculate and memorize mouse position and part left upper corner position - for moving on the screen
posX = MX - Xs
PosY = MY - Ys
oMX = MX
oMY = MY
End If
P(T).pX = MX - posX 'write to array new part position on the screen
P(T).pY = MY - PosY
' if we go to the correct position with a tolerance of 10 pixels, it will lock the part
If Abs(P(T).X - P(T).pX) < 10 Then
If Abs(P(T).Y - P(T).pY) < 10 Then
P(T).pX = P(T).X
P(T).pY = P(T).Y
P(T).Locked = 1 'ok
_SetAlpha 220, _RGB32(0) To _RGB32(255), P(T).Handle
Completed = Completed + 1 ' this is counter for correct placed parts
Sound 250, .5
LB = 0
Exit Do
End If
End If
End If
_Display
MoveShow T ' If the part is moved, the display is done by this SUB. The only difference is that it ensures that the piece being moved is always visible.
MovedImage = T ' note which piece was moved last
' congrats, if you study source code: program small hack (move piece to 10, 10 or less)
Hck& = _KeyDown(100303) ' press and hold right shift for hack
If Hck& Then ' use if you don't see correct target position for part when is moved!
Locate 3
Print "Move to 10, 10 or less: "; Abs(P(T).X - P(T).pX), Abs(P(T).Y - P(T).pY)
End If
_Display
_Limit 30
Loop
If Completed = TotalPieces Then ' if all parts are in correct position,
_PrintMode _FillBackground
For a = 0 To UBound(P) - 1
_SetAlpha 255, _RGB32(0) To _RGB32(255), P(a).Handle ' set for all parts full alpha
Next a
Show ' diplay it
_Display
Sleep 3
_AutoDisplay
msg = _MessageBox("Puzzle", "Try next image?", "yesno", "question", 1)
Select Case msg
Case 0 ' if player doesn't want continue,
Screen 0
Print "Good bye..." ' print message
For a = 0 To UBound(P)
If P(a).Handle < 0 Then _FreeImage P(a).Handle 'erase all images from memory
Next a
_FreeImage Mask& ' erase mask
_FreeImage Img& ' erase image loaded in begin
System ' exit to system
Case 1
_FreeImage Img& ' if player continue to next image,
Img = 0 ' erase previous image loaded in begin from memory,
For a = 0 To UBound(P)
If P(a).Handle < 0 Then _FreeImage P(a).Handle 'arase all parts images
Next a
ReDim G(0) As Long ' reset graphic array to 0
ReDim P(0) As Puzz ' reset game array to 0
Erase P ' delete game array
Erase G ' delete graphic array
imgIndex = imgIndex + 1 ' images counter up to 1 (used in begin)
If imgIndex > UBound(ImaArray) Then imgIndex = LBound(ImaArray)
GoTo restart ' skip to program begin
End Select
End If
' +-------------------------------------------------------------------------------+
' |the program only goes to this area once every time the mouse button is released|
' +-------------------------------------------------------------------------------+
posX = 0 ' this variable now reset mouse settings used on row 189
_Dest 0
If MovedImage > -1 Then ' see row 217
MyIndexP = MovedImage ' this block shift images in graphic array so, when you click to part, this is placed to UBOUND,
ShiftIndex = 0 ' se when is mouse button released, is not last moved piece "in backround" behind the other pieces
For srt = 0 To UBound(G) - 1
If G(srt) = MyIndexP Then ShiftIndex = 1
G(srt) = G(srt + ShiftIndex)
Next srt
ubG = UBound(G)
G(ubG) = MyIndexP
MovedImage = -1
End If
End If
End If
End If
End If
_Source s
End If
End If
Next T
' small program for on-screen text in left upper corner
Locate 1 ' and help - show parts which are not placed when H is pressed
_PrintMode _KeepBackground
Print "Done: "; Completed; " / "; TotalPieces; "["; Int((Completed / TotalPieces) * 100); "%]"
Print "Can't find part? Press H!"
Kbd$ = InKey$
If UCase$(Kbd$) = "H" Then
D = _Dest
_Dest 0
For a = 0 To UBound(P)
If P(a).Handle < -1 And P(a).Locked = 0 Then
MiddleX = (P(a).pX + _Width(P(a).Handle) \ 2)
MiddleY = (P(a).pY + _Height(P(a).Handle) \ 2)
_AutoDisplay
For h = 1 To 5
For Circl = 10 To 30
Circle (MiddleX, MiddleY), Circl, _RGB32(255 - 128 / circ, 10, 210 / circ)
Next
_Delay .01
For Circl = 30 To 10 Step -1
Circle (MiddleX, MiddleY), Circl, _RGB32(255 - 128 / circ, 10, 210 / circ)
Next
_Delay .01
Next h
End If
Next a
_Dest D
End If
_Display
Loop
End
Sub Show
_Dest 0
Cls , _RGB32(200)
For s = 0 To UBound(G)
' SUB contains two steps: First - display correct placed parts,
If P(G(s)).Handle < 0 Then
If P(G(s)).Locked = 1 Then
imgX = P(G(s)).pX
If imgX > _Width(0) + _Width(P(G(s)).Handle) Then imgX = _Width(0) - _Width(P(G(s)).Handle)
imgY = P(G(s)).pY
If imgY > _Height(0) + _Height(P(G(s)).Handle) Then imgY = _Height(0) - _Height(P(G(s)).Handle)
_PutImage (imgX, imgY), P(G(s)).Handle
End If
End If
Next s
For s = 0 To UBound(G)
' Second - then show all others parts - so is not possible "hide" free parts
If P(G(s)).Handle < 0 Then
If P(G(s)).Locked = 0 Then
imgX = P(G(s)).pX
If imgX > _Width(0) + _Width(P(G(s)).Handle) Then imgX = _Width(0) - _Width(P(G(s)).Handle)
imgY = P(G(s)).pY
If imgY > _Height(0) + _Height(P(G(s)).Handle) Then imgY = _Height(0) - _Height(P(G(s)).Handle)
_PutImage (imgX, imgY), P(G(s)).Handle
' _Delay .1
End If
End If
Next s
End Sub
Sub MoveShow (id)
Show
If P(id).Handle < 0 Then
imgX = P(id).pX ' the same as show, but moved part is always displayed on top
imgY = P(id).pY ' (sub is used when part is moved with mouse)
_PutImage (imgX, imgY), P(id).Handle
End If
End Sub
Sub Sort ' according to the area of ??the picture, place the indexes of the P field
' for rendering in the G field. The largest area will be the first (index 0)
' 1) Create array P2 and write here area (width * height) for image the same index in array P
ubP = UBound(P) ' this is not very good method, because transparency pixels are here calculated as full pixels...
ReDim p2(ubP) As Long
For copy = 0 To ubP
p2(copy) = _Width(P(copy).Handle) * _Height(P(copy).Handle)
Next
' go through field P2, find the largest area, write it in field G and then set it to zero in field P2
ReDim G(ubP) As Long
Do Until All = ubP
i = 0
max = 0
Rec = 0
Do Until i = ubP
If p2(i) > 0 Then
If max < p2(i) Then max = p2(i): Rec = i
End If
i = i + 1
Loop
If max Then
p2(Rec) = 0
G(iG) = Rec ' set the value of the index of the field P in field G
iG = iG + 1
End If
All = All + 1
Loop
ReDim p2(0) As Long
Erase p2
End Sub
Sub GiveForm (source As Long, img As Long, images() As Puzz) ' returns individual tiles as individual images
' source is MASK source image, img is input image, images() is array for image parts
ReDim As Long X, Y, MinX, MinY, MaxX, maxY, Virtual, V2, Allimages, Ui
Cls
For Allimages = 0 To UBound(P) - 1
Kolor~& = _RGB32(P(Allimages).R, P(Allimages).G, P(Allimages).B) 'read mask color for THIS part
X = 0
Y = 0
MinX = _Width(source)
MaxX = 0
MinY = _Height(source)
maxY = 0
' find image size and copy element to virtual screen in 1 step
Virtual = _NewImage(_Width(source), _Height(source), 32)
_Source source
_Dest Virtual
Cls ' Background color in Virtual must be set as black
Do Until Y = _Height(source) - 1
X = 0
Do Until X = _Width(source) - 1
CC~& = Point(X, Y)
If CC~& = Kolor~& Then
If MinY > Y Then MinY = Y
If maxY < Y Then maxY = Y
If MinX > X Then MinX = X
If MaxX < X Then MaxX = X
PSet (X, Y), Kolor~& ' draw 1 part to virtual screen (which use the same size as mask image)
End If ' and measure real image width and height
X = X + 1 ' (you draw here only 1 mask for 1 part image to Virtual)
Loop
Y = Y + 1
Loop
'---------------------------
P(Allimages).X = MinX ' put left upper corner position for this 1 part to array P
P(Allimages).Y = MinY
'---------------------------
If MaxX - MinX < 10 Or maxY - MinY < 10 Then ' this condition block creating really very small parts (10x10 pixels and less) '
_FreeImage Virtual ' HERE WAS memory leak - miss _freeimage before... - _continue skip _freeimage...
_Continue ' do not create really small pieces
End If
_SetAlpha 0, Kolor~&, Virtual ' set color in mask image as transparent
V2 = _NewImage(_Width(source), _Height(source), 32) ' create image the same size as mask
d = _Dest
_Dest V2
Cls , _RGB32(50) ' set this image background color (also set colors intensity on the game screen)
_Dest d
RatioX = _DesktopWidth / _Width(img&) ' RotioX, RatioY - calculate the aspect ratio of the image
RatioY = _DesktopHeight / _Height(img&) ' relative to the aspect ratio of the screen so that the placed image is not stretched
If RatioX < RatioY Then Ratio = RatioX Else Ratio = RatioY ' and distorted, but reduced (or enlarged) in the aspect ratio, without its deformation
ImageX = (_DesktopWidth - _Width(img&) * Ratio) \ 2 ' calculate image position in middle
MyImage& = _NewImage(_Width(img&) * Ratio, _Height(img&) * Ratio) ' output image - create it in ratio
_PutImage (0, 0)-(_Width(img&) * Ratio, _Height(img&) * Ratio), img&, MyImage& ' place original image to empty image MyImage - in ratio
_PutImage (ImageX, 0), MyImage&, V2 ' place centered image (complete image) in ratio to V2
_PutImage , Virtual, V2 ' place mask image to complete centered image in correct ratio
Ui = UBound(images)
P(Allimages).Handle = _NewImage(MaxX - MinX + 1, maxY - MinY + 1, 32) ' create image in real size (big as part)
_PutImage (0, 0), V2, P(Allimages).Handle, (MinX, MinY)-(MaxX, maxY) ' place this part image from V2 to P().handle
_SetAlpha 0, _RGB32(0), P(Allimages).Handle ' set transparent background to P().handle
_FreeImage V2 ' clear ram
_FreeImage Virtual
_FreeImage MyImage&
Virtual = 0
R = 16 / 9 ' this is for preview only, when parts are created, i show image on the screen
PreviewWDTH = 150 * R
PreviewHGHT = 150
_PutImage (100 + PreviewWDTH, 50 + PreviewHGHT)-(400 + PreviewWDTH * R, 350 + PreviewHGHT), img&
Text1$ = "Generating Puzzle, please wait..."
Text2$ = Str$(Allimages) + "/" + LTrim$(Str$(UBound(P)))
CenterX = _Width(0) \ 2 - _PrintWidth(Text1$) \ 2
CenterX2 = _Width(0) \ 2 - _PrintWidth(Text2$) \ 2
CenterY = _Height(0) \ 2 - 16
Centery2 = CenterY + 20
_PrintString (CenterX, CenterY), Text1$, 0
_PrintString (CenterX2, Centery2), Text2$, 0
Next Allimages
End Sub
Sub PlaceForm (typ As Integer, dest As Long, kolor As _Unsigned Long) ' generate some parts to mask image in white color. Se easy, so comment here is not needed.
D = _Dest
_Dest dest
W = _Width(dest)
H = _Height(dest)
Select Case typ
Case 1
Circle (-W / 2 + Rnd * W, -H / 2 + Rnd * H), -W / 4 + Rnd * W / 8, kolor
Case 2
Line (-W / 2 + Rnd * W, -H / 2 + Rnd * H)-(-W / 2 + Rnd * W, -H / 2 + Rnd * H), kolor, B
Case 3, 4, 5, 6
Dim X(typ) As Integer
Dim Y(typ) As Integer
'vygeneruju cilove body
For Rand = 0 To typ
X(Rand) = Rand + Rnd * W
Y(Rand) = Rand + Rnd * H
Next
PReset (X(0), Y(0))
For Drw = 0 To typ
Line -(X(Drw), Y(Drw)), kolor
Next
Line -(X(0), Y(0)), kolor
Case 7
cX = -W / 2 * Rnd + W * Rnd
cY = -H / 2 * Rnd + H * Rnd
For a = 0 To 300 Step 60
PReset (cX, cY)
For s = 0 To W Step 50
aR = _D2R(a)
If s < 100 Then noise = 0 Else noise = Rnd * 20
nX = cX + Cos(aR) * 2 * s + noise
ny = cY + Sin(aR) * 2 * s + noise
Line -(nX, ny), kolor
Next s
Next a
End Select
End Sub
![[Image: puzz-prev.png]](https://i.ibb.co/k5prX3y/puzz-prev.png)
RE: Relax game - Puzzle - PhilOfPerth - 09-29-2024
(09-29-2024, 07:21 PM)Petr Wrote: Hi.
When I was working on the free-select image program, I didn't know that it would have consequences. An idea came during development.
And so this game was born. It's meant to be a relaxing puzzle. It contains 19 photos, some are from my private collection, but there is nothing personal, some are downloaded from the Internet. The principle of the game is simple.
The program uses the photo as if it were a painting on glass and breaks it like you break glass. The resulting pieces then player put together to create the original image. No score, nothing like that, it's not a competition. Really small parts are banned because no one wants to mouse hunt a 4x3 pixel piece...
Tell us what you think about it.
Finally.... you know how a relaxing game turns into a hellish game? Quite simply, I could write a novel about memory leak detection.
But of course it is fixed in this version.
Code: (Select All)
'Puzzle / Relax Game writed Petr Preclik 09-27-2024 to 09-29-2024
Dim As Long Img, Mask ' Img is image (from directory images), Mask is NewImage image
' easyest loader...too lasy to implant here direntry...
' +---------------------------------------+
' | Create images names to array ImaArray |
' +---------------------------------------+
Dim ImaArray(19) As String ' 19 images in images folder
imgIndex = 0 ' start from zero (0.jpg)
For fillIma = 19 To 0 Step -1
Path$ = ".\images\" + LTrim$(Str$(fillIma)) + ".jpg"
ImaArray(fillIma) = Path$
Next
Screen _NewImage(_DesktopWidth, _DesktopHeight, 32)
Mask& = _NewImage(_DesktopWidth, _DesktopHeight, 32)
' +-----------------------------------------+
' |My Screen and Mask virtual screen declare|
' +-----------------------------------------+
restart: ' here is used.... GoTo if player's chioce is try next image
Cls
_FullScreen
ReDim Shared G(0) As Long ' Graphic array (contains indexes array P and this set images order on screen. Ubound is always visible (get to screen as last)
' previous image IMG is deleted from memory in row 316 and IMG is set to 0 if next image is played
Img = _LoadImage(ImaArray(imgIndex), 32)
Text1$ = "Generating Puzzle, please wait..."
CenterX = _Width \ 2 - _PrintWidth(Text1$) \ 2
CenterY = _Height \ 2 - 16
_PrintString (CenterX, CenterY), Text1$
'
' 1) Mask border is painted as white line
_Dest Mask&
Cls ' mask must have black background
Line (0, 1)-(_Width(Mask&) - 1, _Height(Mask&) - 1), _RGB32(255), B
' 2) To mask is genereated some random form in white color
Dim f As _Unsigned _Byte
For form = 0 To 3
Randomize Timer
f = 1 + Rnd * 7
PlaceForm f, Mask&, _RGB32(255) 'PlaceForm create some white forms
Next form
PlaceForm 7, Mask&, _RGB32(255)
PlaceForm 7, Mask&, _RGB32(255)
' +-----------------------------------------+
' | My game declare, arrays and variables |
' +-----------------------------------------+
' 3) define the Puzzle type, scan the screen, write the shapes in the field and color the individual shapes.
Type Puzz
As Integer X, Y, pX, pY ' X, Y is real position in image (left upper corner which contains non zero pixel), pX, pY is position on the screen
As _Unsigned _Byte R, G, B ' mask color - used in program begining (row 83)
As Long Handle ' image handle (part of complete image)
As _Byte Locked ' if is image moved to correct place, is this 1 else is 0. If is set to 1, player can't moving this part
' default angle is always 0 in this version, rotation is not used in this first version
End Type
ReDim Shared P(0) As Puzz ' Game array
' 4) searching and coloring individual parts of the mask
_Source Mask&
_Dest Mask& ' Part image size is not set here, but on row 528, 529 in SUB GiveForm
B = 150
R = 127
For Y = 0 To _Height(Mask&)
For X = 0 To _Width(Mask&)
p~& = Point(X, Y)
If p~& = _RGB32(0) Then
B = B + 1
If B > 255 Then B = 0: G = G + 1
If G > 255 Then G = 0: R = R + 1
Paint (X, Y), _RGB32(R, G, B), _RGB32(255)
UbP = UBound(P)
P(UbP).R = R
P(UbP).G = G
P(UbP).B = B
UbP = UbP + 1
ReDim _Preserve P(UbP) As Puzz
End If
Next X
Next Y
_Dest 0
' +---------------------+
' | Call GiveForm SUB |
' +---------------------+
' 5) the GiveForm SUB does all of the above:
' 1) place one concrete shape on the virtual screen
' 2) find the dimensions of the shape (width and height)
' 3) create a suitable virtual screen and copies the shape onto it and then closes the original virtual screen
' 4) return the image descriptor of this shape in P().handle
GiveForm Mask&, Img, P()
' GiveForm (Mask image contains colored parts, always one part = one color; IMG is loaded image file, P() is game array)
' +---------------------+
' | Level logic |
' +---------------------+
' 5b) calculate how many pieces will be generated (small pieces are not generated) - i try it, but.... move part 1x3 pixels.... NO! NO! NO!
' not all .Handle contains image descriptor. If is image too small, here is 0, this image is not used in game and therefore must be real number calculated.
TotalPieces = 0
For a = 0 To UBound(P) - 1
If P(a).Handle < -1 Then TotalPieces = TotalPieces + 1
Next a
' 6) Generate parts start position on the screen - you can delete it, then all parts in game are in left upper corner
For s = 0 To UBound(P)
imgX = Rnd * _Width
If imgX > _Width(0) - _Width(P(s).Handle) Then imgX = _Width(0) - _Width(P(s).Handle)
imgY = Rnd * _Height
If imgY > _Height(0) - _Height(P(s).Handle) Then imgY = _Height(0) - _Height(P(s).Handle)
P(s).pX = imgX
P(s).pY = imgY
Next s
' +---------------------+
' | Sort Sub |
' +---------------------+
Sort ' It calculates the area of ??individual images according to the width and height in the P().Handle array and
' arranges them in the G array so that the largest are below and the smallest above. The smallest part is then
' rendered last. But.... (keep reading it)
Cls , _RGB32(200)
Show
' Show displays parts by field G. Image in UBOUND field G is shown last
Completed = 0 ' Number parts placed to correct image area
Do Until k& = 27
Show
k& = _KeyHit ' You read source code? You are doing good, keep it up!
While _MouseInput: Wend
MX = _MouseX
MY = _MouseY
LB = _MouseButton(1)
For T = UBound(P) - 1 To 0 Step -1
Id = T
If P(Id).Handle < 0 Then ' if Handle is valid,
If LB = -1 Then ' if left mouse button is pressed,
s = _Source
_Source P(Id).Handle
sc~& = Point(MX - P(Id).pX, MY - P(Id).pY)
If _Alpha32(sc~&) > 0 Then ' if mouse is placed on visible area on the part,
Xs = P(Id).pX
Ys = P(Id).pY
Xe = Xs + _Width(P(Id).Handle) - 1
Ye = Ys + _Height(P(Id).Handle) - 1
If MX >= Xs And MX <= Xe Then
If MY >= Ys And MY <= Ye Then
If P(T).Locked = 0 Then ' if part is not moved on the screen in correct place (if locked is 1, is not possible moving it)
Do Until LB = 0 ' LOOP until left mouse button is pressed
While _MouseInput
Wend
MX = _MouseX
MY = _MouseY
LB = _MouseButton(1)
If P(T).Locked = 0 Then 'if part is not moved on the screen in correct place (if locked is 1, is not possible moving it)
MyT = T
If posX = 0 Then ' calculate and memorize mouse position and part left upper corner position - for moving on the screen
posX = MX - Xs
PosY = MY - Ys
oMX = MX
oMY = MY
End If
P(T).pX = MX - posX 'write to array new part position on the screen
P(T).pY = MY - PosY
' if we go to the correct position with a tolerance of 10 pixels, it will lock the part
If Abs(P(T).X - P(T).pX) < 10 Then
If Abs(P(T).Y - P(T).pY) < 10 Then
P(T).pX = P(T).X
P(T).pY = P(T).Y
P(T).Locked = 1 'ok
_SetAlpha 220, _RGB32(0) To _RGB32(255), P(T).Handle
Completed = Completed + 1 ' this is counter for correct placed parts
Sound 250, .5
LB = 0
Exit Do
End If
End If
End If
_Display
MoveShow T ' If the part is moved, the display is done by this SUB. The only difference is that it ensures that the piece being moved is always visible.
MovedImage = T ' note which piece was moved last
' congrats, if you study source code: program small hack (move piece to 10, 10 or less)
Hck& = _KeyDown(100303) ' press and hold right shift for hack
If Hck& Then ' use if you don't see correct target position for part when is moved!
Locate 3
Print "Move to 10, 10 or less: "; Abs(P(T).X - P(T).pX), Abs(P(T).Y - P(T).pY)
End If
_Display
_Limit 30
Loop
If Completed = TotalPieces Then ' if all parts are in correct position,
_PrintMode _FillBackground
For a = 0 To UBound(P) - 1
_SetAlpha 255, _RGB32(0) To _RGB32(255), P(a).Handle ' set for all parts full alpha
Next a
Show ' diplay it
_Display
Sleep 3
_AutoDisplay
msg = _MessageBox("Puzzle", "Try next image?", "yesno", "question", 1)
Select Case msg
Case 0 ' if player doesn't want continue,
Screen 0
Print "Good bye..." ' print message
For a = 0 To UBound(P)
If P(a).Handle < 0 Then _FreeImage P(a).Handle 'erase all images from memory
Next a
_FreeImage Mask& ' erase mask
_FreeImage Img& ' erase image loaded in begin
System ' exit to system
Case 1
_FreeImage Img& ' if player continue to next image,
Img = 0 ' erase previous image loaded in begin from memory,
For a = 0 To UBound(P)
If P(a).Handle < 0 Then _FreeImage P(a).Handle 'arase all parts images
Next a
ReDim G(0) As Long ' reset graphic array to 0
ReDim P(0) As Puzz ' reset game array to 0
Erase P ' delete game array
Erase G ' delete graphic array
imgIndex = imgIndex + 1 ' images counter up to 1 (used in begin)
If imgIndex > UBound(ImaArray) Then imgIndex = LBound(ImaArray)
GoTo restart ' skip to program begin
End Select
End If
' +-------------------------------------------------------------------------------+
' |the program only goes to this area once every time the mouse button is released|
' +-------------------------------------------------------------------------------+
posX = 0 ' this variable now reset mouse settings used on row 189
_Dest 0
If MovedImage > -1 Then ' see row 217
MyIndexP = MovedImage ' this block shift images in graphic array so, when you click to part, this is placed to UBOUND,
ShiftIndex = 0 ' se when is mouse button released, is not last moved piece "in backround" behind the other pieces
For srt = 0 To UBound(G) - 1
If G(srt) = MyIndexP Then ShiftIndex = 1
G(srt) = G(srt + ShiftIndex)
Next srt
ubG = UBound(G)
G(ubG) = MyIndexP
MovedImage = -1
End If
End If
End If
End If
End If
_Source s
End If
End If
Next T
' small program for on-screen text in left upper corner
Locate 1 ' and help - show parts which are not placed when H is pressed
_PrintMode _KeepBackground
Print "Done: "; Completed; " / "; TotalPieces; "["; Int((Completed / TotalPieces) * 100); "%]"
Print "Can't find part? Press H!"
Kbd$ = InKey$
If UCase$(Kbd$) = "H" Then
D = _Dest
_Dest 0
For a = 0 To UBound(P)
If P(a).Handle < -1 And P(a).Locked = 0 Then
MiddleX = (P(a).pX + _Width(P(a).Handle) \ 2)
MiddleY = (P(a).pY + _Height(P(a).Handle) \ 2)
_AutoDisplay
For h = 1 To 5
For Circl = 10 To 30
Circle (MiddleX, MiddleY), Circl, _RGB32(255 - 128 / circ, 10, 210 / circ)
Next
_Delay .01
For Circl = 30 To 10 Step -1
Circle (MiddleX, MiddleY), Circl, _RGB32(255 - 128 / circ, 10, 210 / circ)
Next
_Delay .01
Next h
End If
Next a
_Dest D
End If
_Display
Loop
End
Sub Show
_Dest 0
Cls , _RGB32(200)
For s = 0 To UBound(G)
' SUB contains two steps: First - display correct placed parts,
If P(G(s)).Handle < 0 Then
If P(G(s)).Locked = 1 Then
imgX = P(G(s)).pX
If imgX > _Width(0) + _Width(P(G(s)).Handle) Then imgX = _Width(0) - _Width(P(G(s)).Handle)
imgY = P(G(s)).pY
If imgY > _Height(0) + _Height(P(G(s)).Handle) Then imgY = _Height(0) - _Height(P(G(s)).Handle)
_PutImage (imgX, imgY), P(G(s)).Handle
End If
End If
Next s
For s = 0 To UBound(G)
' Second - then show all others parts - so is not possible "hide" free parts
If P(G(s)).Handle < 0 Then
If P(G(s)).Locked = 0 Then
imgX = P(G(s)).pX
If imgX > _Width(0) + _Width(P(G(s)).Handle) Then imgX = _Width(0) - _Width(P(G(s)).Handle)
imgY = P(G(s)).pY
If imgY > _Height(0) + _Height(P(G(s)).Handle) Then imgY = _Height(0) - _Height(P(G(s)).Handle)
_PutImage (imgX, imgY), P(G(s)).Handle
' _Delay .1
End If
End If
Next s
End Sub
Sub MoveShow (id)
Show
If P(id).Handle < 0 Then
imgX = P(id).pX ' the same as show, but moved part is always displayed on top
imgY = P(id).pY ' (sub is used when part is moved with mouse)
_PutImage (imgX, imgY), P(id).Handle
End If
End Sub
Sub Sort ' according to the area of ??the picture, place the indexes of the P field
' for rendering in the G field. The largest area will be the first (index 0)
' 1) Create array P2 and write here area (width * height) for image the same index in array P
ubP = UBound(P) ' this is not very good method, because transparency pixels are here calculated as full pixels...
ReDim p2(ubP) As Long
For copy = 0 To ubP
p2(copy) = _Width(P(copy).Handle) * _Height(P(copy).Handle)
Next
' go through field P2, find the largest area, write it in field G and then set it to zero in field P2
ReDim G(ubP) As Long
Do Until All = ubP
i = 0
max = 0
Rec = 0
Do Until i = ubP
If p2(i) > 0 Then
If max < p2(i) Then max = p2(i): Rec = i
End If
i = i + 1
Loop
If max Then
p2(Rec) = 0
G(iG) = Rec ' set the value of the index of the field P in field G
iG = iG + 1
End If
All = All + 1
Loop
ReDim p2(0) As Long
Erase p2
End Sub
Sub GiveForm (source As Long, img As Long, images() As Puzz) ' returns individual tiles as individual images
' source is MASK source image, img is input image, images() is array for image parts
ReDim As Long X, Y, MinX, MinY, MaxX, maxY, Virtual, V2, Allimages, Ui
Cls
For Allimages = 0 To UBound(P) - 1
Kolor~& = _RGB32(P(Allimages).R, P(Allimages).G, P(Allimages).B) 'read mask color for THIS part
X = 0
Y = 0
MinX = _Width(source)
MaxX = 0
MinY = _Height(source)
maxY = 0
' find image size and copy element to virtual screen in 1 step
Virtual = _NewImage(_Width(source), _Height(source), 32)
_Source source
_Dest Virtual
Cls ' Background color in Virtual must be set as black
Do Until Y = _Height(source) - 1
X = 0
Do Until X = _Width(source) - 1
CC~& = Point(X, Y)
If CC~& = Kolor~& Then
If MinY > Y Then MinY = Y
If maxY < Y Then maxY = Y
If MinX > X Then MinX = X
If MaxX < X Then MaxX = X
PSet (X, Y), Kolor~& ' draw 1 part to virtual screen (which use the same size as mask image)
End If ' and measure real image width and height
X = X + 1 ' (you draw here only 1 mask for 1 part image to Virtual)
Loop
Y = Y + 1
Loop
'---------------------------
P(Allimages).X = MinX ' put left upper corner position for this 1 part to array P
P(Allimages).Y = MinY
'---------------------------
If MaxX - MinX < 10 Or maxY - MinY < 10 Then ' this condition block creating really very small parts (10x10 pixels and less) '
_FreeImage Virtual ' HERE WAS memory leak - miss _freeimage before... - _continue skip _freeimage...
_Continue ' do not create really small pieces
End If
_SetAlpha 0, Kolor~&, Virtual ' set color in mask image as transparent
V2 = _NewImage(_Width(source), _Height(source), 32) ' create image the same size as mask
d = _Dest
_Dest V2
Cls , _RGB32(50) ' set this image background color (also set colors intensity on the game screen)
_Dest d
RatioX = _DesktopWidth / _Width(img&) ' RotioX, RatioY - calculate the aspect ratio of the image
RatioY = _DesktopHeight / _Height(img&) ' relative to the aspect ratio of the screen so that the placed image is not stretched
If RatioX < RatioY Then Ratio = RatioX Else Ratio = RatioY ' and distorted, but reduced (or enlarged) in the aspect ratio, without its deformation
ImageX = (_DesktopWidth - _Width(img&) * Ratio) \ 2 ' calculate image position in middle
MyImage& = _NewImage(_Width(img&) * Ratio, _Height(img&) * Ratio) ' output image - create it in ratio
_PutImage (0, 0)-(_Width(img&) * Ratio, _Height(img&) * Ratio), img&, MyImage& ' place original image to empty image MyImage - in ratio
_PutImage (ImageX, 0), MyImage&, V2 ' place centered image (complete image) in ratio to V2
_PutImage , Virtual, V2 ' place mask image to complete centered image in correct ratio
Ui = UBound(images)
P(Allimages).Handle = _NewImage(MaxX - MinX + 1, maxY - MinY + 1, 32) ' create image in real size (big as part)
_PutImage (0, 0), V2, P(Allimages).Handle, (MinX, MinY)-(MaxX, maxY) ' place this part image from V2 to P().handle
_SetAlpha 0, _RGB32(0), P(Allimages).Handle ' set transparent background to P().handle
_FreeImage V2 ' clear ram
_FreeImage Virtual
_FreeImage MyImage&
Virtual = 0
R = 16 / 9 ' this is for preview only, when parts are created, i show image on the screen
PreviewWDTH = 150 * R
PreviewHGHT = 150
_PutImage (100 + PreviewWDTH, 50 + PreviewHGHT)-(400 + PreviewWDTH * R, 350 + PreviewHGHT), img&
Text1$ = "Generating Puzzle, please wait..."
Text2$ = Str$(Allimages) + "/" + LTrim$(Str$(UBound(P)))
CenterX = _Width(0) \ 2 - _PrintWidth(Text1$) \ 2
CenterX2 = _Width(0) \ 2 - _PrintWidth(Text2$) \ 2
CenterY = _Height(0) \ 2 - 16
Centery2 = CenterY + 20
_PrintString (CenterX, CenterY), Text1$, 0
_PrintString (CenterX2, Centery2), Text2$, 0
Next Allimages
End Sub
Sub PlaceForm (typ As Integer, dest As Long, kolor As _Unsigned Long) ' generate some parts to mask image in white color. Se easy, so comment here is not needed.
D = _Dest
_Dest dest
W = _Width(dest)
H = _Height(dest)
Select Case typ
Case 1
Circle (-W / 2 + Rnd * W, -H / 2 + Rnd * H), -W / 4 + Rnd * W / 8, kolor
Case 2
Line (-W / 2 + Rnd * W, -H / 2 + Rnd * H)-(-W / 2 + Rnd * W, -H / 2 + Rnd * H), kolor, B
Case 3, 4, 5, 6
Dim X(typ) As Integer
Dim Y(typ) As Integer
'vygeneruju cilove body
For Rand = 0 To typ
X(Rand) = Rand + Rnd * W
Y(Rand) = Rand + Rnd * H
Next
PReset (X(0), Y(0))
For Drw = 0 To typ
Line -(X(Drw), Y(Drw)), kolor
Next
Line -(X(0), Y(0)), kolor
Case 7
cX = -W / 2 * Rnd + W * Rnd
cY = -H / 2 * Rnd + H * Rnd
For a = 0 To 300 Step 60
PReset (cX, cY)
For s = 0 To W Step 50
aR = _D2R(a)
If s < 100 Then noise = 0 Else noise = Rnd * 20
nX = cX + Cos(aR) * 2 * s + noise
ny = cY + Sin(aR) * 2 * s + noise
Line -(nX, ny), kolor
Next s
Next a
End Select
End Sub
Nice one, Petr! I (almost) got the vole picture done, but I couldn't place the last (tiny) piece that s seemed to be hidden under the main pic. Pressing H flashed the piece and the position but it didn't seem to want to go in. I'm sure your code is right, so I'll have another try later. Nice work.
RE: Relax game - Puzzle - Petr - 09-30-2024
Hi. You can search "hack" in source code.... or just press right shift when you move part with mouse
Then move to 10, 10 or less to target.
RE: Relax game - Puzzle - Petr - 09-30-2024
I have a big idea in this direction, I will work on the next version.
RE: Relax game - Puzzle - Dav - 10-03-2024
Really nice work, @Petr! It is relaxing. I couldn't seem to get it all put together at the end either, but had fun anyway. Thanks for sharing your puzzle game.
- Dav
RE: Relax game - Puzzle - Petr - 10-03-2024
(10-03-2024, 01:48 PM)Dav Wrote: Really nice work, @Petr! It is relaxing. I couldn't seem to get it all put together at the end either, but had fun anyway. Thanks for sharing your puzzle game.
- Dav
Thanks so much for your response, Dav. I am working on upgrading this game. I've already tweaked some new functions (for example auto-completion of a specific puzzle if you can't find the target position) and other adjustments. It's taking me longer because wrote the first version when was home sick, but now I'm healthy and only have time after work. The upgrade will be finished soon, I'm not working on anything else right now.
RE: Relax game - Puzzle - Petr - 10-07-2024
Hello, finally have tested (hopefully enough) the second version.
New compared to the previous version:
No more file name and type restrictions, it uses DirEntry.h which works under both Windows and Linux. You can use all types of supported image formats. There may be other files in the "images" folder, or files that QB64 cannot load as images - it doesn't matter, the program will filter everything and take it over. It then shuffles the files in its array and therefore should have a different image order sequence each time.
Accuracy. Now when he clicks on a shard, you will pull out exactly this shard, no other. The original rectangle detection logic has been completely replaced by mask logic.
New shape for image fragmentation - curved line.
There is hatching on the background to better distinguish where parts of the image are still missing and where they are not.
The use of partial transparency is removed, so now you can better orient yourself by color when building.
Related to this is the need to highlight the edges when the shards are no longer visible - that's why I made animated edges for them, using a simple method using MEM and they are now visible well.
Automatic replenishment. If you can't find the place where the shard belongs, left-click on it and then press A. If the indicator in the upper left corner is green, the shard will automatically be smoothly placed in its position. Others can be placed automatically after next 15 seconds.
Another option is to use the right shift, which marks the target position (center) where the shard belongs with a green circle. This is used when the left button is pressed and is unlimited.
Did you mind the mess in the unfinished image? In this version, use the right mouse button to mass-move all the shards to another location (even off the monitor). Then you only need to slide back while pressing the right button and the shards will slide back again. In this case, they will remain laid out as they were.
But there is an option to double-click with the right button. In that case, all the shards will be placed in one pile, from which you can then select with the left button (as in the previous version).
Eventually. If you need to see what the image should look like, press the space bar. After viewing, press it again to return to the game.
But I continue to develop. There will be another version, estimated in two weeks. It depends on when I finish the proper edge detection of the irregular shapes, which is important for my next intention.
The ZIP file contains the source code, the images folder, three photos in it (add your own, or add those from the first version) and the DirEntry.h file that is required for this version.
Have fun and let me know what you think when you try it out. Thank you.
UPDATED SOURCE SOURCE CODE (also in zip file) - In previous code was bug.
Code: (Select All)
'Puzzle / Relax Game writed Petr Preclik 09-27-2024 to 10-06-2024
'Version 2.2 - repaired critical bug - arbitrary declaration the shard as placed, even though it remained in place (the variable was not reset. But only sometimes. So much the worse.)
' You can see image preview - use spaceboard
' You can automatic move segemnt to target - press A or a IF indicator is green
' You can moving all parts at once on the screen out from view and back - use right mouse button
' You can all parts put in one pile - click right twice
' Shard selection is now much more accurate (to one pixel)
' Removed alpha - so you can better orient yourself by colors
' Removed limitation with loading files. Now you can use photos of any supported format with any name - place them in the images folder, the program will recognize unsupported types
' The loaded files are then randomly shuffled, so if there are more photos in the images folder, there is a higher probability that they will not repeat in the same order when the program is launched.
' Since the alpha has been removed, all shards now have animated edges
' The background is now hatched to better highlight the areas where the shard is missing
' Added curved line when generating mask
' On the right side, on the left, there is a box with information in the form of running text (it will be crossed when placing the shard in the places where it is and will be shown again after its placement)
' Small speedup by using MEM functions instead of Point and PSet and moving the calculations before the main loop (GiveForm SUB)
' PROGRAM NEED DIRENTRY.H file!
' Array for deformed line (new)
Type LinePoints
X As Integer
Y As Integer
End Type
ReDim Shared LP(0) As LinePoints ' Array for GetPoints (here added as new)
Type Gtype
As Long Handle, Index ' Type for G array, but .Index is not used now
End Type
ReDim FileList(0) As String
ReDim DirList(0) As String
Dim Shared As Long Img, Mask, MY, MX, LB, RB ' Img is image (from directory images), Mask is NewImage image
'pole loaderu a jeho index
ReDim Shared ImaArray(0) As String '
Dim Shared ImgIndex As Long
Dim Shared GridBck As Long
Dim Shared LastSegmentTime As Single
Dim Shared AllowAuto As Single ' Allow automatic feed to target after 15 seconds (option A, a in game)
Dim Shared TotalPieces, Completed
LastSegmentTime = Timer + 15
GridBck& = Grid(_DesktopWidth, _DesktopHeight, 15, _RGB32(150))
'----------------------------
$If WIN Then
cw$ = ".\images\"
$Else
cw$ = "./images/"
$End If
GetLists _CWD$ + cw$, DirList(), FileList() ' This version contains loader uses DirEntry.H (Thank you, Steve) - This is Steve's SUB
LoadFiles FileList() ' This insert to game array just valid and known images file
Screen _NewImage(_DesktopWidth, _DesktopHeight, 32)
Mask& = _NewImage(_DesktopWidth, _DesktopHeight, 32) 'While in the first version this was only used at the beginning, here it is used all the time!
' +-----------------------------------------+
' |My Screen and Mask virtual screen declare|
' +-----------------------------------------+
restart: ' here is used.... GoTo if player's chioce is try next image
Cls
_FullScreen
ReDim Shared G(0) As Gtype ' Graphic array (contains indexes array P and this set images order on screen. Ubound is always visible (get to screen as last)
' previous image IMG is deleted from memory in row 316 and IMG is set to 0 if next image is played
Img = _LoadImage(ImaArray(ImgIndex), 32)
Text1$ = "Generating Puzzle, please wait..."
CenterX = _Width \ 2 - _PrintWidth(Text1$) \ 2
CenterY = _Height \ 2 - 16
_PrintString (CenterX, CenterY), Text1$
'
' 1) Mask border is painted as white line
_Dest Mask&
Cls ' mask must have black background
Line (0, 1)-(_Width(Mask&) - 1, _Height(Mask&) - 1), _RGB32(255), B
' 2) To mask is genereated some random form in white color
Dim f As _Unsigned _Byte
For form = 0 To 3
Randomize Timer
f = 1 + Rnd * 10
PlaceForm f, Mask&, _RGB32(255) 'PlaceForm create some white forms
Next form
PlaceForm 7, Mask&, _RGB32(255)
'PlaceForm 7, Mask&, _RGB32(255)
' +-----------------------------------------+
' | My game declare, arrays and variables |
' +-----------------------------------------+
' 3) define the Puzzle type, scan the screen, write the shapes in the field and color the individual shapes.
Type Puzz
As Integer X, Y, pX, pY ' X, Y is real position in image (left upper corner which contains non zero pixel), pX, pY is position on the screen
As _Unsigned _Byte R, G, B ' mask color - used in program begining (row 83)
As Long Handle, MskHandle, Brdr ' nove mskhandle bude obsahovat konkretni tvar jednou barvou masky jako obrazek image handle (part of complete image)
As _Byte Locked ' if is image moved to correct place, is this 1 else is 0. If is set to 1, player can't moving this part
' default angle is always 0 in this version, rotation is not used in this first version
End Type
ReDim Shared P(1) As Puzz ' Game array
' 4) searching and coloring individual parts of the mask
_Source Mask&
_Dest Mask& ' Part image size is not set here, but on row 528, 529 in SUB GiveForm
B = 150
R = 127
For Y = 0 To _Height(Mask&) - 1
For X = 0 To _Width(Mask&) - 1
p~& = Point(X, Y)
If p~& = _RGB32(0) Then
B = B + 1
If B > 255 Then B = 0: G = G + 1
If G > 255 Then G = 0: R = R + 1
Paint (X, Y), _RGB32(R, G, B), _RGB32(255)
UbP = UBound(P)
P(UbP).R = R
P(UbP).G = G
P(UbP).B = B
UbP = UbP + 1
ReDim _Preserve P(UbP) As Puzz
End If
Next X
Next Y
_Dest 0
' +---------------------+
' | Call GiveForm SUB |
' +---------------------+
' 5) the GiveForm SUB does all of the above:
' 1) place one concrete shape on the virtual screen
' 2) find the dimensions of the shape (width and height)
' 3) create a suitable virtual screen and copies the shape onto it and then closes the original virtual screen
' 4) return the image descriptor of this shape in P().handle
GiveForm Mask&, Img, P()
' GiveForm (Mask image contains colored parts, always one part = one color; IMG is loaded image file, P() is game array)
' +---------------------+
' | Level logic |
' +---------------------+
' 5b) calculate how many pieces will be generated (small pieces are not generated) - i try it, but.... move part 1x3 pixels.... NO! NO! NO!
' not all .Handle contains image descriptor. If is image too small, here is 0, this image is not used in game and therefore must be real number calculated.
TotalPieces = 0
For A = 0 To UBound(P)
If P(A).Handle < 0 Then TotalPieces = TotalPieces + 1
Next A
' 6) Generate parts start position on the screen - you can delete it, then all parts in game are in left upper corner
For s = 0 To UBound(P)
imgX = Rnd * _Width
If imgX > _Width(0) - _Width(P(s).Handle) Then imgX = _Width(0) - _Width(P(s).Handle)
imgY = Rnd * _Height
If imgY > _Height(0) - _Height(P(s).Handle) Then imgY = _Height(0) - _Height(P(s).Handle)
P(s).pX = imgX
P(s).pY = imgY
Next s
' +---------------------+
' | Sort Sub |
' +---------------------+
Sort ' It calculates the area of ??individual images according to the width and height in the P().Handle array and
' arranges them in the G array so that the largest are below and the smallest above. The smallest part is then
' rendered last. But.... (keep reading it)
Cls , _RGB32(200)
Show
' Show displays parts by field G. Image in UBOUND field G is shown last
Completed = 0 ' Number parts placed to correct image area
Do Until k& = 27
Show
k& = _KeyHit ' You read source code? You are doing good, keep it up!
For T = UBound(P) To 0 Step -1
GetMouse MX, MY, LB, RB
If LB = -1 Then ' if left mouse button is pressed,
Id = ShardId(MX, MY)
'If Id = 0 Then Sound 350, .1: Stop 'pak by to vysvetlovalo bug u autoposuvu - a toto nebyla pricina, Id nikdy neni 0
LastT = Id
Xs = P(Id).pX
Ys = P(Id).pY
Xe = Xs + _Width(P(Id).Handle) - 1
Ye = Ys + _Height(P(Id).Handle) - 1
If P(Id).Locked = 0 Then ' if part is not moved on the screen in correct place (if locked is 1, is not possible moving it)
Do Until LB = 0 ' LOOP until left mouse button is pressed
AnimB
GetMouse MX, MY, LB, RB
If P(Id).Locked = 0 Then 'if part is not moved on the screen in correct place (if locked is 1, is not possible moving it)
MyT = Id
LastT = Id ' Variable for automatic move (when press a)
If posX = 0 Then ' calculate and memorize mouse position and part left upper corner position - for moving on the screen
posX = MX - Xs
PosY = MY - Ys
omx = MX
oMY = MY
End If
P(Id).pX = MX - posX 'write to array new part position on the screen
P(Id).pY = MY - PosY
' if we go to the correct position with a tolerance of 10 pixels, it will lock the part
If Abs(P(Id).X - P(Id).pX) < 10 Then
If Abs(P(Id).Y - P(Id).pY) < 10 Then
If time = 0 Then time = Timer
If Abs(Timer - time) > .45 Then
P(Id).pX = P(Id).X
P(Id).pY = P(Id).Y
P(Id).Locked = 1 'ok
'_SetAlpha 220, _RGB32(0) To _RGB32(255), P(Id).Handle 'Not more need in this version
Completed = Completed + 1 ' this is counter for correct placed parts
'LastSegmentTime = Timer + 15
Sound 250, .5
LB = 0
time = 0
'pokus o odstraneni bugu autoposuvu - dve promenne nize
MyT = 0
LastT = 0
Exit Do
End If
End If
End If
End If
MoveShow Id ' If the part is moved, the display is done by this SUB. The only difference is that it ensures that the piece being moved is always visible.
MovedImage = Id ' note which piece was moved last
' congrats, if you study source code: program small hack (move piece to 10, 10 or less)
Hck& = _KeyDown(100303) ' press and hold right shift for hack
If Hck& Then ' use if you don't see correct target position for part when is moved!
' In first version here was just PRINT, it is done graphically now.
For h = 0 To 1 ' Option right shift
For Circl = 10 To 25 Step 5
CircleFill P(Id).X + _Width(P(Id).MskHandle) \ 2, P(Id).Y + _Height(P(Id).MskHandle) \ 2, Circl, _RGBA32(10 + circ, 255, 25 - circ, 50)
_Display
_Delay .001
Next Circl
If LB = 0 Then Show Else MoveShow (Id)
_Delay .1
For Circl = 25 To 10 Step -5
CircleFill P(Id).X + _Width(P(Id).MskHandle) \ 2, P(Id).Y + _Height(P(Id).MskHandle) \ 2, Circl, _RGBA32(10 + circ, 255, 25 - circ, 50)
_Display
_Delay .001
Next Circl
Next
If LB = 0 Then Show Else MoveShow (Id)
_Dest d
_Display
End If
_Display
_Limit 100
Loop
'------------------------------------------------------ When image is done ----------------------------------------------------------------------------
complete:
If Completed = TotalPieces Then ' if all parts are in correct position,
_PrintMode _FillBackground
_Delay .3
Cls , _RGB32(50)
_AutoDisplay
ViewImage (Img)
Sleep 5
msg = _MessageBox("Puzzle", "Try next image?", "yesno", "question", 1) 'why this small .... always flash?
_Delay .2
_Display
Select Case msg
Case 0 ' if player doesn't want continue,
Screen 0
Print "Good bye..." ' print message
For A = 0 To UBound(P)
If P(A).Handle < 0 Then
_FreeImage P(A).Handle ' erase all images from memory
_FreeImage P(A).MskHandle
_FreeImage P(A).Brdr
End If
Next A
_FreeImage Mask& ' erase mask
_FreeImage Img& ' erase image loaded in begin
System ' exit to system
Case 1
_FreeImage Img& ' if player continue to next image,
Img = 0 ' erase previous image loaded in begin from memory,
Id = 0
For A = 0 To UBound(P)
If P(A).Handle < 0 Then
_FreeImage P(A).Handle ' erase all parts images
_FreeImage P(A).MskHandle
_FreeImage P(A).Brdr
End If
Next A
ReDim G(0) As Gtype ' reset graphic array to 0
ReDim P(1) As Puzz ' reset game array to 0
Erase P ' delete game array
Erase G ' delete graphic array
ImgIndex = ImgIndex + 1 ' images counter up to 1 (used in LoadFiles, its images array index)
If ImgIndex > UBound(ImaArray) Then ImgIndex = LBound(ImaArray)
_AutoDisplay
GoTo restart ' skip to program begin
End Select
End If
End If
'------------------------------------------------------------ GRPAHIC ORDER - when segment is moved, and then is left mouse button released, ----------------------------------------------------------
' so is graphic done with Show SUB. Because last moved segment was last used,
' and he is above, MUST BE VISIBLE. Last rendered image is UBOUND (G).
' G array contains not image handles, but indexes P() array!
' So, when is segment placed to new position, must be placed to ubound array G
' and this do this block
' +-------------------------------------------------------------------------------+
' |the program only goes to this area once every time the mouse button is released|
' +-------------------------------------------------------------------------------+
posX = 0 ' this variable now reset mouse settings used on row 189
_Dest 0
If MovedImage > 0 Then
MyIndexP = LastT ' this block shift images in graphic array so, when you click to part, this is placed to UBOUND,
ShiftIndex = 0 ' so when is mouse button released, is not last moved piece "in backround" behind the other pieces
For srt = 0 To UBound(G) - 1
If G(srt).Handle = MyIndexP Then
ShiftIndex = 1
GRec = G(srt).Handle
End If
G(srt).Handle = G(srt + ShiftIndex).Handle
G(srt).Index = G(srt + ShiftIndex).Index
Next srt
ubG = UBound(G)
G(ubG).Handle = GRec
MovedImage = -1
End If
'-------------------------------------------------- 'END FOR GRAPHIC BLOCK (see Show SUB - is used when nothing is not moved and to MoveShow - -------------------------------------------------------
' MoveShow is used when segment is moved with left mouse button.
End If ' End condition LB = -1 (LB is left mouse button)
'--------------------------------------------------- New: AutoMove block. Cant find segment target? First click with left button to segment. Then --------------------------------------------------------
' press A or a and last selected segment is then automaticaly moved and placed to target!
Auto& = _KeyDown(65) 'a
Auto2& = _KeyDown(97) 'A
' automatically moves the last tile into position
If AllowAuto Then ' If function is allowed (is green indicator on the screen)
If Auto& Or Auto2& Then ' If you press a or A key
If LastT Then ' if you before pressing "a" key click on a part with the possibility of movement (with left button)
If P(LastT).Locked = 0 Then
LastSegmentTime = 0
AutoI = LastT ' memorize this segment (part)
LastT = 0
AutoDone = 0
GETPOINTS P(AutoI).pX, P(AutoI).pY, P(AutoI).X, P(AutoI).Y, LP() 'generate path as array with points
Do Until AutoDone >= UBound(LP)
AutoDone = AutoDone + 32
If AutoDone > UBound(LP) Then AutoDone = UBound(LP) ' This do own auto move. As you can see, not all records are used (then is move too slow)
P(AutoI).pX = LP(AutoDone).X
P(AutoI).pY = LP(AutoDone).Y
If AutoDone Mod 128 = 0 Then AnimB
Show
_Display
Loop
P(AutoI).Locked = 1
Completed = Completed + 1 ' this is counter for correct placed parts
Sound 250, .5 ' tile is in target
Auto& = 0
Auto2& = 0
'pokus o odstraneni bugu autoposuvu kdy nekdy ohlasi ze vlozi ale nozobrazuje.
MyT = 0
LastT = 0
_AutoDisplay
If Completed = TotalPieces Then
_KeyClear
GoTo complete
End If
End If
End If
LastT = 0
_KeyClear
End If
End If
'----------------------------------------------------------------------------------------- End AutoMove block ----------------------------------------------------------------------------------------------
'---------------------------------------------------------------------- View image (press space for view image) --------------------------------------------------------------------------------------------
Space = _KeyDown(32)
If Space Then
SpaceView = Not SpaceView
_KeyClear
_Delay .2
End If
If SpaceView Then
ViewImage (Img)
_Display
Sleep
End If
'-------------------------------------------------- New: Move all unused segments out from the screen and back, or group the parts --------------------------------------------------------------------------
' to the center of the screen. Use right mousde button when left mouse button is released. Press right mouse button and move, or
' right click twice for group parts near middle the screen (not to real middle)
'
GetMouse MX, MY, LB, RB
If RB = -1 Then
AnimB
If Sgn(Timer - FirstRClick) = 1 Then
If Timer - FirstRClick < .5 Then
'double click
Nx = 0 ' variables for move all pieces at once using right mouse button
Ny = 0
MoveR = 0
MoveS = 0
For sa = 0 To UBound(P)
If P(sa).Locked = 0 Then
P(sa).pX = _DesktopWidth \ 2
P(sa).pY = _DesktopHeight \ 2 ' right click twice and group all parts to the screen
End If
Next
End If
End If
If FirstRClick = 0 Then FirstRClick = Timer
Do Until RB = 0
oRMx = MX
oRMy = MY
GetMouse MX, MY, LB, RB
AnimB
MoveR = -oRMx + MX
MoveS = -oRMy + MY
For sa = 0 To UBound(P)
If P(sa).Locked = 0 Then
P(sa).pX = P(sa).pX + MoveR
P(sa).pY = P(sa).pY + MoveS
End If
Next
Show
_Display
_Limit 120
Loop
Else
MoveR = 0
MoveS = 0
If FirstRClick Then
If Timer - FirstRClick > .6 Then FirstRClick = 0
End If
End If
'--------------------------------------------------------- End of block for on screen parts moving ---------------------------------------------------------------------------------------------------
Next T
If LB = 0 And RB = 0 Then AnimB
Kbd$ = InKey$
' ---------------------------------------------------------- A! here is us old "Hack" block! Is also upgraded. Press right shift when left mouse button is pressed -----------------------------------------
If UCase$(Kbd$) = "H" Then ' and green CircleFill show you target
d = _Dest
_Dest 0
ReDim Hlp(0) As LinePoints
hlp_i = 0
For A = 0 To UBound(P)
If P(A).Handle < 0 And P(A).Locked = 0 Then
ReDim _Preserve Hlp(hlp_i) As LinePoints
Hlp(hlp_i).X = (P(A).pX + _Width(P(A).Handle) \ 2) 'tady bylo .Px a .Py coz si myslim bylo blbe. Otestovat. COZ BYLO SPRAVNE TY KRETENE, VRACENO.
Hlp(hlp_i).Y = (P(A).pY + _Height(P(A).Handle) \ 2)
hlp_i = hlp_i + 1
End If
Next A
For h = 1 To 3
For Circl = 10 To 25 Step 5
For A = 0 To UBound(Hlp)
If Hlp(A).Y > 0 And Hlp(A).Y < _DesktopHeight Then
If Hlp(A).X > 0 And Hlp(A).X < _DesktopWidth Then
CircleFill Hlp(A).X, Hlp(A).Y, Circl, _RGBA32(255, 10 + circ, 25 - circ, 50)
Else
Locate 4
Print "Some parts miss on this screen. Right click twice for move parts to middle screen."
_Display
End If
Else
Locate 4
Print "Some parts miss on this screen. Right click twice for move parts to middle screen."
_Display
End If
_Display
Next A
_Delay .01
Next Circl
Show
_Delay .1
For Circl = 25 To 10 Step -5
For A = 0 To UBound(Hlp)
If Hlp(A).Y > 0 And Hlp(A).Y < _DesktopHeight Then
If Hlp(A).X > 0 And Hlp(A).X < _DesktopWidth Then
CircleFill Hlp(A).X, Hlp(A).Y, Circl, _RGBA32(255, 10 + circ, 25 - circ, 50)
Else
Locate 4
Print "Some parts miss on this screen. Right click twice for move parts to middle screen."
_Display
End If
Else
Locate 4
Print "Some parts miss on this screen. Right click twice for move parts to middle screen."
_Display
End If
_Display
Next A
_Delay .01
Next Circl
Next
Show
End If
_Dest d
_Display
Loop
End
Sub FlyMess ' Do on screen message box in left upper corner
Static oldTi As Double 'for text moving in the box
Static FlyPos As Integer
If oldTi = 0 Then oldTi = Timer + .2
If Timer >= oldTi Then
FlyPos = FlyPos + 1 ' is time for next character in text
oldTi = Timer + .2
End If
If oldT > Timer + 1000 Then oldT = 0 ' midnight security (not tested)
If FlyPos = 0 Then FlyPos = 1
If LastSegmentTime = 0 Then LastSegmentTime = Timer + 15 'set time for next A,a option for auto move
If Timer > LastSegmentTime Then AllowAuto = -1 Else AllowAuto = 0
u$ = " Done: " + LTrim$(Str$(Completed)) + " / " + LTrim$(Str$(TotalPieces)) + " [" + LTrim$(Str$(Int((Completed / TotalPieces) * 100))) + "%] "
If AllowAuto Then
t$ = u$ + "Select part and press A for automatic move!"
c~& = _RGB32(55, 211, 78)
Else
t$ = "Wait, recharging..." + u$
c~& = _RGB32(255, 11, 78)
End If
extra$ = " Press H for displaying the position of the parts, or Right Shift for displaying targets. Use right mouse button for moving all parts on the screen. Click right twice for group parts on the screen. Press spacebar for image preview and then again for return. " + Space$(20)
t$ = Space$(20) + t$ + extra$
X = 1 ' box left upper corner coordinate (X)
Y = 8 ' box left upper corner coordinate (Y)
LLen = 200 ' box lenght in pixels
Chars = LLen / _FontWidth
If FlyPos > Len(t$) Then FlyPos = 1
Msg$ = Mid$(t$, FlyPos, Chars)
FlyPos = FlyPos + .01
DeltaT = 15 - (LastSegmentTime - Timer) 'Red/Green line indicator calculation
ALen = (LLen / 15) * DeltaT
If ALen > LLen Then ALen = LLen
Line (X, Y)-(LLen + 9, Y + 36), _RGBA32(100, 100, 100, 150), BF
_PrintMode _KeepBackground
_PrintString (X + 4, Y + 2), Msg$
Color _RGB32(255)
Line (X + 4, Y + 22)-(X + 4 + ALen, Y + 32), c~&, BF
Line (X + 2, Y + 20)-(X + LLen + 7, Y + 34), _RGB32(190), B
End Sub
Sub GetMouse (MX As Long, MY As Long, LB As Long, RB As Long)
While _MouseInput
Wend
MX = _MouseX
MY = _MouseY
LB = _MouseButton(1)
RB = _MouseButton(2)
End Sub
Sub AnimB ' anime borders - according to the edges of the mask, MEMGET and MEMPUT perform the animation of the edges of individual fragments.
Dim As Long a, o ' It's not perfect because the edge detection isn't quite accurate yet
Dim As _MEM m
Dim As _Unsigned Long C, D
a = 0
C~& = _RGB32(50) ' mask border color value (is not the same as own mask image)
Dim gen(49) As _Unsigned Long
Generate = 0
Do Until Generate = 49 ' for better speed first random generate colors for all edges in this step
gen(Generate) = _RGB32(51 + 199 * Rnd)
Generate = Generate + 1
Loop
iG = 0
Do Until a = UBound(P)
If P(a).Handle < -1 Then ' condition from first version - if image handle is valid (in this version is valid always)
If P(a).Locked = 0 Then ' if segment can be moved
If P(a).pX > 0 And P(a).pX < _DesktopWidth Then ' if segment is on the screen (new in this version)
If P(a).pY > 0 And P(a).pY < _DesktopHeight Then
m = _MemImage(P(a).Brdr) ' read mask border image
Do Until o& >= m.SIZE - 12
D~& = gen(iG)
iG = iG + 1
If _MemGet(m, m.OFFSET + o&, _Unsigned Long) > C~& Then _MemPut m, m.OFFSET + o&, D~& 'generate points in border
If iG > 49 Then iG = 0
o& = o& + 8
Loop
o& = 0
End If
End If
End If
End If
a = a + 1
Loop
End Sub
Function ShardId& (X As Integer, Y As Integer) ' ---------------- New Function - Return real P() segment index when is clicke to it. No more rectangle detection for it! Here is used accurate Mask detection! ----------------
Dim As _Unsigned Long Id, Sc
Dim As Long A
S = _Source
_Source Mask&
Id = Point(X, Y) ' Read Mask color (X and Y are mouse graphical coordinates) from Mask virtual screen (you use it hidden so as is used program screen)
_Source S
A& = 0
Do Until A& = UBound(P)
If P(A&).Handle < 0 Then ' if image handle is valid
If P(A&).Locked = 0 Then
Sc = _RGB32(P(A&).R, P(A&).G, P(A&).B) 'read mask color used for this part
If Sc > 0~& Then
If Sc = Id Then
ShardId& = A& '
Exit Function ' if mask color for this part is the same as on the mask,
End If
End If
End If
End If
A& = A& + 1
Loop
ShardId& = 0 ' return P array index
End Function
Sub Show
_Dest Mask
Cls
_Dest 0
Cls , _RGB32(200)
_PutImage (0, 0), GridBck
For s = 0 To UBound(G)
' SUB contains two steps: First - display correct placed parts,
If P(G(s).Handle).Handle < 0 Then
If P(G(s).Handle).Locked = 1 Then
imgX = P(G(s).Handle).pX
imgY = P(G(s).Handle).pY
_PutImage (imgX, imgY), P(G(s).Handle).Handle
_PutImage (imgX, imgY), P(G(s).Handle).MskHandle, Mask& ' place masks to mask
End If
End If
Next s
FlyMess
For s = 0 To UBound(G)
' Second - then show all others parts - so is not possible "hide" free parts
If P(G(s).Handle).Handle < 0 Then
If P(G(s).Handle).Locked = 0 Then
imgX = P(G(s).Handle).pX
imgY = P(G(s).Handle).pY
_PutImage (imgX, imgY), P(G(s).Handle).Handle
_PutImage (imgX, imgY), P(G(s).Handle).Brdr ' place animed borders (if segment move is enabled)
_PutImage (imgX, imgY), P(G(s).Handle).MskHandle, Mask&
End If
End If
Next s
End Sub
Sub MoveShow (id)
Show
If P(id).Handle < 0 Then
imgX = P(id).pX ' the same as show, but moved part is always displayed on top
imgY = P(id).pY ' (sub is used when part is moved with mouse)
_PutImage (imgX, imgY), P(id).Handle
_PutImage (imgX, imgY), P(id).Brdr 'okraje
_PutImage (imgX, imgY), P(id).MskHandle, Mask&
End If
End Sub
Sub Sort ' according to the area of the picture, place the indexes of the P field
' for rendering in the G field. The largest area will be the first (index 0)
' 1) Create array P2 and write here area (width * height) for image the same index in array P
ubP = UBound(P) ' this is not very good method, because transparency pixels are here calculated as full pixels...
ReDim p2(ubP) As Long
For copy = 0 To ubP
p2(copy) = _Width(P(copy).Handle) * _Height(P(copy).Handle)
Next
' go through field P2, find the largest area, write it in field G and then set it to zero in field P2
ReDim G(ubP) As Gtype
Do Until All = ubP
I = 0
Max = 0
Rec = 0
Do Until I = ubP
If p2(I) > 0 Then
If Max < p2(I) Then Max = p2(I): Rec = I
End If
I = I + 1
Loop
If Max Then
p2(Rec) = 0
G(iG).Handle = Rec ' set the value of the index of the field P in field G
G(iG).Index = iG 'snad
iG = iG + 1
End If
All = All + 1
Loop
ReDim p2(0) As Long
Erase p2
End Sub
Sub GiveForm (source As Long, img As Long, images() As Puzz) ' returns individual tiles as individual images
' source is MASK source image, img is input image, images() is array for image parts
D = _Dest
ReDim As Long X, Y, MinX, MinY, MaxX, maxY, Virtual, V2, Allimages, Ui, PstOffset, D
ReDim As _Unsigned Long Kolor
UnC~& = UnUsedColor~&(img) ' find free color for mask (is color, which is not used in source image)
'this is for preview only, when parts are created, show image on the screen
'image ratio is now accepted
PreviewWDTH = 400
PreviewHGHT = 300
If _Width(img) > _Height(img) Then SpcRatio = _Width(img) / _Height(img) Else SpcRatio = _Height(img) / _Width(img)
SpcV_DeltaW = Abs(_Width(img) - PreviewWDTH) '
SpcV_DeltaH = Abs(_Height(img) - PreviewHGHT) ' look to row 535 for details - it is for imageview in image correct ratio
SpcV_PercW = SpcV_DeltaW / (_Width(img) / 100) '
SpcV_PercH = SpcV_DeltaH / (_Height(img) / 100) '
If SpcV_PercW > SpcV_PercH Then SpcV_P = SpcV_PercW Else SpcV_P = SpcV_PercH
SpcV_P = SpcV_P / 100
FinalRatio = 1 - SpcV_P 'downsizing
SpcV_W = FinalRatio * _Width(img)
SpcV_H = FinalRatio * _Height(img)
'on screen text and text position
Text1$ = "Generating Puzzle, please wait..."
CenterX = _Width(0) \ 2 - _PrintWidth(Text1$) \ 2
LineLen = _PrintWidth(Text1$)
CenterY = _Height(0) \ 2 - 16
LineY = CenterY + 20
'image down sizing in ratio
RatioX = _DesktopWidth / _Width(img&) ' RotioX, RatioY - calculate the aspect ratio of the image
RatioY = _DesktopHeight / _Height(img&) ' relative to the aspect ratio of the screen so that the placed image is not stretched
If RatioX < RatioY Then Ratio = RatioX Else Ratio = RatioY ' and distorted, but reduced (or enlarged) in the aspect ratio, without its deformation
ImageX = (_DesktopWidth - _Width(img&) * Ratio) \ 2 ' calculate image position in middle
ImageY = (_DesktopHeight - _Height(img&) * Ratio) \ 2
Dim As _MEM Pnt, Pst ' Pnt as Point, Pst as PSet
Pnt = _MemImage(source)
Hs = _Height(source)
Ws = _Width(source)
Dim PNewSize As Long
PNewSize = 0
For Allimages = 0 To UBound(P)
Kolor~& = _RGB32(P(Allimages).R, P(Allimages).G, P(Allimages).B) 'read mask color for THIS part
X = 0
Y = 0
MinX = _Width(source)
MaxX = 0
MinY = _Height(source)
maxY = 0
' find image size and copy element to virtual screen in 1 step
Virtual = _NewImage(_Width(source), _Height(source), 32)
_Source source
_Dest Virtual
Cls , UnC~& ' Background color in Virtual must be set as color, which is not used in image
Pst = _MemImage(Virtual)
S = 0
Do Until Y = Hs
X = 0
Do Until X = Ws
' CC~& = Point(X, Y)
PstOffset = (Y * Ws + X) * 4
CC~& = _MemGet(Pnt, Pnt.OFFSET + PstOffset, _Unsigned Long)
If CC~& = Kolor~& Then
If MinY > Y Then MinY = Y
If maxY < Y Then maxY = Y
If MinX > X Then MinX = X
If MaxX < X Then MaxX = X
'PSet (X, Y), Kolor~& ' draw 1 part to virtual screen (which use the same size as mask image)
_MemPut Pst, Pst.OFFSET + PstOffset, CC~&
S = S + 1 ' valid area without transparent parts
End If ' and measure real image width and height
X = X + 1 ' (you draw here only 1 mask for 1 part image to Virtual)
Loop
Y = Y + 1
Loop
_MemFree Pst
' we have done writing points to virtual screen in this SUB
'---------------------------
P(Allimages).X = MinX ' put left upper corner position for this 1 part to array P
P(Allimages).Y = MinY
'---------------------------
NotCreate = 0
If S < 500 Then NotCreate = 1 ' this condition block creating really very small parts (15x15 pixels and less) '
If MaxX - MinX < 15 Or maxY - MinY < 15 Then NotCreate = 1 ' S = visible area on the image (S = so much pixels is visible)
If NotCreate Then
_FreeImage Virtual ' HERE WAS memory leak - miss _freeimage before... - _continue skip _freeimage...
_Continue ' do not create really small pieces
End If
_SetAlpha 0, Kolor~&, Virtual ' set color in mask image as transparent
V2 = _NewImage(_Width(source), _Height(source), 32) ' create image the same size as mask
D = _Dest
_Dest V2
Cls , _RGB32(50) ' set this image background color (also set colors intensity on the game screen) barva okraju okolo
_Dest D
MyImage& = _NewImage(_Width(img&) * Ratio, _Height(img&) * Ratio) ' output image - create it in ratio
_PutImage (0, 0)-(_Width(img&) * Ratio, _Height(img&) * Ratio), img&, MyImage& ' place original image to empty image MyImage - in ratio
_PutImage (ImageX, ImageY), MyImage&, V2 ' place centered image (complete image) in ratio to V2 'zde nove pridan ImageY pro centrovani v ose Y a vypada to ze ok
_PutImage , Virtual, V2 ' place mask image to complete centered image in correct ratio
Ui = UBound(images)
P(Allimages).Handle = _NewImage(MaxX - MinX + 1, maxY - MinY + 1, 32) ' create image in real size (big as part)
_SetAlpha 0, UnC~&, V2 ' upgraded to color not used in img image set transparent background to P().handle
_PutImage (0, 0), V2, P(Allimages).Handle, (MinX, MinY)-(MaxX, maxY) ' place this part image from V2 to P().handle
_FreeImage V2 ' clear ram
' _MemFree Pst
_FreeImage Virtual
_FreeImage MyImage&
Virtual = 0
' this is for preview only, when parts are created, show image on the screen
' image ratio is now accepted
_PutImage (200, 150)-(200 + SpcV_W, 150 + SpcV_H), img&, 0
' text "please wait, loading"
_PrintString (CenterX, CenterY), Text1$, 0
Line (CenterX - 2, LineY - 2)-(CenterX + LineLen + 2, LineY + 17), _RGB32(255), B
Line (CenterX, LineY)-(CenterX + LineLen * Allimages / UBound(P), LineY + 15), _RGB32(120, 100, 150), BF ' generate indicator
Next Allimages
_MemFree Pnt
MikroMask ' create masks for all parts
D = _Dest
_Dest Mask
Cls
_Dest D
End Sub
Function UnUsedColor~& (ImageHandle As Long) 'cca 0.1 sec to find unused color
Dim BGRA(255, 255, 255) As _Unsigned _Byte 'return first free (in image not used) color
Dim As Long S
Dim As _Unsigned _Byte B, G, R, A
Dim As _MEM m
m = _MemImage(ImageHandle&)
Do Until S = m.SIZE - 4
_MemGet m, m.OFFSET + S, B
_MemGet m, m.OFFSET + S + 1, G
_MemGet m, m.OFFSET + S + 2, R
_MemGet m, m.OFFSET + S + 3, A
BGRA(R, G, B) = 1
S = S + 4
Loop
R = 0
G = 0
B = 0
Do Until R = 255 Or BGRA(R, G, B) = 0
G = 0
Do Until G = 255 Or BGRA(R, G, B) = 0
B = 0
Do Until B = 255 Or BGRA(R, G, B) = 0
B = B + 1
Loop
G = G + 1
Loop
R = R + 1
Loop
' none owerflow conditions here, because it is 16 777 216 colors. How big is this screen, if each pixel use own 1 color? 4096x4096 pixels. Who writes programs in 8K here?
_MemFree m '
Erase BGRA
UnUsedColor = _RGB32(R, G, B)
End Function
Sub MikroMask ' with the help of a saved image in .handle, made a mask image in .mskhandle in one color
Dim As _MEM m, n
Dim As Long o
Dim As _Unsigned Long K
Do Until a = UBound(P)
If P(a).Handle < 0 Then
m = _MemImage(P(a).Handle) 'zdroj
w = _Width(P(a).Handle)
h = _Height(P(a).Handle)
P(a).MskHandle = _NewImage(w, h, 32)
n = _MemImage(P(a).MskHandle) 'cil
K = _RGB32(P(a).R, P(a).G, P(a).B)
Do Until o& = n.SIZE - 4
If _MemGet(m, m.OFFSET + o&, _Unsigned Long) Then _MemPut n, n.OFFSET + o&, K~&
o& = o& + 4
Loop
_MemFree m
_MemFree n
End If
a = a + 1
o& = 0
Loop
LightMask
End Sub
Sub LightMask ' Creates an image with mask boundaries (this is then only used to animate the boundaries of the shape,
Dim As _MEM m ' where, if you look closely, you'll see that the edge detection can't be used for anything else, because it's bad).
Dim As Long o, a
Dim As _Unsigned Long K, L
D = _Dest
Do Until a = UBound(P)
If P(a).Handle < 0 Then
w = _Width(P(a).Handle)
h = _Height(P(a).Handle)
K~& = _RGB32(P(a).R, P(a).G, P(a).B)
L = _RGB32(255 - P(a).R, 255 - P(a).G, 255 - P(a).B)
Percents = 0
' version for reducion the mask for the edges and its insertion into the original mask:
Po = 6 ' edge size
If w >= h Then Percents = Po / (w / 100) Else Percents = Po / (h / 100)
Percents = 1 - Percents / 100 ' downsize
NewW = CInt(w * Percents)
NewH = CInt(h * Percents)
DeltaW = CInt((w - NewW) \ 2) ' target coordinates for original mask in new bigger mask
DeltaH = CInt((h - NewH) \ 2)
DnMask& = _NewImage(w, h, 32) ' image for inserting two masks. First original (bigger) mask
_Dest DnMask&
Cls ' set black background
_Dest D
_PutImage , P(a).MskHandle, DnMask& ' insert original (big) mask - size as segment
_SetAlpha 0, _RGB32(0), DnMask& ' set transparency
m = _MemImage(DnMask&)
Do Until o = m.SIZE - 4
If _MemGet(m, m.OFFSET + o&, _Unsigned Long) = K~& Then _MemPut m, m.OFFSET + o&, L~& 'colorize original mask to color L
o = o + 4
Loop
_PutImage (DeltaW, DeltaH)-(NewW, NewH), P(a).MskHandle, DnMask& ' deposit of the original mask in a reduced size in the middle (even the edges with the color L will remain)
_SetAlpha 0, K~&, DnMask& ' set transparency for K color - is reduced mask color, so now exist BAD image with edges)
' developing better versions for this now.
o = 0
Do Until o = m.SIZE - 4 ' for edeges colorizing set first pixels here
If _MemGet(m, m.OFFSET + o&, _Unsigned Long) = L~& Then
K~& = _RGB32(55 + 200 * Rnd)
_MemPut m, m.OFFSET + o&, K~& ' as you can see here, image set to color K is here random filled
End If
o = o + 4
Loop
P(a).Brdr = _CopyImage(DnMask&, 32) ' save border mask to array P
_MemFree m
_FreeImage DnMask&
End If
a = a + 1
o& = 0
Loop
_Dest D
End Sub
Sub PlaceForm (typ As Integer, dest As Long, kolor As _Unsigned Long) ' generate some parts to mask image in white color. Se easy, so comment here is not needed.
D = _Dest
_Dest dest
W = _Width(dest)
H = _Height(dest)
Select Case typ
Case 1
Circle (-W / 2 + Rnd * W, -H / 2 + Rnd * H), -W / 4 + Rnd * W / 8, kolor
Case 2
Line (-W / 2 + Rnd * W, -H / 2 + Rnd * H)-(-W / 2 + Rnd * W, -H / 2 + Rnd * H), kolor, B
Case 3, 4, 5, 6
Dim X(typ) As Integer
Dim Y(typ) As Integer
'vygeneruju cilove body
For Rand = 0 To typ
X(Rand) = Rand + Rnd * W
Y(Rand) = Rand + Rnd * H
Next
PReset (X(0), Y(0))
For Drw = 0 To typ - 1
GETPOINTS X(Drw), Y(Drw), X(Drw + 1), Y(Drw + 1), LP()
Color kolor
DeformedLine
'Line -(X(Drw), Y(Drw)), kolor
Next
Line -(X(0), Y(0)), kolor
Case 7
cX = -W / 2 * Rnd + W * Rnd
cY = -H / 2 * Rnd + H * Rnd
For a = 0 To 300 Step 60
PReset (cX, cY)
For s = 0 To W Step 50
aR = _D2R(a)
If s < 100 Then noise = 0 Else noise = Rnd * 20
nX = cX + Cos(aR) * 2 * s + noise
ny = cY + Sin(aR) * 2 * s + noise
Line -(nX, ny), kolor
Next s
Next a
Case 8, 9, 10, 11
Dim X(typ) As Integer
Dim Y(typ) As Integer
'vygeneruju cilove body
For Rand = 0 To typ
X(Rand) = Rand + Rnd * W
Y(Rand) = Rand + Rnd * H
Next
PReset (X(0), Y(0))
For Drw = 0 To typ - 1
Line -(X(Drw), Y(Drw)), kolor
Next
Line -(X(0), Y(0)), kolor
End Select
End Sub
Sub DeformedLine ' 1) get array with points as normal line (LP is shared output array GETPOINTS SUB)
Static n, noise ' 2) do not fill it point to point but in step + use random points in small range
noise = noise + n
If noise > 18 Then n = -1
If noise < 3 Then n = 1
If LP(0).X > 0 And LP(0).Y > 0 Then PReset (LP(0).X, LP(0).Y)
For e = 0 To UBound(LP) Step 10
If LP(e).X < 0 Or LP(e).Y < 0 Then
PReset (LP(e).X * -1, LP(e).Y * -1)
End If
x = -noise / 2 + noise * Rnd + LP(e).X
y = -noise / 2 + noise * Rnd + LP(e).Y
Line -(x, y)
Next e
e = UBound(LP) - 1
If LP(e).X > 0 And LP(e).Y > 0 Then Line -(LP(e).X, LP(e).Y)
End Sub
Sub GETPOINTS (x1, y1, x2, y2, A() As LinePoints) ' Return points in LP() array - points so as line statement works
Dim lenght As Integer
lenght = _Hypot(x1 - x2, y1 - y2) 'Fellippe Heitor show me using this great function.
ReDim A(lenght) As LinePoints
For fill = 0 To lenght
If x1 > x2 Then A(fill).X = x1 - fill * ((x1 - x2) / lenght)
If x1 < x2 Then A(fill).X = x1 + fill * ((x2 - x1) / lenght)
If x1 = x2 Then A(fill).X = x1
If y1 > y2 Then A(fill).Y = y1 - fill * ((y1 - y2) / lenght)
If y1 < y2 Then A(fill).Y = y1 + fill * ((y2 - y1) / lenght)
If y1 = y2 Then A(fill).Y = y1
Next
End Sub
Sub CircleFill (cx As Integer, cy As Integer, r As Integer, c As _Unsigned Long) 'SMcNeill routine
Dim a As Long, b As Long
Dim x As Long, y As Long
Dim xx As Long, yy As Long
Dim sx As Long, sy As Long
Dim e As Long
Dim rx As Integer, ry As Integer
rx = r: ry = r
a = 2 * rx * rx
b = 2 * ry * ry
x = rx
xx = ry * ry * (1 - rx - rx)
yy = rx * rx
sx = b * rx
Do While sx >= sy
Line (cx - x, cy - y)-(cx + x, cy - y), c, BF
If y <> 0 Then Line (cx - x, cy + y)-(cx + x, cy + y), c, BF
y = y + 1
sy = sy + a
e = e + yy
yy = yy + a
If (e + e + xx) > 0 Then
x = x - 1
sx = sx - b
e = e + xx
xx = xx + b
End If
Loop
x = 0
y = ry
xx = rx * ry
yy = rx * rx * (1 - ry - ry)
e = 0
sx = 0
sy = a * ry
Do While sx <= sy
Line (cx - x, cy - y)-(cx + x, cy - y), c, BF
Line (cx - x, cy + y)-(cx + x, cy + y), c, BF
Do
x = x + 1
sx = sx + b
e = e + xx
xx = xx + b
Loop Until (e + e + yy) > 0
y = y - 1
sy = sy - a
e = e + yy
yy = yy + a
Loop
End Sub
Sub GetLists (SearchDirectory As String, DirList() As String, FileList() As String) 'copy from XMas program 02-12-2021 - Steve's work
Declare CustomType Library ".\direntry"
Function load_dir& (s As String)
Function has_next_entry& ()
Sub close_dir ()
Sub get_next_entry (s As String, flags As Long, file_size As Long)
End Declare
Dim flags As Long, file_size As Long, DirCount As Long, FileCount As Long, length As Long
Dim nam$, slash$
ReDim _Preserve DirList(1000), FileList(1000)
DirCount = 0: FileCount = 0
$If WIN Then
slash$ = "\"
$Else
slash$ = "/"
$End If
If Right$(SearchDirectory$, 1) <> "/" And Right$(SearchDirectory$, 1) <> "\" Then SearchDirectory$ = SearchDirectory$ + slash$
If load_dir(SearchDirectory + Chr$(0)) Then
Do
length = has_next_entry
If length > -1 Then
nam$ = Space$(length)
get_next_entry nam$, flags, file_size
If _DirExists(SearchDirectory + nam$) Then
DirCount = DirCount + 1
If DirCount > UBound(DirList) Then ReDim _Preserve DirList(UBound(DirList) + 100)
DirList(DirCount) = nam$
ElseIf _FileExists(SearchDirectory + nam$) Then
FileCount = FileCount + 1
If FileCount > UBound(FileList) Then ReDim _Preserve FileList(UBound(FileList) + 100)
FileList(FileCount) = nam$
Else 'This else should never actually trigger
Print: Print: Print "zzz... Unknown file found: "; SearchDirectory; slash$; nam$, _DirExists(nam$)
Beep: Sleep ' alert the user to
End If
End If
Loop Until length = -1
End If
close_dir
ReDim _Preserve DirList(DirCount)
ReDim _Preserve FileList(FileCount)
End Sub
Sub LoadFiles (FileA() As String)
'1) SUB load ALL files from images subdirectory to array FileA, check if file extension is valid, this place to array FileB.
'2) in FileB array check file format validity, if is not valid in first step create array, which contains invalid records indexes numbers,
'3) in next step all invalid files shift to ubound (example - if 6 files has known extension, but unknown format, program shift it to
' Ubound(FileB), Ubound(FileB) - 1 to Ubound(FileB) -6.
'4) in next step this records are deleted from memory using _Preserve, so then FileB array contains only compatible image files.
'5) Then is in RandomizeArr created random index mix and records in FileB are randomly replaced.
'6) This is then placed to ImaArray (this was used in first version for this program)
Print "Checking image files in images folder:"
test = 0
' Check files by extension to array FileB
ReDim FileB(0) As String ' note: Index 0 in array FileA contains none record, it start from 1
Do Until test = UBound(FileA) + 1 ' +1 must be here or 1 file miss!
Select Case UCase$(Right$(RTrim$(FileA(test)), 3))
Case "JPG", "PNG", "TGA", "BMP", "PSD", "GIF", "HDR", "PIC", "PNM", "PCX", "SVG", "ICO", "CUR", "QOI"
ib = ib + 1 ' select files mask
ReDim _Preserve FileB(ib) As String
FileB(ib) = FileA(test)
End Select
test = test + 1
Loop
$If WIN Then
pth$ = "images\"
$Else
pth$ = "images/"
$End If
UboP = UBound(FileB)
test = 1
ReDim InvalidRec(0) As Long
Do Until test = UboP + 1
testf& = _LoadImage(pth$ + FileB(test), 32)
If testf& < -1 Then
Color 7 'grey Here it all starts, it is Screen 0
Print "File: "; FileB(test);
Color 2 'green
Print " PASS"
Ti = Ti + 1
_FreeImage testf&
Else
Color 7
Print "File: "; FileB(test);
Color 4 'red
Print " FAIL";
' note the number of the index where there is an invalid entry in the InvalidRec field from 1
removed = removed + 1
ReDim _Preserve InvalidRec(removed) As Long
InvalidRec(removed) = test
Print " - selected as invalid record"
Color 7
End If
test = test + 1
Loop
' now move the invalid records to the ubound of the FileB field
i = 0
For eraseit = 1 To removed
index = InvalidRec(eraseit) - i
invalid$ = FileB(index) ' store the invalid record in the invalid$ variable
i = i + 1 ' i variable: because every time a record is deleted, all invalid records are moved to the end of the field,
For t = index To UboP - 1 ' the indexes of the original invalid records also change (always by -1). That is why it is necessary
FileB(t) = FileB(t + 1) ' to take the shift in the variable into account.
Next t
FileB(UboP) = invalid$
Next
ReDim _Preserve FileB(UboP - removed) As String ' Delete invalid recors in array FileB
If UBound(FileB) < 1 Then
Cls
Print "No record."
Print "Not valid files or none file in "; pth$; " subdirectory."
Print "Please create images subfolder and copy here some valid"
Print "image files (JPG, BMP, GIF, PCX, PNG....)"
Print
Print "Press any key to end."
Sleep
System
End If
ReDim ImaArray(UBound(FileB) - 1) As String ' This was array for files in first version this program and start from zero. So here is used also (program use it)
'Here, random shuffling of indices in the FileB array is resolved so that images do not follow each other in the same order each time it is run. But first the reference to index 0 is removed,
'because it contains no record, but the original ImaArray field uses index 0.
ReDim s(UBound(FileB) - 1) As Long ' records here are replaced, so index 0 now also contains valid value
For d = 0 To UBound(s) ' fill array
s(d) = d + 1 ' To RandomizeArr only the field with the index numbers of another field as they follow one another in it is sent.
' The output is an array of the same size, but each array index already contains a random value. In development, chose a procedure
' that guarantees that no value is repeated unless it is repeated in the input field.
Next
RandomizeArr s()
For d = 0 To UBound(s)
ImaArray(d) = pth$ + FileB(s(d)) ' place randomized valid records (path and file name) according to random index to array ImaArray
Next
Erase FileA
Erase FileB
Erase InvalidRec
Erase s
End Sub
Sub RandomizeArr (s() As Long) ' randomize number in Long type array
If UBound(s) < 2 Then Exit Sub
Dim size As Long
size& = UBound(s)
If size& <= 10 Then
For mix = 0 To 2
For small = 0 To size
numA = 0
numB = 0
Randomize Timer
Do Until numA <> numB
numA = Rnd * (size& - small)
numB = 1 + Rnd * (size& - mix)
If numA < 0 Then numA = 0
If numA > size& Then numA = size&
If numB < 0 Then numB = 0
If numB > size& Then numB = size&
Loop
Swap s(numA), s(numB)
Next small, mix
Else
For e = 10 To 0 Step -1
For c = 0 To size& - 10 Step 10
For d = c To c + 10 + e
numA = 0
numB = 0
Randomize Timer
Do Until numA <> numB
numA = c + Rnd * (size& - c)
numB = c + Rnd * (size& - c)
If numA < 0 Then numA = 0
If numA > size& Then numA = size&
If numB < 0 Then numB = 0
If numB > size& Then numB = size&
Loop
Swap s(numA), s(numB)
Next d
Next c
Next e
End If
End Sub
Function Grid& (W As Long, H As Long, Density As Integer, Kolor As _Unsigned Long) 'Draw and return grid image handle (in background)
Gr& = _NewImage(W, H, 32)
D = _Dest
_Dest Gr&
L = _Hypot(H, LStep)
Color Kolor
For X = -W To W Step Density
a = _Atan2(0, Density) + _D2R(90)
x2 = X + Sin(a) * L
y2 = H + Cos(a) * L
Line (X, 0)-(x2, y2)
Line (X, H)-(x2, 0)
Next
_Dest D
Grid& = Gr&
End Function
Sub ViewImage (Img As Long)
'I've gotten a little carried away with aspect ratios, so it's time for my favorite percentages...
If _Width(Img) > _Height(Img) Then SpcRatio = _Width(Img) / _Height(Img) Else SpcRatio = _Height(Img) / _Width(Img)
SpcV_DeltaW = Abs(_Width(Img) - _DesktopWidth) ' img and screen width difference
SpcV_DeltaH = Abs(_Height(Img) - _DesktopHeight) ' img and screen height difference
SpcV_PercW = SpcV_DeltaW / (_Width(Img) / 100) ' what percentage is it from the total width of the img
SpcV_PercH = SpcV_DeltaH / (_Height(Img) / 100) ' what percentage is it from the total height of the img
If SpcV_PercW > SpcV_PercH Then SpcV_P = SpcV_PercW Else SpcV_P = SpcV_PercH 'choose a higher ratio (here in percentage)
SpcV_P = SpcV_P / 100
FinalRatio = 1 - SpcV_P ' downsizing
SpcV_W = FinalRatio * _Width(Img) ' X position on the screen
SpcV_H = FinalRatio * _Height(Img) ' Y position on the screen
SpcV_DeltaX = (_DesktopWidth - SpcV_W) \ 2 ' center image in X axis
_PutImage (SpcV_DeltaX, 0)-(SpcV_DeltaX + SpcV_W, SpcV_H), Img&, 0
End Sub
'continue next time