Introduction
Most PDFs with complex Arabic generally used for the Qur'an use special fonts or images or sacrifice being raw Unicode text in various ways. Qur'anic Arabic renders fine with a complex script rendering engine present in most web browers or document editors now through GDI or for more accuracy than DirectWrite or a custom complex script library. iTextSharp is one of the best libraries for doing the task. The result will be fully copy and pastable Unicode Qur'anic Arabic text.
Background
VB.NET, .NET, DirectWrite, PDF, iTextSharp, Qur'anic Arabic and ligaturizing are useful to know to understand this. DirectWrite provides accurate calculations and Unicode ligature conversions to properly and correctly align the diacritics. iTextSharp is used in this example to write the diacritics out one by one.
Required are Unicode standard data (currently v7.0.0) UnicodeData.txt and ArabicShaping.txt which are loaded to generate complete ligature and Arabic information in the most comprehensive standards based method freely available from (which should be put in a directory called metadata):
Using the Code
Example:
'Before rendering complex Arabic text, call the following:
Text = WriteArabicPdfDiacritics(Doc, Writer, DrawFont, FixedFont, Text, Rect,
Baseline, False, Forms, FontFace)
The code which also includes a FitText scaling function and GetTextWidthDraw pre-calculation function:
Public Class ArabicData
<serializable> _
Public Structure ArabicCombo
Public UnicodeName As String()
Public Symbol As Char()
Public Shaping() As Char
Public ReadOnly Property Connecting As Boolean
Get
If Not Shaping Is Nothing And Shaping.Length = 1 Then Return ArabicLetters(FindLetterBySymbol(Shaping(0))).Connecting
Return (Not Shaping Is Nothing AndAlso (Shaping(1) <> Nothing Or Shaping(3) <> Nothing))
End Get
End Property
Public ReadOnly Property Terminating As Boolean
Get
If Not Shaping Is Nothing And Shaping.Length = 1 _
Then Return ArabicLetters(FindLetterBySymbol(Shaping(0))).Terminating
Return (Not Shaping Is Nothing AndAlso ((Shaping(0) <> _
Nothing Or Shaping(1) <> Nothing) And Shaping(2) = Nothing And Shaping(3) = Nothing))
End Get
End Property
End Structure
Public Shared _ArabicCombos() As ArabicCombo
<serializable> _
Public Structure ArabicSymbol
Public UnicodeName As String
Public Symbol As Char
Public Shaping() As Char
Public JoiningStyle As String
Public CombiningClass As Integer
Public ReadOnly Property Connecting As Boolean
Get
Return JoiningStyle <> "T" AndAlso _
(JoiningStyle = "final" Or JoiningStyle = "medial" Or JoiningStyle = "C" _
Or (Not Shaping Is Nothing AndAlso (Shaping(1) <> Nothing Or Shaping(3) <> Nothing)))
End Get
End Property
Public ReadOnly Property Terminating As Boolean
Get
Return JoiningStyle <> "T" AndAlso _
(JoiningStyle = "isolated" Or JoiningStyle = "final" Or JoiningStyle = "U" _
Or (Not Shaping Is Nothing AndAlso ((Shaping(0) <> Nothing Or Shaping(1) <> _
Nothing) And Shaping(2) = Nothing And Shaping(3) = Nothing)))
End Get
End Property
End Structure
Public Shared _ArabicLetters() As ArabicSymbol
Public Shared Sub LoadArabic()
If Not DiskCache.GetCacheItem("ArabicLetters", DateTime.MinValue) Is Nothing _
And Not DiskCache.GetCacheItem("ArabicCombos", DateTime.MinValue) Is Nothing Then
_ArabicLetters = CType((New System.Runtime.Serialization.Formatters.Binary.BinaryFormatter)._
Deserialize(New IO.MemoryStream(DiskCache.GetCacheItem("ArabicLetters", _
DateTime.MinValue))), ArabicData.ArabicSymbol())
_ArabicCombos = CType((New System.Runtime.Serialization.Formatters.Binary.BinaryFormatter)._
Deserialize(New IO.MemoryStream(DiskCache.GetCacheItem("ArabicCombos", _
DateTime.MinValue))), ArabicData.ArabicCombo())
Return
End If
Dim CharArr As New ArrayList
Dim Letters As New ArrayList
Dim Combos As New ArrayList
Dim Ranges As ArrayList = MakeUniCategory(ALCategories)
For Count = 0 To Ranges.Count - 1
Dim Range As ArrayList = CType(Ranges(Count), ArrayList)
If Range.Count = 1 Then
CharArr.Add(Range(0))
Else
For SubCount = 0 To Range.Count - 1
CharArr.Add(Range(SubCount))
Next
End If
Next
For Count = 0 To CharArr.Count - 1
If _DecData.ContainsKey(ChrW(CInt(CharArr(Count)))) AndAlso Not _DecData.Item_
(ChrW(CInt(CharArr(Count)))).Chars Is Nothing AndAlso _DecData.Item_
(ChrW(CInt(CharArr(Count)))).Chars.Length <> 0 Then
Dim ComCount As Integer
For ComCount = 0 To Combos.Count - 1
If String.Join(String.Empty, Array.ConvertAll(CType(Combos(ComCount), _
ArabicCombo).Symbol, Function(Sym As Char) CStr(Sym))) = String.Join_
(String.Empty, Array.ConvertAll(_DecData.Item(ChrW(CInt(CharArr(Count)))).Chars, _
Function(Sym As Char) CStr(Sym))) Then Exit For
Next
Dim ArComb As ArabicCombo
If ComCount = Combos.Count Then
ArComb = New ArabicCombo
ArComb.Shaping = {Nothing, Nothing, Nothing, Nothing}
ArComb.UnicodeName = {Nothing, Nothing, Nothing, Nothing}
ArComb.Symbol = _DecData.Item(ChrW(CInt(CharArr(Count)))).Chars
Else
ArComb = CType(Combos(ComCount), ArabicCombo)
End If
Dim Idx As Integer = Array.IndexOf(ShapePositions, _DecData.Item(ChrW(CInt(CharArr(Count)))).JoiningStyle)
If Idx = -1 Then
ArComb.UnicodeName = {_Names.Item(ChrW(CInt(CharArr(Count))))(0)}
ArComb.Shaping = {ChrW(CInt(CharArr(Count)))}
Dim ArabicLet As New ArabicSymbol
ArabicLet.Symbol = ChrW(CInt(CharArr(Count)))
ArabicLet.UnicodeName = _Names.Item(ArabicLet.Symbol)(0)
ArabicLet.JoiningStyle = _DecData.Item(ArabicLet.Symbol).JoiningStyle
ArabicLet.Shaping = _DecData.Item(ArabicLet.Symbol).Shapes
Letters.Add(ArabicLet)
Else
ArComb.UnicodeName(Idx) = _Names.Item(ChrW(CInt(CharArr(Count))))(0)
ArComb.Shaping(Idx) = ChrW(CInt(CharArr(Count)))
End If
If ComCount = Combos.Count Then Combos.Add(ArComb)
Else
Dim ArabicLet As New ArabicSymbol
ArabicLet.Symbol = ChrW(CInt(CharArr(Count)))
If Array.IndexOf(CombineCategories, _UniClass(ArabicLet.Symbol)) _
<> -1 Then ArabicLet.JoiningStyle = "T"
If Array.IndexOf(CausesJoining, ArabicLet.Symbol) <> -1 _
Then ArabicLet.JoiningStyle = "C"
If _DecData.ContainsKey(ChrW(CInt(CharArr(Count)))) Then
ArabicLet.JoiningStyle = _DecData.Item(ArabicLet.Symbol).JoiningStyle
ArabicLet.Shaping = _DecData.Item(ArabicLet.Symbol).Shapes
End If
ArabicLet.UnicodeName = _Names.Item(ArabicLet.Symbol)(0)
Letters.Add(ArabicLet)
End If
Next
CharArr = New ArrayList
Ranges = MakeUniCategory(WeakCategories)
For Count = 0 To Ranges.Count - 1
Dim Range As ArrayList = CType(Ranges(Count), ArrayList)
If Range.Count = 1 Then
CharArr.Add(Range(0))
Else
For SubCount = 0 To Range.Count - 1
CharArr.Add(Range(SubCount))
Next
End If
Next
For Count = 0 To CharArr.Count - 1
Dim ArabicLet As New ArabicSymbol
ArabicLet.Symbol = ChrW(CInt(CharArr(Count)))
ArabicLet.JoiningStyle = If(Array.IndexOf(CombineCategories, _UniClass(ArabicLet.Symbol)) _
<> -1, "T", If(Array.IndexOf(CausesJoining, ArabicLet.Symbol) <> -1, _
"C", "U"))
ArabicLet.UnicodeName = _Names.Item(ArabicLet.Symbol)(0)
Letters.Add(ArabicLet)
Next
CharArr = New ArrayList
Ranges = MakeUniCategory(NeutralCategories)
For Count = 0 To Ranges.Count - 1
Dim Range As ArrayList = CType(Ranges(Count), ArrayList)
If Range.Count = 1 Then
CharArr.Add(Range(0))
Else
For SubCount = 0 To Range.Count - 1
CharArr.Add(Range(SubCount))
Next
End If
Next
For Count = 0 To CharArr.Count - 1
Dim ArabicLet As New ArabicSymbol
ArabicLet.Symbol = ChrW(CInt(CharArr(Count)))
ArabicLet.JoiningStyle = If(Array.IndexOf(CombineCategories, _UniClass(ArabicLet.Symbol)) _
<> -1, "T", If(Array.IndexOf(CausesJoining, ArabicLet.Symbol) <> -1, _
"C", "U"))
ArabicLet.UnicodeName = _Names.Item(ArabicLet.Symbol)(0)
Letters.Add(ArabicLet)
Next
_ArabicLetters = CType(Letters.ToArray(GetType(ArabicSymbol)), ArabicSymbol())
_ArabicCombos = CType(Combos.ToArray(GetType(ArabicCombo)), ArabicCombo())
Dim MemStream As New IO.MemoryStream
Dim Ser As New System.Runtime.Serialization.Formatters.Binary.BinaryFormatter
Ser.Serialize(MemStream, _ArabicLetters)
DiskCache.CacheItem("ArabicLetters", Now, MemStream.ToArray())
MemStream.Close()
MemStream = New IO.MemoryStream
Ser.Serialize(MemStream, _ArabicCombos)
DiskCache.CacheItem("ArabicCombos", Now, MemStream.ToArray())
MemStream.Close()
End Sub
Public Shared ReadOnly Property ArabicCombos As ArabicCombo()
Get
If _ArabicCombos Is Nothing Then
LoadArabic()
End If
Return _ArabicCombos
End Get
End Property
Public Shared ReadOnly Property ArabicLetters As ArabicSymbol()
Get
If _ArabicLetters Is Nothing Then
LoadArabic()
End If
Return _ArabicLetters
End Get
End Property
Public Shared Function GetUnicodeName(Character As Char) As String
Dim Str As New System.Text.StringBuilder(512)
Try
NativeMethods.GetUName(CUShort(AscW(Character)), Str)
Catch e As System.DllNotFoundException
If FindLetterBySymbol(Character) = -1 Then Return String.Empty
Dim Res As String = Utility.LoadResourceString("unicode_" + _
ArabicLetters(FindLetterBySymbol(Character)).UnicodeName)
If Res.Length <> 0 Then Return Res
Return ArabicLetters(FindLetterBySymbol(Character)).UnicodeName
End Try
Return Str.ToString()
End Function
Public Shared Function ToCamelCase(Str As String) As String
Return System.Text.RegularExpressions.Regex.Replace(Str, "([A-Z])([A-Z]+)(-| |$)", _
Function(CamCase As System.Text.RegularExpressions.Match) CamCase.Groups(1).Value + _
CamCase.Groups(2).Value.ToLower())
End Function
Public Shared Function IsTerminating(Str As String, Index As Integer) As Boolean
Dim bIsEnd = True
For CharCount As Integer = Index + 1 To Str.Length - 1
Dim Idx As Integer = FindLetterBySymbol(Str(CharCount))
If Idx = -1 OrElse ArabicLetters(Idx).JoiningStyle <> "T" Then
bIsEnd = Idx = -1 OrElse Not ArabicLetters(Idx).Connecting
Exit For
End If
Next
Return bIsEnd
End Function
Public Shared Function IsLastConnecting(Str As String, Index As Integer) As Boolean
Dim bLastConnects = False
For CharCount As Integer = Index - 1 To 0 Step -1
Dim Idx As Integer = FindLetterBySymbol(Str(CharCount))
If Idx <> -1 AndAlso ArabicLetters(Idx).JoiningStyle <> "T" Then
bLastConnects = Idx <> -1 AndAlso Not ArabicLetters(Idx).Terminating
Exit For
End If
Next
Return bLastConnects
End Function
Public Shared Function GetShapeIndex(bConnects As Boolean, _
bLastConnects As Boolean, bIsEnd As Boolean) As Integer
If Not bLastConnects And (Not bConnects Or bConnects And bIsEnd) Then
Return 0
ElseIf bLastConnects And (Not bConnects Or bConnects And bIsEnd) Then
Return 1
ElseIf Not bLastConnects And bConnects And Not bIsEnd Then
Return 2
ElseIf bLastConnects And bConnects And Not bIsEnd Then
Return 3
End If
Return -1
End Function
Public Shared Function GetShapeIndexFromString(Str As String, _
Index As Integer, Length As Integer) As Integer
Dim bIsEnd = IsTerminating(Str, Index + Length - 1)
Dim Idx As Integer = FindLetterBySymbol(Str.Chars(Index + Length - 1))
Dim bConnects As Boolean = Not ArabicLetters(Idx).Terminating
Dim bLastConnects As Boolean = ArabicLetters(Idx).Connecting And IsLastConnecting(Str, Index)
Return GetShapeIndex(bConnects, bLastConnects, bIsEnd)
End Function
Public Shared Function TransformChars(Str As String) As String
For Count As Integer = 0 To ArabicCombos.Length - 1
If ArabicCombos(Count).Shaping.Length = 1 Then
Str = Str.Replace(String.Join(String.Empty, Array.ConvertAll(ArabicCombos_
(Count).Symbol, Function(Sym As Char) CStr(Sym))), ArabicCombos(Count).Shaping(0))
End If
Next
Return Str
End Function
Public Structure LigatureInfo
Public Ligature As String
Public Indexes() As Integer
End Structure
Public Shared Function GetFormsRange(BeginIndex As Char, EndIndex As Char) As Char()
Dim Forms As New List(Of Char)
For Count As Integer = 0 To ArabicCombos.Length - 1
If Not ArabicCombos(Count).Shaping Is Nothing Then
Array.ForEach(ArabicCombos(Count).Shaping, Sub(Shape As Char) _
If Shape >= BeginIndex AndAlso Shape <= EndIndex Then Forms.Add(Shape))
End If
Next
For Count As Integer = 0 To ArabicLetters.Length - 1
If Not ArabicLetters(Count).Shaping Is Nothing Then
Array.ForEach(ArabicLetters(Count).Shaping, Sub(Shape As Char) _
If Shape >= BeginIndex AndAlso Shape <= EndIndex Then Forms.Add(Shape))
End If
Next
Return Forms.ToArray()
End Function
Public Shared _PresentationForms() As Char
Public Shared _PresentationFormsA() As Char
Public Shared _PresentationFormsB() As Char
Public Shared ReadOnly Property GetPresentationForms As Char()
Get
If _PresentationForms Is Nothing Then
Dim Forms As New List(Of Char)
Forms.AddRange(GetPresentationFormsA())
Forms.AddRange(GetPresentationFormsB())
_PresentationForms = Forms.ToArray()
End If
Return _PresentationForms
End Get
End Property
Public Shared ReadOnly Property GetPresentationFormsA() As Char()
Get
If _PresentationFormsA Is Nothing Then
_PresentationFormsA = GetFormsRange(ChrW(&HFB50), ChrW(&HFDFF))
End If
Return _PresentationFormsA
End Get
End Property
Public Shared ReadOnly Property GetPresentationFormsB() As Char()
Get
If _PresentationFormsB Is Nothing Then
_PresentationFormsB = GetFormsRange(ChrW(&HFE70), ChrW(&HFEFF))
End If
Return _PresentationFormsB
End Get
End Property
Public Shared Function CheckLigatureMatch(Str As String, CurPos As Integer, _
ByRef Positions As Integer()) As Integer
If Str.Length > 2 AndAlso FindLetterBySymbol(Str(1)) <> -1 _
AndAlso ArabicLetters(FindLetterBySymbol(Str(1))).JoiningStyle = "T" _
AndAlso ArabicLetters(FindLetterBySymbol(Str(2))).JoiningStyle = "T" _
AndAlso (LigatureLookups.ContainsKey(Str.Substring(0, 3)) Or _
LigatureLookups.ContainsKey(Str(0) + Str(2) + Str(1))) Then
Positions = {CurPos, CurPos + 1, CurPos + 2}
Return LigatureLookups.Item(If(LigatureLookups.ContainsKey(Str.Substring(0, 3)), _
Str.Substring(0, 3), Str(0) + Str(2) + Str(1)))
ElseIf Str.Length > 1 AndAlso FindLetterBySymbol(Str(1)) <> -1 _
AndAlso ArabicLetters(FindLetterBySymbol(Str(1))).JoiningStyle = "T" _
AndAlso LigatureLookups.ContainsKey(Str.Substring(0, 2)) Then
Positions = {CurPos, CurPos + 1}
Return LigatureLookups.Item(Str.Substring(0, 2))
End If
If FindLetterBySymbol(Str(0)) <> -1 AndAlso ArabicLetters_
(FindLetterBySymbol(Str(0))).JoiningStyle <> "T" Then
Dim StrCount As Integer = 0
Positions = {CurPos + StrCount}
For Count = 1 To 18
StrCount += 1
While StrCount <> Str.Length AndAlso FindLetterBySymbol(Str(StrCount)) _
<> -1 AndAlso ArabicLetters(FindLetterBySymbol(Str(StrCount))).JoiningStyle = "T"
StrCount += 1
End While
If StrCount = Str.Length Then Exit For
ReDim Preserve Positions(Count)
Positions(Count) = CurPos + StrCount
Next
If Positions.Length = 1 Then Positions = {}
While Positions.Length <> 0
If LigatureLookups.ContainsKey(String.Join(String.Empty, _
Array.ConvertAll(Positions, Function(Pos As Integer) CStr(Str(Pos - CurPos))))) Then
Return LigatureLookups.Item(String.Join(String.Empty, _
Array.ConvertAll(Positions, Function(Pos As Integer) CStr(Str(Pos - CurPos)))))
End If
ReDim Preserve Positions(Positions.Length - 2)
End While
End If
If Str.Length > 1 AndAlso FindLetterBySymbol(Str(1)) <> -1 _
AndAlso ArabicLetters(FindLetterBySymbol(Str(1))).JoiningStyle = "T" _
AndAlso (LigatureLookups.ContainsKey(" " + Str.Substring(0, 2)) Or _
LigatureLookups.ContainsKey(" " + Str(1) + Str(0))) Then
Positions = {CurPos, CurPos + 1}
Return LigatureLookups.Item(" " + If(LigatureLookups.ContainsKey_
(" " + Str.Substring(0, 2)), Str.Substring(0, 2), Str(1) + Str(0)))
ElseIf Str.Length > 2 AndAlso FindLetterBySymbol(Str(1)) <> -1 _
AndAlso ArabicLetters(FindLetterBySymbol(Str(1))).JoiningStyle = "T" _
AndAlso ArabicLetters(FindLetterBySymbol(Str(2))).JoiningStyle = "T" _
AndAlso (LigatureLookups.ContainsKey(Str(0) + Str(2))) Then
Positions = {CurPos, CurPos + 2}
Return LigatureLookups.Item(Str(0) + Str(2))
ElseIf LigatureLookups.ContainsKey(Str.Substring(0, 1)) Then
Positions = {CurPos}
Return LigatureLookups.Item(Str.Substring(0, 1))
ElseIf LigatureLookups.ContainsKey(" " + Str.Substring(0, 1)) Then
Positions = {CurPos}
Return LigatureLookups.Item(" " + Str.Substring(0, 1))
End If
Return -1
End Function
Public Shared _LigatureCombos() As ArabicCombo
Public Shared ReadOnly Property LigatureCombos As ArabicCombo()
Get
If _LigatureCombos Is Nothing Then
ReDim _LigatureCombos(ArabicLetters.Length + ArabicCombos.Length - 1)
ArabicCombos.CopyTo(_LigatureCombos, 0)
For Count = 0 To ArabicLetters.Length - 1
_LigatureCombos(ArabicCombos.Length + Count).Symbol = {ArabicLetters(Count).Symbol}
_LigatureCombos(ArabicCombos.Length + Count).Shaping = ArabicLetters(Count).Shaping
Next
Array.Sort(_LigatureCombos, Function(Com1 As ArabicCombo, Com2 As ArabicCombo) _
If(Com1.Symbol.Length = Com2.Symbol.Length, String.Join(String.Empty, _
Array.ConvertAll(Com1.Symbol, Function(Sym As Char) CStr(Sym))).CompareTo_
(String.Join(String.Empty, Array.ConvertAll(Com2.Symbol, Function(Sym As Char) CStr(Sym)))), _
If(Com1.Symbol.Length > Com2.Symbol.Length, -1, 1)))
End If
Return _LigatureCombos
End Get
End Property
Public Shared _LigatureShapes As Dictionary(Of Char, Integer)
Public Shared ReadOnly Property LigatureShapes As Dictionary(Of Char, Integer)
Get
If _LigatureShapes Is Nothing Then
Dim Combos As ArabicCombo() = LigatureCombos
_LigatureShapes = New Dictionary(Of Char, Integer)
For Count As Integer = 0 To Combos.Length - 1
If Not Combos(Count).Shaping Is Nothing Then
For SubCount As Integer = 0 To Combos(Count).Shaping.Length - 1
_LigatureShapes.Add(Combos(Count).Shaping(SubCount), Count)
Next
End If
Next
End If
Return _LigatureShapes
End Get
End Property
Public Shared _LigatureLookups As Dictionary(Of String, Integer)
Public Shared ReadOnly Property LigatureLookups As Dictionary(Of String, Integer)
Get
If _LigatureLookups Is Nothing Then
_LigatureLookups = New Dictionary(Of String, Integer)
Dim Combos As ArabicCombo() = LigatureCombos
For Count = 0 To Combos.Length - 1
If Not Combos(Count).Shaping Is Nothing And Not _LigatureLookups.ContainsKey_
(String.Join(String.Empty, Array.ConvertAll(Combos(Count).Symbol, Function(Sym As Char) CStr(Sym)))) Then
_LigatureLookups.Add(String.Join(String.Empty, Array.ConvertAll_
(Combos(Count).Symbol, Function(Sym As Char) CStr(Sym))), Count)
End If
Next
End If
Return _LigatureLookups
End Get
End Property
Public Shared Function GetLigatures(Str As String, Dir As Boolean, _
SupportedForms As Char()) As LigatureInfo()
Dim Count As Integer
Dim SubCount As Integer
Dim Ligatures As New List(Of LigatureInfo)
Dim Combos As ArabicCombo() = LigatureCombos
Count = 0
While Count <> Str.Length
If Dir Then
If LigatureShapes.ContainsKey(Str.Chars(Count)) Then
shaped Arabic or other strategies beyond just default shaping
Ligatures.Add(New LigatureInfo With {.Ligature = _
Combos(LigatureShapes.Item(Str.Chars(Count))).Symbol, .Indexes = {Count}})
End If
Else
Dim Indexes As Integer() = Nothing
SubCount = CheckLigatureMatch(Str.Substring(Count), Count, Indexes)
If SubCount <> -1 AndAlso Combos(SubCount).Shaping <> _
Nothing AndAlso Combos(SubCount).Shaping.Length <> 1 Then
Dim Index As Integer = Array.FindIndex(Combos(SubCount).Symbol, _
Function(Ch As Char) Ch = " " Or FindLetterBySymbol(Ch) <> -1 _
AndAlso (ArabicLetters(FindLetterBySymbol(Ch)).JoiningStyle = "T" _
Or ArabicLetters(FindLetterBySymbol(Ch)).JoiningStyle = "C"))
Dim Shape As Integer = If(Index = 0, If(FindLetterBySymbol(Combos(SubCount).Symbol_
(Index)) <> -1 AndAlso ArabicLetters(FindLetterBySymbol_
(Combos(SubCount).Symbol(Index))).JoiningStyle = _
"C", 3, 0), GetShapeIndexFromString(Str, Count, Indexes(Indexes.Length - 1) - Count + _
1 - If(Index = -1, 0, Index)))
If Combos(SubCount).Shaping(Shape) <> ChrW(0) AndAlso Array.IndexOf_
(SupportedForms, Combos(SubCount).Shaping(Shape)) <> -1 Then
Ligatures.Add(New LigatureInfo With {.Ligature = _
Combos(SubCount).Shaping(Shape), .Indexes = Indexes})
End If
End If
End If
Count += 1
While Array.FindIndex(Ligatures.ToArray(), Function(Lig As LigatureInfo) _
Array.IndexOf(Lig.Indexes, Count) <> -1) <> -1
Count += 1
End While
End While
Return Ligatures.ToArray()
End Function
Public Shared Function ConvertLigatures(Str As String, Dir As Boolean, SupportedForms As Char()) As String
Dim Ligatures() As LigatureInfo = GetLigatures(Str, Dir, SupportedForms)
For Count = Ligatures.Length - 1 To 0 Step -1
For Index = 0 To Ligatures(Count).Indexes.Length - 1
Str = Str.Remove(Ligatures(Count).Indexes(Index), _
1).Insert(Ligatures(Count).Indexes(0), Ligatures(Count).Ligature)
Next
Next
Return Str
End Function
Public Shared _ArabicLetterMap As Dictionary(Of Char, Integer)
Public Shared ReadOnly Property ArabicLetterMap As Dictionary(Of Char, Integer)
Get
If _ArabicLetterMap Is Nothing Then
_ArabicLetterMap = New Dictionary(Of Char, Integer)
For Index = 0 To ArabicLetters.Length - 1
If ArabicLetters(Index).Symbol <> ChrW(0) Then
_ArabicLetterMap.Add(ArabicLetters(Index).Symbol, Index)
End If
Next
End If
Return _ArabicLetterMap
End Get
End Property
Public Shared Function FindLetterBySymbol(Symbol As Char) As Integer
Return If(ArabicLetterMap.ContainsKey(Symbol), ArabicLetterMap.Item(Symbol), -1)
End Function
Public Const Space As Char = ChrW(&H20)
Public Const ExclamationMark As Char = ChrW(&H21)
Public Const QuotationMark As Char = ChrW(&H22)
Public Const Comma As Char = ChrW(&H2C)
Public Const FullStop As Char = ChrW(&H2E)
Public Const HyphenMinus As Char = ChrW(&H2D)
Public Const Colon As Char = ChrW(&H3A)
Public Const LeftParenthesis As Char = ChrW(&H5B)
Public Const RightParenthesis As Char = ChrW(&H5D)
Public Const LeftSquareBracket As Char = ChrW(&H5B)
Public Const RightSquareBracket As Char = ChrW(&H5D)
Public Const LeftCurlyBracket As Char = ChrW(&H7B)
Public Const RightCurlyBracket As Char = ChrW(&H7D)
Public Const NoBreakSpace As Char = ChrW(&HA0)
Public Const LeftPointingDoubleAngleQuotationMark As Char = ChrW(&HAB)
Public Const RightPointingDoubleAngleQuotationMark As Char = ChrW(&HBB)
Public Const ArabicComma As Char = ChrW(&H60C)
Public Const ArabicLetterHamza As Char = ChrW(&H621)
Public Const ArabicLetterAlefWithMaddaAbove As Char = ChrW(&H622)
Public Const ArabicLetterAlefWithHamzaAbove As Char = ChrW(&H623)
Public Const ArabicLetterWawWithHamzaAbove As Char = ChrW(&H624)
Public Const ArabicLetterAlefWithHamzaBelow As Char = ChrW(&H625)
Public Const ArabicLetterYehWithHamzaAbove As Char = ChrW(&H626)
Public Const ArabicLetterAlef As Char = ChrW(&H627)
Public Const ArabicLetterBeh As Char = ChrW(&H628)
Public Const ArabicLetterTehMarbuta As Char = ChrW(&H629)
Public Const ArabicLetterTeh As Char = ChrW(&H62A)
Public Const ArabicLetterTheh As Char = ChrW(&H62B)
Public Const ArabicLetterJeem As Char = ChrW(&H62C)
Public Const ArabicLetterHah As Char = ChrW(&H62D)
Public Const ArabicLetterKhah As Char = ChrW(&H62E)
Public Const ArabicLetterDal As Char = ChrW(&H62F)
Public Const ArabicLetterThal As Char = ChrW(&H630)
Public Const ArabicLetterReh As Char = ChrW(&H631)
Public Const ArabicLetterZain As Char = ChrW(&H632)
Public Const ArabicLetterSeen As Char = ChrW(&H633)
Public Const ArabicLetterSheen As Char = ChrW(&H634)
Public Const ArabicLetterSad As Char = ChrW(&H635)
Public Const ArabicLetterDad As Char = ChrW(&H636)
Public Const ArabicLetterTah As Char = ChrW(&H637)
Public Const ArabicLetterZah As Char = ChrW(&H638)
Public Const ArabicLetterAin As Char = ChrW(&H639)
Public Const ArabicLetterGhain As Char = ChrW(&H63A)
Public Const ArabicTatweel As Char = ChrW(&H640)
Public Const ArabicLetterFeh As Char = ChrW(&H641)
Public Const ArabicLetterQaf As Char = ChrW(&H642)
Public Const ArabicLetterKaf As Char = ChrW(&H643)
Public Const ArabicLetterLam As Char = ChrW(&H644)
Public Const ArabicLetterMeem As Char = ChrW(&H645)
Public Const ArabicLetterNoon As Char = ChrW(&H646)
Public Const ArabicLetterHeh As Char = ChrW(&H647)
Public Const ArabicLetterWaw As Char = ChrW(&H648)
Public Const ArabicLetterAlefMaksura As Char = ChrW(&H649)
Public Const ArabicLetterYeh As Char = ChrW(&H64A)
Public Const ArabicFathatan As Char = ChrW(&H64B)
Public Const ArabicDammatan As Char = ChrW(&H64C)
Public Const ArabicKasratan As Char = ChrW(&H64D)
Public Const ArabicFatha As Char = ChrW(&H64E)
Public Const ArabicDamma As Char = ChrW(&H64F)
Public Const ArabicKasra As Char = ChrW(&H650)
Public Const ArabicShadda As Char = ChrW(&H651)
Public Const ArabicSukun As Char = ChrW(&H652)
Public Const ArabicMaddahAbove As Char = ChrW(&H653)
Public Const ArabicHamzaAbove As Char = ChrW(&H654)
Public Const ArabicHamzaBelow As Char = ChrW(&H655)
Public Const ArabicVowelSignDotBelow As Char = ChrW(&H65C)
Public Const Bullet As Char = ChrW(&H2022)
Public Const ArabicLetterSuperscriptAlef As Char = ChrW(&H670)
Public Const ArabicLetterAlefWasla As Char = ChrW(&H671)
Public Const ArabicSmallHighLigatureSadWithLamWithAlefMaksura As Char = ChrW(&H6D6)
Public Const ArabicSmallHighLigatureQafWithLamWithAlefMaksura As Char = ChrW(&H6D7)
Public Const ArabicSmallHighMeemInitialForm As Char = ChrW(&H6D8)
Public Const ArabicSmallHighLamAlef As Char = ChrW(&H6D9)
Public Const ArabicSmallHighJeem As Char = ChrW(&H6DA)
Public Const ArabicSmallHighThreeDots As Char = ChrW(&H6DB)
Public Const ArabicSmallHighSeen As Char = ChrW(&H6DC)
Public Const ArabicEndOfAyah As Char = ChrW(&H6DD)
Public Const ArabicStartOfRubElHizb As Char = ChrW(&H6DE)
Public Const ArabicSmallHighRoundedZero As Char = ChrW(&H6DF)
Public Const ArabicSmallHighUprightRectangularZero As Char = ChrW(&H6E0)
Public Const ArabicSmallHighMeemIsolatedForm As Char = ChrW(&H6E2)
Public Const ArabicSmallLowSeen As Char = ChrW(&H6E3)
Public Const ArabicSmallWaw As Char = ChrW(&H6E5)
Public Const ArabicSmallYeh As Char = ChrW(&H6E6)
Public Const ArabicSmallHighNoon As Char = ChrW(&H6E8)
Public Const ArabicPlaceOfSajdah As Char = ChrW(&H6E9)
Public Const ArabicEmptyCentreLowStop As Char = ChrW(&H6EA)
Public Const ArabicEmptyCentreHighStop As Char = ChrW(&H6EB)
Public Const ArabicRoundedHighStopWithFilledCentre As Char = ChrW(&H6EC)
Public Const ArabicSmallLowMeem As Char = ChrW(&H6ED)
Public Const ArabicSemicolon As Char = ChrW(&H61B)
Public Const ArabicLetterMark As Char = ChrW(&H61C)
Public Const ArabicQuestionMark As Char = ChrW(&H61F)
Public Const ArabicLetterPeh As Char = ChrW(&H67E)
Public Const ArabicLetterTcheh As Char = ChrW(&H686)
Public Const ArabicLetterVeh As Char = ChrW(&H6A4)
Public Const ArabicLetterGaf As Char = ChrW(&H6AF)
Public Const ArabicLetterNoonGhunna As Char = ChrW(&H6BA)
Public Const ZeroWidthSpace As Char = ChrW(&H200B)
Public Const ZeroWidthNonJoiner As Char = ChrW(&H200C)
Public Const ZeroWidthJoiner As Char = ChrW(&H200D)
Public Const LeftToRightMark As Char = ChrW(&H200E)
Public Const RightToLeftMark As Char = ChrW(&H200F)
Public Const PopDirectionalFormatting As Char = ChrW(&H202C)
Public Const LeftToRightOverride As Char = ChrW(&H202D)
Public Const RightToLeftOverride As Char = ChrW(&H202E)
Public Const NarrowNoBreakSpace As Char = ChrW(&H202F)
Public Const DottedCircle As Char = ChrW(&H25CC)
Public Const OrnateLeftParenthesis As Char = ChrW(&HFD3E)
Public Const OrnateRightParenthesis As Char = ChrW(&HFD3F)
Public Shared LTRCategories As String() = New String() {"L"}
Public Shared RTLCategories As String() = New String() {"R", "AL"}
Public Shared ALCategories As String() = New String() {"AL"}
Public Shared CombineCategories As String() = New String() {"Mn", "Me", "Cf"}
Public Shared NeutralCategories As String() = New String() {"B", _
"S", "WS", "ON"}
Public Shared WeakCategories As String() = New String() {"EN", _
"ES", "ET", "AN", "CS", "NSM", "BN"}
Public Shared ExplicitCategories As String() = New String() {"LRE", _
"LRO", "RLE", "RLO", "PDF", "LRI", _
"RLI", "FSI", "PDI"}
Public Shared CausesJoining As Char() = New Char() {ArabicTatweel, ZeroWidthJoiner}
Public Shared Function GetUniCats() As String()
Return {"function IsLTR(c) { " + MakeUniCategoryJS(LTRCategories) + " }", _
"function IsRTL(c) { " + MakeUniCategoryJS(RTLCategories) + " }", _
"function IsAL(c) { " + MakeUniCategoryJS(ALCategories) + " }", _
"function IsNeutral(c) { " + MakeUniCategoryJS(NeutralCategories) + " }", _
"function IsWeak(c) { " + MakeUniCategoryJS(WeakCategories) + " }", _
"function IsExplicit(c) { " + MakeUniCategoryJS(ExplicitCategories) + " }"}
End Function
Public Shared Function GetJoiningData() As Dictionary(Of Char, String)
Dim Strs As String() = IO.File.ReadAllLines(Utility.GetFilePath("metadata\ArabicShaping.txt"))
Dim Joiners As New Dictionary(Of Char, String)
For Count = 0 To Strs.Length - 1
If Strs(Count)(0) <> "#" Then
Dim Vals As String() = Strs(Count).Split(";"c)
Joiners.Add(ChrW(Integer.Parse(Vals(0), Globalization.NumberStyles.AllowHexSpecifier)), Vals(4))
End If
Next
Return Joiners
End Function
Structure DecData
Public JoiningStyle As String
Public Chars As Char()
Public Shapes As Char()
End Structure
Public Shared ShapePositions As String() = {"isolated", _
"final", "initial", "medial"}
Public Shared _CombPos As Dictionary(Of Char, Integer)
Public Shared _UniClass As Dictionary(Of Char, String)
Public Shared _DecData As Dictionary(Of Char, DecData)
Public Shared _Ranges As Dictionary(Of String, ArrayList)
Public Shared _Names As Dictionary(Of Char, String())
Public Shared Sub GetDecompositionCombiningCatData()
Dim Strs As String() = IO.File.ReadAllLines(Utility.GetFilePath("metadata\UnicodeData.txt"))
_CombPos = New Dictionary(Of Char, Integer)
_UniClass = New Dictionary(Of Char, String)
_Ranges = New Dictionary(Of String, ArrayList)
_DecData = New Dictionary(Of Char, DecData)
_Names = New Dictionary(Of Char, String())
For Count = 0 To Strs.Length - 1
Dim Vals As String() = Strs(Count).Split(";"c)
If (Vals(2)(0) = "S" And Vals(4) <> "ON") Or _
Integer.Parse(Vals(0), Globalization.NumberStyles.AllowHexSpecifier) >= &H10000 Then Continue For
Dim Ch As Char = ChrW(Integer.Parse(Vals(0), Globalization.NumberStyles.AllowHexSpecifier))
_UniClass.Add(Ch, Vals(2))
If Vals(5) <> "" Then
Dim CombData As String() = Vals(5).Split(" "c)
If Not _DecData.ContainsKey(Ch) Then _DecData.Add(Ch, _
New DecData With {.Shapes = New Char() {Nothing, Nothing, Nothing, Nothing}})
Dim Data As DecData = _DecData(Ch)
If CombData(0).StartsWith("<") And CombData(0).EndsWith(">") Then
Data.JoiningStyle = CombData(0).Trim("<"c, ">"c)
ReDim Data.Chars(CombData.Length - 2)
For SubCount = 0 To CombData.Length - 2
Data.Chars(SubCount) = ChrW(Integer.Parse(CombData(SubCount + 1), _
Globalization.NumberStyles.AllowHexSpecifier))
Next
_DecData(Ch) = Data
If CombData.Length = 2 Then
If Not _DecData.ContainsKey(Data.Chars(0)) Then _DecData.Add(Data.Chars(0), _
New DecData With {.Shapes = New Char() {Nothing, Nothing, Nothing, Nothing}})
Dim ShapeData As DecData = _DecData(Data.Chars(0))
If Array.IndexOf(ShapePositions, Data.JoiningStyle) <> -1 Then _
ShapeData.Shapes(Array.IndexOf(ShapePositions, Data.JoiningStyle)) = Ch
End If
Else
Data.Chars = Array.ConvertAll(CombData, Function(Dat As String) _
ChrW(If(Integer.Parse(Dat, Globalization.NumberStyles.AllowHexSpecifier) _
>= &H10000, 0, Integer.Parse(Dat, Globalization.NumberStyles.AllowHexSpecifier))))
_DecData(Ch) = Data
End If
End If
If Vals(3) <> "" Then
_CombPos.Add(Ch, Integer.Parse(Vals(3), Globalization.NumberStyles.Integer))
End If
If Vals(10) <> "" Then
_Names.Add(Ch, {Vals(1), Vals(10)})
Else
_Names.Add(Ch, {Vals(1)})
End If
Dim NewRangeMatch As Integer = Integer.Parse(Vals(0), Globalization.NumberStyles.AllowHexSpecifier)
If Not _Ranges.ContainsKey(Vals(4)) Then _Ranges.Add(Vals(4), New ArrayList)
If _Ranges(Vals(4)).Count <> 0 AndAlso CInt(CType(_Ranges(Vals(4))(_Ranges(Vals(4)).Count - 1), _
ArrayList)(CType(_Ranges(Vals(4))(_Ranges(Vals(4)).Count - 1), ArrayList).Count - 1)) + 1 = NewRangeMatch Then
CType(_Ranges(Vals(4))(_Ranges(Vals(4)).Count - 1), ArrayList).Add(NewRangeMatch)
Else
_Ranges(Vals(4)).Add(New ArrayList From {NewRangeMatch})
End If
Next
End Sub
Public Shared Function MakeUniCategory(Cats As String()) As ArrayList
If _Ranges Is Nothing Then GetDecompositionCombiningCatData()
Dim Ranges As New ArrayList
For Count = 0 To Cats.Length - 1
If _Ranges.ContainsKey(Cats(Count)) Then
Ranges.AddRange(_Ranges(Cats(Count)))
End If
Next
Return Ranges
End Function
End Class
Structure CharPosInfo
Public Index As Integer
Public Length As Integer
Public Width As Single
Public PriorWidth As Single
Public X As Single
Public Y As Single
Public Height As Single
End Structure
Const ERROR_INSUFFICIENT_BUFFER As Integer = 122
Class TextSource
Implements SharpDX.DirectWrite.TextAnalysisSource
Public Sub New(Str As String, Factory As SharpDX.DirectWrite.Factory)
_Str = Str
_Factory = Factory
End Sub
Dim _Str As String
Public _Factory As SharpDX.DirectWrite.Factory
Public Function GetLocaleName(textPosition As Integer, ByRef textLength As Integer) _
As String Implements SharpDX.DirectWrite.TextAnalysisSource.GetLocaleName
Return Threading.Thread.CurrentThread.CurrentCulture.Name
End Function
Public Function GetNumberSubstitution(textPosition As Integer, ByRef textLength As Integer) _
As SharpDX.DirectWrite.NumberSubstitution _
Implements SharpDX.DirectWrite.TextAnalysisSource.GetNumberSubstitution
Return New SharpDX.DirectWrite.NumberSubstitution_
(_Factory, SharpDX.DirectWrite.NumberSubstitutionMethod.None, Nothing, True)
End Function
Public Function GetTextAtPosition(textPosition As Integer) _
As String Implements SharpDX.DirectWrite.TextAnalysisSource.GetTextAtPosition
Return _Str.Substring(textPosition)
End Function
Public Function GetTextBeforePosition(textPosition As Integer) _
As String Implements SharpDX.DirectWrite.TextAnalysisSource.GetTextBeforePosition
Return _Str.Substring(0, textPosition - 1)
End Function
Public ReadOnly Property ReadingDirection As SharpDX.DirectWrite.ReadingDirection _
Implements SharpDX.DirectWrite.TextAnalysisSource.ReadingDirection
Get
Return SharpDX.DirectWrite.ReadingDirection.RightToLeft
End Get
End Property
Public Property Shadow As IDisposable Implements SharpDX.ICallbackable.Shadow
#Region "IDisposable Support"
Private disposedValue As Boolean
Protected Overridable Sub Dispose(disposing As Boolean)
If Not Me.disposedValue Then
If disposing Then
End If
End If
Me.disposedValue = True
End Sub
Public Sub Dispose() Implements IDisposable.Dispose
Dispose(True)
GC.SuppressFinalize(Me)
End Sub
#End Region
End Class
Class TextSink
Implements SharpDX.DirectWrite.TextAnalysisSink
Public Sub SetBidiLevel(textPosition As Integer, textLength As Integer, _
explicitLevel As Byte, resolvedLevel As Byte) _
Implements SharpDX.DirectWrite.TextAnalysisSink.SetBidiLevel
_explicitLevel = explicitLevel
_resolvedLevel = resolvedLevel
End Sub
Public Sub SetLineBreakpoints(textPosition As Integer, textLength As Integer, _
lineBreakpoints() As SharpDX.DirectWrite.LineBreakpoint) _
Implements SharpDX.DirectWrite.TextAnalysisSink.SetLineBreakpoints
_lineBreakpoints = lineBreakpoints
End Sub
Public Sub SetNumberSubstitution(textPosition As Integer, textLength As Integer, _
numberSubstitution As SharpDX.DirectWrite.NumberSubstitution) _
Implements SharpDX.DirectWrite.TextAnalysisSink.SetNumberSubstitution
_numberSubstitution = numberSubstitution
End Sub
Public Sub SetScriptAnalysis(textPosition As Integer, textLength As Integer, _
scriptAnalysis As SharpDX.DirectWrite.ScriptAnalysis) _
Implements SharpDX.DirectWrite.TextAnalysisSink.SetScriptAnalysis
_scriptAnalysis = scriptAnalysis
End Sub
Public _scriptAnalysis As SharpDX.DirectWrite.ScriptAnalysis
Public _numberSubstitution As SharpDX.DirectWrite.NumberSubstitution
Public _lineBreakpoints() As SharpDX.DirectWrite.LineBreakpoint
Public _explicitLevel As Byte
Public _resolvedLevel As Byte
Public Property Shadow As IDisposable Implements SharpDX.ICallbackable.Shadow
#Region "IDisposable Support"
Private disposedValue As Boolean
Protected Overridable Sub Dispose(disposing As Boolean)
If Not Me.disposedValue Then
If disposing Then
End If
End If
Me.disposedValue = True
End Sub
Public Sub Dispose() Implements IDisposable.Dispose
Dispose(True)
GC.SuppressFinalize(Me)
End Sub
#End Region
End Class
Public Shared Function GetWordDiacriticPositionsDWrite(Str As String, useFont As Font, _
Forms As Char(), IsRTL As Boolean, ByRef BaseLine As Single, ByRef Pos As CharPosInfo()) As SizeF
If Str = String.Empty Then Return New SizeF(0, 0)
Dim Factory As New SharpDX.DirectWrite.Factory()
Dim Analyze As New SharpDX.DirectWrite.TextAnalyzer(Factory)
Dim Font As SharpDX.DirectWrite.Font = Factory.GdiInterop.FromSystemDrawingFont(useFont)
Dim FontFace As New SharpDX.DirectWrite.FontFace(Font)
Dim Analysis As New SharpDX.DirectWrite.ScriptAnalysis
Dim Sink As New TextSink
Dim Source As New TextSource(Str, Factory)
Analyze.AnalyzeScript(Source, 0, Str.Length, Sink)
Analysis = Sink._scriptAnalysis
Dim GlyphCount As Integer = Str.Length * 3 \ 2 + 16
Dim ClusterMap(Str.Length - 1) As Short
Dim TextProps(Str.Length - 1) As SharpDX.DirectWrite.ShapingTextProperties
Dim GlyphIndices(GlyphCount - 1) As Short
Dim GlyphProps(GlyphCount - 1) As SharpDX.DirectWrite.ShapingGlyphProperties
Dim ActualGlyphCount As Integer = 0
Dim FeatureDisabler() As SharpDX.DirectWrite.FontFeature = {
New SharpDX.DirectWrite.FontFeature(SharpDX.DirectWrite.FontFeatureTag.GlyphCompositionDecomposition, 1),
New SharpDX.DirectWrite.FontFeature(SharpDX.DirectWrite.FontFeatureTag.DiscretionaryLigatures, 0),
New SharpDX.DirectWrite.FontFeature(SharpDX.DirectWrite.FontFeatureTag.StandardLigatures, 0),
New SharpDX.DirectWrite.FontFeature(SharpDX.DirectWrite.FontFeatureTag.ContextualAlternates, 0),
New SharpDX.DirectWrite.FontFeature(SharpDX.DirectWrite.FontFeatureTag.StylisticSet1, 0)
}
Do
Try
Analyze.GetGlyphs(Str, Str.Length, FontFace, False, IsRTL, Analysis, Nothing, Nothing, _
New SharpDX.DirectWrite.FontFeature()() {FeatureDisabler}, New Integer() _
{Str.Length}, GlyphCount, ClusterMap, TextProps, GlyphIndices, GlyphProps, ActualGlyphCount)
Exit Do
Catch ex As SharpDX.SharpDXException
If ex.ResultCode = SharpDX.Result.GetResultFromWin32Error(ERROR_INSUFFICIENT_BUFFER) Then
GlyphCount *= 2
ReDim GlyphIndices(GlyphCount - 1)
ReDim GlyphProps(GlyphCount - 1)
End If
End Try
Loop While True
ReDim Preserve GlyphIndices(ActualGlyphCount - 1)
ReDim Preserve GlyphProps(ActualGlyphCount - 1)
Dim GlyphAdvances(ActualGlyphCount - 1) As Single
Dim GlyphOffsets(ActualGlyphCount - 1) As SharpDX.DirectWrite.GlyphOffset
Analyze.GetGlyphPlacements(Str, ClusterMap, TextProps, Str.Length, GlyphIndices, _
GlyphProps, ActualGlyphCount, FontFace, useFont.Size, False, IsRTL, Analysis, Nothing, _
New SharpDX.DirectWrite.FontFeature()() {FeatureDisabler}, New Integer() _
{Str.Length}, GlyphAdvances, GlyphOffsets)
Dim CharPosInfos As New List(Of CharPosInfo)
Dim LastPriorWidth As Single = 0
Dim PriorWidth As Single = 0
Dim RunStart As Integer = 0
Dim RunRes As Integer = ClusterMap(0)
(Array.ConvertAll(Forms, Function(Ch As Char) AscW(Ch)))
If IsRTL And Not Pos Is Nothing Then
Dim LigArray() As ArabicData.LigatureInfo = ArabicData.GetLigatures(Str, False, Forms)
For CharCount = 0 To ClusterMap.Length - 1
Dim RunCount As Integer = 0
For ResCount As Integer = ClusterMap(CharCount) To If(CharCount = _
ClusterMap.Length - 1, ActualGlyphCount - 1, ClusterMap(CharCount + 1) - 1)
If GlyphAdvances(ResCount) = 0 And (ClusterMap.Length <= RunStart + _
RunCount OrElse ClusterMap(RunStart) = ClusterMap(RunStart + RunCount)) Then
Dim Index As Integer = Array.FindIndex(LigArray, Function(Lig As _
ArabicData.LigatureInfo) Lig.Indexes(0) = RunStart + RunCount)
Dim LigLen As Integer = 1
If Index <> -1 Then
While LigLen <> LigArray(Index).Indexes.Length _
AndAlso LigArray(Index).Indexes(LigLen - 1) + 1 = LigArray(Index).Indexes(LigLen)
LigLen += 1
End While
If LigLen <> 1 Then
Dim CheckGlyphCount As Integer = 0
Dim CheckClusterMap(RunCount + LigLen - 1) As Short
Dim CheckTextProps(RunCount + LigLen - 1) As SharpDX.DirectWrite.ShapingTextProperties
Dim CheckGlyphIndices(GlyphCount - 1) As Short
Dim CheckGlyphProps(GlyphCount - 1) As SharpDX.DirectWrite.ShapingGlyphProperties
Analyze.GetGlyphs(Str.Substring(RunStart, RunCount + LigLen), RunCount + LigLen, _
FontFace, False, IsRTL, Analysis, Nothing, Nothing, _
New SharpDX.DirectWrite.FontFeature()() {FeatureDisabler}, New Integer() _
{RunCount + LigLen}, GlyphCount, CheckClusterMap, CheckTextProps, _
CheckGlyphIndices, CheckGlyphProps, CheckGlyphCount)
If CheckGlyphCount <> LigLen And CheckGlyphCount <> _
LigLen - If(GlyphProps(RunRes).Justification <> _
SharpDX.DirectWrite.ScriptJustify.Blank And GlyphProps(RunRes).Justification <> _
SharpDX.DirectWrite.ScriptJustify.ArabicBlank, 0, 1) _
Then LigLen = 1
End If
End If
If Not GlyphProps(ResCount).IsDiacritic Or Not GlyphProps(ResCount).IsZeroWidthSpace _
Or Not GlyphProps(ResCount).IsClusterStart Then
If LigLen = 1 AndAlso System.Text.RegularExpressions.Regex.Match_
(Str(RunStart + RunCount), "[\p{IsArabic}\p{IsArabicPresentationForms-A}\p_
{IsArabicPresentationForms-B}]").Success And Char.GetUnicodeCategory_
(Str(RunStart + RunCount)) = Globalization.UnicodeCategory.DecimalDigitNumber Then
Dim _Mets As SharpDX.DirectWrite.GlyphMetrics() = _
FontFace.GetDesignGlyphMetrics(GlyphIndices, False)
CharPosInfos.Add(New CharPosInfo With {.Index = RunStart + _
RunCount, .Length = If(Index = -1, 1, LigLen), .PriorWidth = PriorWidth, _
.Width = 2 * CSng((_Mets(ResCount).AdvanceWidth) * useFont.SizeInPoints / _
FontFace.Metrics.DesignUnitsPerEm), .X = GlyphOffsets(ResCount).AdvanceOffset - _
GlyphAdvances(RunRes) - CSng((_Mets(ResCount).AdvanceWidth) * useFont.SizeInPoints / _
FontFace.Metrics.DesignUnitsPerEm) / 4, .Y = GlyphOffsets(ResCount).AscenderOffset, _
.Height = CSng((_Mets(ResCount).AdvanceHeight + _Mets(ResCount)._
BottomSideBearing - _Mets(ResCount).TopSideBearing) * useFont.SizeInPoints / FontFace.Metrics.DesignUnitsPerEm)})
Else
Dim _Mets As SharpDX.DirectWrite.GlyphMetrics() = FontFace.GetDesignGlyphMetrics(GlyphIndices, False)
CharPosInfos.Add(New CharPosInfo With {.Index = RunStart + RunCount, .Length = _
If(Index = -1, 1, LigLen), .PriorWidth = PriorWidth - _
If(GlyphProps(RunRes).Justification = SharpDX.DirectWrite.ScriptJustify._
ArabicKashida And RunCount = 1 And If(CharCount = ClusterMap.Length - 1, _
ActualGlyphCount, ClusterMap(CharCount + 1)) - ClusterMap(CharCount) = _
CharCount - RunStart, GlyphAdvances(RunRes), 0), .Width = GlyphAdvances(RunRes) + _
If(GlyphProps(RunRes).IsClusterStart And GlyphProps(RunRes).IsDiacritic, _
CSng((_Mets(RunRes).AdvanceWidth) * useFont.SizeInPoints / _
FontFace.Metrics.DesignUnitsPerEm), 0), .X = GlyphOffsets(ResCount).AdvanceOffset, _
.Y = GlyphOffsets(ResCount).AscenderOffset + If(GlyphProps(RunRes).IsClusterStart _
And GlyphProps(RunRes).IsDiacritic, CSng((_Mets(RunRes).AdvanceHeight - _Mets_
(RunRes).TopSideBearing - _Mets(RunRes).VerticalOriginY) * useFont.SizeInPoints / _
FontFace.Metrics.DesignUnitsPerEm), 0)})
If GlyphProps(RunRes).Justification = SharpDX.DirectWrite.ScriptJustify.ArabicKashida _
And RunCount = 1 And If(CharCount = ClusterMap.Length - 1, ActualGlyphCount, _
ClusterMap(CharCount + 1)) - ClusterMap(CharCount) = CharCount - RunStart Then
CharPosInfos.Add(New CharPosInfo With {.Index = RunStart + RunCount + 1, _
.Length = If(Index = -1, 1, LigLen), .PriorWidth = PriorWidth, .Width = _
GlyphAdvances(RunRes) + If(GlyphProps(RunRes).IsClusterStart And _
GlyphProps(RunRes).IsDiacritic, CSng((_Mets(RunRes).AdvanceWidth) * _
useFont.SizeInPoints / FontFace.Metrics.DesignUnitsPerEm), 0), .X = _
GlyphOffsets(ResCount).AdvanceOffset, .Y = GlyphOffsets(RunRes).AscenderOffset + _
If(GlyphProps(RunRes).IsClusterStart And GlyphProps(RunRes).IsDiacritic, _
CSng((_Mets(RunRes).AdvanceHeight - _Mets(RunRes).TopSideBearing - _Mets_
(RunRes).VerticalOriginY) * useFont.SizeInPoints / FontFace.Metrics.DesignUnitsPerEm), 0)})
End If
End If
Else
PriorWidth -= GlyphOffsets(ResCount).AdvanceOffset
End If
End If
If CharCount = ClusterMap.Length - 1 OrElse ClusterMap(CharCount) <> ClusterMap(CharCount + 1) Then
PriorWidth += GlyphAdvances(ResCount)
Dim Index As Integer = Array.FindIndex(LigArray, _
Function(Lig As ArabicData.LigatureInfo) Lig.Indexes(0) = RunStart)
If Index = -1 OrElse (GlyphProps(ResCount).Justification <> _
SharpDX.DirectWrite.ScriptJustify.Blank And GlyphProps(ResCount).Justification _
<> SharpDX.DirectWrite.ScriptJustify.ArabicBlank Or Array.IndexOf_
(LigArray(Index).Indexes, RunStart) = -1) And RunStart + RunCount <> _
Str.Length - 1 Then RunCount += 1
If Index <> -1 AndAlso (GlyphProps(ResCount).Justification <> _
SharpDX.DirectWrite.ScriptJustify.Blank And GlyphProps(ResCount).Justification <> _
SharpDX.DirectWrite.ScriptJustify.ArabicBlank Or _
Array.IndexOf(LigArray(Index).Indexes, RunStart) = -1) Then
While Array.IndexOf(LigArray(Index).Indexes, RunStart + RunCount) <> -1 _
And RunStart + RunCount <> Str.Length - 1
RunCount += 1
End While
End If
If ClusterMap(CharCount) <> ResCount And GlyphAdvances(ResCount) <> 0 Then
RunStart = CharCount
RunCount = 0
RunRes = ResCount
End If
End If
Next
If CharCount <> ClusterMap.Length - 1 AndAlso ClusterMap(CharCount) <> ClusterMap(CharCount + 1) Then
RunStart = CharCount + 1
If GlyphAdvances(ClusterMap(CharCount + 1)) <> 0 Or GlyphProps(ClusterMap_
(CharCount + 1)).IsClusterStart And GlyphProps(ClusterMap(CharCount + 1)).IsDiacritic _
Then RunRes = ClusterMap(CharCount + 1)
End If
Next
End If
GlyphAdvances, GlyphOffsets, False, IsRTL, GeoSink)
Dim Width As Single = 0
Dim Top As Single = 0
Dim Bottom As Single = 0
Dim Mets As SharpDX.DirectWrite.GlyphMetrics() = FontFace.GetDesignGlyphMetrics_
(GlyphIndices, False)
Dim Left As Single = If(IsRTL, 0, GlyphOffsets(0).AdvanceOffset - _
CSng(Mets(0).LeftSideBearing * useFont.SizeInPoints / FontFace.Metrics.DesignUnitsPerEm))
Dim Right As Single = If(IsRTL, GlyphOffsets(0).AdvanceOffset - _
CSng(Mets(0).RightSideBearing * useFont.SizeInPoints / FontFace.Metrics.DesignUnitsPerEm), 0)
For Count = 0 To Mets.Length - 1
Left = If(IsRTL, Math.Max(Left, GlyphOffsets(Count).AdvanceOffset + Width - _
CSng(Math.Max(0, Mets(Count).LeftSideBearing) * useFont.SizeInPoints / _
FontFace.Metrics.DesignUnitsPerEm)), Math.Min(Left, GlyphOffsets(Count).AdvanceOffset + _
Width - CSng(Mets(Count).LeftSideBearing * useFont.SizeInPoints / _
FontFace.Metrics.DesignUnitsPerEm)))
If GlyphAdvances(Count) <> 0 Then Width += If(IsRTL, -1, 1) * _
CSng(Mets(Count).AdvanceWidth * useFont.SizeInPoints / FontFace.Metrics.DesignUnitsPerEm)
Right = If(IsRTL, Math.Min(Right, GlyphOffsets(Count).AdvanceOffset + Width - _
CSng(Mets(Count).RightSideBearing * useFont.SizeInPoints / FontFace.Metrics.DesignUnitsPerEm)), _
Math.Max(Right, GlyphOffsets(Count).AdvanceOffset + Width - CSng(Math.Min(0, _
Mets(Count).RightSideBearing) * useFont.SizeInPoints / FontFace.Metrics.DesignUnitsPerEm)))
Top = Math.Max(Top, GlyphOffsets(Count).AscenderOffset + CSng((Mets(Count).VerticalOriginY - _
Mets(Count).TopSideBearing) * useFont.SizeInPoints / FontFace.Metrics.DesignUnitsPerEm))
Bottom = Math.Min(Bottom, GlyphOffsets(Count).AscenderOffset + CSng((Mets(Count).VerticalOriginY - _
Mets(Count).AdvanceHeight + Mets(Count).BottomSideBearing) * useFont.SizeInPoints / FontFace.Metrics.DesignUnitsPerEm))
Next
If Not Pos Is Nothing Then Pos = CharPosInfos.ToArray()
Dim Size As SizeF = New SizeF(If(IsRTL, Left - Right, Right - Left), Top - Bottom + _
CSng(FontFace.Metrics.LineGap * useFont.SizeInPoints / FontFace.Metrics.DesignUnitsPerEm))
BaseLine = Top
Source.Shadow.Dispose()
Sink.Shadow.Dispose()
Source.Dispose()
Source._Factory = Nothing
Sink.Dispose()
FontFace.Dispose()
Font.Dispose()
Analyze.Dispose()
Factory.Dispose()
Return Size
End Function
Public Shared Function FitText(Text As String, MaxWidth As Single, MaxSize As Single, _
IsRTL As Boolean, DrawFont As Font, Forms As Char()) As Single
Dim MinSize As Single = 0
Dim Size As SizeF = GetWordDiacriticPositionsDWrite(Text, DrawFont, Forms, IsRTL, Nothing, Nothing)
If Size.Width < MaxWidth Then Return DrawFont.SizeInPoints
For Count = 0 To 50
DrawFont = New Font(DrawFont.FontFamily, (MinSize + MaxSize) / 2, DrawFont.Style)
Size = GetWordDiacriticPositionsDWrite(Text, DrawFont, Forms, IsRTL, Nothing, Nothing)
If Size.Width < MaxWidth Then
MinSize = DrawFont.SizeInPoints
DrawFont.Dispose()
If MaxSize - MinSize < DrawFont.SizeInPoints * 0.1F Then Exit For
Else
MaxSize = DrawFont.SizeInPoints
DrawFont.Dispose()
End If
Next
Return MinSize
End Function
Public Shared Function WriteArabicPdfDiacritics(Doc As iTextSharp.text.Document, _
Writer As iTextSharp.text.pdf.PdfWriter, DrawFont As Font, FixedFont As iTextSharp.text.Font, _
Text As String, Rect As RectangleF, Baseline As Single, FirstAdj As Boolean, Forms As Char(), _
FontFace As SharpDX.DirectWrite.FontFace) As String
Dim ct As iTextSharp.text.pdf.ColumnText
Dim CharPosInfos() As CharPosInfo = {}
Dim useFont As New Font(DrawFont.FontFamily, FixedFont.Size, DrawFont.Style)
GetWordDiacriticPositionsDWrite(Text, useFont, Forms, True, Nothing, CharPosInfos)
For Index As Integer = 0 To CharPosInfos.Length - 1
ct = New iTextSharp.text.pdf.ColumnText(Writer.DirectContent)
ct.RunDirection = iTextSharp.text.pdf.PdfWriter.RUN_DIRECTION_RTL
ct.ArabicOptions = iTextSharp.text.pdf.ColumnText.AR_COMPOSEDTASHKEEL
ct.UseAscender = False
If GetWordDiacriticPositionsDWrite(ArabicData.ConvertLigatures(Text.Substring_
(CharPosInfos(Index).Index, CharPosInfos(Index).Length), False, Forms)(0), _
useFont, Forms, True, Nothing, Nothing).Width <> 0 Then
ct.SetSimpleColumn(Rect.Left + Doc.LeftMargin + Rect.Width - 4 + 2 - _
CharPosInfos(Index).PriorWidth - CharPosInfos(Index).Width - CharPosInfos(Index).X, _
Doc.PageSize.Height - Doc.TopMargin - Rect.Bottom - Baseline + CharPosInfos(Index).Y - _
If(FirstAdj, 2, 0), Rect.Right - 2 + Doc.LeftMargin - CharPosInfos(Index).PriorWidth - _
CharPosInfos(Index).X, Doc.PageSize.Height - Doc.TopMargin - Rect.Top + 1 - Baseline + _
CharPosInfos(Index).Y - If(FirstAdj, 2, 0), CSng(FontFace.Metrics.LineGap * _
FixedFont.Size / FontFace.Metrics.DesignUnitsPerEm), _
iTextSharp.text.Element.ALIGN_RIGHT Or iTextSharp.text.Element.ALIGN_BASELINE)
If CharPosInfos(Index).Length = 1 AndAlso System.Text.RegularExpressions.Regex.Match_
(Text(CharPosInfos(Index).Index), "[\p{IsArabic}\p{IsArabicPresentationForms-A}\p_
{IsArabicPresentationForms-B}]").Success And Char.GetUnicodeCategory(Text_
(CharPosInfos(Index).Index)) = Globalization.UnicodeCategory.DecimalDigitNumber Then
Dim NewFont As New iTextSharp.text.Font(FixedFont)
NewFont.Size = NewFont.Size * GetWordDiacriticPositionsDWrite(ArabicData.ConvertLigatures_
(Text.Substring(CharPosInfos(Index).Index, CharPosInfos(Index).Length), False, Forms)(0), _
useFont, Forms, True, Nothing, Nothing).Height / CharPosInfos(Index).Height
Dim Chunk As New iTextSharp.text.Chunk(Text.Substring(CharPosInfos(Index).Index, _
CharPosInfos(Index).Length), NewFont)
Dim useNewFont As New Font(DrawFont.FontFamily, NewFont.Size, DrawFont.Style)
Chunk.SetHorizontalScaling(CharPosInfos(Index).Width / GetWordDiacriticPositionsDWrite_
(ArabicData.ConvertLigatures(Text.Substring(CharPosInfos(Index).Index, _
CharPosInfos(Index).Length), False, Forms)(0), useNewFont, Forms, True, Nothing, Nothing).Width)
useNewFont.Dispose()
ct.AddText(Chunk)
Else
If Text(CharPosInfos(Index).Index) = " "c Then
ct.AddText(New iTextSharp.text.Chunk(Text.Substring(CharPosInfos_
(Index).Index + 1, CharPosInfos(Index).Length - 1), FixedFont))
Else
ct.AddText(New iTextSharp.text.Chunk(Text.Substring(CharPosInfos_
(Index).Index, CharPosInfos(Index).Length), FixedFont))
End If
End If
ct.Go()
End If
Next
useFont.Dispose()
For Index As Integer = CharPosInfos.Length - 1 To 0 Step -1
If Text(CharPosInfos(Index).Index) = " "c Then
Text = Text.Remove(CharPosInfos(Index).Index + 1, CharPosInfos(Index).Length - 1)
Else
Text = Text.Remove(CharPosInfos(Index).Index, CharPosInfos(Index).Length)
End If
Next
Return Text
End Function
Public Shared Function AddDiacriticSpacing(Str As String, Forms As Char()) As String
Return System.Text.RegularExpressions.Regex.Replace(Str, "(^|\s)([\p{IsArabic}|\_
p{IsArabicPresentationForms-A}|\p{IsArabicPresentationForms-B}]+)", _
Function(Match As System.Text.RegularExpressions.Match) Match.Groups(1).Value + _
If(ArabicData.FindLetterBySymbol(Match.Groups(2).Value(0)) <> -1 _
AndAlso ArabicData.ArabicLetters(ArabicData.FindLetterBySymbol_
(Match.Groups(2).Value(0))).JoiningStyle = _
"T" AndAlso Char.GetUnicodeCategory(Match.Groups(2).Value(0)) <> _
Globalization.UnicodeCategory.Format And (Match.Groups(1).Value.Length = 0 OrElse _
ArabicData.GetLigatures(" " + Match.Groups(2).Value, False, Forms).Length <> 0 _
AndAlso ArabicData.GetLigatures(" " + Match.Groups(2).Value, False, _
Forms)(0).Indexes(0) = 0), " ", String.Empty) + Match.Groups(2).Value)
End Function
Private Shared Function GetTextWidthDraw(DrawFont As Font, Forms As Char(), Str As String, _
FontName As String, MaxWidth As Single, IsRTL As Boolean, ByRef s As SizeF, _
ByRef Baseline As Single) As Integer
If FontName <> String.Empty Then
Dim PrivateFontColl As New Drawing.Text.PrivateFontCollection
PrivateFontColl.AddFontFile(Utility.GetFilePath("files\" + _
Utility.FontFile(Array.IndexOf(Utility.FontList, FontName))))
Dim PrivFont As New Font(PrivateFontColl.Families(0), 100)
s = Utility.GetTextExtent(Str, PrivFont)
s.Width = CInt(Math.Ceiling(Math.Ceiling(s.Width + 1) * 96.0F / 72.0F))
s.Height = CInt(Math.Ceiling(Math.Ceiling(s.Height + 1) * 96.0F / 72.0F))
Baseline = 0
PrivFont.Dispose()
PrivateFontColl.Dispose()
Return Str.Length
End If
s = GetWordDiacriticPositionsDWrite(AddDiacriticSpacing(Str, Forms), DrawFont, Forms, IsRTL, Baseline, Nothing)
Dim Len As Integer = Str.Length
Dim Search As Integer = Len
If s.Width > MaxWidth Then
While Search <> 1
Search = Search \ 2
If s.Width > MaxWidth Then
Len -= Search
Else
Len += Search
End If
s = GetWordDiacriticPositionsDWrite(AddDiacriticSpacing(Str.Substring(0, _
If(Str.IndexOf(" "c, Len - 1) = -1, Str.Length, Str.IndexOf(" "c, Len - 1) + 1)), _
Forms), DrawFont, Forms, IsRTL, Baseline, Nothing)
End While
Len = If(Str.IndexOf(" "c, Len - 1) = -1, Str.Length, Str.IndexOf(" "c, Len - 1) + 1)
If s.Width > MaxWidth Then
Len = Str.LastIndexOf(" "c, Len - 1 - 1) + 1
s = GetWordDiacriticPositionsDWrite(AddDiacriticSpacing(Str.Substring(0, Len), Forms), _
DrawFont, Forms, IsRTL, Baseline, Nothing)
End If
If Len = 0 Then
Len = If(Str.IndexOf(" ") <> -1, Str.IndexOf(" ") + 1, Str.Length)
s.Width = MaxWidth
DrawFont = New Font(DrawFont.FontFamily, FitText(AddDiacriticSpacing(Str.Substring(0, Len), _
Forms), s.Width, DrawFont.SizeInPoints, IsRTL, DrawFont, Forms), DrawFont.Style)
s = GetWordDiacriticPositionsDWrite(AddDiacriticSpacing(Str.Substring(0, Len), Forms), _
DrawFont, Forms, IsRTL, Baseline, Nothing)
DrawFont.Dispose()
s.Width = MaxWidth
End If
End If
Return Len
End Function
Points of Interest
Limitations in this involve ligatures. Some special substitution ligatures revolving around the Arabic Small Waw and Arabic Small Yeh with a Maddah Above have a special glyph substitution. The name of Allah also has a special glyph substitution and though there is an Arabic presentation range accessible ligature which could be swapped out, it is difficult to align the diacritics onto it and it would break copying and pasting into the correct Arabic character range. These issues are handled through using the glyphs that are there with the best alignment possible.
The end of ayah marker is a special case where aligning the numbers inside of it requires special consideration and handling.
History
