picture to Mosaic pictures - Printable Version

Code: (Select All)
'mosaic-picture (MasterGy2022)



'----------------------------------- S E T T I N G S



boss_pic$ = "image1.jpg" 'big picture ! this image will appear large



ratio_resx = 25 'output pictures width number of mosaic

ratio_y_start = 1 / 4 * 3 'mosaic aspect ratio width = 1 ,Height = 1*this

file_search$ = "d:" 'where can I find image files?  exapmle:    a drive "d:"  or directory "d:\pictures"



work_sx = 1200 'output picture width size

cheat_alpha = 100 'color foil alpha value to 1 mosaic

cheat_original = 30 'adding an original image transparent film to the finished work   alpha





'--------------------------------------------------------------------------------------------------------------------------------------------------------------------







If _FileExists(boss_pic$) = 0 Then Print "boss-picture not found !": End

file_ready$ = "pics_ready.dat"



monx = 800

mony = 600



mon = _NewImage(monx, mony, 32)

Screen mon

_Dest mon



If _FileExists(file_ready$) = 0 Then GoSub files_exam







boss_pic = _LoadImage(boss_pic$, 32)





work_sy = Int(work_sx / _Width(boss_pic) * _Height(boss_pic))







mosx = Int(work_sx / ratio_resx)



Open file_ready$ For Input As 1: Line Input #1, temp$: Input #1, ratio_y: If ratio_y <> ratio_y_start Or temp$ <> file_search$ Then Close 1: Kill file_ready$: Run







Close 1



ratio_resy = Int(work_sy / (mosx * ratio_y))

mosy = Int(work_sy / ratio_resy)







read_pic = _NewImage(work_sx, work_sy, 32): _Dest read_pic: _Source boss_pic: _PutImage

work_pic = _NewImage(work_sx, work_sy, 32)

_FullScreen _SquarePixels: Screen work_pic: _Dest work_pic







'database load



Open file_ready$ For Input As 1

Line Input #1, temp$

Input #1, ratio_y

Input #1, pic_c

us = Int((ratio_resx * ratio_resy) / pic_c) + 1

Dim pics$(pic_c - 1), pic_dat(pic_c - 1, 5)

For t = 0 To pic_c - 1

    Line Input #1, pics$(t)

    Input #1, pic_dat(t, 0), pic_dat(t, 1), pic_dat(t, 2)

    pic_dat(t, 3) = us

Next t











'fill mosaic

Dim rmap(ratio_resx - 1, ratio_resy - 1)



sum_mosaic = ratio_resx * ratio_resy

_Source read_pic

_Dest work_pic 'mon

_PutImage



temp = _NewImage(1, 1, 32): _Dest temp: Cls , _RGB32(0, 0, 0, 200)

_Source temp

_Dest work_pic

_PutImage

_FreeImage temp



Do: sum = sum + 1

    Do

        mx = Int(ratio_resx * Rnd)

        my = Int(ratio_resy * Rnd)

    Loop While rmap(mx, my)

    rmap(mx, my) = 1

    x1 = mx * mosx: x2 = x1 + mosx

    y1 = my * mosy: y2 = y1 + mosy



    'paste picture



    _Source read_pic



    ReDim c(3)

    For tx = x1 To x2

        For ty = y1 To y2

            c&& = Point(tx, ty)

            c(0) = _Red32(c&&) + c(0)

            c(1) = _Green32(c&&) + c(1)

            c(2) = _Blue32(c&&) + c(2)

            c(3) = c(3) + 1

    Next ty, tx



    For t = 0 To 2: c(t) = c(t) / c(3): Next t



    min = 9999999999999

    For t = 0 To pic_c - 1: If pic_dat(t, 3) <= 0 Then _Continue

        dis = (pic_dat(t, 0) - c(0)) ^ 2 + (pic_dat(t, 1) - c(1)) ^ 2 + (pic_dat(t, 2) - c(2)) ^ 2

        If dis < min Then min = dis: ok = t

    Next t



    temp = _LoadImage(pics$(ok), 32)

    'Print #5, pics$(ok), ok

    _Source temp

    _Dest work_pic

    area ax1, ay1, ax2, ay2, temp, ratio_y

    _PutImage (x1, y1)-(x2, y2), , , (ax1, ay1)-(ax2, ay2)

    _FreeImage temp



    'shadow

    temp = _NewImage(1, 1, 32): _Dest temp: Cls , _RGB32(c(0), c(1), c(2), cheat_alpha)

    _Source temp

    _Dest work_pic

    _PutImage (x1, y1)-(x2, y2)

    _Source work_pic

    _FreeImage temp





    pic_dat(ok, 3) = pic_dat(ok, 3) - 1



Loop Until sum_mosaic = sum









'add original picture shadow

_Dest read_pic

_SetAlpha cheat_original

_Dest work_pic

_Source read_pic

_PutImage



'saving

SaveImage work_pic, "saved.bmp"





End





























End

'files exam ------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------

files_exam:

ratio_y = ratio_y_start

Locate 1, 1: Print "Waiting ! I will search for the image files in the specified locations ...few minutes"

Shell _Hide "dir /b /s /a:-s " + file_search$ + "\*.bmp " + file_search$ + "\*.jpg " + file_search$ + "\*.jpeg" + " >file_stat.dat"







Open "file_stat.dat" For Input As 1: Do: Line Input #1, s$: pic_c = pic_c + 1: Loop Until EOF(1): Close 1

Locate 3, 1: Print pic_c; " can be used pictures find"







Open "file_stat.dat" For Input As 1

Open "temp.dat" For Output As 2



ex_pic_size = 200

ex_pic = _NewImage(ex_pic_size, ex_pic_size * ratio_y, 32)



For t = 0 To pic_c - 1

    _Dest mon

    Locate 5, 1: Print "Examine the color depth of the image files ..."; Int(1000 / (pic_c - 1) * t) / 10; "% ready   ("; pic_c; "/"; (t + 1); ")"

    Line Input #1, s$



    Locate 6, 1: Print s$ + Space$(40)

    '    End



    If _FileExists(s$) And Mid$(s$, Len(file_search$) + 2, 1) <> "$" Then



        x = _LoadImage(s$, 32)



        If x Then

            hiba = 0

            On Error GoTo error1

            _Source x

            On Error GoTo 0

            If hiba = 0 Then



                _Dest ex_pic

                area ax1, ay1, ax2, ay2, x, ratio_y



                _PutImage , , , (ax1, ay1)-(ax2, ay2)

                _Dest mon

                psize = monx / 3

                _Source ex_pic

                _PutImage (0, Int(mony / 2))-(psize, Int(mony / 2 + psize * ratio_y))





                '                Screen ex_pic

                ReDim c(3)

                For tx = 0 To ex_pic_size - 1

                    For ty = 0 To ex_pic_size - 1

                        c&& = Point(tx, ty)

                        c(0) = _Red32(c&&) + c(0)

                        c(1) = _Green32(c&&) + c(1)

                        c(2) = _Blue32(c&&) + c(2)

                        c(3) = c(3) + 1

                Next ty, tx



                Print #2, s$

                Print #2, Int(c(0) / c(3)), Int(c(1) / c(3)), Int(c(2) / c(3)): cnt = cnt + 1

                _FreeImage x

            End If

        End If

    End If



Next t

Close 1, 2





Open "temp.dat" For Input As 1



ReDim pics$(cnt - 1), pic_dat(cnt - 1, 5)

For t = 0 To cnt - 1

    Line Input #1, pics$(t)

    Input #1, pic_dat(t, 0), pic_dat(t, 1), pic_dat(t, 2)

Next t

Close 1







For t = 0 To cnt - 2: Locate 8, 1: Print "subtraction of identical shades :"; Int(1000 / (pic_c - 1) * t) / 10; "%"

    For t2 = t + 1 To cnt - 1

        pic_dat(t2, 4) = (pic_dat(t, 0) = pic_dat(t2, 0) And pic_dat(t, 1) = pic_dat(t2, 1) And pic_dat(t, 2) = pic_dat(t2, 2)) Or pic_dat(t2, 4)

    Next t2

Next t





For t = 0 To cnt - 1: present = present + Abs(pic_dat(t, 4) = 0): Next t

Locate 9, 1: Print "substractions :"; cnt - present; " pictures"



Open file_ready$ For Output As 1

Print #1, file_search$

Print #1, ratio_y

Print #1, present

For t = 0 To cnt - 1: If pic_dat(t, 4) Then _Continue

    Print #1, pics$(t)

    Print #1, pic_dat(t, 0), pic_dat(t, 1), pic_dat(t, 2)

Next t

Close 1













_FreeImage ex_pic

On Error GoTo 0

Kill "file_stat.dat"

Kill "temp.dat"

Sleep 2

Run











error1: hiba = 1: Resume Next



Sub SaveImage (image As Long, filename As String)

    bytesperpixel& = _PixelSize(image&)

    If bytesperpixel& = 0 Then Print "Text modes unsupported!": End

    If bytesperpixel& = 1 Then bpp& = 8 Else bpp& = 24

    x& = _Width(image&)

    y& = _Height(image&)

    b$ = "BM????QB64????" + MKL$(40) + MKL$(x&) + MKL$(y&) + MKI$(1) + MKI$(bpp&) + MKL$(0) + "????" + String$(16, 0) 'partial BMP header info(???? to be filled later)

    If bytesperpixel& = 1 Then

        For c& = 0 To 255 ' read BGR color settings from JPG image + 1 byte spacer(CHR$(0))

            cv& = _PaletteColor(c&, image&) ' color attribute to read.

            b$ = b$ + Chr$(_Blue32(cv&)) + Chr$(_Green32(cv&)) + Chr$(_Red32(cv&)) + Chr$(0) 'spacer byte

        Next

    End If

    Mid$(b$, 11, 4) = MKL$(Len(b$)) ' image pixel data offset(BMP header)

    lastsource& = _Source

    _Source image&

    If ((x& * 3) Mod 4) Then padder$ = String$(4 - ((x& * 3) Mod 4), 0)

    For py& = y& - 1 To 0 Step -1 ' read JPG image pixel color data

        r$ = ""

        For px& = 0 To x& - 1

            c& = Point(px&, py&) 'POINT 32 bit values are large LONG values

            If bytesperpixel& = 1 Then r$ = r$ + Chr$(c&) Else r$ = r$ + Left$(MKL$(c&), 3)

        Next px&

        d$ = d$ + r$ + padder$

    Next py&

    _Source lastsource&

    Mid$(b$, 35, 4) = MKL$(Len(d$)) ' image size(BMP header)

    b$ = b$ + d$ ' total file data bytes to create file

    Mid$(b$, 3, 4) = MKL$(Len(b$)) ' size of data file(BMP header)

    If LCase$(Right$(filename$, 4)) <> ".bmp" Then ext$ = ".bmp"

    f& = FreeFile

    Open filename$ + ext$ For Output As #f&: Close #f& ' erases an existing file

    Open filename$ + ext$ For Binary As #f&

    Put #f&, , b$

    Close #f&

End Sub





Sub area (ax1, ay1, ax2, ay2, pic, ratio_y)



    x = _Width(pic)

    y = _Width(pic) * ratio_y



    If y > _Height(pic) Then

        y = _Height(pic)

        x = _Height(pic) / ratio_y

    End If



    ax1 = (_Width(pic) - x) / 2

    ax2 = ax1 + x

    ay1 = 0 '(_Height(pic) - y) / 2

    ay2 = ay1 + y







End Sub