09-29-2024, 11:08 PM
(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
![[Image: puzz-prev.png]](https://i.ibb.co/k5prX3y/puzz-prev.png)
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.
Of all the places on Earth, and all the planets in the Universe, I'd rather live here (Perth, W.A.) 
Please visit my Website at: http://oldendayskids.blogspot.com/
Please visit my Website at: http://oldendayskids.blogspot.com/