Text 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
#Tools Off          'use ON only when needed for Trace/Profile/CallStk
#Include "win32api.inc"
 
%ID_Graphic = 500
Global hDlg As DWord, hFont As DWord
Global hArray(), maxX As Long, maxY As Long, Stereogram As String
 
Function PBMain() As Long
   Local hDlg As DWord
   Dialog New Pixels, 0, "SIRTS",300,300,500,600, %WS_OverlappedWindow To hDlg
   Control Add Button, hDlg, 100,"Push", 10,10,100,20
   Control Add Graphic, hDlg, %ID_Graphic, "", 10,40,480,550, %WS_Border
 
   Font New "Courier New", 10, 1 To hFont
   Control Set Font hDlg, %ID_Graphic, hFont
 
   Graphic Attach hDlg, %ID_Graphic
   Dialog Show Modal hDlg Call DlgProc
End Function
 
CallBack Function DlgProc() As Long
   If CB.Msg = %WM_Command AND CB.Ctl = 100 AND CB.Ctlmsg = %BN_Clicked Then
      CreateSIRTS
      '     Graphic Print Stereogram
   End If
End Function
 
Sub CreateSIRTS
   Dim iLevel As Long, sPattern As String, Diff As Long
   Dim i As Long, CharList As String, PatternSize As Long, x As Long, y As Long
   maxX = 50 : maxY = 50 : ReDim hArray(maxX, maxY): CreateDepthArray: Stereogram = ""
   PatternSize = 10 : CharList = "NancyNancy"
   For y = 0 To maxY - 1
      iLevel = 0: sPattern = ""
      For i = 1 To PatternSize: sPattern = sPattern & Mid$(CharList, Int(Rnd * Len(CharList) + 1), 1): Next i
      Diff = PatternSize
      For x = 0 To maxX - 1
         If hArray(x, y) <> iLevel Then
            Diff = PatternSize - hArray(x, y)
            iLevel = hArray(x, y)
         End If
         sPattern = sPattern & Left$(Right$(sPattern, Diff), 1)
      Next x
      Graphic Print sPattern
   Next y
End Sub
 
Sub CreateDepthArray
   Dim x As Single, y As Single
   For y = 0.2 * maxY To 0.5 * maxY
      For x = 0.2 * maxX To 0.5 * maxX
         If x < UBound(hArray, 1) AND y < UBound(hArray, 2) Then hArray(x, y) = 1
      Next x: Next y
      For y = 0.3 * maxY To 0.6 * maxY
         For x = 0.3 * maxX To 0.6 * maxX
            If x < UBound(hArray, 1) AND y < UBound(hArray, 2) Then hArray(x, y) = 2
         Next x: Next y
End Sub
 
'gbs_00426
'Date: 03-10-2012

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