Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
timage.bi
| Uploader: |  ThePuppetMaster |
| Datum/Zeit: | 24.12.2023 01:06:43 |
Hinweis: Dieser Quelltext ist Bestandteil des Projekts LOUPEDECK-Live Linux Treiber, zu dem es auf FreeBASIC-Portal.de eine Projektseite gibt.
'##############################################################################################################################################################
'##############################################################################################################################################################
'### TImage - V:1.01.0 - R:0
'##############################################################################################################################################################
'##############################################################################################################################################################
'### Date of Idea: 2013.02.22 - 23:46:16
'### Autor: DeltaLab's Germany [Experimental Computing]
'### Martin Wiemann
'### Contact: freeBASIC@DeltaLabs.de / IRC://DeltaLabs/#deltalabs
'### Licence: DE: Tu was du nicht lassen kannst, solange du hiermit nicht mehr Geld verdienst als ich.
'##############################################################################################################################################################
'##############################################################################################################################################################
'##############################################################################################################################################################
#IF Defined(TImage_FreeImage)
#Include Once "FreeImage.bi"
#ENDIF
#Include Once "crt/string.bi"
#Include Once "fbgfx.bi"
'##############################################################################################################################################################
Enum TImage_LineStyle_Enum
LineStyle_Continues = 0
LineStyle_Dot
LineStyle_Dash
LineStyle_DotDash
LineStyle_Step2
LineStyle_Max
End Enum
'##############################################################################################################################################################
Enum TImage_FontType_Enum
FontType_Monospace = 0
FontType_Dynamicspace
End Enum
'##############################################################################################################################################################
Type TImage
V_Width as UInteger
V_Height as UInteger
V_BPP as UInteger
V_Data as ULong Ptr
V_FontType as TImage_FontType_Enum
V_FontT as UInteger
V_FontH as UInteger
V_FontP as UInteger Ptr
V_FontW as UInteger Ptr
Declare Sub CLS (ByRef V_Color as UInteger = &H00000000)
Declare Sub ReplaceColor (ByRef V_ColorFind as UInteger, ByRef V_ColorReplace as UInteger)
Declare Sub PSET (ByRef V_X as Integer, ByRef V_Y as Integer, ByRef V_Color as UInteger = &H00000000)
Declare Function Point (ByRef V_X as Integer, ByRef V_Y as Integer) as UInteger
Declare Sub Line (ByRef V_X1 as Integer, ByRef V_Y1 as Integer, ByRef V_X2 as Integer, ByRef V_Y2 as Integer, ByRef V_Color as UInteger = &H00000000, ByRef V_Box as Integer = 0, ByRef V_Filled as Integer = 0, ByRef V_LineStyle as TImage_LineStyle_Enum = LineStyle_Continues)
Declare Sub Circle (ByRef V_X as Integer, ByRef V_Y as Integer, ByRef V_Radius as Integer, ByRef V_Color as UInteger = &HFFFFFFFF, ByRef V_Filled as Integer = 0, ByRef V_LineStyle as TImage_LineStyle_Enum = LineStyle_Continues)
Declare Sub Put (ByRef V_TargetX as Integer, V_TargetY as Integer, ByRef V_SourceImage as TImage Ptr, ByRef V_SourceX as UInteger = 0, ByRef V_SourceY as UInteger = 0, ByRef V_SourceW as UInteger = 0, ByRef V_SourceH as UInteger = 0, ByRef V_CopyMaskColor as UInteger = &HFF000000, ByRef V_PutColor as UInteger = &HFF000000, V_IgnorCopyMaskColor as Integer = 0, V_TransparencyMaskColor as UInteger = &HFF000000)
Declare Sub DrawString (ByRef V_Font as TImage Ptr = 0, ByRef V_Text as String, ByRef V_X as Integer, ByRef V_Y as Integer, ByRef V_Color as UInteger = &HFFFFFF, ByRef V_CharSpace as Integer = 0, ByRef V_LineSpace as Integer = 0, ByRef V_NoLinebreak as Integer = 0, ByRef V_CheckAlpha as Integer = 0)
End Type
'##############################################################################################################################################################
Dim Shared TImage_GFX_MainFont as TImage Ptr
'##############################################################################################################################################################
Function TImageCreate(ByRef V_Width as UInteger, ByRef V_Height as UInteger, ByRef V_BPP as UInteger = 32, V_AllocMem as Any Ptr = 0) as TImage Ptr
If (V_Width <= 0) Or (V_Height <= 0) Or (Fix(V_BPP / 8)) <= 0 Then Return 0
Dim TImg as TImage
With TImg
.V_Width = V_Width
.V_Height = V_Height
.V_BPP = V_BPP
If V_AllocMem = 0 Then
.V_Data = CAllocate(V_Width * V_Height * Fix(V_BPP / 8))
Else: .V_Data = V_AllocMem
End If
End With
Dim TImgPtr as TImage Ptr = New TImage
*TImgPtr = TImg
Return TImgPtr
End Function
'##############################################################################################################################################################
Sub TImageDestroy(ByRef V_Image as TImage Ptr)
If V_Image = 0 Then Exit Sub
If V_Image->V_Data <> 0 Then DeAllocate(V_Image->V_Data)
If V_Image->V_FontP <> 0 Then DeAllocate(V_Image->V_FontP)
If V_Image->V_FontW <> 0 Then DeAllocate(V_Image->V_FontW)
Delete V_Image
V_Image = 0
End Sub
'##############################################################################################################################################################
Function TCheckDiffed(ByRef V_Image1 as TImage Ptr, ByRef V_Image2 as TImage Ptr) as Integer
If V_Image1 = 0 Then Return 1
If V_Image2 = 0 Then Return 1
If V_Image1->V_Width <> V_Image2->V_Width Then Return 1
If V_Image1->V_Height <> V_Image2->V_Height Then Return 1
If V_Image1->V_BPP <> V_Image2->V_BPP Then Return 1
If V_Image1->V_Width = 0 Then Return 0
If V_Image2->V_Height = 0 Then Return 0
'Dim TData1 as Any Ptr = V_Image1->V_Data
'Dim TData2 as Any Ptr = V_Image2->V_Data
'Dim TMax as UInteger = V_Image1->V_Width * V_Image1->V_Height * Fix(V_Image1->V_BPP / 8)
''Print #1, "TMax0:" & TMax
'For X as UInteger = 0 to TMax - 1
' 'If V_Image1->V_Data[X] <> V_Image2->V_Data[X] Then Return 1
' If Cast(UByte Ptr, TData1)[X] <> Cast(UByte Ptr, TData2)[X] Then Return 1
'Next
Dim TAdr as UInteger
For Y as UInteger = 0 to V_Image1->V_Height - 1
For X as UInteger = 0 to V_Image1->V_Width - 1
TAdr = Y * V_Image1->V_Width + X
If V_Image1->V_Data[TAdr] <> V_Image2->V_Data[TAdr] Then Return 1
Next
Next
Return 0
End Function
'##############################################################################################################################################################
Function TDataCopy(ByRef V_Source as TImage Ptr, ByRef V_Dest as TImage Ptr) as Integer
If V_Source = 0 Then Return 0
If V_Dest = 0 Then Return 0
If V_Source->V_Width <> V_Dest->V_Width Then Return 0
If V_Source->V_Height <> V_Dest->V_Height Then Return 0
If V_Source->V_BPP <> V_Dest->V_BPP Then Return 0
If V_Source->V_Width = 0 Then Return 0
If V_Dest->V_Height = 0 Then Return 0
'Dim TMax as UInteger = V_Source->V_Width * V_Source->V_Height
'Print #1, "TMax1:" & TMax
'For X as UInteger = 0 to TMax
' V_Dest->V_Data[X] = V_Source->V_Data[X]
'Next
Dim TAdr as UInteger
For Y as UInteger = 0 to V_Source->V_Height - 1
For X as UInteger = 0 to V_Source->V_Width - 1
TAdr = Y * V_Source->V_Width + X
V_Dest->V_Data[TAdr] = V_Source->V_Data[TAdr]
Next
Next
Return 1
End Function
'##############################################################################################################################################################
Function TLoadImageFromFile(ByRef V_FilePathName as String, ByRef R_TransparencyColor as UInteger = &HFF000000, ByRef R_Width as UInteger = 0, ByRef R_Height as UInteger = 0, ByRef R_FileMutex as Any Ptr = 0) as TImage Ptr
Dim TImg As TImage Ptr
#IF Defined(TFreeImage)
Dim FIF As FREE_IMAGE_FORMAT
Dim dib As FIBITMAP Ptr
Dim dib32 As FIBITMAP Ptr
Dim DIBWidth As UInteger
Dim DIBHeight As UInteger
Dim flags As UInteger
Dim Bits As Any Ptr
FIF = FreeImage_GetFileType(StrPtr(V_FilePathName), 0)
If FIF = FIF_UNKNOWN Then FIF = FreeImage_GetFIFFromFilename(StrPtr(V_FilePathName))
If FIF = FIF_UNKNOWN Then Return NULL
If FIF = FIF_JPEG Then flags = JPEG_ACCURATE
dib = FreeImage_Load(FIF, StrPtr(V_FilePathName), flags)
If dib = 0 Then Return NULL
DIBWidth = FreeImage_GetWidth(dib)
DIBHeight = FreeImage_GetHeight(dib)
TImg = TImageCreate(DIBWidth, DIBHeight, 32)
If TImg = 0 Then FreeImage_Unload dib: Return 0
FreeImage_FlipVertical Dib
Dib32 = FreeImage_ConvertTo32Bits(Dib)
Bits = FreeImage_GetBits(Dib32)
#IF defined(__fb_win32__)
movememory Cast(UByte Ptr, TImg->V_Data), Bits, DIBWidth * DIBHeight * 4
#ELSEIF defined(__fb_linux__)
memcpy Cast(UByte Ptr, TImg->V_Data), Bits, DIBWidth * DIBHeight * 4
#ENDIF
R_Width = DIBWidth
R_Height = DIBHeight
FreeImage_Unload dib
FreeImage_Unload dib32
#ELSE
If R_FileMutex <> 0 Then MutexLock(R_FileMutex)
If Dir(V_FilePathName, -1) = "" Then
If R_FileMutex <> 0 Then MutexUnLock(R_FileMutex)
Return 0
End If
Dim TFNID as Integer = FreeFile()
If Open(V_FilePathName For Binary Access Read As #TFNID) <> 0 Then Return 0
If R_FileMutex <> 0 Then MutexUnLock(R_FileMutex)
Dim TSig as UShort : If Get(#TFNID, , TSig) <> 0 Then Close #TFNID: Return 0
Dim TSize as ULong : If Get(#TFNID, , TSize) <> 0 Then Close #TFNID: Return 0
Dim TRes1 as UShort : If Get(#TFNID, , TRes1) <> 0 Then Close #TFNID: Return 0
Dim TRes2 as UShort : If Get(#TFNID, , TRes2) <> 0 Then Close #TFNID: Return 0
Dim TOffset as ULong : If Get(#TFNID, , TOffset) <> 0 Then Close #TFNID: Return 0
If TSig <> &H4D42 Then Close #TFNID: Return 0
If TSize < 1 Then Close #TFNID: Return 0
Dim TDIBSize as ULong : If Get(#TFNID, , TDIBSize) <> 0 Then Close #TFNID: Return 0
Dim TWidth as Long : If Get(#TFNID, , TWidth) <> 0 Then Close #TFNID: Return 0
Dim THeight as Long : If Get(#TFNID, , THeight) <> 0 Then Close #TFNID: Return 0
Dim TPlanes as UShort : If Get(#TFNID, , TPlanes) <> 0 Then Close #TFNID: Return 0
Dim TBPP as UShort : If Get(#TFNID, , TBPP) <> 0 Then Close #TFNID: Return 0
Dim TCompress as ULong : If Get(#TFNID, , TCompress) <> 0 Then Close #TFNID: Return 0
Dim TImgSize as ULong : If Get(#TFNID, , TImgSize) <> 0 Then Close #TFNID: Return 0
Dim TXPPM as ULong : If Get(#TFNID, , TXPPM) <> 0 Then Close #TFNID: Return 0
Dim TYPPM as ULong : If Get(#TFNID, , TYPPM) <> 0 Then Close #TFNID: Return 0
Dim TCCT as ULong : If Get(#TFNID, , TCCT) <> 0 Then Close #TFNID: Return 0
Dim TICC as ULong : If Get(#TFNID, , TICC) <> 0 Then Close #TFNID: Return 0
Dim TMask(0 to 3) as ULong
If Get(#TFNID, , TMask(0)) <> 0 Then Close #TFNID: Return 0
If Get(#TFNID, , TMask(1)) <> 0 Then Close #TFNID: Return 0
If Get(#TFNID, , TMask(2)) <> 0 Then Close #TFNID: Return 0
If Get(#TFNID, , TMask(3)) <> 0 Then Close #TFNID: Return 0
If TWidth < 1 Then Close #TFNID: Return 0
If THeight < 1 Then Close #TFNID: Return 0
If TPlanes <> 1 Then Close #TFNID: Return 0
If TBPP < 1 Then Close #TFNID: Return 0
If TCompress <> 0 Then Close #TFNID: Return 0
Dim T as String
Dim X as Integer
Dim Y as Integer
Seek #TFNID, TOffset + 1
Select Case TBPP
Case 24
Y = TWidth * (TBPP / 8)
If (Y Mod 4) <> 0 Then Y = Fix(TWidth * (TBPP / 8) / 4) * 4 + 4
T = Space(Y)
TImg = TImageCreate(CInt(TWidth), CInt(THeight))
For Y = THeight - 1 To 0 Step -1
Get #TFNID, , T
For X = 0 To TWidth * (TBPP / 8) - 1 Step (TBPP / 8)
TImg->V_Data[Y * TWidth + (X / (TBPP / 8))] = (T[X + 2] shl 16) or (T[X + 1] shl 8) or T[X]
Next
Next
Case Else: Close #TFNID: Return 0
End Select
Close #TFNID
#ENDIF
Return TImg
End Function
'###############################################################################################################################################
Function TLoadImageFromMem(ByRef V_Data as String, ByRef R_TransparencyColor as UInteger = &HFF000000, ByRef R_Width as UInteger = 0, ByRef R_Height as UInteger = 0) as TImage Ptr
Dim TImg as TImage Ptr
#IF Defined(TFreeImage)
If Len(V_Data) <= 0 Then Return 0
Dim MEM as FIMEMORY Ptr
MEM = FreeImage_OpenMemory(Cast(Byte Ptr, @V_Data[0]), Len(V_Data))
If MEM = 0 Then Return 0
Dim DIB As FIBITMAP Ptr
DIB = FreeImage_LoadFromMemory(FIF_JPEG, MEM, JPEG_DEFAULT)
If DIB = 0 Then FreeImage_CloseMemory(MEM): Return 0
Dim DIBWidth as Integer = Cast(Integer, FreeImage_GetWidth(DIB))
Dim DIBHeight as Integer = Cast(Integer, FreeImage_GetHeight(DIB))
If (DIBWidth <= 0) or (DIBHeight <= 0) Then FreeImage_Unload(DIB): FreeImage_CloseMemory(MEM): Return 0
FreeImage_FlipVertical(DIB)
Dim DIB32 as FIBITMAP Ptr = FreeImage_ConvertTo32Bits(DIB)
If DIB32 = 0 Then FreeImage_Unload(DIB): FreeImage_CloseMemory(MEM): Return 0
TImg = TImageCreate(DIBWidth, DIBHeight, 32)
If TImg = 0 Then FreeImage_Unload(DIB32): FreeImage_Unload(DIB): FreeImage_CloseMemory(MEM): Return 0
Dim Bits as Any Ptr = FreeImage_GetBits(DIB32)
#IF defined(__fb_win32__)
movememory Cast(UByte Ptr, TImg->V_Data), Bits, DIBWidth * DIBHeight * 4
#ELSEIF defined(__fb_linux__)
memcpy Cast(UByte Ptr, TImg->V_Data), Bits, DIBWidth * DIBHeight * 4
#ENDIF
R_Width = DIBWidth
R_Height = DIBHeight
FreeImage_Unload(DIB32)
FreeImage_Unload(DIB)
FreeImage_CloseMemory(MEM)
#ELSE
#ENDIF
Return TImg
End Function
'##############################################################################################################################################################
Function TImageScale(ByRef V_Image as TImage Ptr, V_Width as UInteger, V_Height as UInteger, V_ScaleType as Integer = 1) as TImage Ptr
If V_Image = 0 Then Return 0
If V_Width <= 0 Then Return 0
If V_Height <= 0 Then Return 0
Dim TImg as TImage Ptr = TImageCreate(V_Width, V_Height, V_Image->V_BPP)
Dim TW as UInteger = V_Image->V_Width
Dim TH as UInteger = V_Image->V_Height
If V_Width > V_Image->V_Width Then TW = V_Width
If V_Height > V_Image->V_Height Then TH = V_Height
Dim TSourceW as UInteger = V_Image->V_Width * V_Image->V_Height
Dim TTargetW as UInteger = TImg->V_Width * TImg->V_Height
Dim TSourceDW as Single = V_Image->V_Width / TW
Dim TSourceDH as Single = V_Image->V_Height / TH
Dim TTargetDW as Single = TImg->V_Width / TW
Dim TTargetDH as Single = TImg->V_Height / TH
Dim TSourceL as UInteger
Dim TTargetL as UInteger
Dim TSourceP as Integer
Dim TTargetP as Integer
Dim X as Integer
Dim Y as Integer
Select Case V_ScaleType
Case 0 'BilineareInterpolation
For Y = 0 to TH - 1
For X = 0 to TW - 1
TSourceP = CInt(Fix(TSourceDH * Y) * V_Image->V_Width + Fix(TSourceDW * X))
TTargetP = CInt(Fix(TTargetDH * Y) * TImg->V_Width + Fix(TTargetDW * X))
TImg->V_Data[TTargetP] = V_Image->V_Data[TSourceP]
Next
Next
Case Else 'NearestNeighbor
For Y = 0 to TH - 1
TSourceL = Fix(TSourceDH * Y) * V_Image->V_Width
TTargetL = Fix(TTargetDH * Y) * TImg->V_Width
For X = 0 to TW - 1
TSourceP = CInt(TSourceL + Fix(TSourceDW * X))
TTargetP = CInt(TTargetL + Fix(TTargetDW * X))
TImg->V_Data[TTargetP] = V_Image->V_Data[TSourceP]
Next
Next
End Select
Return TImg
End Function
'##############################################################################################################################################################
Function TLoadFontDynamicspaceFromFile(ByRef V_FilePathName as String, ByRef R_TransparencyColor as UInteger = &HFF000000, ByRef V_ScaleFactor as Double = 1.0, ByRef R_FileMutex as Any Ptr = 0) as TImage Ptr
Dim TImgT as TImage Ptr = TLoadImageFromFile(V_FilePathName, R_TransparencyColor, , , R_FileMutex)
If TImgT = 0 Then Return 0
Dim TImg as TImage Ptr = TImgT
If V_ScaleFactor <> 1.0 Then
TImg = TImageScale(TImgT, TImgT->V_Width * V_ScaleFactor, TImgT->V_Height * V_ScaleFactor)
TImageDestroy(TImgT)
End If
If TImg = 0 Then Return 0
With *TImg
Dim M as Integer
Dim Z as Integer
Dim TF as Integer
Dim TFC as Integer = ASC("A")
.V_FontType = FontType_Dynamicspace
.V_FontP = CAllocate(SizeOf(UInteger) * 255)
.V_FontW = CAllocate(SizeOf(UInteger) * 255)
TF = 0
For Y as Integer = 0 to .V_Height - 1
For X as Integer = 0 to .V_Width - 1
If .V_Data[Y * .V_Width + X] <> &H00000000 Then
.V_FontT = Y
TF = 1
Exit For
End If
Next
If TF = 1 Then Exit For
Next
TF = 0
For Y as Integer = .V_Height - 1 to 0 Step -1
For X as Integer = 0 to .V_Width - 1
If .V_Data[Y * .V_Width + X] <> &H00000000 Then
.V_FontH = Y - .V_FontT + 1
TF = 1
Exit For
End If
Next
If TF = 1 Then Exit For
Next
For X as Integer = 0 to .V_Width - 1
TF = 0
For Y as Integer = 0 to .V_Height - 1
If M = 0 Then
TF = 1
If .V_Data[Y * .V_Width + X] <> &H00000000 Then
.V_FontP[TFC] = X
M = 1
Exit For
End If
Else
If .V_Data[Y * .V_Width + X] = &H00FF0000 Then .V_Data[Y * .V_Width + X] = R_TransparencyColor
If .V_Data[Y * .V_Width + X] <> &H00000000 Then TF = 1: Exit For
End If
Next
If TF = 0 Then
.V_FontW[TFC] = X - .V_FontP[TFC]
M = 0
Z += 1
Select Case Z
Case 0 to 25: TFC = 65 + Z 'AZ
Case 26: TFC = 153 'Ö
Case 27: TFC = 142 'Ä
Case 28: TFC = 154 'Ü
Case 29 to 54: TFC = 97 + (Z - 29) 'az
Case 55 : TFC = 148 'ö
Case 56: TFC = 132 'ä
Case 57: TFC = 129 'ü
Case 58: TFC = 225 'ß
Case 59 to 68: TFC = 48 + (Z - 59) '09
Case 69: TFC = 230 'µ
Case 70: TFC = ASC("<")
Case 71: TFC = ASC("|")
Case 72: TFC = ASC(">")
Case 73: TFC = ASC(",")
Case 74: TFC = ASC(".")
Case 75: TFC = ASC("-")
Case 76: TFC = ASC(";")
Case 77: TFC = ASC(":")
Case 78: TFC = ASC("_")
Case 79: TFC = ASC("#")
Case 80: TFC = ASC("+")
Case 81: TFC = ASC("*")
Case 82: TFC = 248 '°
Case 83: TFC = ASC("!")
Case 84: TFC = ASC("""")
Case 85: TFC = 167 '§
Case 86: TFC = ASC("$")
Case 87: TFC = ASC("%")
Case 88: TFC = ASC("&")
Case 89: TFC = ASC("/")
Case 90: TFC = ASC("(")
Case 91: TFC = ASC(")")
Case 92: TFC = ASC("=")
Case 93: TFC = ASC("?")
Case 94: TFC = ASC("{")
Case 95: TFC = ASC("[")
Case 96: TFC = ASC("]")
Case 97: TFC = ASC("}")
Case 98: TFC = ASC("\")
Case 99: TFC = ASC("@")
Case 100: TFC = 128 '
Case Else: TFC = 0
End Select
'If TFC > 0 Then Print "CHR: >" & Z & "<___>" & TFC & "<___>" & Chr(TFC) & "<"
End If
Next
End With
Return TImg
End Function
'##############################################################################################################################################################
Sub TCLS(ByRef V_Image as TImage Ptr, ByRef V_Color as UInteger = &H00000000)
If V_Image = 0 Then Exit Sub
With *V_Image
Dim TW as UInteger = .V_Width * 4
Dim TMem as ULong Ptr = Allocate(TW)
For X as UInteger = 0 to .V_Width - 1
TMem[X] = V_Color
Next
For X as UInteger = 0 to .V_Height - 1
memcpy(@.V_Data[X * .V_Width], TMem, TW)
Next
DeAllocate(TMem)
End With
End Sub
'##############################################################################################################################################################
Sub TReplaceColor(ByRef V_Image as TImage Ptr, ByRef V_ColorFind as UInteger, ByRef V_ColorReplace as UInteger)
If V_Image = 0 Then Exit Sub
With *V_Image
For X as UInteger = 0 to .V_Height * .V_Width - 1
If .V_Data[X] = V_ColorFind Then .V_Data[X] = V_ColorReplace
Next
End With
End Sub
'##############################################################################################################################################################
#Macro TPSet(V_Image, V_X, V_Y, V_Color)
If V_Image <> 0 Then
With *V_Image
If (V_X >= 0) AndAlso (V_X < .V_Width) AndAlso (V_Y >= 0) AndAlso (V_Y < .V_Height) Then .V_Data[V_Y * .V_Width + V_X] = V_Color
End With
End If
#EndMacro
'##############################################################################################################################################################
Function TPoint(ByRef V_Image as TImage Ptr, ByRef V_X as Integer, ByRef V_Y as Integer) as UInteger
If V_Image = 0 Then Return 0
With *V_Image
If (V_X >= 0) AndAlso (V_X < .V_Width) AndAlso (V_Y >= 0) AndAlso (V_Y < .V_Height) Then Return .V_Data[V_Y * .V_Width + V_X]
End With
Return 0
End Function
'##############################################################################################################################################################
#Macro TINT_Point_SetVal(RV_DataPtr, V_Color, V_LineStyle, RV_TC)
Select Case V_LineStyle
Case LineStyle_Continues
RV_DataPtr = V_Color
Case LineStyle_Dot
If RV_TC = 0 Then
RV_DataPtr = V_Color
RV_TC = 1
Else: RV_TC = 0
End If
Case LineStyle_DotDash
RV_TC += 1
Select Case RV_TC
Case 1: RV_DataPtr = V_Color
Case 2 to 3
Case 4 to 7: RV_DataPtr = V_Color
Case 8
Case Else: RV_TC = 0
End Select
Case LineStyle_Dash
RV_TC += 1
Select Case RV_TC
Case 1 to 4: RV_DataPtr = V_Color
Case 5 to 8
Case Else: RV_TC = 0
End Select
Case LineStyle_Step2
RV_TC += 1
Select Case RV_TC
Case 1 to 2: RV_DataPtr = V_Color
Case 3 to 4
Case Else: RV_TC = 0
End Select
End Select
#EndMacro
'##############################################################################################################################################################
Sub TLine(ByRef V_Image as TImage Ptr, ByRef V_X1 as Integer, ByRef V_Y1 as Integer, ByRef V_X2 as Integer, ByRef V_Y2 as Integer, ByRef V_Color as UInteger = &HFFFFFFFF, ByRef V_Box as Integer = 0, ByRef V_Filled as Integer = 0, ByRef V_LineStyle as TImage_LineStyle_Enum = LineStyle_Continues)
If V_Image = 0 Then Exit Sub
If V_Image->V_Data = 0 Then Exit Sub
Dim TX1 as Integer = V_X1
Dim TX2 as Integer = V_X2
Dim TY1 as Integer = V_Y1
Dim TY2 as Integer = V_Y2
Dim TC1 as UInteger
Dim TC2 as UInteger
Dim TD1 as UInteger
Dim TD2 as UInteger
Dim TW1 as UInteger
Dim TMDLen as UInteger = V_Image->V_Width * V_Image->V_Height
With *V_Image
If V_Box = 1 Then
If TX1 < 0 Then TX1 = 0
If TX1 >= .V_Width Then TX1 = .V_Width - 1
If TX2 < 0 Then TX2 = 0
If TX2 >= .V_Width Then TX2 = .V_Width - 1
If TY1 < 0 Then TY1 = 0
If TY1 >= .V_Height Then TY1 = .V_Height - 1
If TY2 < 0 Then TY2 = 0
If TY2 >= .V_Height Then TY2 = .V_Height - 1
If TX1 > TX2 Then Swap TX1, TX2
If TY1 > TY2 Then Swap TY1, TY2
If V_Filled = 1 Then
If V_LineStyle <> LineStyle_Continues Then
For Y as Integer = TY1 to TY2
If TC2 = 0 Then TC2 = 1 Else TC2 = 0
TC1 = TC2
For X as Integer = TX1 to TX2
TINT_Point_SetVal(V_Image->V_Data[Y * .V_Width + X], V_Color, V_LineStyle, TC1)
Next
Next
Else
For Y as Integer = TY1 to TY2
For X as Integer = TX1 to TX2
V_Image->V_Data[Y * .V_Width + X] = V_Color
Next
Next
End If
Else
For X as Integer = TX1 to TX2
TINT_Point_SetVal(V_Image->V_Data[TY1 * .V_Width + X], V_Color, V_LineStyle, TC1)
TINT_Point_SetVal(V_Image->V_Data[TY2 * .V_Width + X], V_Color, V_LineStyle, TC2)
Next
For Y as Integer = TY1 to TY2
TINT_Point_SetVal(V_Image->V_Data[Y * .V_Width + TX1], V_Color, V_LineStyle, TC1)
TINT_Point_SetVal(V_Image->V_Data[Y * .V_Width + TX2], V_Color, V_LineStyle, TC2)
Next
End If
Else
If TX1 = TX2 Then
If TX1 < 0 Then TX1 = 0
If TX1 >= .V_Width Then TX1 = .V_Width - 1
If TX2 < 0 Then TX2 = 0
If TX2 >= .V_Width Then TX2 = .V_Width - 1
If TY1 < 0 Then TY1 = 0
If TY1 >= .V_Height Then TY1 = .V_Height - 1
If TY2 < 0 Then TY2 = 0
If TY2 >= .V_Height Then TY2 = .V_Height - 1
If TX1 > TX2 Then Swap TX1, TX2
If TY1 > TY2 Then Swap TY1, TY2
For Y as Integer = TY1 to TY2
TINT_Point_SetVal(V_Image->V_Data[Y * .V_Width + TX1], V_Color, V_LineStyle, TC1)
Next
ElseIf TY1 = TY2 Then
If TX1 < 0 Then TX1 = 0
If TX1 >= .V_Width Then TX1 = .V_Width - 1
If TX2 < 0 Then TX2 = 0
If TX2 >= .V_Width Then TX2 = .V_Width - 1
If TY1 < 0 Then TY1 = 0
If TY1 >= .V_Height Then TY1 = .V_Height - 1
If TY2 < 0 Then TY2 = 0
If TY2 >= .V_Height Then TY2 = .V_Height - 1
If TX1 > TX2 Then Swap TX1, TX2
If TY1 > TY2 Then Swap TY1, TY2
For X as Integer = TX1 to TX2
TINT_Point_SetVal(V_Image->V_Data[TY1 * .V_Width + X], V_Color, V_LineStyle, TC1)
Next
Else
Dim TMultiplier as Double
If Abs(TX2 - TX1) > Abs(TY2 - TY1) Then
TMultiplier = (TY2 - TY1) / (TX2 - TX1)
For X as Integer = IIf(TX1 < TX2, TX1, TX2) to IIf(TX1 < TX2, TX2, TX1)
If X >= .V_Width Then Exit For
If X >= 0 Then
TD1 = (CInt(TY1 + (X - TX1) * TMultiplier) * .V_Width + X)
If TMDLen > TD1 Then
TINT_Point_SetVal(V_Image->V_Data[TD1], V_Color, V_LineStyle, TC1)
End If
End If
Next
Else
TMultiplier = (TX2 - TX1) / (TY2 - TY1)
TW1 = (.V_Width - 1)
For Y as Integer = IIf(TY1 < TY2, TY1, TY2) to IIf(TY1 < TY2, TY2, TY1)
If Y >= .V_Height Then Exit For
If Y >= 0 Then
TD1 = (TX1 + (Y - TY1) * TMultiplier)
TD2 = CInt(Y * .V_Width) + TD1
If TMDLen > TD2 Then
If (TD1 >= 0) and (TD1 < TW1) Then
TINT_Point_SetVal(V_Image->V_Data[TD2], V_Color, V_LineStyle, TC1)
End If
End If
End If
Next
End If
End If
End If
End With
End Sub
'##############################################################################################################################################################
Sub TCircle(ByRef V_Image as TImage Ptr, ByRef V_X as Integer, ByRef V_Y as Integer, ByRef V_Radius as Integer, ByRef V_Color as UInteger = &HFFFFFFFF, ByRef V_Filled as Integer = 0, ByRef V_LineStyle as TImage_LineStyle_Enum = LineStyle_Continues)
If V_Image = 0 Then Exit Sub
If V_Image->V_Data = 0 Then Exit Sub
Dim TMDLen as UInteger = V_Image->V_Width * V_Image->V_Height
With *V_Image
Dim D as Double = -V_Radius
Dim Y as Double
Dim X as Double = V_Radius
Dim TW1 as UInteger
Dim TC1(8) as UInteger
Dim TV as Integer
If V_Filled = 0 Then
Do Until Y > X
TW1 = (V_X + X)
If (TW1 >= 0) and (TW1 < .V_Width) Then
TV = (TW1 + (V_Y + Y) * .V_Width)
If (TV >= 0) and (TV < TMDLen) Then
TINT_Point_SetVal(V_Image->V_Data[TV], V_Color, V_LineStyle, TC1(1))
End If
TV = (TW1 + (V_Y + V_Radius - Y - V_Radius) * .V_Width)
If (TV >= 0) and (TV < TMDLen) Then
TINT_Point_SetVal(V_Image->V_Data[TV], V_Color, V_LineStyle, TC1(2))
End If
End If
TW1 = (V_X + V_Radius - X - V_Radius)
If (TW1 >= 0) and (TW1 < .V_Width) Then
TV = (TW1 + (V_Y + Y) * .V_Width)
If (TV >= 0) and (TV < TMDLen) Then
TINT_Point_SetVal(V_Image->V_Data[TV], V_Color, V_LineStyle, TC1(3))
End If
TV = TW1 + (V_Y + V_Radius - Y - V_Radius) * .V_Width
If (TV >= 0) and (TV < TMDLen) Then
TINT_Point_SetVal(V_Image->V_Data[TV], V_Color, V_LineStyle, TC1(4))
End If
End If
TW1 = (V_X + Y)
If (TW1 >= 0) and (TW1 < .V_Width) Then
TV = TW1 + (V_Y + X) * .V_Width
If (TV >= 0) and (TV < TMDLen) Then
TINT_Point_SetVal(V_Image->V_Data[TV], V_Color, V_LineStyle, TC1(5))
End If
TV = (TW1 + (V_Y + V_Radius - X - V_Radius) * .V_Width)
If (TV >= 0) and (TV < TMDLen) Then
TINT_Point_SetVal(V_Image->V_Data[TV], V_Color, V_LineStyle, TC1(6))
End If
End If
TW1 = (V_X + V_Radius - Y - V_Radius)
If (TW1 >= 0) and (TW1 < .V_Width) Then
TV = (TW1 + (V_Y + X) * .V_Width)
If (TV >= 0) and (TV < TMDLen) Then
TINT_Point_SetVal(V_Image->V_Data[TV], V_Color, V_LineStyle, TC1(7))
End If
TV = (TW1 + (V_Y + V_Radius - X - V_Radius) * .V_Width)
If (TV >= 0) and (TV < TMDLen) Then
TINT_Point_SetVal(V_Image->V_Data[TV], V_Color, V_LineStyle, TC1(8))
End If
End If
D = D + 2 * Y + 1
Y = Y + 1
If D > 0 Then
D = D - 2 * X + 2
X = X - 1
End If
Loop
Else
Dim TY as Integer
Dim TYL1 as Double
Dim TYL2 as Double
Dim TX1a as Double
Dim TX1b as Double
Dim TX2a as Double
Dim TX2b as Double
Dim T1i as Integer
Dim T2i as Integer
Dim TModX as Integer
Select Case V_LineStyle
Case LineStyle_Continues : TModX = 1
Case LineStyle_Dot : TModX = 2
Case LineStyle_DotDash : TModX = 8
Case LineStyle_Dash : TModX = 4
Case LineStyle_Step2 : TModX = 2
End Select
Do Until Y > X
TY = V_Y + Y
If (TY >= 0) and (TY < .V_Height) Then
TC1(1) = (TY + V_X + V_Radius - X - V_Radius) mod TModX
For XX as Integer = V_X + V_Radius - X - V_Radius to V_X + X
If (XX >= 0) and (XX < .V_Width) Then
TV = Int(XX + TY * .V_Width)
If (TV >= 0) and (TV < TMDLen) Then
TINT_Point_SetVal(V_Image->V_Data[TV], V_Color, V_LineStyle, TC1(1))
End If
End If
Next
TY = V_Y + V_Radius - Y - V_Radius
TC1(1) = (TY + V_X + V_Radius - X - V_Radius) mod TModX
For XX as Integer = V_X + V_Radius - X - V_Radius to V_X + X
If (XX >= 0) and (XX < .V_Width) Then
TV = Int(XX + TY * .V_Width)
If (TV >= 0) and (TV < TMDLen) Then
TINT_Point_SetVal(V_Image->V_Data[TV], V_Color, V_LineStyle, TC1(1))
End If
End If
Next
TY = V_Y + X
If TYL1 <> TY Then
If T1i = 1 Then
TC1(1) = (TY + TX1a - 1) mod TModX
For XX as Double = TX1a to TX1b
If (XX >= 0) and (XX < .V_Width) Then
TV = Int(XX + TYL1 * .V_Width)
If (TV >= 0) and (TV < TMDLen) Then
TINT_Point_SetVal(V_Image->V_Data[TV], V_Color, V_LineStyle, TC1(1))
End If
End If
Next
End If
T1i = 1
TYL1 = TY
End If
TX1a = V_X + V_Radius - Y - V_Radius
TX1b = V_X + Y
TY = V_Y + V_Radius - X - V_Radius
If TYL2 <> TY Then
If T2i = 1 Then
TC1(1) = (TY + TX2a - 1) mod TModX
For XX as Double = TX2a to TX2b
If (XX >= 0) and (XX < .V_Width) Then
TV = Int(XX + TYL2 * .V_Width)
If (TV >= 0) and (TV < TMDLen) Then
TINT_Point_SetVal(V_Image->V_Data[TV], V_Color, V_LineStyle, TC1(1))
End If
End If
Next
End If
T2i = 1
TYL2 = TY
End If
TX2a = V_X + V_Radius - Y - V_Radius
TX2b = V_X + Y
End If
D = D + 2 * Y + 1
Y = Y + 1
If D > 0 Then
D = D - 2 * X + 2
X = X - 1
End If
Loop
TC1(1) = (TY + TX2a) mod TModX
For XX as Integer = V_X + V_Radius - Y - V_Radius + 1 to V_X + Y - 1
If (XX >= 0) and (XX < .V_Width) Then
TV = Int(XX + TYL1 * .V_Width)
If (TV >= 0) and (TV < TMDLen) Then
TINT_Point_SetVal(V_Image->V_Data[TV], V_Color, V_LineStyle, TC1(1))
End If
End If
Next
TC1(1) = (TY + TX1a) mod TModX
For XX as Integer = V_X + V_Radius - Y - V_Radius + 1 to V_X + Y - 1
If (XX >= 0) and (XX < .V_Width) Then
TV = Int(XX + TYL2 * .V_Width)
If (TV >= 0) and (TV < TMDLen) Then
TINT_Point_SetVal(V_Image->V_Data[TV], V_Color, V_LineStyle, TC1(1))
End If
End If
Next
End If
End With
End Sub
'##############################################################################################################################################################
Function TPut_AlphaBlitterGray(ByRef V_SourcePix as ULong, ByRef V_DestPix as ULong, ByRef V_Param as UInteger) as ULong
If (V_SourcePix and &HFFFFFF) = &HFF00FF Then Return V_DestPix
If (V_SourcePix and &HFFFFFF) = &H000000 Then Return V_DestPix
Dim TA as ULong = V_SourcePix and &H0000FF
Dim TDR as ULong = (V_DestPix and &HFF0000) shr 16
Dim TDG as ULong = (V_DestPix and &H00FF00) shr 8
Dim TDB as ULong = (V_DestPix and &H0000FF)
Dim TPR as ULong = (V_Param and &HFF0000) shr 16
Dim TPG as ULong = (V_Param and &H00FF00) shr 8
Dim TPB as ULong = (V_Param and &H0000FF)
Dim TOut as ULong
If TDR > TPR Then
TOut = TPR + (TDR - TPR) / 255 * (255 - TA)
Else: TOut = TDR + (TPR - TDR) / 255 * TA
End If
TOut shl= 8
If TDG > TPG Then
TOut or= TPG + (TDG - TPG) / 255 * (255 - TA)
Else: TOut or= TDG + (TPG - TDG) / 255 * TA
End If
TOut shl= 8
If TDB > TPB Then
TOut or= TPB + (TDB - TPB) / 255 * (255 - TA)
Else: TOut or= TDB + (TPB - TDB) / 255 * TA
End If
Return &HFF000000 or TOut
End Function
'##############################################################################################################################################################
Sub TPut(ByRef V_TargetImage as TImage Ptr, ByRef V_TargetX as Integer, V_TargetY as Integer, ByRef V_SourceImage as TImage Ptr, ByRef V_SourceX as UInteger = 0, ByRef V_SourceY as UInteger = 0, ByRef V_SourceW as UInteger = 0, ByRef V_SourceH as UInteger = 0, ByRef V_CopyMaskColor as UInteger = &HFF000000, ByRef V_PutColor as UInteger = &HFF000000, V_IgnorCopyMaskColor as Integer = 0, V_TransparencyMaskColor as UInteger = &HFF000000, V_UseGrayScaleAsAlpha as Integer = 0, V_UseAlphaChan as Integer = 0, V_UsePutColor as Integer = 0)
If V_TargetImage = 0 Then Exit Sub
If V_SourceImage = 0 Then Exit Sub
If V_TargetImage->V_Data = 0 Then Exit Sub
If V_SourceImage->V_Data = 0 Then Exit Sub
Dim SX1 as Integer = V_SourceX
Dim SY1 as Integer = V_SourceY
Dim SX2 as Integer = V_SourceX + V_SourceW
Dim SY2 as Integer = V_SourceY + V_SourceH
If (V_SourceX = 0) and (V_SourceY = 0) and (V_SourceW = 0) and (V_SourceH = 0) Then
SX2 = V_SourceImage->V_Width - 1
SY2 = V_SourceImage->V_Height - 1
End If
If SX2 >= V_SourceImage->V_Width Then SX2 = V_SourceImage->V_Width - 1
If SY2 >= V_SourceImage->V_Height Then SY2 = V_SourceImage->V_Height - 1
If SX1 >= SX2 Then Exit Sub
If SY1 >= SY2 Then Exit Sub
Dim X as Integer
Dim Y as Integer
Dim TX as Integer
Dim TY as Integer = V_TargetY
If V_IgnorCopyMaskColor = 0 Then
If V_CopyMaskColor <> &HFF000000 Then
If V_UseGrayScaleAsAlpha = 0 Then
For Y = SY1 to SY2
If (TY >= 0) and (TY < V_TargetImage->V_Height) Then
TX = V_TargetX
For X = SX1 to SX2
If (TX >= 0) and (TX < V_TargetImage->V_Width) Then
If V_CopyMaskColor = V_SourceImage->V_Data[Y * V_SourceImage->V_Width + X] Then
V_TargetImage->V_Data[TY * V_TargetImage->V_Width + TX] = V_PutColor
End If
End If
TX += 1
Next
End If
TY += 1
Next
Else
For Y = SY1 to SY2
If (TY >= 0) and (TY < V_TargetImage->V_Height) Then
TX = V_TargetX
For X = SX1 to SX2
If (TX >= 0) and (TX < V_TargetImage->V_Width) Then
V_TargetImage->V_Data[TY * V_TargetImage->V_Width + TX] = TPut_AlphaBlitterGray(V_SourceImage->V_Data[Y * V_SourceImage->V_Width + X], V_TargetImage->V_Data[TY * V_TargetImage->V_Width + TX], V_PutColor)
End If
TX += 1
Next
End If
TY += 1
Next
End If
Else
If V_UsePutColor = 0 Then
For Y = SY1 to SY2
If (TY >= 0) and (TY < V_TargetImage->V_Height) Then
TX = V_TargetX
For X = SX1 to SX2
If (TX >= 0) and (TX < V_TargetImage->V_Width) Then
If V_TransparencyMaskColor <> V_SourceImage->V_Data[Y * V_SourceImage->V_Width + X] Then
V_TargetImage->V_Data[TY * V_TargetImage->V_Width + TX] = V_SourceImage->V_Data[Y * V_SourceImage->V_Width + X]
End If
End If
TX += 1
Next
End If
TY += 1
Next
Else
For Y = SY1 to SY2
If (TY >= 0) and (TY < V_TargetImage->V_Height) Then
TX = V_TargetX
For X = SX1 to SX2
If (TX >= 0) and (TX < V_TargetImage->V_Width) Then
If V_TransparencyMaskColor <> V_SourceImage->V_Data[Y * V_SourceImage->V_Width + X] Then
V_TargetImage->V_Data[TY * V_TargetImage->V_Width + TX] = V_PutColor
End If
End If
TX += 1
Next
End If
TY += 1
Next
End If
End If
Else
If V_UseAlphaChan = 0 Then
For Y = SY1 to SY2
If (TY >= 0) and (TY < V_TargetImage->V_Height) Then
TX = V_TargetX
For X = SX1 to SX2
If (TX >= 0) and (TX < V_TargetImage->V_Width) Then
If V_CopyMaskColor <> V_SourceImage->V_Data[Y * V_SourceImage->V_Width + X] Then
V_TargetImage->V_Data[TY * V_TargetImage->V_Width + TX] = V_SourceImage->V_Data[Y * V_SourceImage->V_Width + X]
End If
End If
TX += 1
Next
End If
TY += 1
Next
Else
'Print #1, "ALPHA-BLIT:" & Timer()
Dim TA as UInteger
Dim TDR as UInteger
Dim TDG as UInteger
Dim TDB as UInteger
Dim TPR as UInteger
Dim TPG as UInteger
Dim TPB as UInteger
Dim TSrc as UInteger
Dim TDest as UInteger
Dim TOut as UInteger
For Y = SY1 to SY2
If (TY >= 0) and (TY < V_TargetImage->V_Height) Then
TX = V_TargetX
For X = SX1 to SX2
If (TX >= 0) and (TX < V_TargetImage->V_Width) Then
TSrc = V_SourceImage->V_Data[Y * V_SourceImage->V_Width + X]
TDest = V_TargetImage->V_Data[TY * V_TargetImage->V_Width + TX]
TA = (TSrc and &HFF000000) shr 24
TDR = (TDest and &H00FF0000) shr 16
TDG = (TDest and &H0000FF00) shr 8
TDB = (TDest and &H000000FF)
TPR = (TSrc and &H00FF0000) shr 16
TPG = (TSrc and &H0000FF00) shr 8
TPB = (TSrc and &H000000FF)
If TDR > TPR Then
TOut = TPR + (TDR - TPR) / 255 * (255 - TA)
Else: TOut = TDR + (TPR - TDR) / 255 * TA
End If
TOut shl= 8
If TDG > TPG Then
TOut or= TPG + (TDG - TPG) / 255 * (255 - TA)
Else: TOut or= TDG + (TPG - TDG) / 255 * TA
End If
TOut shl= 8
If TDB > TPB Then
TOut or= TPB + (TDB - TPB) / 255 * (255 - TA)
Else: TOut or= TDB + (TPB - TDB) / 255 * TA
End If
V_TargetImage->V_Data[TY * V_TargetImage->V_Width + TX] = &HFF000000 or TOut
End If
TX += 1
Next
End If
TY += 1
Next
End If
End If
End Sub
'##############################################################################################################################################################
Sub TPutToFB(ByRef V_TargetImage as FB.Image Ptr, ByRef V_SourceImage as TImage Ptr)
Dim TW as Integer
Dim TH as Integer
Dim TPitch as Integer
Dim TPixels as Any Ptr
Dim TRowT As UInteger Ptr
Dim TRowS As UInteger Ptr
If 0 <> ImageInfo(V_TargetImage, TW, TH, , TPitch, TPixels) Then Exit Sub
If TW <> V_SourceImage->V_Width Then Exit Sub
If TH <> V_SourceImage->V_Height Then Exit Sub
For Y As Integer = 0 To V_SourceImage->V_Height - 1
memcpy(TPixels + Y * TPitch, V_SourceImage->V_Data + Y * V_SourceImage->V_Width, V_SourceImage->V_Width * 4 - 1)
' TRowS = V_SourceImage->V_Data + Y * V_SourceImage->V_Width
' TRowT = TPixels + Y * TPitch
' For X As Integer = 0 To V_SourceImage->V_Width - 1
' TRowT[X] = TRowS[X]
' Next
Next
End Sub
'##############################################################################################################################################################
Sub TDrawStringGetMaxDimensions(ByRef V_Font as TImage Ptr = 0, ByRef V_Text as String, ByRef R_Width as UInteger, ByRef R_Height as UInteger, ByRef V_CharSpace as Integer = 0, ByRef V_LineSpace as Integer = 0, ByRef V_NoLinebreak as Integer = 0, ByRef V_AutoWordbreak as Integer = 0)
R_Width = 0
R_Height = 0
Dim TFont as TImage Ptr = V_Font
If TFont = 0 Then TFont = TImage_GFX_MainFont
If TFont = 0 Then Exit Sub
If TFont->V_Data = 0 Then TFont = TImage_GFX_MainFont
If TFont = 0 Then Exit Sub
If TFont->V_Data = 0 Then Exit Sub
Dim XX as UInteger = 0
Dim Y as UInteger = 0
Dim TH as UInteger = TFont->V_Height
Dim TFK as Integer
Select Case TFont->V_FontType
Case FontType_Monospace
Dim TW as UInteger = TFont->V_Width / 256
For X as UInteger = 1 to Len(V_Text)
Select Case V_Text[X - 1]
Case 13
Case 10
If V_NoLinebreak = 0 Then
If (XX * TW) > R_Width Then R_Width = XX * TW
Y += 1: XX = 0
End If
Case Else: XX += 1
End Select
Next
If XX > R_Width Then R_Width = XX
R_Height = (Y * (TH + V_LineSpace)) + TH
Case FontType_Dynamicspace
TH = TFont->V_FontH
For X as UInteger = 1 to Len(V_Text)
TFK = 0
Select Case V_Text[X - 1]
Case 32: XX += TH / 2
Case 13
Case 10
If V_NoLinebreak = 0 Then
If XX > R_Width Then R_Width = XX
If V_LineSpace > 0 Then Y += V_LineSpace Else Y += TH + 2
XX = 0
End If
Case 194
X += 1
If X > Len(V_Text) Then Exit For
Select Case V_Text[X - 1]
Case 176: TFK = 248 '?
Case 181: TFK = 230 '?
Case 167: TFK = 245 '?
End Select
Case 195
X += 1
If X > Len(V_Text) Then Exit For
Select Case V_Text[X - 1]
Case 164: TFK = 132 '?
Case 182: TFK = 148 '?
Case 188: TFK = 129 '?
Case 132: TFK = 142 '?
Case 150: TFK = 153 '?
Case 156: TFK = 154 '?
Case 159: TFK = 225 '?
End Select
Case Else: TFK = V_Text[X - 1]
End Select
If TFK > 0 Then
XX += TFont->V_FontW[TFK]
If V_CharSpace > 0 Then XX += V_CharSpace Else XX += CInt(TH / 32)
End If
Next
If XX > R_Width Then R_Width = XX
R_Height = Y + TH + 2
End Select
End Sub
'##############################################################################################################################################################
Sub TDrawString(ByRef V_Target as TImage Ptr, ByRef V_Font as TImage Ptr = 0, ByRef V_Text as String, ByRef V_X as Integer, ByRef V_Y as Integer, ByRef V_Color as UInteger = &H00FFFFFF, ByRef V_CharSpace as Integer, ByRef V_LineSpace as Integer = 0, ByRef V_NoLinebreak as Integer = 0, ByRef V_CheckAlpha as Integer = 0)
Dim TFont as TImage Ptr = V_Font
If TFont = 0 Then TFont = TImage_GFX_MainFont
If TFont = 0 Then Exit Sub
If TFont->V_Data = 0 Then TFont = TImage_GFX_MainFont
If TFont = 0 Then Exit Sub
If TFont->V_Data = 0 Then Exit Sub
Dim XX as Integer = 0
Dim Y as UInteger = 0
Dim TH as UInteger = TFont->V_Height
Dim TFK as Integer
Select Case TFont->V_FontType
Case FontType_Monospace
Dim TW as UInteger = TFont->V_Width / 256
For X as UInteger = 1 to Len(V_Text)
Select Case V_Text[X - 1]
Case 13
Case 10: If V_NoLinebreak = 0 Then Y += 1: XX = 0
Case Else
XX += 1
TPut(V_Target, V_X + ((XX - 1) * (TW + V_CharSpace)), V_Y + (Y * (TH + V_LineSpace)), TFont, V_Text[X - 1] * TW, 0, TW - 1, TH - 1, &H00FFFFFF, V_Color, , , 1, , 1)
End Select
Next
Case FontType_Dynamicspace
TH = TFont->V_FontH
For X as UInteger = 1 to Len(V_Text)
TFK = 0
Select Case V_Text[X - 1]
Case 32: XX += TH / 2
Case 13
Case 10
If V_NoLinebreak = 0 Then
If V_LineSpace > 0 Then Y += V_LineSpace Else Y += TH + 2
XX = 0
End If
Case 194
X += 1
If X > Len(V_Text) Then Exit For
Select Case V_Text[X - 1]
Case 176: TFK = 248 '?
Case 181: TFK = 230 '?
Case 167: TFK = 245 '?
End Select
Case 195
X += 1
If X > Len(V_Text) Then Exit For
Select Case V_Text[X - 1]
Case 164: TFK = 132 '?
Case 182: TFK = 148 '?
Case 188: TFK = 129 '?
Case 132: TFK = 142 '?
Case 150: TFK = 153 '?
Case 156: TFK = 154 '?
Case 159: TFK = 225 '?
End Select
Case Else: TFK = V_Text[X - 1]
End Select
If TFK > 0 Then
'Print #1, "DS:>" & V_X + XX & "<___>" & V_Y + (Y * (TH + V_LineSpace)) & "<___>" & TFont->V_FontP[TFK] & "<___>" & TFont->V_FontW[TFK] & "<___>" & V_CharSpace & "<"
TPut(V_Target, V_X + XX, V_Y + Y, TFont, TFont->V_FontP[TFK], TFont->V_FontT, TFont->V_FontW[TFK], TFont->V_FontH, &H00FFFFFF, V_Color, , , 1)
XX += TFont->V_FontW[TFK]
If V_CharSpace > 0 Then XX += V_CharSpace Else XX += CInt(TH / 32)
End If
Next
End Select
End Sub
'##############################################################################################################################################################
'Sub TGFXInit(ByRef V_MainFontPathName as String)
'If TGFX_MainFont <> 0 Then TImageDestroy(TGFX_MainFont)
'TGFX_MainFont = TLoadImageFromFile(V_MainFontPathName)
'End Sub
'##############################################################################################################################################################
Private Sub TImage.CLS(ByRef V_Color as UInteger = &H00000000)
TCLS(@This, V_Color)
End Sub
'--------------------------------------------------------------------------------------------------------------------------------------------------------------
Private Sub TImage.ReplaceColor(ByRef V_ColorFind as UInteger, ByRef V_ColorReplace as UInteger)
TReplaceColor(@This, V_ColorFind, V_ColorReplace)
End Sub
'--------------------------------------------------------------------------------------------------------------------------------------------------------------
Private Sub TImage.PSET(ByRef V_X as Integer, ByRef V_Y as Integer, ByRef V_Color as UInteger = &H00000000)
TPSet(@This, V_X, V_Y, V_Color)
End Sub
'--------------------------------------------------------------------------------------------------------------------------------------------------------------
Private Function TImage.Point(ByRef V_X as Integer, ByRef V_Y as Integer) as UInteger
Return TPoint(@This, V_X, V_Y)
End Function
'--------------------------------------------------------------------------------------------------------------------------------------------------------------
Private Sub TImage.Line(ByRef V_X1 as Integer, ByRef V_Y1 as Integer, ByRef V_X2 as Integer, ByRef V_Y2 as Integer, ByRef V_Color as UInteger = &H00000000, ByRef V_Box as Integer = 0, ByRef V_Filled as Integer = 0, ByRef V_LineStyle as TImage_LineStyle_Enum = LineStyle_Continues)
TLine(@This, V_X1, V_Y1, V_X2, V_Y2, V_Color, V_Box, V_Filled, V_LineStyle)
End Sub
'--------------------------------------------------------------------------------------------------------------------------------------------------------------
Private Sub TImage.Circle(ByRef V_X as Integer, ByRef V_Y as Integer, ByRef V_Radius as Integer, ByRef V_Color as UInteger = &HFFFFFFFF, ByRef V_Filled as Integer = 0, ByRef V_LineStyle as TImage_LineStyle_Enum = LineStyle_Continues)
TCircle(@This, V_X, V_Y, V_Radius, V_Color, V_Filled, V_LineStyle)
End Sub
'--------------------------------------------------------------------------------------------------------------------------------------------------------------
Private Sub TImage.Put(ByRef V_TargetX as Integer, V_TargetY as Integer, ByRef V_SourceImage as TImage Ptr, ByRef V_SourceX as UInteger = 0, ByRef V_SourceY as UInteger = 0, ByRef V_SourceW as UInteger = 0, ByRef V_SourceH as UInteger = 0, ByRef V_CopyMaskColor as UInteger = &HFF000000, ByRef V_PutColor as UInteger = &HFF000000, V_IgnorCopyMaskColor as Integer = 0, V_TransparencyMaskColor as UInteger = &HFF000000)
TPut(@This, V_TargetX, V_TargetY, V_SourceImage, V_SourceX, V_SourceY, V_SourceW, V_SourceH, V_CopyMaskColor, V_PutColor, V_IgnorCopyMaskColor)
End Sub
'--------------------------------------------------------------------------------------------------------------------------------------------------------------
Private Sub TImage.DrawString(ByRef V_Font as TImage Ptr = 0, ByRef V_Text as String, ByRef V_X as Integer, ByRef V_Y as Integer, ByRef V_Color as UInteger = &HFFFFFF, ByRef V_CharSpace as Integer = 0, ByRef V_LineSpace as Integer = 0, ByRef V_NoLinebreak as Integer = 0, ByRef V_CheckAlpha as Integer = 0)
TDrawString(@This, V_Font, V_Text, V_X, V_Y, V_Color, V_CharSpace, V_LineSpace, V_NoLinebreak, V_CheckAlpha)
End Sub