Attribute VB_Name = "ModHalfTone"

'ModHalfTone.bas

Option Explicit

Private Cul As Long
Private ix As Long, iy As Long     ' Image data array scanning
Private ixx As Long, iyy As Long   ' Mask coords for Private MaskArray()
' MaskArray() set @ CalcSelectCoords
' or CalcSelectCoordsFromMinxmax on Form1
Private i As Long, j As Long
Private k As Long
Private B As Long, g As Long, r As Long

Private Intens() As Long

Private AvGrey As Long
Private greysum As Long
Private greycount As Long
Private zMul As Single
Private zErr As Single

Private HalftoneLimits()  As Long   ' 25,50,75,100,125,150,175,200,230
Private RandomLimits() As Long      ' 25,50,75,100,125,150,175,200,230
Private LineLimits() As Long        ' 60,120,180
Private LineLimits2() As Long       ' 42,84,126,164,210,252
Private NX As Long, NY As Long, NT As Long    ' Pattern dims
Private tm() As Byte  ' Pattern array
Private TS$()         ' Pattern string array

'<<<< Progress bar >>>>>>>>>>
Private xd As Single, xp As Single

Public Sub HTBlackWhite(BWLim As Long)
' BWLim  20 -> 200
   StartProgress HIY
   For iy = 0 To FullH - 1
   For ix = 0 To FullW - 1
      If aSelectAccepted Then ' Selection ON
         If (ix >= LOX And ix <= HIX) And (iy >= LOY And iy <= HIY) Then
            If Not aExternal Then   ' Internal
               If MaskArray(ix - LOX, iy - LOY) = 0 Then HTBlackWhiteCALC BWLim
            Else  'External
               If MaskArray(ix - LOX, iy - LOY) <> 0 Then HTBlackWhiteCALC BWLim
            End If
         Else
            If aExternal Then HTBlackWhiteCALC BWLim
         End If
      Else  ' Selection OFF
         HTBlackWhiteCALC BWLim
      End If
   Next ix
   DrawProgress
   Next iy
   
   frmHalfTone.picPB.Cls
End Sub

Private Sub HTBlackWhiteCALC(BWLim As Long)
' Private ix As Long, iy As Long
      Cul = (1& * picDATAORG(0, ix, iy) + _
                  picDATAORG(1, ix, iy) + _
                  picDATAORG(2, ix, iy)) \ 3
      If Cul < BWLim Then
         picDATA(0, ix, iy) = 0
         picDATA(1, ix, iy) = 0
         picDATA(2, ix, iy) = 0
      Else
         picDATA(0, ix, iy) = 255
         picDATA(1, ix, iy) = 255
         picDATA(2, ix, iy) = 255
      End If
End Sub

Public Sub Floyd_SteinbergA(zDiv As Single)

'Simplest Floyd-SteinbergA
'   x 3
'   3 2  /8

Dim rL As Byte, gL As Byte, bL As Byte
Dim RR As Byte, GR As Byte, BR As Byte

   LngToRGB RightColor, rL, gL, bL
   LngToRGB LeftColor, RR, GR, BR

   FillIntensityArray
   zMul = 1 / zDiv
   
   StartProgress HIY
   For iy = 0 To FullH - 1
   For ix = 0 To FullW - 1
      If aSelectAccepted Then ' Selection ON
         If (ix >= LOX And ix <= HIX) And (iy >= LOY And iy <= HIY) Then
            If Not aExternal Then   ' Internal
               If MaskArray(ix - LOX, iy - LOY) = 0 Then Floyd_SteinbergACALC zErr, zMul, greysum, bL, gL, rL, BR, GR, RR
            Else  'External
               If MaskArray(ix - LOX, iy - LOY) <> 0 Then Floyd_SteinbergACALC zErr, zMul, greysum, bL, gL, rL, BR, GR, RR
            End If
         Else
            If aExternal Then Floyd_SteinbergACALC zErr, zMul, greysum, bL, gL, rL, BR, GR, RR
         End If
      Else  ' Selection OFF
         Floyd_SteinbergACALC zErr, zMul, greysum, bL, gL, rL, BR, GR, RR
      End If
   Next ix
   DrawProgress
   Next iy
   
   frmHalfTone.picPB.Cls
   Erase Intens()

End Sub

Private Sub Floyd_SteinbergACALC(zErr As Single, zMul As Single, greysum As Long, _
   bL As Byte, gL As Byte, rL As Byte, _
   BR As Byte, GR As Byte, RR As Byte)
' Private ix As Long, iy As Long
' Private Intens() As Integer
   If Intens(ix, iy) > greysum Then
      picDATA(0, ix, iy) = bL
      picDATA(1, ix, iy) = gL
      picDATA(2, ix, iy) = rL
      zErr = (Intens(ix, iy) - 255) * zMul
   Else
      picDATA(0, ix, iy) = BR
      picDATA(1, ix, iy) = GR
      picDATA(2, ix, iy) = RR
      zErr = Intens(ix, iy) * zMul
   End If
   ' Spread error
   Intens(ix - 1, iy + 1) = Intens(ix - 1, iy + 1) + 3 * zErr
   Intens(ix + 1, iy + 1) = Intens(ix + 1, iy + 1) + 2 * zErr
   Intens(ix + 1, iy) = Intens(ix + 1, iy) + 3 * zErr
End Sub

Public Sub Floyd_SteinbergB(zDiv As Single)
' zDiv = 16 -> 48

' 2 colors are LeftColor & RightColor

' Spreader Floyd-Steinberg B
' 0 7 0
' 3 5 1 /16

Dim rL As Byte, gL As Byte, bL As Byte
Dim RR As Byte, GR As Byte, BR As Byte

   LngToRGB RightColor, rL, gL, bL
   LngToRGB LeftColor, RR, GR, BR

   FillIntensityArray
   zMul = 1 / zDiv
   
   
   StartProgress HIY
   For iy = 0 To FullH - 1
   For ix = 0 To FullW - 1
      If aSelectAccepted Then ' Selection ON
         If (ix >= LOX And ix <= HIX) And (iy >= LOY And iy <= HIY) Then
            If Not aExternal Then   ' Internal
               If MaskArray(ix - LOX, iy - LOY) = 0 Then Floyd_SteinbergBCALC zErr, zMul, greysum, bL, gL, rL, BR, GR, RR
            Else  'External
               If MaskArray(ix - LOX, iy - LOY) <> 0 Then Floyd_SteinbergBCALC zErr, zMul, greysum, bL, gL, rL, BR, GR, RR
            End If
         Else
            If aExternal Then Floyd_SteinbergBCALC zErr, zMul, greysum, bL, gL, rL, BR, GR, RR
         End If
      Else  ' Selection OFF
         Floyd_SteinbergBCALC zErr, zMul, greysum, bL, gL, rL, BR, GR, RR
      End If
   Next ix
   DrawProgress
   Next iy
   
   frmHalfTone.picPB.Cls
   Erase Intens()
End Sub

Private Sub Floyd_SteinbergBCALC(zErr As Single, zMul As Single, greysum As Long, _
   bL As Byte, gL As Byte, rL As Byte, _
   BR As Byte, GR As Byte, RR As Byte)
' Private ix As Long, iy As Long
' Private Intens() As Integer

' Spreader Floyd-Steinberg B
' 0 7 0
' 3 5 1 /16
   If Intens(ix, iy) > greysum Then
      picDATA(0, ix, iy) = bL
      picDATA(1, ix, iy) = gL
      picDATA(2, ix, iy) = rL
      zErr = (Intens(ix, iy) - 255) * zMul
   Else
      picDATA(0, ix, iy) = BR
      picDATA(1, ix, iy) = GR
      picDATA(2, ix, iy) = RR
      zErr = Intens(ix, iy) * zMul
   End If
   ' Spread error
   Intens(ix - 1, iy + 1) = Intens(ix - 1, iy + 1) + 3 * zErr
   Intens(ix, iy + 1) = Intens(ix, iy + 1) + 5 * zErr
   Intens(ix + 1, iy + 1) = Intens(ix + 1, iy + 1) + zErr
   Intens(ix + 1, iy) = Intens(ix + 1, iy) + 7 * zErr
End Sub

Public Sub Stucki(zDiv As Single)
Dim rL As Byte, gL As Byte, bL As Byte
Dim RR As Byte, GR As Byte, BR As Byte

   LngToRGB RightColor, rL, gL, bL
   LngToRGB LeftColor, RR, GR, BR
   
   FillIntensityArray
   zMul = 1 / zDiv
   
   StartProgress HIY
   For iy = 0 To FullH - 1
   For ix = 0 To FullW - 1
      If aSelectAccepted Then ' Selection ON
         If (ix >= LOX And ix <= HIX) And (iy >= LOY And iy <= HIY) Then
            If Not aExternal Then   ' Internal
               If MaskArray(ix - LOX, iy - LOY) = 0 Then StuckiCALC zErr, zMul, greysum, bL, gL, rL, BR, GR, RR
            Else  'External
               If MaskArray(ix - LOX, iy - LOY) <> 0 Then StuckiCALC zErr, zMul, greysum, bL, gL, rL, BR, GR, RR
            End If
         Else
            If aExternal Then StuckiCALC zErr, zMul, greysum, bL, gL, rL, BR, GR, RR
         End If
      Else  ' Selection OFF
         StuckiCALC zErr, zMul, greysum, bL, gL, rL, BR, GR, RR
      End If
   Next ix
   DrawProgress
   Next iy
   
   frmHalfTone.picPB.Cls
   Erase Intens()
End Sub

Public Sub StuckiCALC(zErr As Single, zMul As Single, greysum As Long, _
   bL As Byte, gL As Byte, rL As Byte, _
   BR As Byte, GR As Byte, RR As Byte)
   
'Stucki
'    x 8 4
'2 4 8 4 2
'1 2 4 2 1  / 42
   
   If Intens(ix, iy) > greysum Then
      picDATA(0, ix, iy) = bL
      picDATA(1, ix, iy) = gL
      picDATA(2, ix, iy) = rL
      zErr = (Intens(ix, iy) - 255) * zMul
   Else
      picDATA(0, ix, iy) = BR
      picDATA(1, ix, iy) = GR
      picDATA(2, ix, iy) = RR
      zErr = Intens(ix, iy) * zMul
   End If

   ' Spread error
   Intens(ix - 2, iy + 2) = Intens(ix - 2, iy + 2) + zErr
   Intens(ix - 1, iy + 2) = Intens(ix - 1, iy + 2) + 2 * zErr
   Intens(ix, iy + 2) = Intens(ix, iy + 2) + 4 * zErr
   Intens(ix + 1, iy + 2) = Intens(ix + 1, iy + 2) + 2 * zErr
   Intens(ix + 2, iy + 2) = Intens(ix + 2, iy + 2) + zErr
      'j+1  '2 4 8 4 2
   Intens(ix - 2, iy + 1) = Intens(ix - 2, iy + 1) + 2 * zErr
   Intens(ix - 1, iy + 1) = Intens(ix - 1, iy + 1) + 4 * zErr
   Intens(ix, iy + 1) = Intens(ix, iy + 1) + 8 * zErr
   Intens(ix + 1, iy + 1) = Intens(ix + 1, iy + 1) + 4 * zErr
   Intens(ix + 2, iy + 1) = Intens(ix + 2, iy + 1) + 2 * zErr
   'iy x 8 4
   Intens(ix + 1, iy) = Intens(ix + 1, iy) + 8 * zErr
   Intens(ix + 2, iy) = Intens(ix + 2, iy) + 4 * zErr
      
End Sub

Public Sub Burkes(zDiv As Single)
Dim rL As Byte, gL As Byte, bL As Byte
Dim RR As Byte, GR As Byte, BR As Byte
   LngToRGB RightColor, rL, gL, bL
   LngToRGB LeftColor, RR, GR, BR

   FillIntensityArray
   zMul = 1 / zDiv

   StartProgress HIY
   For iy = 0 To FullH - 1
   For ix = 0 To FullW - 1
      If aSelectAccepted Then ' Selection ON
         If (ix >= LOX And ix <= HIX) And (iy >= LOY And iy <= HIY) Then
            If Not aExternal Then   ' Internal
               If MaskArray(ix - LOX, iy - LOY) = 0 Then BurkesCALC zErr, zMul, greysum, bL, gL, rL, BR, GR, RR
            Else  'External
               If MaskArray(ix - LOX, iy - LOY) <> 0 Then BurkesCALC zErr, zMul, greysum, bL, gL, rL, BR, GR, RR
            End If
         Else
            If aExternal Then BurkesCALC zErr, zMul, greysum, bL, gL, rL, BR, GR, RR
         End If
      Else  ' Selection OFF
         BurkesCALC zErr, zMul, greysum, bL, gL, rL, BR, GR, RR
      End If
   Next ix
   DrawProgress
   Next iy
   
   frmHalfTone.picPB.Cls
   Erase Intens()

End Sub

Private Sub BurkesCALC(zErr As Single, zMul As Single, greysum As Long, _
   bL As Byte, gL As Byte, rL As Byte, _
   BR As Byte, GR As Byte, RR As Byte)

' Burkes
'    x 8 4
'2 4 8 4 2  / 32

   If Intens(ix, iy) > greysum Then
      picDATA(0, ix, iy) = bL
      picDATA(1, ix, iy) = gL
      picDATA(2, ix, iy) = rL
      zErr = (Intens(ix, iy) - 255) * zMul
   Else
      picDATA(0, ix, iy) = BR
      picDATA(1, ix, iy) = GR
      picDATA(2, ix, iy) = RR
      zErr = Intens(ix, iy) * zMul
   End If
   
   ' Spread error
   Intens(ix - 2, iy + 1) = Intens(ix - 2, iy + 1) + 2 * zErr
   Intens(ix - 1, iy + 1) = Intens(ix - 1, iy + 1) + 4 * zErr
   Intens(ix, iy + 1) = Intens(ix, iy + 1) + 8 * zErr
   Intens(ix + 1, iy + 1) = Intens(ix + 1, iy + 1) + 4 * zErr
   Intens(ix + 2, iy + 1) = Intens(ix + 2, iy + 1) + 2 * zErr
   'iy   x 8 4
   Intens(ix + 1, iy) = Intens(ix + 1, iy) + 8 * zErr
   Intens(ix + 2, iy) = Intens(ix + 2, iy) + 4 * zErr

End Sub


Public Sub Sierra(zDiv As Single)
Dim rL As Byte, gL As Byte, bL As Byte
Dim RR As Byte, GR As Byte, BR As Byte

   LngToRGB RightColor, rL, gL, bL
   LngToRGB LeftColor, RR, GR, BR

   FillIntensityArray
   zMul = 1 / zDiv
   
   StartProgress HIY
   For iy = 0 To FullH - 1
   For ix = 0 To FullW - 1
      If aSelectAccepted Then ' Selection ON
         If (ix >= LOX And ix <= HIX) And (iy >= LOY And iy <= HIY) Then
            If Not aExternal Then   ' Internal
               If MaskArray(ix - LOX, iy - LOY) = 0 Then SierraCALC zErr, zMul, greysum, bL, gL, rL, BR, GR, RR
            Else  'External
               If MaskArray(ix - LOX, iy - LOY) <> 0 Then SierraCALC zErr, zMul, greysum, bL, gL, rL, BR, GR, RR
            End If
         Else
            If aExternal Then SierraCALC zErr, zMul, greysum, bL, gL, rL, BR, GR, RR
         End If
      Else  ' Selection OFF
         SierraCALC zErr, zMul, greysum, bL, gL, rL, BR, GR, RR
      End If
   Next ix
   DrawProgress
   Next iy
   
   frmHalfTone.picPB.Cls
   Erase Intens()

End Sub

Private Sub SierraCALC(zErr As Single, zMul As Single, greysum As Long, _
   bL As Byte, gL As Byte, rL As Byte, _
   BR As Byte, GR As Byte, RR As Byte)

'Sierra
'    x 5 3
'2 4 5 4 2
'  2 3 2    / 32

   If Intens(ix, iy) > greysum Then
      picDATA(0, ix, iy) = bL
      picDATA(1, ix, iy) = gL
      picDATA(2, ix, iy) = rL
      zErr = (Intens(ix, iy) - 255) * zMul
   Else
      picDATA(0, ix, iy) = BR
      picDATA(1, ix, iy) = GR
      picDATA(2, ix, iy) = RR
      zErr = Intens(ix, iy) * zMul
   End If
   
   ' Spread error
   Intens(ix - 1, iy + 2) = Intens(ix - 1, iy + 2) + 2 * zErr
   Intens(ix, iy + 2) = Intens(ix, iy + 2) + 3 * zErr
   Intens(ix + 1, iy + 2) = Intens(ix + 1, iy + 2) + 2 * zErr
   'j+1  2 4 5 4 2
   Intens(ix - 2, iy + 1) = Intens(ix - 2, iy + 1) + 2 * zErr
   Intens(ix - 1, iy + 1) = Intens(ix - 1, iy + 1) + 4 * zErr
   Intens(ix, iy + 1) = Intens(ix, iy + 1) + 5 * zErr
   Intens(ix + 1, iy + 1) = Intens(ix + 1, iy + 1) + 4 * zErr
   Intens(ix + 2, iy + 1) = Intens(ix + 2, iy + 1) + 2 * zErr
   'iy x 5 3
   Intens(ix + 1, iy) = Intens(ix + 1, iy) + 5 * zErr
   Intens(ix + 2, iy) = Intens(ix + 2, iy) + 3 * zErr

End Sub


Public Sub Jarvis(zDiv As Single)
Dim rL As Byte, gL As Byte, bL As Byte
Dim RR As Byte, GR As Byte, BR As Byte

   LngToRGB RightColor, rL, gL, bL
   LngToRGB LeftColor, RR, GR, BR

   FillIntensityArray
   zMul = 1 / zDiv
   
   StartProgress HIY
   For iy = 0 To FullH - 1
   For ix = 0 To FullW - 1
      If aSelectAccepted Then ' Selection ON
         If (ix >= LOX And ix <= HIX) And (iy >= LOY And iy <= HIY) Then
            If Not aExternal Then   ' Internal
               If MaskArray(ix - LOX, iy - LOY) = 0 Then JarvisCALC zErr, zMul, greysum, bL, gL, rL, BR, GR, RR
            Else  'External
               If MaskArray(ix - LOX, iy - LOY) <> 0 Then JarvisCALC zErr, zMul, greysum, bL, gL, rL, BR, GR, RR
            End If
         Else
            If aExternal Then JarvisCALC zErr, zMul, greysum, bL, gL, rL, BR, GR, RR
         End If
      Else  ' Selection OFF
         JarvisCALC zErr, zMul, greysum, bL, gL, rL, BR, GR, RR
      End If
   Next ix
   DrawProgress
   Next iy
   
   frmHalfTone.picPB.Cls
   Erase Intens()

End Sub

Private Sub JarvisCALC(zErr As Single, zMul As Single, greysum As Long, _
   bL As Byte, gL As Byte, rL As Byte, _
   BR As Byte, GR As Byte, RR As Byte)

'Jarvis, Judice and Ninke filter:
'    x 7 5
'3 5 7 5 3
'1 3 5 3 1  / 48
   
   If Intens(ix, iy) > greysum Then
      picDATA(0, ix, iy) = bL
      picDATA(1, ix, iy) = gL
      picDATA(2, ix, iy) = rL
      zErr = (Intens(ix, iy) - 255) * zMul
   Else
      picDATA(0, ix, iy) = BR
      picDATA(1, ix, iy) = GR
      picDATA(2, ix, iy) = RR
      zErr = Intens(ix, iy) * zMul
   End If
   
   ' Spread error
   Intens(ix - 2, iy + 2) = Intens(ix - 2, iy + 2) + zErr
   Intens(ix - 1, iy + 2) = Intens(ix - 1, iy + 2) + 3 * zErr
   Intens(ix, iy + 2) = Intens(ix, iy + 2) + 5 * zErr
   Intens(ix + 1, iy + 2) = Intens(ix + 1, iy + 2) + 3 * zErr
   Intens(ix + 2, iy + 2) = Intens(ix + 2, iy + 2) + zErr
   'j+1  3 5 7 5 3
   Intens(ix - 2, iy + 1) = Intens(ix - 2, iy + 1) + 3 * zErr
   Intens(ix - 1, iy + 1) = Intens(ix - 1, iy + 1) + 5 * zErr
   Intens(ix, iy + 1) = Intens(ix, iy + 1) + 7 * zErr
   Intens(ix + 1, iy + 1) = Intens(ix + 1, iy + 1) + 5 * zErr
   Intens(ix + 2, iy + 1) = Intens(ix + 2, iy + 1) + 3 * zErr
   'iy x 7 5
   Intens(ix + 1, iy) = Intens(ix + 1, iy) + 7 * zErr
   Intens(ix + 2, iy) = Intens(ix + 2, iy) + 5 * zErr

End Sub


Public Sub HTHalfTone(zFrac As Single)
Dim sum$
'Half tone
' (i,j) 0 0 0
'       0 0 0
'       0 0 0 (i+2,j+2)

' 0 0 0  0 0 0  W 0 0  W 0 W  W 0 W  W 0 W  W 0 W  W W W  W W W  W W W
' 0 0 0  0 0 0  0 0 0  0 0 0  0 0 0  0 0 0  W 0 0  W 0 0  W 0 W  W W W
' 0 0 0  0 0 W  0 0 W  0 0 W  W 0 W  W W W  W W W  W W W  W W W  W W W
'          0      1      2      3      4      5      6      7      8
'         25,    50,    75,   100,   125,   150,   175,   200,   230   >230

   For k = 0 To 8
      HalftoneLimits(k) = HalftoneLimits(k) * zFrac * 0.5
   Next k

   NX = 3
   NY = 3
   NT = 9
   ReDim tm(0 To NX - 1, 0 To NY - 1, 0 To NT - 1)
   ReDim TS$(0 To NT - 1)
   ' These patterns can be changed
   ' to give other effects. There are
   ' NT strings of length NX*NY
   ' NB 1's in a string will mask
   '    1's in later strings
   TS$(0) = "000000001"
   TS$(1) = "100000000"
   TS$(2) = "001000000"
   TS$(3) = "000000100"
   TS$(4) = "000000010"
   TS$(5) = "000100000"
   TS$(6) = "010000000"
   TS$(7) = "000001000"
   TS$(8) = "000010000"
   
   sum$ = ""
   For k = 0 To NT - 1
      sum$ = sum$ & TS$(k)
   Next k
   CopyMemory tm(0, 0, 0), ByVal sum$, Len(sum$)
   
   DO_PATTERN HalftoneLimits()

End Sub

Public Sub HTHalfTone2(zFrac As Single) ' Fuzzier half-tone
Dim sum$

'Half tone 2
' (i,j) 0 0 0 0 0
'       0 0 0 0 0
'       0 0 0 0 0
'       0 0 0 0 0
'       0 0 0 0 0(i+4,j+4)

'   0      1      2      3      4      5      6      7      8
'   25,    50,    75,   100,   125,   150,   175,   200,   230   >230



   For k = 0 To 8
      HalftoneLimits(k) = HalftoneLimits(k) * zFrac * 0.5
   Next k

   NX = 5
   NY = 5
   NT = 9
   ReDim tm(0 To NX - 1, 0 To NY - 1, 0 To NT - 1)
   ReDim TS$(0 To NT - 1)
   TS$(0) = "0000000000001000000000000"
   TS$(1) = "0000000000010100000000000"
   TS$(2) = "0000000100000000010000000"
   TS$(3) = "0000001010000000101000000"
   TS$(4) = "0010000000100010000000100"
   TS$(5) = "0010010001000001000100000"
   TS$(6) = "0101000000000000000001010"
   TS$(7) = "0000100000000000000010000"
   TS$(8) = "1000000000000000000000001"
   
   sum$ = ""
   For k = 0 To NT - 1
      sum$ = sum$ & TS$(k)
   Next k
   CopyMemory tm(0, 0, 0), ByVal sum$, Len(sum$)
   
   DO_PATTERN HalftoneLimits()

End Sub

Public Sub HTLine(zFrac As Single)
Dim sum$
'Line
' 0 0 0     0 0 0    1 1 1    1 1 1
' 0 0 0     1 1 1    0 0 0    1 1 1
' 0 0 0     0 0 0    1 1 1    1 1 1
'  <60      <120      <180     >=180
'   0         1         2
   For k = 0 To 2
      LineLimits(k) = LineLimits(k) * zFrac * 0.5
   Next k

   NX = 3
   NY = 3
   NT = 3
   ReDim tm(NX - 1, NY - 1, NT - 1)
   ReDim TS$(NT - 1)
   TS$(0) = "000000000"
   TS$(1) = "000111000"
   TS$(2) = "111000111"
   sum$ = ""
   For k = 0 To NT - 1
      sum$ = sum$ & TS$(k)
   Next k
   CopyMemory tm(0, 0, 0), ByVal sum$, Len(sum$)
   
   DO_PATTERN LineLimits()

End Sub


Public Sub HTLine2(zFrac As Single)  ' Coarse lines
Dim sum$

'Line 2
' 0 0 0  0 0 0  0 0 0  0 0 0  0 0 W  0 0 0  0 W 0  0 0 0  W 0 0  0 0 0
' 0 W 0  W 0 W  0 0 0  0 0 0  0 0 0  0 0 0  0 0 0  0 0 0  0 0 0  0 0 0
' 0 0 0  0 0 0  0 0 0  0 0 0  W 0 0  0 0 0  0 W 0  0 0 0  0 0 W  0 0 0
'          0      1      2      3      4      5      6      7      8
'         25,    50,    75,   100,   125,   150,   175,   200,   230   >230


   For k = 0 To 6
      LineLimits2(k) = LineLimits2(k) * zFrac * 0.5
   Next k

   NX = 3
   NY = 3
   NT = 9
   ReDim tm(NX - 1, NY - 1, NT - 1)
   ReDim TS$(NT - 1)
   
   TS$(0) = "000010000"
   TS$(1) = "000101000"
   TS$(2) = "000000000"
   TS$(3) = "001000100"
   TS$(4) = "000000000"
   TS$(5) = "010000010"
   TS$(6) = "100000001"
   TS$(7) = "100000001"
   TS$(8) = "000000000"
   
   sum$ = ""
   For k = 0 To NT - 1
      sum$ = sum$ & TS$(k)
   Next k
   CopyMemory tm(0, 0, 0), ByVal sum$, Len(sum$)
   
   DO_PATTERN LineLimits2()

End Sub

Public Sub HTRandom(zFrac As Single)
' Private NX As Long, NY As Long, NT As Long    ' Pattern dims

Dim rL As Byte, gL As Byte, bL As Byte
Dim RR As Byte, GR As Byte, BR As Byte

Dim ii As Long, jj As Long
Dim iup As Long, jup As Long
Dim n As Long
'Random
' 0 0 0
' 0 0 0
' 0 0 0

'   1      2      3      4      5      6      7      8      9
'   25,    50,    75,   100,   125,   150,   175,   200,   230   >230

   Randomize 8

   For k = 0 To 8
      RandomLimits(k) = RandomLimits(k) * zFrac * 0.5
   Next k

   LngToRGB RightColor, rL, gL, bL
   LngToRGB LeftColor, RR, GR, BR

   NY = 3
   NX = 3
   NT = 9
   
   '' Ensure same sequence each time
   'Rnd -1
   'Randomize 1
   'DStruc.Ranseed = 255 * Rnd
   
   FillIntensityArray
   
If Not aSelectAccepted Or (aSelectAccepted And (Not aExternal)) Then
   
   
   StartProgress HIY

   If aSelectAccepted Then
      For jj = LOY To HIY
      For ii = LOX To HIX
         If MaskArray(ii - LOX, jj - LOY) = 0 Then RandCALC ii, jj, BR, GR, RR
      Next ii
      DrawProgress
      Next jj
   Else
      For jj = LOY To HIY
      For ii = LOX To HIX
         RandCALC ii, jj, BR, GR, RR
      Next ii
      DrawProgress
      Next jj
   End If
   
   StartProgress HIY
   For jj = LOY To HIY Step NY
   jup = jj + NY - 1
   For ii = LOX To HIX Step NX
   iup = ii + NX - 1
      GetAvGrey jj, ii  ', NX, NY, AvGrey
      If AvGrey = 0 Then
         AvGrey = 2
         Exit For
      End If
         For n = 0 To 8
            If AvGrey < RandomLimits(n) Then
               RandEval n, jj, ii, rL, gL, bL
               Exit For
            End If
         Next n
         If n = 10 Then RandEval 10, jj, ii, rL, gL, bL
   Next ii
   DrawProgress
   Next jj
   
Else  ' External


   StartProgress HIY

      For jj = 0 To FullH - 1
      For ii = 0 To FullW - 1
         If (ii >= LOX And ii <= HIX) And (jj >= LOY And jj <= HIY) Then
            If MaskArray(ii - LOX, jj - LOY) <> 0 Then RandCALC ii, jj, BR, GR, RR
         Else
            RandCALC ii, jj, BR, GR, RR
         End If
      Next ii
      DrawProgress
      Next jj
   
   StartProgress HIY
   For jj = 0 To FullH - 1 Step NY
   jup = jj + NY - 1
   For ii = 0 To FullW - 1 Step NX
   iup = ii + NX - 1
      GetAvGrey jj, ii  ', NX, NY, AvGrey
      If AvGrey = 0 Then
         AvGrey = 2
         Exit For
      End If
         For n = 0 To 8
            If AvGrey < RandomLimits(n) Then
               RandEval n, jj, ii, rL, gL, bL
               Exit For
            End If
         Next n
         If n = 10 Then RandEval 10, jj, ii, rL, gL, bL
   Next ii
   DrawProgress
   Next jj


End If
   
   frmHalfTone.picPB.Cls

End Sub

Private Sub RandEval(ByVal k As Long, jj As Long, ii As Long, _
rL As Byte, gL As Byte, bL As Byte)

' Private NX As Long, NY As Long, NT As Long    ' Pattern dims

' VB Code to roughly match mcode
Dim iiup As Long, jjup As Long

   jjup = jj + NY - 1
   iiup = ii + NX - 1
   
If Not aSelectAccepted Or (aSelectAccepted And (Not aExternal)) Then
   
   If k < 10 Then
      If RandomLimits(k) >= 128 Then
         For j = jj To jjup
            If j >= LOY And j <= HIY Then
               For i = ii To iiup
                  If i >= LOX And i <= HIX Then
                     If aSelectAccepted Then
                        If MaskArray(i - LOX, j - LOY) = 0 Then RandCALC i, j, bL, gL, rL
                     Else
                        RandCALC i, j, bL, gL, rL
                     End If
                  End If
                  Next i
            End If
         Next j
      End If
   End If
   

   If k > 0 And k < 9 Then
      For k = 1 To 8
         ' Variations
         'j = Int(((jjup - jj + 1) * Rnd) + jj)
         'i = Int(((iiup - ii + 1) * Rnd) + ii)

         'j = Int(((jjup - jj) * Rnd) + jj)
         'i = Int(((iiup - ii) * Rnd) + ii)

         j = Int(((jjup) * Rnd) + jj)
         i = Int(((iiup) * Rnd) + ii)
         If i >= LOX And i <= HIX And j >= LOY And j <= HIY Then
            If aSelectAccepted Then
               If MaskArray(i - LOX, j - LOY) = 0 Then RandCALC i, j, 255, 255, 255
            Else
               RandCALC i, j, 255, 255, 255
            End If
         End If
      Next k
   End If

Else  ' External

   If k < 10 Then
      If RandomLimits(k) >= 128 Then
         For j = jj To jjup
            For i = ii To iiup
               If (i >= LOX And i <= HIX) And (j >= LOY And j <= HIY) Then
                  If MaskArray(i - LOX, j - LOY) <> 0 Then RandCALC i, j, bL, gL, rL
               Else
                  RandCALC i, j, bL, gL, rL
               End If
            Next i
         Next j
      End If
   End If
   

   If k > 0 And k < 9 Then
      For k = 1 To 8
         ' Variations
         'j = Int(((jjup - jj + 1) * Rnd) + jj)
         'i = Int(((iiup - ii + 1) * Rnd) + ii)

         'j = Int(((jjup - jj) * Rnd) + jj)
         'i = Int(((iiup - ii) * Rnd) + ii)

         j = Int(((jjup) * Rnd) + jj)
         i = Int(((iiup) * Rnd) + ii)
         If (i >= LOX And i <= HIX) And (j >= LOY And j <= HIY) Then
            If MaskArray(i - LOX, j - LOY) <> 0 Then RandCALC i, j, 255, 255, 255
         Else
            If (i >= 0 And i <= FullW - 1) And (j >= 0 And j <= FullH - 1) Then
               RandCALC i, j, 255, 255, 255
            End If
         End If
      Next k
   End If


End If

End Sub
Private Sub RandCALC(ii As Long, jj As Long, BR As Byte, GR As Byte, RR As Byte)
   picDATA(0, ii, jj) = BR
   picDATA(1, ii, jj) = GR
   picDATA(2, ii, jj) = RR
End Sub

' For Debug
'Private Sub RandCALC2(ii As Long, jj As Long, BR As Byte, GR As Byte, RR As Byte)
'   picDATA(0, ii, jj) = BR
'   picDATA(1, ii, jj) = GR
'   picDATA(2, ii, jj) = RR
'End Sub
'Private Sub RandCALC3(ii As Long, jj As Long, BR As Byte, GR As Byte, RR As Byte)
'   picDATA(0, ii, jj) = BR
'   picDATA(1, ii, jj) = GR
'   picDATA(2, ii, jj) = RR
'End Sub
'Private Sub RandCALC4(ii As Long, jj As Long, BR As Byte, GR As Byte, RR As Byte)
'   picDATA(0, ii, jj) = BR
'   picDATA(1, ii, jj) = GR
'   picDATA(2, ii, jj) = RR
'End Sub





Public Sub DO_PATTERN(Limits() As Long)
Dim rL As Byte, gL As Byte, bL As Byte
Dim RR As Byte, GR As Byte, BR As Byte

Dim ii As Long, jj As Long
Dim iup As Long, jup As Long
Dim n As Long
' Zero Intensity Array
ReDim Intens(-1 To FullW + 6, -1 To FullH + 6)

'NB Written to match mcode

   LngToRGB RightColor, rL, gL, bL
   LngToRGB LeftColor, RR, GR, BR
   
   FillIntensityArray
   
If Not aSelectAccepted Or (aSelectAccepted And (Not aExternal)) Then
   
   StartProgress HIY
   For jj = LOY To HIY
   For ii = LOX To HIX
      If aSelectAccepted Then
         If MaskArray(ii - LOX, jj - LOY) = 0 Then DO_PATTERNCALC ii, jj, BR, GR, RR
      Else
         DO_PATTERNCALC ii, jj, BR, GR, RR
      End If
   Next ii
   DrawProgress
   Next jj
   
   'NX = 3,NY = 3,NT = 9
   'NX = 5,NY = 5,NT = 9
   
   For jj = LOY To HIY Step NY
   jup = jj + NY - 1
   
   For ii = LOX To HIX Step NX
   iup = ii + NX - 1
      GetAvGrey jj, ii ', NX, NY, AvGrey   Gets AvGrey uses Intens
      
      If AvGrey = 0 Then
         AvGrey = 2
         'GoTo NexJJ
      End If
      
      For n = 0 To NT - 1
         If AvGrey >= Limits(n) Then
            
            For j = jj To jup
               If j < LOY Or j > HIY Then Exit For
                  For i = ii To iup
                     If i < LOX Or i > HIX Then Exit For
                     '        ( 0 to 2, 0 to 2, 0 to 8)
                        If tm(i - ii, j - jj, n) = 49 Then  ' "1"
                           If aSelectAccepted Then
                              If MaskArray(i - LOX, j - LOY) = 0 Then DO_PATTERNCALC i, j, bL, gL, rL
                           Else
                               DO_PATTERNCALC i, j, bL, gL, rL
                           End If
                        End If
                  Next i
            Next j
         
         End If
      Next n
   Next ii
'NexJJ:
   Next jj
   
   
Else  ' External

   
   StartProgress HIY
   For jj = 0 To FullH - 1
   For ii = 0 To FullW - 1
      If aSelectAccepted Then
         If (ii >= LOX And ii <= HIX) And (jj >= LOY And jj <= HIY) Then
            If Not aExternal Then   ' Internal
               If MaskArray(ii - LOX, jj - LOY) = 0 Then DO_PATTERNCALC ii, jj, BR, GR, RR
            Else  'External
               If MaskArray(ii - LOX, jj - LOY) <> 0 Then DO_PATTERNCALC ii, jj, BR, GR, RR
            End If
         Else
            If aExternal Then DO_PATTERNCALC ii, jj, BR, GR, RR
         End If
      Else  ' Selection OFF
         DO_PATTERNCALC ii, jj, BR, GR, RR
      End If
      
   Next ii
   DrawProgress
   Next jj
   
   'NX = 3,NY = 3,NT = 9
   'NX = 5,NY = 5,NT = 9
   
   For jj = 0 To FullH - 1 Step NY
   jup = jj + NY - 1
   
   For ii = 0 To FullW - 1 Step NX
   iup = ii + NX - 1
      GetAvGrey jj, ii ', NX, NY, AvGrey   Gets AvGrey uses Intens
      
      If AvGrey = 0 Then
         AvGrey = 2
         'GoTo NexJJ
      End If
      
      For n = 0 To NT - 1
         If AvGrey >= Limits(n) Then 'GoTo NexN
            For j = jj To jup
                  For i = ii To iup
                     '        ( 0 to 2, 0 to 2, 0 to 8)
                        If tm(i - ii, j - jj, n) = 49 Then  ' "1"
                           If ((i >= LOX And i <= HIX) And (j >= LOY And j <= HIY)) Then
                              If MaskArray(i - LOX, j - LOY) <> 0 Then DO_PATTERNCALC i, j, bL, gL, rL
                           Else
                              If ((i >= 0 And i <= FullW - 1) And (j >= 0 And j <= FullH - 1)) Then
                                 DO_PATTERNCALC i, j, bL, gL, rL
                              End If
                           End If
                        End If
                  Next i
            Next j
         
         End If
      Next n
   Next ii
'NexJJ:
   Next jj

End If
   
   Erase Intens()
   frmHalfTone.picPB.Cls

End Sub
Private Sub DO_PATTERNCALC(ii As Long, jj As Long, BR As Byte, GR As Byte, RR As Byte)
   picDATA(0, ii, jj) = BR
   picDATA(1, ii, jj) = GR
   picDATA(2, ii, jj) = RR
End Sub


Public Sub GetAvGrey(jj As Long, ii As Long) ', NX, NY, AvGrey)' In: y,x,template size NX by NY Out: AvGrey
Dim AvCount As Long
Dim i As Long, j As Long

Dim U As Long
Dim v As Long
v = UBound(Intens(), 2)
U = UBound(Intens(), 1)
   AvCount = 0
   AvGrey = 0
   For j = jj To jj + NY - 1
      For i = ii To ii + NX - 1
         If i <= U And j <= v Then
         AvGrey = AvGrey + Intens(i, j)
         End If
         AvCount = AvCount + 1
      Next i
   Next j
   If AvCount = 0 Then AvGrey = 0 Else AvGrey = AvGrey \ AvCount
End Sub

Public Sub HTInvert()

   picDATA() = picDATAORG()
      
   StartProgress HIY
   For iy = 0 To FullH - 1
   For ix = 0 To FullW - 1
      If aSelectAccepted Then ' Selection ON
         If (ix >= LOX And ix <= HIX) And (iy >= LOY And iy <= HIY) Then
            If Not aExternal Then   ' Internal
               If MaskArray(ix - LOX, iy - LOY) = 0 Then HTInvertCALC
            Else  'External
               If MaskArray(ix - LOX, iy - LOY) <> 0 Then HTInvertCALC
            End If
         Else
            If aExternal Then HTInvertCALC
         End If
      Else  ' Selection OFF
         HTInvertCALC
      End If
   Next ix
   DrawProgress
   Next iy
   frmHalfTone.picPB.Cls
End Sub

Private Sub HTInvertCALC()
   picDATA(0, ix, iy) = Not picDATAORG(0, ix, iy)
   picDATA(1, ix, iy) = Not picDATAORG(1, ix, iy)
   picDATA(2, ix, iy) = Not picDATAORG(2, ix, iy)
End Sub

Public Sub FillIntensityArray()
   ReDim Intens(-2 To FullW + 2, -1 To FullH + 2)
   greysum = 0
   
   HLXY

   greycount = (HigherX - LowerX) * (HigherY - LowerY)
   
   For iy = LowerY To HigherY
   For ix = LowerX To HigherX
      Intens(ix, iy) = (1& * picDATAORG(0, ix, iy) + _
                             picDATAORG(1, ix, iy) + _
                             picDATAORG(2, ix, iy)) \ 3
      greysum = greysum + Intens(ix, iy)
   Next ix
   Next iy
   greysum = greysum \ greycount
   
   picDATA() = picDATAORG()

End Sub


Public Sub SetDefaultFactors()
'BlackThreshHold = 128
'FSADIV = 8
'FSBDIV = 16
'StuckiDiv = 42
'BurkesDiv = 32
'SierraDiv = 42
'JarvisDiv = 48

   ReDim HalftoneLimits(0 To 9)
   HalftoneLimits(0) = 25
   HalftoneLimits(1) = 50
   HalftoneLimits(2) = 75
   HalftoneLimits(3) = 100
   HalftoneLimits(4) = 125
   HalftoneLimits(5) = 150
   HalftoneLimits(6) = 175
   HalftoneLimits(7) = 200
   HalftoneLimits(8) = 230
   
   ReDim LineLimits(0 To 2)
   LineLimits(0) = 60
   LineLimits(1) = 120
   LineLimits(2) = 180
   
   ReDim LineLimits2(0 To 8)
   LineLimits2(0) = 25
   LineLimits2(1) = 50
   LineLimits2(2) = 75
   LineLimits2(3) = 100
   LineLimits2(4) = 125
   LineLimits2(5) = 150
   LineLimits2(6) = 175
   LineLimits2(7) = 200
   LineLimits2(8) = 230
   
   ReDim RandomLimits(0 To 8)
   RandomLimits(0) = 25
   RandomLimits(1) = 50
   RandomLimits(2) = 75
   RandomLimits(3) = 100
   RandomLimits(4) = 125
   RandomLimits(5) = 150
   RandomLimits(6) = 175
   RandomLimits(7) = 200
   RandomLimits(8) = 230
   
   'UpLim = 200
End Sub


Private Sub StartProgress(PAR As Long)
' Private xd As Single, xp As Single
' EG: Par = PRELIEF * FullH
   frmHalfTone.picPB.DrawWidth = 3
   frmHalfTone.picPB.Cls
   xp = 0
   xd = frmHalfTone.picPB.Width / PAR
   frmHalfTone.picPB.PSet (xp, 2), vbRed
End Sub

Private Sub DrawProgress()
Dim FW As Long
' Private xd As Single, xp As Single
   frmHalfTone.picPB.Line -(xp, 2), vbRed
   frmHalfTone.picPB.Refresh
   xp = xp + xd
   FW = frmHalfTone.picPB.Width
End Sub
       


