diff --git a/paket.dependencies b/paket.dependencies index 0bdb8299..9306cf60 100644 --- a/paket.dependencies +++ b/paket.dependencies @@ -44,6 +44,7 @@ nuget Silk.NET.GLFW = 2.15.0 nuget Silk.NET.Core = 2.15.0 nuget SharpZipLib ~> 1.4.1 +nuget FuzzySharp ~> 2.0.2 group Test framework: net6.0 diff --git a/paket.lock b/paket.lock index f5b40fb7..cb6ae067 100644 --- a/paket.lock +++ b/paket.lock @@ -113,6 +113,7 @@ NUGET System.Reflection.Emit.Lightweight (>= 4.3) - restriction: || (&& (== net471) (< net45)) (== net6.0) (== net6.0-windows7.0) (== netstandard2.0) FSys (0.0.1) FSharp.Core (>= 4.7) + FuzzySharp (2.0.2) GLSLangSharp (0.4.15) FSharp.Core (>= 5.0) Microsoft.Bcl.AsyncInterfaces (6.0) - restriction: || (== net471) (&& (== net6.0) (>= net461)) (&& (== net6.0) (< netcoreapp3.1)) (&& (== net6.0-windows7.0) (>= net461)) (&& (== net6.0-windows7.0) (< netcoreapp3.1)) (== netstandard2.0) diff --git a/src/Aardvark.Rendering.Text/Aardvark.Rendering.Text.fsproj b/src/Aardvark.Rendering.Text/Aardvark.Rendering.Text.fsproj index c79b0e9c..bda3f101 100644 --- a/src/Aardvark.Rendering.Text/Aardvark.Rendering.Text.fsproj +++ b/src/Aardvark.Rendering.Text/Aardvark.Rendering.Text.fsproj @@ -21,6 +21,7 @@ + diff --git a/src/Aardvark.Rendering.Text/Font.fs b/src/Aardvark.Rendering.Text/Font.fs index 8480dfd4..8d31044c 100644 --- a/src/Aardvark.Rendering.Text/Font.fs +++ b/src/Aardvark.Rendering.Text/Font.fs @@ -8,6 +8,7 @@ open System.Collections.Concurrent open System.Runtime.CompilerServices open Aardvark.Base open Aardvark.Rendering +open Typography.OpenFont.Extensions [] @@ -186,78 +187,7 @@ module private Typography = //|] - - - module FontResolver = - module private Win32 = - open Microsoft.FSharp.NativeInterop - open System.Runtime.InteropServices - open System.Security - - type HKey = - | HKEY_CLASSES_ROOT = 0x80000000 - | HKEY_CURRENT_USER = 0x80000001 - | HKEY_LOCAL_MACHINE = 0x80000002 - | HKEY_USERS = 0x80000003 - | HKEY_PERFORMANCE_DATA = 0x80000004 - | HKEY_CURRENT_CONFIG = 0x80000005 - | HKEY_DYN_DATA = 0x80000006 - - type Flags = - | RRF_RT_ANY = 0x0000ffff - | RRF_RT_DWORD = 0x00000018 - | RRF_RT_QWORD = 0x00000048 - | RRF_RT_REG_BINARY = 0x00000008 - | RRF_RT_REG_DWORD = 0x00000010 - | RRF_RT_REG_EXPAND_SZ = 0x00000004 - | RRF_RT_REG_MULTI_SZ = 0x00000020 - | RRF_RT_REG_NONE = 0x00000001 - | RRF_RT_REG_QWORD = 0x00000040 - | RRF_RT_REG_SZ = 0x00000002 - - [] - extern int RegGetValue(HKey hkey, string lpSubKey, string lpValue, Flags dwFlags, uint32& pdwType, nativeint pvData, uint32& pcbData) - - let tryGetFontFileName (family : string) (style : FontStyle) = - - let suffix = - match style with - | FontStyle.BoldItalic -> " Bold Italic" - | FontStyle.Bold -> " Bold" - | FontStyle.Italic -> " Italic" - | _ -> "" - - let name = sprintf "%s%s (TrueType)" family suffix - let arr : byte[] = Array.zeroCreate 1024 - let gc = GCHandle.Alloc(arr, GCHandleType.Pinned) - - try - let ptr = gc.AddrOfPinnedObject() - let mutable pdwType = 0u - let mutable pcbData = uint32 arr.Length - if RegGetValue(HKey.HKEY_LOCAL_MACHINE, "software\\microsoft\\windows nt\\currentversion\\Fonts", name, Flags.RRF_RT_REG_SZ, &pdwType, ptr, &pcbData) = 0 then - if pcbData > 0u && arr.[int pcbData - 1] = 0uy then pcbData <- pcbData - 1u - let file = System.Text.Encoding.UTF8.GetString(arr, 0, int pcbData) - let path = System.IO.Path.Combine(Environment.GetFolderPath(Environment.SpecialFolder.Fonts), file) - Some path - else - None - finally - gc.Free() - - - let tryResolveFont (family : string) (style : FontStyle) : Option = - match Environment.OSVersion with - | Windows -> Win32.tryGetFontFileName family style - | _ -> failwith "not implemented" - - - let resolveFont (family : string) (style : FontStyle) = - match tryResolveFont family style with - | Some file -> file - | None -> failwithf "[Text] could not get font %s %A" family style - - + [] @@ -358,7 +288,7 @@ type Glyph internal(g : Typography.OpenFont.Glyph, isValid : bool, scale : float -type private FontImpl private(f : Typeface) = +type private FontImpl internal(f : Typeface, familyName : string, weight : int, italic : bool) = let scale = f.CalculateScaleToPixel 1.0f |> float let glyphCache = Dict() @@ -387,9 +317,10 @@ type private FontImpl private(f : Typeface) = static let symbola = lazy ( - let resName = typeof.Assembly.GetManifestResourceNames() |> Array.find (fun n -> n.EndsWith "Symbola.ttf") - use s = typeof.Assembly.GetManifestResourceStream(resName) - new FontImpl(s) + let assembly = typeof.Assembly + let resName = assembly.GetManifestResourceNames() |> Array.find (fun n -> n.EndsWith "Symbola.ttf") + let openStream () = assembly.GetManifestResourceStream(resName) + FontImpl("Symbola.ttf", openStream, 400, false) ) let get (c : CodePoint) (self : FontImpl) = @@ -415,24 +346,26 @@ type private FontImpl private(f : Typeface) = ) ) - static let getTypeFace (file : string) = - try - use stream = System.IO.File.OpenRead file - let reader = OpenFontReader() - reader.Read(stream, 0, ReadFlags.Full) - with e -> - failwithf "could not load font %s: %A" file e.Message - static member Symbola = symbola.Value - member x.Family = f.Name + member x.Family = familyName member x.LineHeight = lineHeight member x.Descent = descent member x.Ascent = ascent member x.LineGap = lineGap member x.InternalLeading = internalLeading member x.ExternalLeading = externalLeading - member x.Style = FontStyle.Regular + member x.Weight = weight + member x.Italic = italic + + member x.Style = + if weight >= 700 then + if italic then FontStyle.BoldItalic + else FontStyle.Bold + else + if italic then FontStyle.Italic + else FontStyle.Regular + member x.Spacing = spacing @@ -446,26 +379,49 @@ type private FontImpl private(f : Typeface) = let d = f.GetKernDistance(l, r) float d * scale - new(file : string) = - FontImpl(getTypeFace file) - - new(stream : System.IO.Stream) = - let reader = OpenFontReader() - FontImpl(reader.Read(stream, 0, ReadFlags.Full)) - + new(file : string, ?weight : int, ?italic : bool) = + let weight = defaultArg weight 400 + let italic = defaultArg italic false + let entry = + FontResolver.FontTableEntries.ofFile file + |> FontResolver.FontTableEntries.chooseBestEntry weight italic + + let face = entry |> FontResolver.FontTableEntries.read System.IO.File.OpenRead + FontImpl(face, entry.FamilyName, entry.Weight, entry.Italic) + + new(name : string, openStream : unit -> System.IO.Stream, ?weight : int, ?italic : bool) = + let weight = defaultArg weight 400 + let italic = defaultArg italic false + let entry = + FontResolver.FontTableEntries.ofStream () openStream + |> FontResolver.FontTableEntries.chooseBestEntry weight italic + + + let face = entry |> FontResolver.FontTableEntries.read openStream + FontImpl(face, name, entry.Weight, entry.Italic) -type Font private(impl : FontImpl, family : string, style : FontStyle) = +type Font private(impl : FontImpl, family : string) = static let symbola = lazy ( let impl = FontImpl.Symbola - new Font(impl, impl.Family, impl.Style) + new Font(impl, impl.Family) ) - static let systemTable = System.Collections.Concurrent.ConcurrentDictionary() + static let systemTable = System.Collections.Concurrent.ConcurrentDictionary() static let fileTable = System.Collections.Concurrent.ConcurrentDictionary() + + static let copyStream (stream : System.IO.Stream) = + let arr = + use data = new System.IO.MemoryStream() + stream.CopyTo(data) + data.ToArray() + + fun () -> new System.IO.MemoryStream(arr) :> System.IO.Stream + + static member Symbola = symbola.Value member x.Family = family @@ -475,32 +431,76 @@ type Font private(impl : FontImpl, family : string, style : FontStyle) = member x.LineGap = impl.LineGap member x.InternalLeading = impl.InternalLeading member x.ExternalLeading = impl.ExternalLeading - member x.Style = style + member x.Style = impl.Style + member x.Weight = impl.Weight + member x.Italic = impl.Italic member x.Spacing = impl.Spacing member x.GetGlyph(c : CodePoint) = impl.GetGlyph(c) member x.GetKerning(l : CodePoint, r : CodePoint) = impl.GetKerning(l,r) - static member Load(file : string) = + static member Load(file : string, weight : int, italic : bool) = let impl = fileTable.GetOrAdd(file, fun file -> - let impl = FontImpl(file) + let impl = FontImpl(file, weight, italic) impl ) - Font(impl, impl.Family, impl.Style) + Font(impl, impl.Family) + + static member Load(file : string) = + Font.Load(file, 400, false) + + static member Load(file : string, style : FontStyle) = + let weight = + match style with + | FontStyle.Bold | FontStyle.BoldItalic -> 700 + | _ -> 400 + let italic = + match style with + | FontStyle.Italic | FontStyle.BoldItalic -> true + | _ -> false + Font.Load(file, weight, italic) + + new(stream : System.IO.Stream, weight : int, italic : bool) = + let openStream = copyStream stream + let impl = FontImpl("Stream", openStream, weight, italic) + Font(impl, impl.Family) + + new(stream : System.IO.Stream, style : FontStyle) = + let weight = + match style with + | FontStyle.Bold | FontStyle.BoldItalic -> 700 + | _ -> 400 + let italic = + match style with + | FontStyle.Italic | FontStyle.BoldItalic -> true + | _ -> false + Font(stream, weight, italic) new(stream : System.IO.Stream) = - let impl = FontImpl(stream) - Font(impl, impl.Family, impl.Style) + Font(stream, 400, false) - new(family : string, style : FontStyle) = + new(family : string, weight : int, italic : bool) = let impl = - systemTable.GetOrAdd((family, style), fun (family, style) -> - let impl = FontImpl(FontResolver.resolveFont family style) + systemTable.GetOrAdd((family, weight, italic), fun (family, weight, italic) -> + let (face, familyName, weight, italic) = FontResolver.loadTypeface family weight italic + let impl = FontImpl(face, familyName, weight, italic) impl ) - Font(impl, family, style) + Font(impl, family) + + new(family : string, style : FontStyle) = + let weight = + match style with + | FontStyle.Bold | FontStyle.BoldItalic -> 700 + | _ -> 400 + let italic = + match style with + | FontStyle.Italic | FontStyle.BoldItalic -> true + | _ -> false + Font(family, weight, italic) + - new(family : string) = Font(family, FontStyle.Regular) + new(family : string) = Font(family, 400, false) type ShapeCache(r : IRuntime) = static let cache = ConcurrentDictionary() diff --git a/src/Aardvark.Rendering.Text/FontResolver.fs b/src/Aardvark.Rendering.Text/FontResolver.fs new file mode 100644 index 00000000..6b2e8647 --- /dev/null +++ b/src/Aardvark.Rendering.Text/FontResolver.fs @@ -0,0 +1,369 @@ +namespace Aardvark.Rendering.Text + +open Aardvark.Base +open System +open System.IO +open System.Runtime.InteropServices +open Microsoft.FSharp.NativeInterop +open System.Security +open FuzzySharp +open Typography.OpenFont + +module internal FontResolver = + + type FontTableEntry<'a> = + { + Tag : 'a + FamilyName : string + Offset : int + Weight : int + Italic : bool + SubFamilyName : string + } + + module FontTableEntries = + // resolve according to: https://developer.mozilla.org/en-US/docs/Web/CSS/font-weight + let chooseBestEntry (weight : int) (italic : bool) (available : list>) = + + let members = + if italic then + let italics = available |> List.filter (fun m -> m.Italic) + match italics with + | [] -> available + | _ -> italics + else + let nonitalic = available |> List.filter (fun m -> not m.Italic) + match nonitalic with + | [] -> available + | _ -> nonitalic + + let bestEntry = + let map = members |> List.map (fun m -> m.Weight, m) |> MapExt.ofList + let (l, s, r) = MapExt.neighbours weight map + + match s with + | Some (_, m) -> m + | None -> + // If the target weight given is between 400 and 500 inclusive: + if weight >= 400 && weight <= 500 then + // Look for available weights between the target and 500, in ascending order. + match r with + | Some (rw, rm) when rw <= 500 -> + rm + | _ -> + // If no match is found, look for available weights less than the target, in descending order. + match l with + | Some (lw, lm) -> + lm + | None -> + // If no match is found, look for available weights greater than 500, in ascending order. + Option.get r |> snd + + elif weight < 400 then + // If a weight less than 400 is given, look for available weights less than the target, in descending order. + // If no match is found, look for available weights greater than the target, in ascending order. + match l with + | Some (_, lm) -> lm + | None -> Option.get r |> snd + + else + // If a weight greater than 500 is given, look for available weights greater than the target, in ascending order. + // If no match is found, look for available weights less than the target, in descending order. + match r with + | Some (_, rm) -> rm + | None -> Option.get l |> snd + + bestEntry + + let ofStream (tag : 'a) (openStream : unit -> #Stream) = + try + let ofInfo (info : PreviewFontInfo) = + { + Tag = tag + FamilyName = info.TypographicFamilyName + Offset = info.ActualStreamOffset + Weight = int info.Weight + Italic = info.OS2TranslatedStyle.HasFlag Extensions.TranslatedOS2FontStyle.ITALIC || info.OS2TranslatedStyle.HasFlag Extensions.TranslatedOS2FontStyle.OBLIQUE + SubFamilyName = info.SubFamilyName + } + + let r = OpenFontReader() + use s = openStream() :> System.IO.Stream + let info = r.ReadPreview s + if info.IsFontCollection then + List.init info.MemberCount (info.GetMember >> ofInfo) + else + [ofInfo info] + with _ -> + [] + + let ofFile (file : string) = + if System.IO.File.Exists file then + ofStream file (fun () -> System.IO.File.OpenRead file) + else + [] + + let read (openStream : 'a -> #System.IO.Stream) (entry : FontTableEntry<'a>) = + let reader = OpenFontReader() + use s = openStream entry.Tag :> System.IO.Stream + reader.Read(s, entry.Offset, ReadFlags.Full) + + + type FontTable<'a> (entries : seq>) = + + static let normalizeFamilyName (name : string) = + name.ToLowerInvariant().Trim() + + + + let table = + let dict = System.Collections.Generic.Dictionary>() + + for e in entries do + let key = normalizeFamilyName e.FamilyName + + match dict.TryGetValue key with + | (true, s) -> + dict.[key] <- e :: s + | _ -> + dict.[key] <- [e] + + dict + + let keys = + table + |> Seq.collect (fun (KeyValue(key, e)) -> e |> Seq.map (fun e -> e.FamilyName, key)) + |> Seq.toArray + + let names = + keys |> Array.map fst + + + member x.Find(family : string, weight : int, italic : bool) = + let res = FuzzySharp.Process.ExtractOne(family, names) + let (_, key) = keys.[res.Index] + let entries = table.[key] + FontTableEntries.chooseBestEntry weight italic entries + + + module private Win32 = + + + type HKey = + | HKEY_CLASSES_ROOT = 0x80000000 + | HKEY_CURRENT_USER = 0x80000001 + | HKEY_LOCAL_MACHINE = 0x80000002 + | HKEY_USERS = 0x80000003 + | HKEY_PERFORMANCE_DATA = 0x80000004 + | HKEY_CURRENT_CONFIG = 0x80000005 + | HKEY_DYN_DATA = 0x80000006 + + type Flags = + | RRF_RT_ANY = 0x0000ffff + | RRF_RT_DWORD = 0x00000018 + | RRF_RT_QWORD = 0x00000048 + | RRF_RT_REG_BINARY = 0x00000008 + | RRF_RT_REG_DWORD = 0x00000010 + | RRF_RT_REG_EXPAND_SZ = 0x00000004 + | RRF_RT_REG_MULTI_SZ = 0x00000020 + | RRF_RT_REG_NONE = 0x00000001 + | RRF_RT_REG_QWORD = 0x00000040 + | RRF_RT_REG_SZ = 0x00000002 + + [] + extern int RegGetValue(HKey hkey, string lpSubKey, string lpValue, Flags dwFlags, uint32& pdwType, nativeint pvData, uint32& pcbData) + + let tryGetFontFileName (family : string) (weight : int) (italic : bool) = + + // TODO: respect weight and italic properly + let bold = weight >= 700 + let suffix = + if bold then + if italic then " Bold Italic" + else " Bold" + else + if italic then " Italic" + else "" + + let name = sprintf "%s%s (TrueType)" family suffix + let arr : byte[] = Array.zeroCreate 1024 + let gc = GCHandle.Alloc(arr, GCHandleType.Pinned) + + try + let ptr = gc.AddrOfPinnedObject() + let mutable pdwType = 0u + let mutable pcbData = uint32 arr.Length + if RegGetValue(HKey.HKEY_LOCAL_MACHINE, "software\\microsoft\\windows nt\\currentversion\\Fonts", name, Flags.RRF_RT_REG_SZ, &pdwType, ptr, &pcbData) = 0 then + if pcbData > 0u && arr.[int pcbData - 1] = 0uy then pcbData <- pcbData - 1u + let file = System.Text.Encoding.UTF8.GetString(arr, 0, int pcbData) + let path = System.IO.Path.Combine(Environment.GetFolderPath(Environment.SpecialFolder.Fonts), file) + Some path + else + None + finally + gc.Free() + + + + module private MacOs = + open System.Runtime.InteropServices + open System.IO + open System.Linq + open Typography + open Typography.OpenFont + open Aardvark.Base + + type CFArrayCallbackDelegate = delegate of nativeint * nativeint -> unit + + module CFText = + [] + let private CoreFoundation = "/System/Library/Frameworks/CoreFoundation.framework/Versions/A/CoreFoundation" + + [] + let private CoreGraphics = "/System/Library/Frameworks/CoreGraphics.framework/Versions/A/CoreGraphics" + + [] + let private CoreText = "/System/Library/Frameworks/CoreText.framework/Versions/A/CoreText" + + + [] + type CFRange = { Start : nativeint; Length : nativeint } + + [] + extern void* CFDictionaryCreateMutable (void* a, int cap, void* b, void* c) + + [] + extern void* CTFontCollectionCreateFromAvailableFonts (void* dict) + + [] + extern void* CTFontCollectionCreateMatchingFontDescriptors(void* coll) + + [] + extern int CFArrayGetCount(void* arr) + + [] + extern void CFArrayApplyFunction(void* arr, CFRange range, CFArrayCallbackDelegate func, void* ctx) + + [] + extern void* CTFontDescriptorCopyAttribute(void* desc, void* key) + + + [] + extern void* CFStringCreateWithCString(void* a, string b, void* c) + + [] + extern void CFStringGetCString(void* str, byte* buffer, int len, void* encoding) + + [] + extern void* CFURLCopyFileSystemPath(void* url, int pathStyle) + + + let table = + lazy ( + + //let NSFontNameAttribute = CFStringCreateWithCString(0n, "NSFontNameAttribute", 0n) + let NSFontFamilyAttribute = CFStringCreateWithCString(0n, "NSFontFamilyAttribute", 0n) + let NSFontFaceAttribute = CFStringCreateWithCString(0n, "NSFontFaceAttribute", 0n) + let NSCTFontFileURLAttribute = CFStringCreateWithCString(0n, "NSCTFontFileURLAttribute", 0n) + + + + let ptr = CFDictionaryCreateMutable (0n, 100000, 0n, 0n) + + + let coll = CTFontCollectionCreateFromAvailableFonts ptr + let arr = CTFontCollectionCreateMatchingFontDescriptors coll + let cnt = CFArrayGetCount arr + + let mutable range = { Start = 0n; Length = nativeint cnt } + + let getString (font : nativeint) (att : nativeint) = + let test = CTFontDescriptorCopyAttribute(font, att) + let buffer = Array.zeroCreate 8192 + use ptr = fixed buffer + CFStringGetCString(test, ptr, 8192, 0n) + + + let mutable l = 0 + while l < buffer.Length && buffer.[l] <> 0uy do l <- l + 1 + + + + System.Text.Encoding.UTF8.GetString(buffer,0, l) + + let getPath (font : nativeint) (att : nativeint) = + let test = CTFontDescriptorCopyAttribute(font, att) + let path = CFURLCopyFileSystemPath(test, 0) + + let buffer = Array.zeroCreate 8192 + use ptr = fixed buffer + CFStringGetCString(path, ptr, 8192, 0n) + + let mutable l = 0 + while l < buffer.Length && buffer.[l] <> 0uy do l <- l + 1 + + + System.Text.Encoding.UTF8.GetString(buffer, 0, l) + + let files = System.Collections.Generic.Dictionary>() + let func = + CFArrayCallbackDelegate(fun ptr _ -> + let face = getString ptr NSFontFaceAttribute + let family = getString ptr NSFontFamilyAttribute + let path = getPath ptr NSCTFontFileURLAttribute + + match files.TryGetValue family with + | (true, set) -> set.Add path |> ignore + | _ -> + let set = System.Collections.Generic.HashSet() + set.Add path |> ignore + files.[family] <- set + + + ) + CFArrayApplyFunction(arr, range, func, 0n) + + + + let allEntries = System.Collections.Generic.List() + for KeyValue(family, files) in files do + for f in files do + + let entries = FontTableEntries.ofFile f |> List.map (fun i -> { i with FamilyName = family }) + allEntries.AddRange entries + + + FontTable allEntries + ) + + + + + let tryLoadTypeFace (family : string) (weight : int) (italic : bool) : Option = + try + let entry = + match Environment.OSVersion with + | Windows -> + match Win32.tryGetFontFileName family weight italic with + | Some file -> Some { FontTableEntry.FamilyName = family; Tag = file; Weight = weight; Italic = italic; Offset = 0; SubFamilyName = "" } + | None -> failwithf "[Text] could not get font %s %A %s" family weight (if italic then "italic" else "") + | Mac -> + MacOs.CFText.table.Value.Find(family, weight, italic) |> Some + | _ -> + failwith "not implemented" + match entry with + | Some entry -> + let face = entry |> FontTableEntries.read File.OpenRead + Some (face, entry.FamilyName, entry.Weight, entry.Italic) + | None -> + None + with _ -> + None + + let loadTypeface (family : string) (weight : int) (italic : bool) = + match tryLoadTypeFace family weight italic with + | Some file -> file + | None -> failwithf "[Text] could not get font %s %A %s" family weight (if italic then "italic" else "") + + + diff --git a/src/Aardvark.Rendering.Text/paket.references b/src/Aardvark.Rendering.Text/paket.references index 71cc4379..498dd664 100644 --- a/src/Aardvark.Rendering.Text/paket.references +++ b/src/Aardvark.Rendering.Text/paket.references @@ -5,4 +5,5 @@ FShade.GLSL Unofficial.LibTessDotNet FSharp.Core Unofficial.Typography -Aardvark.Build \ No newline at end of file +Aardvark.Build +FuzzySharp \ No newline at end of file