photos writings music about

<- prev | next ->

tools



Namespace TOOLS
Function PointInBox(x As Integer, y As Integer, x1 As Integer, y1 As Integer, x2 As Integer, y2 As Integer, dostep As Integer = FALSE) As Integer
      '' Detect if a point is within a box. Skip swap if doStep is True because 2nd values are relative to first.
      If dostep Then
            If x >= x1 AndAlso y >= y1 AndAlso x <= x1+x2-1 AndAlso y <= y1+y2-1 Then Return TRUE
      Else
            If x2 < x1 Then Swap x2, x1
            If y2 < y1 Then Swap y2, y1
            If x >= x1 AndAlso y >= y1 AndAlso x <= x2 AndAlso y <= y2 Then Return TRUE
      End If
      Return FALSE
End Function

'Function BoxesOverlap(a_x1 As Integer, a_y1 As Integer, a_x2 As Integer, a_y2 As Integer, b_x1 As Integer, b_y1 As Integer, b_x2 As Integer, b_y2 As Integer) As Integer
'      '' This has a problem where it misses when a box lays across another box and no points are within each other.
'      If a_x2 < a_x1 Then Swap a_x2, a_x1
'      If a_y2 < a_y1 Then Swap a_y2, a_y1
'      If b_x2 < b_x1 Then Swap b_x2, b_x1
'      If b_y2 < b_y1 Then Swap b_y2, b_y1
'      If            PointInBox(a_x1, a_y1, b_x1, b_y1, b_x2, b_y2) _
'      OrElse PointInBox(a_x1, a_y2, b_x1, b_y1, b_x2, b_y2) _
'      OrElse PointInBox(a_x2, a_y1, b_x1, b_y1, b_x2, b_y2) _
'      OrElse PointInBox(a_x2, a_y2, b_x1, b_y1, b_x2, b_y2) _
'      OrElse PointInBox(b_x1, b_y1, a_x1, a_y1, a_x2, a_y2) _
'      OrElse PointInBox(b_x1, b_y2, a_x1, a_y1, a_x2, a_y2) _
'      OrElse PointInBox(b_x2, b_y1, a_x1, a_y1, a_x2, a_y2) _
'      OrElse PointInBox(b_x2, b_y2, a_x1, a_y1, a_x2, a_y2) _
'      Then
'            Return TRUE
'      End If
'      Return FALSE
'End Function

Function BoxesOverlap(a_x1 As Integer, a_y1 As Integer, a_x2 As Integer, a_y2 As Integer, b_x1 As Integer, b_y1 As Integer, b_x2 As Integer, b_y2 As Integer) As Integer
      '' Fix any inverted box
      If a_x2 < a_x1 Then Swap a_x2, a_x1
      If a_y2 < a_y1 Then Swap a_y2, a_y1
      If b_x2 < b_x1 Then Swap b_x2, b_x1
      If b_y2 < b_y1 Then Swap b_y2, b_y1
      '' Check if box A and B overlap in any way
      If a_x1 > b_x2 Or b_x1 > a_x2 Then
            Return FALSE
      ElseIf a_y1 > b_y2 Or b_y1 > a_y2 Then
            Return FALSE
      EndIf
      Return TRUE
End Function

Function BoxInBox(a_x1 As Integer, a_y1 As Integer, a_x2 As Integer, a_y2 As Integer, b_x1 As Integer, b_y1 As Integer, b_x2 As Integer, b_y2 As Integer) As Integer
      '' Fix any inverted box
      If a_x2 < a_x1 Then Swap a_x2, a_x1
      If a_y2 < a_y1 Then Swap a_y2, a_y1
      If b_x2 < b_x1 Then Swap b_x2, b_x1
      If b_y2 < b_y1 Then Swap b_y2, b_y1
      '' Check if box A is within box B. (Does not work vice-versa)
      If            PointInBox(a_x1, a_y1, b_x1, b_y1, b_x2, b_y2) _
      AndAlso PointInBox(a_x2, a_y2, b_x1, b_y1, b_x2, b_y2) _
      Then
            Return TRUE
      EndIf
      Return FALSE
End Function

Function side_of_a_line(x1 As Integer, y1 As Integer, x2 As Integer, y2 As Integer, px As Integer, py As Integer) As Integer
Return Sgn( (x2 - x1) * (py - y1) - (y2 - y1) * (px - x1) )
End Function

Function poly_xy_relationship(x As Integer, y As Integer, p As _poly_, px As Integer = 0, py As Integer = 0) As Integer
      '' Check if x,y is behind, within, or in front of poly, with starting x,y for poly.
      With p
            If side_of_a_line(x, y, px+.x1, py+.y1, px+.x2, py+.y2) = -1 _
            AndAlso side_of_a_line(x, y, px+.x2, py+.y2, px+.x3, py+.y3) = -1 _
            Then
                  Function = Located.Back '' is behind poly
                  If side_of_a_line(x, y, px+.x3, py+.y3, px+.x4, py+.y4) = -1 _
                  AndAlso side_of_a_line(x, y, px+.x4, py+.y4, px+.x1, py+.y1) = -1 _
                  Then
                        Function = Located.Within '' is within poly
                  EndIf
            Else
                  Function = Located.Front '' is in front of poly
            EndIf
      End With
End Function

Function poly_overlap(p1 As _poly_, p2 As _poly_, p1x As Integer = 0, p1y As Integer = 0, p2x As Integer = 0, p2y As Integer = 0) As Integer
      '' Check if poly overlaps poly, with optional starting x,y for each poly.
      If             poly_xy_relationship(p1x+p1.x1,p1y+p1.y1,p2,p2x,p2y) = Located.Within _
      OrElse poly_xy_relationship(p1x+p1.x2,p1y+p1.y2,p2,p2x,p2y) = Located.Within _
      OrElse poly_xy_relationship(p1x+p1.x3,p1y+p1.y3,p2,p2x,p2y) = Located.Within _
      OrElse poly_xy_relationship(p1x+p1.x4,p1y+p1.y4,p2,p2x,p2y) = Located.Within _
      OrElse poly_xy_relationship(p2x+p2.x1,p2y+p2.y1,p1,p1x,p1y) = Located.Within _
      OrElse poly_xy_relationship(p2x+p2.x2,p2y+p2.y2,p1,p1x,p1y) = Located.Within _
      OrElse poly_xy_relationship(p2x+p2.x3,p2y+p2.y3,p1,p1x,p1y) = Located.Within _
      OrElse poly_xy_relationship(p2x+p2.x4,p2y+p2.y4,p1,p1x,p1y) = Located.Within _
      Then
            Return TRUE
      Else
            Return FALSE
      EndIf
End Function

Function doesExist (filename As String) As Integer
      Dim As Integer ff
      ff = FreeFile
      Open filename For Binary As #ff
      If Lof(ff) > 0 Then
            Close #ff
            Return TRUE
      Else
            Close #ff
            Kill filename
            Return FALSE
      End If
      Close #ff
End Function

Function dropPath (filepath As String) As String
      Dim As Integer slash,n
      Dim c As String * 1
      Dim As String filename
      For n = 1 To Len(filepath)
           c = Mid(filepath, n, 1)
           If n = Len(filepath) Then filename = Mid(filepath, slash + 1, n - slash): Exit For
           If c = "\" Then slash = n
      Next
      dropPath = filename
End Function

Function dropFile (f As String) As String
      Dim As Integer slash,n
      Dim c As String * 1
      Dim As String p
      For n = Len(f) To 1 Step -1
            c = Mid(f, n, 1)
            If c = "\" Then
                  slash = n
                  p = Left(f,slash)
                  Exit For
            EndIf
            If n = 1 Then p = "" : Exit For
      Next
     
      Return p
End Function

Function strIf(Bool As Integer, rtrnTrue As ZString Ptr, rtrnFalse As ZString Ptr) As String
      If Bool Then Return *rtrnTrue Else Return *rtrnFalse
End Function

Function ImageScale_NrNbr(s As fb.Image Ptr, Scale As Single=1.0) As fb.Image Ptr
' NewImage = ImageScale(SourceImage,Scale)
Static As fb.Image Ptr t
If s            =0 Then Return 0
If s->width <1 Then Return 0
If s->height<1 Then Return 0
scale=Abs(scale)
Dim As Integer w = s->width *Scale
Dim As Integer h = s->height*Scale
If w<4 Then w=4
If h<4 Then h=4
If t Then ImageDestroy(t)
t=ImageCreate(w,h)
Dim As Integer xs=(s->width /t->Width ) * (1024*64)
Dim As Integer ys=(s->height/t->height) * (1024*64)
Dim As Integer x,y,sy
Select Case As Const s->bpp
      Case 4
           Dim As Uinteger Ptr ps=cptr(Uinteger Ptr,s)+8
           Dim As Uinteger      sp=(s->pitch Shr 2)
           Dim As Uinteger Ptr pt=cptr(Uinteger Ptr,t)+8
           Dim As Uinteger      tp=(t->pitch Shr 2)-t->width
           For ty As Integer = 0 To t->height-1
            Dim As Uinteger Ptr src=ps+(sy Shr 16)*sp
            For tx As Integer = 0 To t->width-1
                 *pt=src[x Shr 16]:pt+=1:x+=xs
            Next
            pt+=tp:sy+=ys:x=0
           Next
      Case 2
           Dim As Ushort Ptr ps=cptr(Ushort Ptr,s)+16
           Dim As Uinteger      sp=(s->pitch Shr 1)
           Dim As Ushort Ptr pt=cptr(Ushort Ptr,t)+16
           Dim As Uinteger      tp=(t->pitch Shr 1)-t->width
           For ty As Integer = 0 To t->height-1
            Dim As Ushort Ptr src=ps+(sy Shr 16)*sp
            For tx As Integer = 0 To t->width-1
                 *pt=src[x Shr 16]:pt+=1:x+=xs
            Next
            pt+=tp:sy+=ys:x=0
           Next
      Case 1
           Dim As Ubyte Ptr ps=cptr(Ubyte Ptr,s)+32
           Dim As Uinteger      sp=s->pitch
           Dim As Ubyte Ptr pt=cptr(Ubyte Ptr,t)+32
           Dim As Uinteger      tp=t->pitch-t->width
           For ty As Integer = 0 To t->height-1
            Dim As Ubyte Ptr src=ps+(sy Shr 16)*sp
            For tx As Integer = 0 To t->width-1
                 *pt=src[x Shr 16]:pt+=1:x+=xs
            Next
            pt+=tp:sy+=ys:x=0
           Next
End Select
Return t
End Function

Sub ImageResizeX2_Smooth(Byval dst As FB.Image Ptr, Byval src As FB.Image Ptr)
     
      Dim As Integer                  x = src->Width-1
      Dim As Integer                  y = src->Height-1
      Dim As Integer                  i = Any,j = Any, i2 = Any
      Dim As Uinteger                  A = Any,B = Any,C = Any,D = Any,P = Any,p1 = Any,p2 = Any,p3 = Any,p4 = Any
      Dim As Uinteger                  spitch = src->Pitch Shr 2
      Dim As Uinteger                  dpitch = dst->Pitch Shr 1
      Dim As Uinteger Ptr            s1 = CPtr( Uinteger Ptr, CPtr( FB.IMAGE Ptr, src + 1 ) )
      Dim As Uinteger Ptr            d0 = CPtr( Uinteger Ptr, CPtr( FB.IMAGE Ptr, dst + 1 ) )
      Dim As Uinteger Ptr            s0 = s1 - spitch
      Dim As Uinteger Ptr            s2 = s1 + spitch
      Dim As Uinteger Ptr            d1 = d0 + ( dpitch Shr 1 )
     
      For j =0 To y
                  i2 = 0
                  For i =0 To x
                              P=s1[ i ]
                              p1=P:p2=P:p3=P:p4=P
                            
                              If( j = 0 )Then A=P Else A=s0[ i      ]
                              If( i = 0 )Then C=P Else C=s1[ i-1 ]
                              If( i = x )Then B=P Else B=s1[ i+1 ]
                              If( j = y )Then D=P Else D=s2[ i      ]
                            
                              If( A <> D )And( C <> B )Then
                                          p1 = IIf( C = A, C, P )
                                          p2 = IIf( A = B, B, P )
                                          p3 = IIf( C = D, C, P )
                                          p4 = IIf( D = B, B, P )
                              Else
                                          p1 = P
                                          p2 = P
                                          p3 = P
                                          p4 = P
                              End If
                            
                              d0[ i2      ] = p1
                              d0[ i2+1 ] = p2
                              d1[ i2      ] = p3
                              d1[ i2+1 ] = p4
                            
                              i2 += 2
                            
                  Next i
                  s0 += sPitch
                  s1 += sPitch
                  s2 += sPitch
                  d0 += dPitch
                  d1 += dPitch
      Next j
End Sub

Sub BMP_Get_WH(filename As String, w As Integer, h As Integer)
      Dim As Integer ff=FreeFile
      Open filename For Binary As #ff
      Get #ff, 19, w
      Get #ff, 23, h
      Close #ff
End Sub

Function RoundUpPower2(valu As Integer) As Integer
      #DEFINE MaxPower 4096

      Dim As Integer p2_ = 2
     
      For I As Integer = 1 To MaxPower - 1
            If valu <= p2_ Then Return p2_
            p2_ = p2_ Shl 1
      Next
     
      Return 0
     
End Function

Sub posneg(value As Integer, sym As Integer, clr As UInteger)
      If value > 0 Then sym = Asc("+"): clr = RGB(0,112,63)
      If value < 0 Then sym = Asc("-"): clr = RGB(155,0,0)
End Sub

Sub db_Write(msg As string)
      Dim As Integer ff = FreeFile
      If Open(ExePath & "\DEBUG "+dropPath(Command(0))+".txt" For Append As #ff) <> 0 Then
            Close #ff
            Beep : Beep : Beep: Beep
            Print "DEBUG file could not be opened."
            Sleep
            End
      Else
            Print #ff, Trim(msg)
            Close #ff
      EndIf
End Sub

Sub db_clear()
      Kill "DEBUG "+dropPath(Command(0))+".txt"
End Sub
End Namespace


<- back