Mosaic Stereogram

Date: 02-16-2022

Return to Index

 
'Compilable Example:  (Jose Includes)
#Compiler PBWin 9, PBWin 10
#Compile EXE
#Dim All
%Unicode=1
 
#Debug Error On     'catch array/pointer errors - OFF in production
#Debug Display On   'display untrapped errors   - OFF in production
#Include "win32api.inc"
#Resource "gbsnippets.pbr"
 
%ID_Graphic = 500 : %ID_Timer = 400
Global hDlg As DWord, hImgListMosaic&, stgMaxX As Long, stgMaxY As Long
Global stgArray() As Long, stgCharList$, stgPatternSize As Long, Resizing&
 
Function PBMain() As Long
   Dialog New Pixels, 0, "Mosaic Stereogram",400,100,700,600, %WS_OverlappedWindow To hDlg
   Control Add Graphic, hDlg, %ID_Graphic, "", 0,0,700,600, %WS_Border
   Graphic Attach hDlg, %ID_Graphic, Redraw
   Graphic Color %Black, %White : Graphic Clear
   Dialog Show Modal hDlg Call DlgProc
End Function
 
CallBack Function DlgProc() As Long
   Select Case CB.Msg
      Case %WM_Size
         Resizing& = 1
         Local w As Long, h As Long
         Dialog Get Client hDlg To w,h
         Control Kill hDlg, %ID_Graphic
         Control Add Graphic, hDlg, %ID_Graphic, "", 0,0,w,h, %WS_Border
         Graphic Attach hDlg, %ID_Graphic, Redraw
         Graphic Color %Black, %White : Graphic Clear
         Resizing& = 0
 
      Case %WM_InitDialog
         MosaicCreateImageList
         SetTimer(CB.Hndl, %ID_Timer, 40, 0)
 
      Case %WM_Timer
         If Resizing& = 0 Then InitializeStereogram : CreateMosaicStereogram
   End Select
End Function
 
Sub CreateMosaicStereogram
   Local iLevel As Long, sPattern As String, Diff As Long
   Local i As Long, x As Long, y As Long, char$, img$
 
   'create/display the stereogram
   For y = 0 To stgMaxY - 1
      iLevel = 0: sPattern = ""
      For i = 1 To stgPatternSize: sPattern = sPattern & Mid$(stgCharList, Rnd(1,Len(stgCharList)), 1): Next i
      Diff = stgPatternSize
      For x = 0 To stgMaxX - 1
         If stgArray(x, y) <> iLevel Then
            Diff = stgPatternSize - stgArray(x, y)
            iLevel = stgArray(x, y)
         End If
         sPattern = sPattern + Left$(Right$(sPattern, Diff), 1)
         char$ = Right$(sPattern, 1) : img$ = "mos" + Format$(Asc(char$), "000")
         Graphic ImageList (15*x, 30*y), hImgListMosaic, Asc(char$)-69, 0&, %ILD_Normal
      Next x
   Next y
   Graphic Redraw
End Sub
 
Sub InitializeStereogram   'text or mosaic
   Local x As Long, y As Long, d As Single, i As Long
   'random display characters
   Control Get Client hDlg, %ID_Graphic To stgMaxX, stgMaxY
   stgMaxX = stgMaxX /15  : stgMaxY = stgMaxY/30
   ReDim stgArray(stgMaxX, stgMaxY) : stgPatternSize = 10
   stgCharList = ""
   For i = 0 To stgPatternSize : stgCharList = stgCharList + Chr$(Rnd(70,150)) : Next i
   'animation variables
   Static irep As Single : irep = irep + 0.05 : d = 0.2 * ABS(Sin(irep))
   'create depth array (object to be displayed)
   For y = (0.2+d) * stgMaxY To (0.5+d) * stgMaxY
      For x = (0.2+d) * stgMaxX To (0.5+d) * stgMaxX
         stgArray(x, y) = 1
      Next x : Next y
      For y = (0.3+d) * stgMaxY To (0.6+d) * stgMaxY
         For x = (0.3+d) * stgMaxX To (0.6+d) * stgMaxX
            stgArray(x, y) = 2
         Next x : Next y
End Sub
 
Sub MosaicCreateImageList()
   'create imagelist  w,h,depth,size
   Local i As Long
   ImageList New Icon 32,32,32,100 To hImgListMosaic
   For i = 1 To 100
      ImageList Add Icon hImgListMosaic, "mos" + Format$(i,"000")
   Next i
End Sub
 
'gbs_00437
'Date: 03-10-2012

created by gbSnippets
http://www.garybeene.com/sw/gbsnippets.htm