diff --git a/CodeCompletion/CodeCompletion.cs b/CodeCompletion/CodeCompletion.cs index 140dcfd25..d6ecd504e 100644 --- a/CodeCompletion/CodeCompletion.cs +++ b/CodeCompletion/CodeCompletion.cs @@ -9,6 +9,7 @@ using PascalABCCompiler.Parsers; using PascalABCCompiler.Errors; using System.IO; using Languages.Facade; +using System.Linq; namespace CodeCompletion { @@ -280,17 +281,28 @@ namespace CodeCompletion } const string LibSourceDirectoryIdent = "%LIBSOURCEDIRECTORY%"; - public static string FindSourceFileName(string unit_name, out int found_dir_ind, bool caseSensitiveSearch, params string[] ddirs) + public static string FindSourceFileName(string unit_name, out int found_dir_ind, ILanguage currentUnitLanguage, params string[] ddirs) { // TODO: check error in older version List Dirs = new List(); Dirs.AddRange(ddirs); if (CodeCompletionController.comp != null) - Dirs.AddRange(CodeCompletionController.comp.CompilerOptions.SearchDirectories); + Dirs.AddRange(CodeCompletionController.comp.GetCurrentSearchDirectories(currentUnitLanguage)); // Надо как-то проверять, что мы не в инсталированной версии EVA if (CodeCompletionController.StandartDirectories.ContainsKey(LibSourceDirectoryIdent) && Directory.Exists(CodeCompletionController.StandartDirectories[LibSourceDirectoryIdent])) - Dirs.Add(CodeCompletionController.StandartDirectories[LibSourceDirectoryIdent]); - return CodeCompletionController.comp.FindSourceFileNameInDirs(unit_name, out found_dir_ind, caseSensitiveSearch, Dirs.ToArray()); + Dirs.AddRange(GetLibSourceDirectories(currentUnitLanguage)); + return CodeCompletionController.comp.FindSourceFileNameInDirs(unit_name, out found_dir_ind, currentUnitLanguage, Dirs.ToArray()); + } + + private static string[] GetLibSourceDirectories(ILanguage currentUnitLanguage) + { + return LanguageProvider.Instance.Languages + .Where(lang => lang == currentUnitLanguage) + .Concat(LanguageProvider.Instance.Languages.Where(lang => lang != currentUnitLanguage)) + .Select(lang => Path.Combine(CodeCompletionController.StandartDirectories[LibSourceDirectoryIdent], + lang.Name.Replace(PascalABCCompiler.StringConstants.pascalLanguageName, ""))) // для PascalABC.NET прямо в LibSource, остальные во внутренних папках + .Where(dir => Directory.Exists(dir)) + .ToArray(); } public static CodeCompletionNameHelper Helper diff --git a/CodeCompletion/CodeCompletionPCUReader.cs b/CodeCompletion/CodeCompletionPCUReader.cs index b2706a380..b8e3ec892 100644 --- a/CodeCompletion/CodeCompletionPCUReader.cs +++ b/CodeCompletion/CodeCompletionPCUReader.cs @@ -79,6 +79,7 @@ namespace CodeCompletion pcu_file.Version = br.ReadInt16(); pcu_file.Revision = br.ReadInt32(); pcu_file.CRC = br.ReadInt64(); + pcu_file.UseRtlDll = br.ReadBoolean(); pcu_file.IncludeDebugInfo = br.ReadBoolean(); return true; } @@ -108,7 +109,10 @@ namespace CodeCompletion pcu_file.SourceFileName = br.ReadString(); else pcu_file.SourceFileName = Path.GetFileNameWithoutExtension(FileName); - int num_names = br.ReadInt32(); + + pcu_file.languageName = br.ReadString(); + + int num_names = br.ReadInt32(); pcu_file.names = new NameRef[num_names]; for (int i=0; i usedUnitNames, bool caseSensitiveSearch) + private void CompileImportedDependencies(statement_list statementList, string fileName, Hashtable ns_cache, List usedUnitNames, Languages.Facade.ILanguage currentUnitLanguage) { var importStatements = statementList.list.Where(st => st is import_statement || st is from_import_statement); @@ -3362,7 +3363,7 @@ namespace CodeCompletion { CompileImportedUnit(unitNode.name, import, import.modules_names, Path.GetDirectoryName(fileName), - cur_scope, unl, caseSensitiveSearch); + cur_scope, unl, currentUnitLanguage); usedUnitNames.Add(unitNode.name); } @@ -3371,7 +3372,7 @@ namespace CodeCompletion { CompileImportedUnit(fromImport.module_name.name, fromImport, fromImport.imported_names, Path.GetDirectoryName(fileName), - cur_scope, unl, caseSensitiveSearch); + cur_scope, unl, currentUnitLanguage); usedUnitNames.Add(fromImport.module_name.name); } @@ -5063,7 +5064,7 @@ namespace CodeCompletion { unit_or_namespace s = _implementation_node.uses_modules.units[j]; CompileUsedUnitOrNamespace(s, Path.GetDirectoryName(this.cur_unit_file_name), - cur_scope, ns_cache, unl, currentLanguage.CaseSensitive); + cur_scope, ns_cache, unl, currentLanguage); } } impl_scope = cur_scope; diff --git a/Compiler/Compiler.cs b/Compiler/Compiler.cs index c8d520847..78f93acc7 100644 --- a/Compiler/Compiler.cs +++ b/Compiler/Compiler.cs @@ -363,8 +363,6 @@ namespace PascalABCCompiler } } - public string[] ParserSearchPaths; - // LeftToAll - слева во все модули, RightToMain - справа, только в основную программу public enum StandardModuleAddMethod { LeftToAll, RightToMain }; @@ -458,8 +456,7 @@ namespace PascalABCCompiler { "%PABCSYSTEM%", SystemDirectory } }; - ParserSearchPaths = new string[] { Path.Combine(SystemDirectory, "Lib") }; - SearchDirectories = ParserSearchPaths.ToList(); + SearchDirectories = new List(); } @@ -634,10 +631,6 @@ namespace PascalABCCompiler get { return state; } } - private void SetSupportedSourceFiles() - { - supportedSourceFiles = LanguageProvider.Languages.Select(language => SupportedSourceFile.Make(language)).ToArray(); - } private void SetSupportedProjectFiles() { @@ -645,13 +638,6 @@ namespace PascalABCCompiler supportedProjectFiles = new SupportedSourceFile[] { new SupportedSourceFile(new string[1] { ".pabcproj" }, "PascalABC.NET") }; } - private SupportedSourceFile[] supportedSourceFiles = null; - public SupportedSourceFile[] SupportedSourceFiles - { - get { return supportedSourceFiles; } - set { supportedSourceFiles = value; } - } - private SupportedSourceFile[] supportedProjectFiles = null; public SupportedSourceFile[] SupportedProjectFiles { @@ -805,7 +791,6 @@ namespace PascalABCCompiler if (ChangeCompilerState != null) OnChangeCompilerState += ChangeCompilerState; - supportedSourceFiles = comp.SupportedSourceFiles; supportedProjectFiles = comp.SupportedProjectFiles; // 29.07.2024 EVA @@ -842,7 +827,6 @@ namespace PascalABCCompiler SyntaxTreeToSemanticTreeConverter = new TreeConverter.SyntaxTreeToSemanticTreeConverter(); CodeGeneratorsController = new CodeGenerators.Controller(); - SetSupportedSourceFiles(); SetSupportedProjectFiles(); semanticTreeConvertersController = new SemanticTreeConvertersController(this); @@ -1133,14 +1117,14 @@ namespace PascalABCCompiler if (implementationUsesList != null) { - SetUseDLLForSystemUnits(Path.GetDirectoryName(unitFileName), implementationUsesList, implementationUsesList.Count - 1, CurrentUnit.Language.CaseSensitive); + SetUseDLLForSystemUnits(Path.GetDirectoryName(unitFileName), implementationUsesList, implementationUsesList.Count - 1, CurrentUnit.Language); for (int i = implementationUsesList.Count - 1; i >= 0; i--) { - if (!IsPossibleNetNamespaceOrStandardPasFile(implementationUsesList[i], true, Path.GetDirectoryName(unitFileName), CurrentUnit.Language.CaseSensitive)) + if (!IsPossibleNetNamespaceOrStandardPasFile(implementationUsesList[i], true, Path.GetDirectoryName(unitFileName), CurrentUnit.Language)) { // докомпилируем юнит, если он не является пространством имен или стандартным pas файлом из Lib - CompileUnit(CurrentUnit.ImplementationUsedUnits, CurrentUnit.ImplementationUsedDirectUnits, implementationUsesList[i], Path.GetDirectoryName(unitFileName), CurrentUnit.Language.CaseSensitive); + CompileUnit(CurrentUnit.ImplementationUsedUnits, CurrentUnit.ImplementationUsedDirectUnits, implementationUsesList[i], Path.GetDirectoryName(unitFileName), CurrentUnit.Language); } else { @@ -1946,7 +1930,7 @@ namespace PascalABCCompiler return usesSection; } - public string FindPCUFileName(string fileName, string currentPath, out int folderPriority, bool caseSensitiveSearch) + public string FindPCUFileName(string fileName, string currentPath, out int folderPriority, ILanguage currentUnitLanguage) { if (string.IsNullOrEmpty(Path.GetExtension(fileName))) fileName += CompilerOptions.CompiledUnitExtension; @@ -1958,11 +1942,12 @@ namespace PascalABCCompiler if (Path.GetExtension(fileName) != CompilerOptions.CompiledUnitExtension) fileNameWithPriority = null; - else if (FindFileWithExtensionInDirs(fileName, out _, caseSensitiveSearch, currentPath) is string resultFileName1) + else if (FindFileWithExtensionInDirs(fileName, out _, currentUnitLanguage, currentPath) is string resultFileName1) fileNameWithPriority = Tuple.Create(resultFileName1, 1); - else if (CompilerOptions.OutputDirectory != CompilerOptions.SourceFileDirectory && FindFileWithExtensionInDirs(Path.GetFileName(fileName), out _, caseSensitiveSearch, CompilerOptions.OutputDirectory) is string resultFileName2) + else if (CompilerOptions.OutputDirectory != CompilerOptions.SourceFileDirectory && FindFileWithExtensionInDirs(Path.GetFileName(fileName), out _, currentUnitLanguage, CompilerOptions.OutputDirectory) is string resultFileName2) fileNameWithPriority = Tuple.Create(resultFileName2, 2); - else if (FindFileWithExtensionInDirs(fileName, out var dirIndex, caseSensitiveSearch, CompilerOptions.SearchDirectories.ToArray()) is string resultFileName3) + else if (FindFileWithExtensionInDirs( + fileName, out var dirIndex, currentUnitLanguage, GetCurrentSearchDirectories(currentUnitLanguage)) is string resultFileName3) fileNameWithPriority = Tuple.Create(resultFileName3, 3 + dirIndex); else fileNameWithPriority = null; @@ -1974,16 +1959,28 @@ namespace PascalABCCompiler return fileNameWithPriority?.Item1; } - public string FindSourceFileName(string fileName, string currentPath, out int folderPriority, bool caseSensitiveSearch) + public string[] GetCurrentSearchDirectories(ILanguage currentUnitLanguage) + { + var libDirs = LanguageProvider.Languages + .Where(lang => lang == currentUnitLanguage) + .Concat(LanguageProvider.Languages.Where(lang => lang != currentUnitLanguage)) + .Select(lang => Path.Combine(CompilerOptions.SystemDirectory, "Lib", + lang.Name.Replace(StringConstants.pascalLanguageName, ""))) // для PascalABC.NET прямо в Lib, остальные во внутренних папках + .Where(dir => Directory.Exists(dir)); + + return CompilerOptions.SearchDirectories.Concat(libDirs).ToArray(); + } + + public string FindSourceFileName(string fileName, string currentPath, out int folderPriority, ILanguage currentUnitLanguage) { var cacheKey = Tuple.Create(fileName.ToLower(), currentPath?.ToLower()); if (!SourceFileNamesDictionary.TryGetValue(cacheKey, out var fileNameWithPriority)) { - if (FindSourceFileNameInDirs(fileName, out _, caseSensitiveSearch, currentPath) is string resultFileName1) + if (FindSourceFileNameInDirs(fileName, out _, currentUnitLanguage, currentPath) is string resultFileName1) fileNameWithPriority = Tuple.Create(resultFileName1, 1); - else if (FindSourceFileNameInDirs(fileName, out var dirIndex, caseSensitiveSearch, CompilerOptions.SearchDirectories.ToArray()) is string resultFileName2) + else if (FindSourceFileNameInDirs(fileName, out var dirIndex, currentUnitLanguage, GetCurrentSearchDirectories(currentUnitLanguage)) is string resultFileName2) fileNameWithPriority = Tuple.Create(resultFileName2, 3 + dirIndex); else fileNameWithPriority = null; @@ -1995,26 +1992,24 @@ namespace PascalABCCompiler return fileNameWithPriority?.Item1; } - public string FindSourceFileNameInDirs(string fileName, out int foundDirIndex, bool caseSensitiveSearch, params string[] Dirs) + public string FindSourceFileNameInDirs(string fileName, out int foundDirIndex, ILanguage currentUnitLanguage, params string[] Dirs) { var fileNameExtension = Path.GetExtension(fileName); var isExtensionEmpty = string.IsNullOrEmpty(fileNameExtension); - // TODO: ищем сперва для расширения текущего языка EVA - - foreach (SupportedSourceFile sf in SupportedSourceFiles) + // Ищем сначала по расширениям текущего языка, потом по всем остальным + foreach (ILanguage lang in new ILanguage[] { currentUnitLanguage }.Concat(LanguageProvider.Languages.Where(l => l != currentUnitLanguage))) { - foreach (string extension in sf.Extensions) + foreach (string extension in lang.FilesExtensions) { if (isExtensionEmpty || fileNameExtension == extension) { - var resultFileName = FindFileWithExtensionInDirs(isExtensionEmpty ? fileName + extension : fileName, out foundDirIndex, caseSensitiveSearch, Dirs); + var resultFileName = FindFileWithExtensionInDirs(isExtensionEmpty ? fileName + extension : fileName, out foundDirIndex, currentUnitLanguage, Dirs); if (resultFileName != null) return resultFileName; } } - } - + } foundDirIndex = 0; return null; @@ -2082,13 +2077,13 @@ namespace PascalABCCompiler throw new InvalidOperationException($"Could not find path to \"{u2.UnitFileName}\" relative to \"{u1.UnitFileName}\""); } - private string FindFileWithExtensionInDirs(string fileName, out int foundDirIndex, bool caseSensitiveSearch, params string[] dirs) + private string FindFileWithExtensionInDirs(string fileName, out int foundDirIndex, ILanguage currentUnitLanguage, params string[] dirs) { if (Path.IsPathRooted(fileName)) { foundDirIndex = 0; - if (caseSensitiveSearch) + if (currentUnitLanguage.CaseSensitive) { var foundFileName = Directory.GetFiles(Path.GetDirectoryName(fileName), Path.GetFileName(fileName), SearchOption.TopDirectoryOnly) .FirstOrDefault(f => f == fileName); @@ -2106,7 +2101,7 @@ namespace PascalABCCompiler var dir = dirs[dirIndex]; var fullFileName = Path.Combine(dir, fileName); - if (caseSensitiveSearch) + if (currentUnitLanguage.CaseSensitive) { var foundFileName = Directory.GetFiles(dir, fileName, SearchOption.TopDirectoryOnly) .FirstOrDefault(f => f == fullFileName); @@ -2202,7 +2197,7 @@ namespace PascalABCCompiler } - public string GetUnitFileName(SyntaxTree.unit_or_namespace unitNode, string currentPath, bool caseSensitiveSearch) + public string GetUnitFileName(SyntaxTree.unit_or_namespace unitNode, string currentPath, ILanguage currentUnitLanguage) { if (unitNode is SyntaxTree.uses_unit_in unitNodeCasted && unitNodeCasted.name == null) return unitNodeCasted.in_file.Value; @@ -2221,10 +2216,10 @@ namespace PascalABCCompiler } - return GetUnitFileName(unitName, unitNode.UsesPath(), currentPath, unitNode.source_context, caseSensitiveSearch); + return GetUnitFileName(unitName, unitNode.UsesPath(), currentPath, unitNode.source_context, currentUnitLanguage); } - public string GetUnitFileName(string unitName, string usesPath, string currentPath, SyntaxTree.SourceContext sourceContext, bool caseSensitiveSearch) + public string GetUnitFileName(string unitName, string usesPath, string currentPath, SyntaxTree.SourceContext sourceContext, ILanguage currentUnitLanguage) { var cacheKey = Tuple.Create(usesPath.ToLower(), currentPath?.ToLower()); @@ -2232,7 +2227,7 @@ namespace PascalABCCompiler if (GetUnitFileNameCache.TryGetValue(cacheKey, out var unitPaths)) { - if (caseSensitiveSearch) + if (currentUnitLanguage.CaseSensitive) { foreach (var unitPath in unitPaths) { @@ -2249,8 +2244,8 @@ namespace PascalABCCompiler } // число приоритета меньше означает, что папка более важная - var sourceFileName = FindSourceFileName(usesPath, currentPath, out var sourceFilePriority, caseSensitiveSearch); - var pcuFileName = FindPCUFileName(usesPath, currentPath, out var pcuFilePriority, caseSensitiveSearch); + var sourceFileName = FindSourceFileName(usesPath, currentPath, out var sourceFilePriority, currentUnitLanguage); + var pcuFileName = FindPCUFileName(usesPath, currentPath, out var pcuFilePriority, currentUnitLanguage); bool sourceFileExists = sourceFileName != null; bool pcuFileExists = pcuFileName != null; @@ -2455,7 +2450,7 @@ namespace PascalABCCompiler namespaces[unitModule.unit_name.idunit_name.name] = namespaceNode; } - AddDeclarationsAndReferencedUnitsToNamespaces(namespaceModules, file, unitModule, namespaceNode, compilationUnit.Language.CaseSensitive); + AddDeclarationsAndReferencedUnitsToNamespaces(namespaceModules, file, unitModule, namespaceNode, compilationUnit.Language); } // корневой модуль является чем-то одним из этого @@ -2511,7 +2506,7 @@ namespace PascalABCCompiler } private void AddDeclarationsAndReferencedUnitsToNamespaces(List namespace_modules, string file, - SyntaxTree.unit_module unitModule, SyntaxTree.syntax_namespace_node namespaceNode, bool caseSensitive) + SyntaxTree.unit_module unitModule, SyntaxTree.syntax_namespace_node namespaceNode, ILanguage currentUnitLanguage) { if (unitModule.interface_part.interface_definitions != null) { @@ -2524,7 +2519,7 @@ namespace PascalABCCompiler CheckForDuplicatesInUsesSection(unitModule.interface_part.uses_modules.units); foreach (SyntaxTree.unit_or_namespace name_space in unitModule.interface_part.uses_modules.units) { - if (IsPossibleNetNamespaceOrStandardPasFile(name_space, false, Path.GetDirectoryName(file), caseSensitive)) + if (IsPossibleNetNamespaceOrStandardPasFile(name_space, false, Path.GetDirectoryName(file), currentUnitLanguage)) { namespaceNode.referenced_units.AddElement(new namespace_unit_node(GetNamespace(name_space), GetLocationFromTreenode(name_space, unitModule.file_name)), null); } @@ -2752,7 +2747,7 @@ namespace PascalABCCompiler NetHelper.AssemblyResolveScope assemblyResolveScope; - private bool IsPossibleNetNamespaceOrStandardPasFile(SyntaxTree.unit_or_namespace name_space, bool addToStandardModules, string currentPath, bool caseSensitiveSearch) + private bool IsPossibleNetNamespaceOrStandardPasFile(SyntaxTree.unit_or_namespace name_space, bool addToStandardModules, string currentPath, ILanguage currentUnitLanguage) { if (name_space is SyntaxTree.uses_unit_in) return false; @@ -2761,8 +2756,8 @@ namespace PascalABCCompiler if (name_space.name.idents.Count > 1) return true; - string sourceFileName = FindSourceFileName(name_space.name.idents[0].name, currentPath, out _, caseSensitiveSearch); - string pcuFileName = FindPCUFileName(name_space.name.idents[0].name, currentPath, out _, caseSensitiveSearch); + string sourceFileName = FindSourceFileName(name_space.name.idents[0].name, currentPath, out _, currentUnitLanguage); + string pcuFileName = FindPCUFileName(name_space.name.idents[0].name, currentPath, out _, currentUnitLanguage); // если нет исходников и pcu if (sourceFileName == null && pcuFileName == null) @@ -2951,9 +2946,9 @@ namespace PascalABCCompiler /// Синтаксический узел текущего модуля (или пространства имен) /// Директория родительского модуля /// Скомпилированный юнит - public CompilationUnit CompileUnit(unit_node_list unitsFromUsesSection, Dictionary directUnitsFromUsesSection, SyntaxTree.unit_or_namespace currentUnitNode, string previousPath, bool caseSensitiveSearch = false) + public CompilationUnit CompileUnit(unit_node_list unitsFromUsesSection, Dictionary directUnitsFromUsesSection, SyntaxTree.unit_or_namespace currentUnitNode, string previousPath, ILanguage previousUnitLanguage = null) { - string unitFileName = GetUnitFileName(currentUnitNode, previousPath, caseSensitiveSearch); + string unitFileName = GetUnitFileName(currentUnitNode, previousPath, previousUnitLanguage); string unitId = Path.ChangeExtension(unitFileName, null); // Имя папки, в которой лежит текущий модуль // Используется для подключения модулей, $include и т.п. из модуля, подключённого с uses-in @@ -2983,7 +2978,7 @@ namespace PascalABCCompiler else { // если есть pcu - возврат EVA - if (UnitHasPCU(unitsFromUsesSection, directUnitsFromUsesSection, currentUnitNode, ref unitFileName, ref currentUnit, caseSensitiveSearch)) + if (UnitHasPCU(unitsFromUsesSection, directUnitsFromUsesSection, currentUnitNode, ref unitFileName, ref currentUnit, previousUnitLanguage)) return currentUnit; // нет pcu и модуль не откомпилирован => новый модуль EVA @@ -3156,7 +3151,7 @@ namespace PascalABCCompiler { interfaceUsesList = GetInterfaceUsesSection(currentUnit.SyntaxTree); - SetUseDLLForSystemUnits(currentDirectory, interfaceUsesList, interfaceUsesList.Count - 1 - currentUnit.InterfaceUsedUnits.Count, currentUnit.Language.CaseSensitive); + SetUseDLLForSystemUnits(currentDirectory, interfaceUsesList, interfaceUsesList.Count - 1 - currentUnit.InterfaceUsedUnits.Count, currentUnit.Language); references = GetReferences(currentUnit); @@ -3230,9 +3225,9 @@ namespace PascalABCCompiler { for (int i = implementationUsesList.Count - 1; i >= 0; i--) { - if (!IsPossibleNetNamespaceOrStandardPasFile(implementationUsesList[i], true, currentPath, currentUnit.Language.CaseSensitive)) + if (!IsPossibleNetNamespaceOrStandardPasFile(implementationUsesList[i], true, currentPath, currentUnit.Language)) { - CompilationUnit unitFromUsesSection = UnitTable[Path.ChangeExtension(GetUnitFileName(implementationUsesList[i], currentPath, currentUnit.Language.CaseSensitive), null)]; + CompilationUnit unitFromUsesSection = UnitTable[Path.ChangeExtension(GetUnitFileName(implementationUsesList[i], currentPath, currentUnit.Language), null)]; // защита от попадания в бесконечный цикл (когда мы вернемся в тот юнит, в котором уже были (еще не скомпилированный), а затем спустимся по дереву зависимостей сюда же и т.д.) // первая часть условия - если мы встречаем юнит не первый раз, вторая часть - если интерфейс еще не скомпилирован @@ -3246,7 +3241,7 @@ namespace PascalABCCompiler } else { - CompileUnit(currentUnit.ImplementationUsedUnits, currentUnit.ImplementationUsedDirectUnits, implementationUsesList[i], currentPath, currentUnit.Language.CaseSensitive); + CompileUnit(currentUnit.ImplementationUsedUnits, currentUnit.ImplementationUsedDirectUnits, implementationUsesList[i], currentPath, currentUnit.Language); } } else @@ -3322,7 +3317,7 @@ namespace PascalABCCompiler shouldReturnCurrentUnit = false; for (int i = interfaceUsesList.Count - 1 - currentUnit.InterfaceUsedUnits.Count; i >= 0; i--) // здесь откидываются модули с уже откомпилированными интерфейсами из секции uses (см. комментарий, обозначенный #1710) { - if (IsPossibleNetNamespaceOrStandardPasFile(interfaceUsesList[i], true, currentPath, currentUnit.Language.CaseSensitive) || namespaces.ContainsKey(interfaceUsesList[i].name.idents[0].name)) + if (IsPossibleNetNamespaceOrStandardPasFile(interfaceUsesList[i], true, currentPath, currentUnit.Language) || namespaces.ContainsKey(interfaceUsesList[i].name.idents[0].name)) { currentUnit.InterfaceUsedUnits.AddElement(new namespace_unit_node(GetNamespace(interfaceUsesList[i])), null); currentUnit.possibleNamespaces.Add(interfaceUsesList[i]); @@ -3336,7 +3331,7 @@ namespace PascalABCCompiler #endregion // компиляция модулей из интерфейса текущего модуля - CompileUnit(currentUnit.InterfaceUsedUnits, currentUnit.InterfaceUsedDirectUnits, interfaceUsesList[i], currentPath, currentUnit.Language.CaseSensitive); + CompileUnit(currentUnit.InterfaceUsedUnits, currentUnit.InterfaceUsedDirectUnits, interfaceUsesList[i], currentPath, currentUnit.Language); // если текущий модуль был откомпилирован в другом рекурсивном вызове if (currentUnit.State == UnitState.Compiled) @@ -3351,7 +3346,7 @@ namespace PascalABCCompiler private void SemanticCheckNoLoopDependenciesOfInterfaces(CompilationUnit currentUnit, string unitFileName, SyntaxTree.unit_or_namespace usedUnitNode, string currentPath) { - var usedUnitFileName = GetUnitFileName(usedUnitNode, currentPath, currentUnit.Language.CaseSensitive); + var usedUnitFileName = GetUnitFileName(usedUnitNode, currentPath, currentUnit.Language); var usedUnitId = Path.ChangeExtension(usedUnitFileName, null); // когда образуется цикл здесь сохранится смежная вершина графа (используемый юнит), которая тоже принадлежит циклу @@ -3378,13 +3373,13 @@ namespace PascalABCCompiler /// /// Если в программе в секции uses есть не про-во имен и не стандартный модуль, то использование PABCRtl.dll отменяется /// - private void SetUseDLLForSystemUnits(string currentDirectory, List usesList, int lastUnitIndex, bool caseSensitive) + private void SetUseDLLForSystemUnits(string currentDirectory, List usesList, int lastUnitIndex, ILanguage currentUnitLanguage) { if (usesList != null && CompilerOptions.UseDllForSystemUnits) { for (int i = lastUnitIndex; i >= 0; i--) { - if (!IsPossibleNetNamespaceOrStandardPasFile(usesList[i], false, currentDirectory, caseSensitive)) + if (!IsPossibleNetNamespaceOrStandardPasFile(usesList[i], false, currentDirectory, currentUnitLanguage)) { CompilerOptions.UseDllForSystemUnits = false; break; @@ -3648,7 +3643,7 @@ namespace PascalABCCompiler return docs; } - private bool UnitHasPCU(unit_node_list unitsFromUsesSection, Dictionary directUnitsFromUsesSection, SyntaxTree.unit_or_namespace currentUnitNode, ref string UnitFileName, ref CompilationUnit currentUnit, bool caseSensitiveSearch) + private bool UnitHasPCU(unit_node_list unitsFromUsesSection, Dictionary directUnitsFromUsesSection, SyntaxTree.unit_or_namespace currentUnitNode, ref string UnitFileName, ref CompilationUnit currentUnit, ILanguage previousUnitLanguage) { if (Path.GetExtension(UnitFileName).ToLower() == CompilerOptions.CompiledUnitExtension) { @@ -3657,7 +3652,7 @@ namespace PascalABCCompiler if (UnitTable.Count == 0) throw new ProgramModuleExpected(UnitFileName, null); try { - if ((currentUnit = ReadPCU(UnitFileName, caseSensitiveSearch)) != null) + if ((currentUnit = ReadPCU(UnitFileName, previousUnitLanguage)) != null) { AddCurrentUnitAndItsReferencesToUsesLists(unitsFromUsesSection, directUnitsFromUsesSection, currentUnitNode, currentUnit, GetReferences(currentUnit)); @@ -3683,7 +3678,7 @@ namespace PascalABCCompiler throw new CompilerInternalError("PCUReader", e); #endif } - string SourceFileName = FindSourceFileName(Path.ChangeExtension(UnitFileName, null), null, out _, caseSensitiveSearch); + string SourceFileName = FindSourceFileName(Path.ChangeExtension(UnitFileName, null), null, out _, previousUnitLanguage); if (SourceFileName == null) throw new ReadPCUError(UnitFileName); else @@ -3786,7 +3781,7 @@ namespace PascalABCCompiler } } - public CompilationUnit ReadPCU(string FileName, bool caseSensitiveSearch) + public CompilationUnit ReadPCU(string FileName, ILanguage currentUnitLanguage) { if (CompilerOptions.ForIntellisense && false) { @@ -3797,14 +3792,14 @@ namespace PascalABCCompiler return unit; } PCUReader pr = new PCUReader(this, pr_ChangeState); - unit = pr.GetCompilationUnit(FileName, CompilerOptions.Debug, caseSensitiveSearch); + unit = pr.GetCompilationUnit(FileName, CompilerOptions.Debug, currentUnitLanguage); pcuCompilationUnits[FileName] = unit; return unit; } else { PCUReader pr = new PCUReader(this, pr_ChangeState); - return pr.GetCompilationUnit(FileName, CompilerOptions.Debug, caseSensitiveSearch); + return pr.GetCompilationUnit(FileName, CompilerOptions.Debug, currentUnitLanguage); } } @@ -4010,10 +4005,10 @@ namespace PascalABCCompiler return null; return compilationUnit; }*/ - public bool NeedRecompiled(string pcu_name, string[] included, PCUReader pr, bool caseSensitive) + public bool NeedRecompiled(string pcu_name, string[] included, PCUReader pr, ILanguage currentUnitLanguage) { if (!Path.IsPathRooted(pcu_name)) throw new InvalidOperationException(); - string pas_name = FindSourceFileName(Path.ChangeExtension(pcu_name, null), null, out _, caseSensitive); + string pas_name = FindSourceFileName(Path.ChangeExtension(pcu_name, null), null, out _, currentUnitLanguage); var dir = Path.GetDirectoryName(pcu_name); if (UnitTable[Path.ChangeExtension(pas_name, null)] != null) @@ -4024,7 +4019,7 @@ namespace PascalABCCompiler { //if (included[i].Contains("$")) // continue; - var used_unit_fname = GetUnitFileName(Path.GetFileNameWithoutExtension(included[i]), included[i], dir, null, caseSensitive); + var used_unit_fname = GetUnitFileName(Path.GetFileNameWithoutExtension(included[i]), included[i], dir, null, currentUnitLanguage); var used_unit_is_pcu = Path.GetExtension(used_unit_fname) == CompilerOptions.CompiledUnitExtension; if (!used_unit_is_pcu) @@ -4045,7 +4040,7 @@ namespace PascalABCCompiler //Console.WriteLine("{0} {1}",name,RecompileList.Count); for (int i = 0; i < included.Length; i++) { - string pcu_name2 = FindPCUFileName(included[i], dir, out _, caseSensitive); + string pcu_name2 = FindPCUFileName(included[i], dir, out _, currentUnitLanguage); //TODO: Спросить у Сащи насчет < и <=. if ((File.Exists(pcu_name2) && File.GetLastWriteTime(pcu_name) < File.GetLastWriteTime(pcu_name2) && !pr.AlreadyCompiled(pcu_name2))) diff --git a/Compiler/ICompiler.cs b/Compiler/ICompiler.cs index e6e3fb72c..6b8f9344b 100644 --- a/Compiler/ICompiler.cs +++ b/Compiler/ICompiler.cs @@ -50,11 +50,6 @@ namespace PascalABCCompiler { get; } - - SupportedSourceFile[] SupportedSourceFiles - { - get; - } SupportedSourceFile[] SupportedProjectFiles { diff --git a/Compiler/PCU/PCUFileFormatVersion.cs b/Compiler/PCU/PCUFileFormatVersion.cs index bc45f1b85..18ad39e52 100644 --- a/Compiler/PCU/PCUFileFormatVersion.cs +++ b/Compiler/PCU/PCUFileFormatVersion.cs @@ -7,6 +7,6 @@ namespace PascalABCCompiler.PCU { public static class PCUFileFormatVersion { - public static System.Int16 Version = 122; + public static System.Int16 Version = 123; } } diff --git a/Compiler/PCU/PCUReader.cs b/Compiler/PCU/PCUReader.cs index 97c2d94d5..d9738485e 100644 --- a/Compiler/PCU/PCUReader.cs +++ b/Compiler/PCU/PCUReader.cs @@ -6,6 +6,7 @@ using System.Collections.Generic; using System.Reflection; using PascalABCCompiler.TreeConverter; using PascalABCCompiler.TreeRealization; +using Languages.Facade; namespace PascalABCCompiler.PCU { @@ -217,10 +218,10 @@ namespace PascalABCCompiler.PCU ReadPCUHeader(); } - public string GetFullUnitName(string UnitName, bool caseSensitiveSearch) + public string GetFullUnitName(string UnitName, ILanguage currentUnitLanguage) { - var FullUnitName = comp.FindPCUFileName(UnitName, dir, out _, caseSensitiveSearch); + var FullUnitName = comp.FindPCUFileName(UnitName, dir, out _, currentUnitLanguage); if (FullUnitName == null) throw new Errors.FileNotFound(UnitName, null); return FullUnitName; @@ -229,25 +230,28 @@ namespace PascalABCCompiler.PCU private PCUReader GetPCUReaderForUnitId(int id) { if (id == -1) return this; - string s = GetFullUnitName(pcu_file.incl_modules[id], pcu_file.languageCaseSensitive); + + ILanguage currentUnitLanguage = LanguageProvider.Instance.SelectLanguageByName(pcu_file.languageName); + + string s = GetFullUnitName(pcu_file.incl_modules[id], currentUnitLanguage); if ( !units.TryGetValue(s, out var pr) ) { pr = new PCUReader(this); - pr.GetCompilationUnit(s, this.readDebugInfo, pcu_file.languageCaseSensitive); + pr.GetCompilationUnit(s, this.readDebugInfo, currentUnitLanguage); } return pr; } //десериализация модуля //читается только шапка PCU и заполняются имена сущностей модуля в таблицу символов - public CompilationUnit GetCompilationUnit(string FileName, bool readDebugInfo, bool caseSensitiveSearch) + public CompilationUnit GetCompilationUnit(string FileName, bool readDebugInfo, ILanguage currentUnitLanguage) { try { // Compiler.CombinePath всегда должно быть применено к имени файла, перед тем как кидать его сюда if (!Path.IsPathRooted(FileName)) throw new InvalidOperationException(); - FileName = GetFullUnitName(FileName, caseSensitiveSearch); + FileName = GetFullUnitName(FileName, currentUnitLanguage); dir = Path.GetDirectoryName(FileName); this.FileName = FileName; @@ -277,8 +281,9 @@ namespace PascalABCCompiler.PCU ChangeState(this, PCUReaderWriterState.BeginReadTree, unit); cun.scope = new WrappedUnitInterfaceScope(this); - //TODO сохранить в PCU - cun.scope.CaseSensitive = pcu_file.languageCaseSensitive; + bool unitLanguageCaseSensitive = LanguageProvider.Instance.SelectLanguageByName(pcu_file.languageName).CaseSensitive; + + cun.scope.CaseSensitive = unitLanguageCaseSensitive; if (string.Compare(unit_name, StringConstants.pascalSystemUnitName, true)==0) PascalABCCompiler.TreeConverter.syntax_tree_visitor.init_system_module(cun); @@ -287,8 +292,7 @@ namespace PascalABCCompiler.PCU cun.implementation_scope = new WrappedUnitImplementationScope(this, cun.scope); //\ssyy - //TODO сохранить в PCU - cun.implementation_scope.CaseSensitive = pcu_file.languageCaseSensitive; + cun.implementation_scope.CaseSensitive = unitLanguageCaseSensitive; string SourceFileName = pcu_file.SourceFileName; if (Path.GetDirectoryName(SourceFileName) == "") @@ -354,7 +358,10 @@ namespace PascalABCCompiler.PCU need = true; return need; }*/ - if (comp.NeedRecompiled(FileName, pcu_file.incl_modules, this, pcu_file.languageCaseSensitive)) + + ILanguage currentUnitLanguage = LanguageProvider.Instance.SelectLanguageByName(pcu_file.languageName); + + if (comp.NeedRecompiled(FileName, pcu_file.incl_modules, this, currentUnitLanguage)) { //comp.RecompileList.Add(unit_name,unit_name); comp.RecompileList.Add(FileName); @@ -366,7 +373,7 @@ namespace PascalABCCompiler.PCU { //if (pcu_file.incl_modules[i].Contains("$")) // continue; - var used_unit_fname = comp.GetUnitFileName(Path.GetFileNameWithoutExtension(pcu_file.incl_modules[i]), pcu_file.incl_modules[i], dir, new SyntaxTree.SourceContext(0,0,0,0, FileName), pcu_file.languageCaseSensitive); + var used_unit_fname = comp.GetUnitFileName(Path.GetFileNameWithoutExtension(pcu_file.incl_modules[i]), pcu_file.incl_modules[i], dir, new SyntaxTree.SourceContext(0,0,0,0, FileName), currentUnitLanguage); if (Path.GetExtension(used_unit_fname) != comp.CompilerOptions.CompiledUnitExtension) return true; if ( !units.TryGetValue(used_unit_fname, out var pr) ); @@ -377,7 +384,7 @@ namespace PascalABCCompiler.PCU used_units.Add(used_unit_fname); if (!already_compiled.Contains(used_unit_fname)) { - var sub_u = pr.GetCompilationUnit(used_unit_fname, this.readDebugInfo, pcu_file.languageCaseSensitive); + var sub_u = pr.GetCompilationUnit(used_unit_fname, this.readDebugInfo, currentUnitLanguage); if (sub_u == null) return true; this.unit.InterfaceUsedDirectUnits.Add(sub_u.SemanticTree, sub_u); this.unit.InterfaceUsedUnits.AddElement(sub_u.SemanticTree, pcu_file.incl_modules[i]); @@ -580,7 +587,7 @@ namespace PascalABCCompiler.PCU else cur_doc = new document(pcu_file.SourceFileName); - pcu_file.languageCaseSensitive = br.ReadBoolean(); + pcu_file.languageName = br.ReadString(); int num_names = br.ReadInt32(); pcu_file.names = new NameRef[num_names]; @@ -2490,7 +2497,8 @@ namespace PascalABCCompiler.PCU //Добавляем подключенные модули for (int i = 0; i < uses_count; i++) { - if ( units.TryGetValue(GetFullUnitName(pcu_file.incl_modules[i], pcu_file.languageCaseSensitive), out var pcu_r) ); + if ( units.TryGetValue(GetFullUnitName(pcu_file.incl_modules[i], + LanguageProvider.Instance.SelectLanguageByName(pcu_file.languageName)), out var pcu_r) ); { top_scopes.Add(pcu_r.cun.scope); } diff --git a/Compiler/PCU/PCUWriter.cs b/Compiler/PCU/PCUWriter.cs index d3398f7e4..d2ebd8970 100644 --- a/Compiler/PCU/PCUWriter.cs +++ b/Compiler/PCU/PCUWriter.cs @@ -171,7 +171,7 @@ namespace PascalABCCompiler.PCU public string SourceFileName; - public bool languageCaseSensitive; + public string languageName; public NameRef[] names; //список имен интерфейсной части модуля public string[] incl_modules; //список подключаемых модулей @@ -305,7 +305,7 @@ namespace PascalABCCompiler.PCU GetUsedUnits();//заполняем список полключаемых модулей - pcu_file.languageCaseSensitive = Unit.Language.CaseSensitive; + pcu_file.languageName = Unit.Language.Name; GetCountOfMembers();//заполняем список имен интерфейсных сущностей WriteUnit();//пишем имя interface_namespace @@ -439,7 +439,7 @@ namespace PascalABCCompiler.PCU if (pcu_file.IncludeDebugInfo) fbw.Write(pcu_file.SourceFileName); - fbw.Write(pcu_file.languageCaseSensitive); + fbw.Write(pcu_file.languageName); fbw.Write(pcu_file.names.Length); for (int i=0; i - /// Имя директории, содержащей установленные плагины языков программирования - /// - private const string languageKitsDirectoryName = "LanguageKits"; - - /// - /// Событие, информирующее об успешной загрузке плагина языка + /// Событие, информирующее об успешной загрузке языкового пакета /// public static event Action LanguageLoaded; /// - /// Событие, информирующее об ошибке загрузки плагина языка + /// Событие, информирующее об ошибке загрузки языкового пакета /// public static event Action LanguageLoadErrorOccured; /// - /// Возвращает директорию, содержащую комплекты языков (если ее нет, то вернется null) - /// - private static DirectoryInfo GetLanguageKitsDirectory() - { - string binDirectoryPath = Path.GetDirectoryName(Assembly.GetExecutingAssembly().Location); - string languageKitsDirectoryPath = Path.Combine(binDirectoryPath, languageKitsDirectoryName); - - if (Directory.Exists(languageKitsDirectoryPath)) - return new DirectoryInfo(languageKitsDirectoryPath); - - return null; - } - - /// - /// Загружает все языковые комплекты для использования (имя "главной" dll должно заканчиваться на Language) - /// - public static void LoadAllLanguageKits() - { - DirectoryInfo languageKitsDirectory = GetLanguageKitsDirectory(); - - if (languageKitsDirectory == null) - return; - - foreach (var languageKit in languageKitsDirectory.GetDirectories()) - { - FileInfo[] dllFiles = languageKit.GetFiles(); - - foreach (var dll in dllFiles) - { - if (dll.Name.EndsWith("LanguageInfo.dll")) - { - IntegrateLanguageFromAssembly(dll); - break; - } - } - } - } - - /// - /// Загружает все языки, доступные в системе + /// Загружает все языки платформы из папки bin /// public static void LoadAllLanguages() - { - LoadStandardLanguages(); - LoadAllLanguageKits(); - } - - /// - /// Загружает стандартные языки платформы из папки bin - /// - public static void LoadStandardLanguages() { string directoryName = Path.GetDirectoryName(Assembly.GetExecutingAssembly().ManifestModule.FullyQualifiedName); diff --git a/ParserTools/Tools.cs b/ParserTools/Tools.cs index 0a8a4ffc9..325b63edd 100644 --- a/ParserTools/Tools.cs +++ b/ParserTools/Tools.cs @@ -35,6 +35,12 @@ namespace PascalABCCompiler public class FormatTools { + + public static string LanguageAndExtensionsFormatted(string languageName, string[] extensions) + { + return string.Format("{0} ({1})", languageName, ExtensionsToString(extensions, "*", ";")); + } + public static string ExtensionsToString(string[] Extensions,string Mask,string Delimer) { string res = ""; diff --git a/ReleaseGenerators/PascalABCNETConsoleZIP.bat b/ReleaseGenerators/PascalABCNETConsoleZIP.bat index 85527ec4d..795694ec4 100644 --- a/ReleaseGenerators/PascalABCNETConsoleZIP.bat +++ b/ReleaseGenerators/PascalABCNETConsoleZIP.bat @@ -2,6 +2,7 @@ cd ..\bin del ..\Release\PACNETConsole.zip ..\utils\pkzipc\pkzipc.exe -add ..\Release\PABCNETC.zip pabcnetc.exe pabcnetcclear.exe Compiler.dll CompilerTools.dll Errors.dll Localization.dll NETGenerator.dll ParserTools.dll ICSharpCode.NRefactory.dll SemanticTree.dll SyntaxTree.dll TreeConverter.dll OptimizerConversion.dll PascalABCParser.dll PascalABCLanguageInfo.dll licence.txt PascalABCNET.chm System.Threading.dll SyntaxTreeConverters.dll YieldHelpers.dll SyntaxVisitors.dll LambdaAnySynToSemConverter.dll LanguageIntegrator.dll StringConstants.dll ..\utils\pkzipc\pkzipc.exe -add -nozip -dir ..\Release\PABCNETC.zip Lib\*.pcu +..\utils\pkzipc\pkzipc.exe -add -nozip -dir ..\Release\PABCNETC.zip Lib\SPython\*.pcu ..\utils\pkzipc\pkzipc.exe -add -nozip -dir ..\Release\PABCNETC.zip Lng\*.dat ..\utils\pkzipc\pkzipc.exe -add -nozip -dir ..\Release\PABCNETC.zip Lng\*.LanguageName ..\utils\pkzipc\pkzipc.exe -add -nozip -dir ..\Release\PABCNETC.zip doc\*.* diff --git a/ReleaseGenerators/PascalABCNET_head.nsh b/ReleaseGenerators/PascalABCNET_head.nsh index aab7bb228..e2bcafd35 100644 --- a/ReleaseGenerators/PascalABCNET_head.nsh +++ b/ReleaseGenerators/PascalABCNET_head.nsh @@ -108,7 +108,9 @@ SectionEnd Section ${AddDirectory} "$INSTDIR\LibSource" + ${AddDirectory} "$INSTDIR\LibSource\SPython" ${AddDirectory} "$INSTDIR\Lib" + ${AddDirectory} "$INSTDIR\Lib\SPython" ${AddDirectory} "$INSTDIR\Highlighting" ${AddDirectory} "$INSTDIR\PT4" ${AddDirectory} "$INSTDIR\Ico" diff --git a/ReleaseGenerators/RebuildStandartModulesSPython.pas b/ReleaseGenerators/RebuildStandartModulesSPython.pas index 5f358b84a..1e65bf547 100644 --- a/ReleaseGenerators/RebuildStandartModulesSPython.pas +++ b/ReleaseGenerators/RebuildStandartModulesSPython.pas @@ -1,7 +1,7 @@ uses // SPython //SPythonSystem, SPythonHidden, - time1, + time1, random1, SPythonSystemPys, itertools, math ; diff --git a/ReleaseGenerators/sect_Core.nsh b/ReleaseGenerators/sect_Core.nsh index 34667ad51..a47c460cb 100644 --- a/ReleaseGenerators/sect_Core.nsh +++ b/ReleaseGenerators/sect_Core.nsh @@ -180,13 +180,6 @@ File ..\bin\Lib\Tasks1Arr.pcu File ..\bin\Lib\WPF.pcu - File ..\bin\Lib\SPythonHidden.pcu - File ..\bin\Lib\SPythonSystem.pcu - File ..\bin\Lib\time1.pcu - File ..\bin\Lib\SPythonSystemPys.pcu - File ..\bin\Lib\itertools.pcu - File ..\bin\Lib\math.pcu - File ..\bin\Lib\PABCRtl.dll File ..\bin\Lib\HelixToolkit.Wpf.dll File ..\bin\Lib\HelixToolkit.dll @@ -280,14 +273,6 @@ ${AddFile} "Tasks1Arr.pcu" ${AddFile} "WPF.pcu" - ;SPython - ${AddFile} "SPythonHidden.pcu" - ${AddFile} "SPythonSystem.pcu" - ${AddFile} "time1.pcu" - ${AddFile} "SPythonSystemPys.pcu" - ${AddFile} "itertools.pcu" - ${AddFile} "math.pcu" - ${AddFile} "turtle.png" ${AddFile} "PABCRtl.dll" @@ -299,6 +284,27 @@ ${AddFile} "PABCRtl.pdb" + ;SPython + Delete "$INSTDIR\Lib\SPython\*.pas" + Delete "$INSTDIR\Lib\SPython\*.pys" + SetOutPath "$INSTDIR\Lib\SPython" + + File ..\bin\Lib\SPython\SPythonHidden.pcu + File ..\bin\Lib\SPython\SPythonSystem.pcu + File ..\bin\Lib\SPython\SPythonSystemPys.pcu + File ..\bin\Lib\SPython\time1.pcu + File ..\bin\Lib\SPython\random1.pcu + File ..\bin\Lib\SPython\itertools.pcu + File ..\bin\Lib\SPython\math.pcu + + ${AddFile} "SPythonHidden.pcu" + ${AddFile} "SPythonSystem.pcu" + ${AddFile} "SPythonSystemPys.pcu" + ${AddFile} "time1.pcu" + ${AddFile} "random1.pcu" + ${AddFile} "itertools.pcu" + ${AddFile} "math.pcu" + SetOutPath "$INSTDIR\Doc" File ..\doc\NumLibABC.pdf ${AddFile} "NumLibABC.pdf" @@ -396,15 +402,6 @@ File ..\bin\Lib\Мозаика.pas File ..\bin\Lib\WPF.pas - ;SPython - File ..\bin\Lib\SPythonHidden.pas - File ..\bin\Lib\SPythonSystem.pas - File ..\bin\Lib\time1.pas - - File ..\bin\Lib\SPythonSystemPys.pys - File ..\bin\Lib\itertools.pys - File ..\bin\Lib\math.pys - File ..\bin\Lib\__RedirectIOMode.vb File ..\bin\Lib\VBSystem.vb @@ -485,19 +482,31 @@ ${AddFile} "Мозаика.pas" ${AddFile} "WPF.pas" + ${AddFile} "__RedirectIOMode.vb" + ${AddFile} "VBSystem.vb" + + ;SPython + SetOutPath "$INSTDIR\LibSource\SPython" + + File ..\bin\Lib\SPython\SPythonHidden.pas + File ..\bin\Lib\SPython\SPythonSystem.pas + File ..\bin\Lib\SPython\time1.pas + + File ..\bin\Lib\SPython\SPythonSystemPys.pys + File ..\bin\Lib\SPython\random1.pys + File ..\bin\Lib\SPython\itertools.pys + File ..\bin\Lib\SPython\math.pys + ${AddFile} "SPythonHidden.pas" ${AddFile} "SPythonSystem.pas" ${AddFile} "time1.pas" ${AddFile} "SPythonSystemPys.pys" + ${AddFile} "random1.pys" ${AddFile} "itertools.pys" ${AddFile} "math.pys" - - ${AddFile} "__RedirectIOMode.vb" - ${AddFile} "VBSystem.vb" - CreateDirectory "$COMMONSTARTMENU\PascalABC.NET" CreateDirectory "$SMPROGRAMS\PascalABC.NET" Push "OptimizerConversion.dll" diff --git a/VisualPascalABCNET/DS/VisualEnvironmentCompiler.cs b/VisualPascalABCNET/DS/VisualEnvironmentCompiler.cs index 72c844a7d..50987af70 100644 --- a/VisualPascalABCNET/DS/VisualEnvironmentCompiler.cs +++ b/VisualPascalABCNET/DS/VisualEnvironmentCompiler.cs @@ -8,6 +8,7 @@ using System.IO; using VisualPascalABCPlugins; using System.Threading; using Languages.Integration; +using Languages.Facade; namespace VisualPascalABC { @@ -174,10 +175,10 @@ namespace VisualPascalABC if (standartCompiler == null) return null; string Filter = "", AllFilter = ""; - foreach (PascalABCCompiler.SupportedSourceFile ssf in standartCompiler.SupportedSourceFiles) + foreach (ILanguage lang in LanguageProvider.Instance.Languages) { - Filter = Tools.MakeFilter(Filter, ssf.LanguageName, ssf.Extensions); - AllFilter = Tools.MakeAllFilter(AllFilter, ssf.LanguageName, ssf.Extensions); + Filter = Tools.MakeFilter(Filter, lang.Name, lang.FilesExtensions); + AllFilter = Tools.MakeAllFilter(AllFilter, lang.Name, lang.FilesExtensions); } Filter += "Программы на C# (*.cs)|*.cs|"; AllFilter += "*.cs;"; @@ -390,8 +391,9 @@ namespace VisualPascalABC if (!(defaultCompilerType == PascalABCCompiler.CompilerType.Remote) || (standartCompiler.State == PascalABCCompiler.CompilerState.Ready && (remoteCompiler != null && remoteCompiler.State == PascalABCCompiler.CompilerState.Ready))) StartingCompleted = true; AddCompilerTextToCompilerMessages(sender, VECStringResources.Get("SUPPORTED_LANGUAGES") + Environment.NewLine); - foreach (PascalABCCompiler.SupportedSourceFile ssf in standartCompiler.SupportedSourceFiles) - AddCompilerTextToCompilerMessages(sender, string.Format(VECStringResources.Get("CM_LANGUAGE_{0}"), ssf) + Environment.NewLine); + foreach (ILanguage lang in LanguageProvider.Instance.Languages) + AddCompilerTextToCompilerMessages(sender, string.Format(VECStringResources.Get("CM_LANGUAGE_{0}"), + PascalABCCompiler.FormatTools.LanguageAndExtensionsFormatted(lang.Name, lang.FilesExtensions) + Environment.NewLine)); if (StartingCompleted) { ChangeVisualEnvironmentState(VisualEnvironmentState.FinishCompilerLoading, standartCompiler); diff --git a/VisualPascalABCNETLinux/DS/VisualEnvironmentCompiler.cs b/VisualPascalABCNETLinux/DS/VisualEnvironmentCompiler.cs index 4ea70da68..7a3fab147 100644 --- a/VisualPascalABCNETLinux/DS/VisualEnvironmentCompiler.cs +++ b/VisualPascalABCNETLinux/DS/VisualEnvironmentCompiler.cs @@ -1,12 +1,13 @@ // Copyright (c) Ivan Bondarev, Stanislav Mikhalkovich (for details please see \doc\copyright.txt) // This code is distributed under the GNU LGPL (for details please see \doc\license.txt) +using Languages.Facade; +using Languages.Integration; using System; using System.Collections.Generic; +using System.IO; using System.Text; using System.Windows.Forms; -using System.IO; using VisualPascalABCPlugins; -using Languages.Integration; namespace VisualPascalABC { @@ -172,10 +173,10 @@ namespace VisualPascalABC if (standartCompiler == null) return null; string Filter = "", AllFilter = ""; - foreach (PascalABCCompiler.SupportedSourceFile ssf in standartCompiler.SupportedSourceFiles) + foreach (ILanguage lang in LanguageProvider.Instance.Languages) { - Filter = Tools.MakeFilter(Filter, ssf.LanguageName, ssf.Extensions); - AllFilter = Tools.MakeAllFilter(AllFilter, ssf.LanguageName, ssf.Extensions); + Filter = Tools.MakeFilter(Filter, lang.Name, lang.FilesExtensions); + AllFilter = Tools.MakeAllFilter(AllFilter, lang.Name, lang.FilesExtensions); } Filter += "Программы на C# (*.cs)|*.cs|"; AllFilter += "*.cs;"; @@ -377,8 +378,9 @@ namespace VisualPascalABC if (!(defaultCompilerType == PascalABCCompiler.CompilerType.Remote) || (standartCompiler.State == PascalABCCompiler.CompilerState.Ready && (remoteCompiler != null && remoteCompiler.State == PascalABCCompiler.CompilerState.Ready))) StartingCompleted = true; AddCompilerTextToCompilerMessages(sender, VECStringResources.Get("SUPPORTED_LANGUAGES") + Environment.NewLine); - foreach (PascalABCCompiler.SupportedSourceFile ssf in standartCompiler.SupportedSourceFiles) - AddCompilerTextToCompilerMessages(sender, string.Format(VECStringResources.Get("CM_LANGUAGE_{0}"), ssf) + Environment.NewLine); + foreach (ILanguage lang in LanguageProvider.Instance.Languages) + AddCompilerTextToCompilerMessages(sender, string.Format(VECStringResources.Get("CM_LANGUAGE_{0}"), + PascalABCCompiler.FormatTools.LanguageAndExtensionsFormatted(lang.Name, lang.FilesExtensions) + Environment.NewLine)); if (StartingCompleted) { ChangeVisualEnvironmentState(VisualEnvironmentState.FinishCompilerLoading, standartCompiler); diff --git a/bin/Lib/LibForVB/ABCObjects/ABCObjects.pas b/bin/Lib/LibForVB/ABCObjects/ABCObjects.pas deleted file mode 100644 index 1f45eb396..000000000 --- a/bin/Lib/LibForVB/ABCObjects/ABCObjects.pas +++ /dev/null @@ -1,2760 +0,0 @@ -///Модуль реализует векторные графические объекты с возможностью масштабирования, наложения друг на друга, -///создания составных графических объектов и многократного их вложения друг в друга. -///Каждый векторный графический объект перерисовывает себя при перемещении, изменении размеров -///и частичном перекрытии другими объектами. -library ABCObjects; - -//#apptype windows -#reference 'System.Windows.Forms.dll' -#reference 'System.Drawing.dll' -//#gendoc true -#savepcu false - -interface - -uses System.Drawing, GraphABC; - -type - GColor = GraphABC.Color; - ContainerABC = class; - GRectangle = System.Drawing.Rectangle; - - /// Базовый класс для всех графических объектов - ObjectABC = class - public - fx,fy: integer; - fw,fh: integer; - col,fcol: GColor; - vis,txtvis: boolean; - txt,fname: string; - fstyle: FontStyleType; - txtscale: real; - ow: ContainerABC; - _dx,_dy: integer; - procedure SetCoords(x,y: integer); - public - // InternalDraw: низкоуровневая процедура (не вызывается пользователем). Просто вызывает Draw(fx,fy) - procedure InternalDraw; - procedure SetVis(v: boolean); - procedure SetColor(cl: GColor); - procedure SetOwner(o: ContainerABC); - procedure SetX(x: integer); - procedure SetY(y: integer); - procedure ObjectABCSetSize(Width,Height: integer); // internal - procedure SetWidth(Width: integer); virtual; - procedure SetHeight(Height: integer); virtual; - procedure SetText(t: string); virtual; - procedure SetTxtVis(b: boolean); - procedure SetTextScale(r: real); - procedure SetFontName(name: string); - procedure SetFontStyle(fs: FontStyleType); - procedure SetFontColor(fc: GColor); - - procedure SetNum(n: integer); - function GetNum: integer; - procedure SetRealNum(r: real); - function GetRealNum: real; - - procedure SetCenter(p: Point); - function GetCenter: Point; - procedure SetPosition(p: Point); - function GetPosition: Point; - - procedure CalcOwnerOffset(var l,t: integer); - procedure DrawAfterChangeBounds(oldBounds,newBounds: GRectangle); - procedure DrawText(x,y: integer; g: Graphics); - procedure Init(x,y,w,h: integer; cl: GColor); - procedure InitBy(g: ObjectABC); - // Draw: переопределяется в подклассах. Рисует объект на текущей канве - procedure Draw(x,y: integer; g: Graphics); virtual; begin end; - procedure Draw(x,y: integer); - public - /// Создает графический объект размера (w,h) цвета cl с координатами левого верхнего угла (x,y) - constructor Create(x,y,w,h: integer; cl: GColor := clWhite); - /// Создает графический объект - копию объекта g - constructor Create(g: ObjectABC); - /// Уничтожает графический объект - destructor Destroy; - // Redraw: низкоуровневая процедура (не вызывается пользователем). - // Обновляет изображение объекта на экране, вызывая drawRect(Bounds). - // Вызывается в ситуациях, когда границы объекта не изменяются (напр., смена цвета) - // или увеличиваются (добавление нового объекта к фигуре) - procedure Redraw; - // RedrawNow - вызывает перерисовку объекта, несмотря на LockDrawing - procedure RedrawNow; - /// Перемещает левый верхний угол графического объекта к точке (x,y) - procedure MoveTo(x,y: integer); - /// Перемещает графический объект на вектор (a,b) - procedure MoveOn(a,b: integer); - /// Перемещает графический объект на вектор, задаваемый свойствами dx,dy - procedure Move; virtual; - /// Масштабирует графический объект в f раз (f>1 - увеличение, 01 - увеличение, 01 - увеличение, 01 - увеличение, 01 - увеличение, 01 - увеличение, 0b then - Result := a - else Result := b -end; - -function min(a,b: real): real; -begin - if ab then - Result := a - else Result := b -end; - -procedure drawRect(r: GRectangle); -// Низкоуровневая процедура (не вызывается пользователем). Вызывает безусловную перерисовку прямоугольника. -var -/// b: Picture; - i: integer; - g: ObjectABC; - gb: System.Drawing.Graphics; - db: boolean; - bmp,bmp1,tb: Bitmap; - rr,rtmp: System.Drawing.Rectangle; -begin - LockGraphics; - // ToDo Сделать то же самое при выходе за границу справа и внизу!!! - if r.X<0 then - r.X := 0; - if r.Width<=0 then - r.Width := 1; - if r.Y<0 then - r.Y := 0; - if r.Height<=0 then - r.Height := 1; - - bmp := GraphBufferBitmap; - rr := new System.Drawing.Rectangle(r.Left,r.Top,r.Right-r.Left,r.Bottom-r.Top); - rtmp := new System.Drawing.Rectangle(0,0,r.Right-r.Left,r.Bottom-r.Top); - - //tb := new Bitmap(r.Right-r.Left,r.Bottom-r.Top); - tb := GetView(tempbmp,rtmp); - - gb := System.Drawing.Graphics.FromImage(tb); - gb.SmoothingMode := GraphWindowGraphics.SmoothingMode; -// gb.TextRenderingHint := System.Drawing.Text.TextRenderingHint.AntiAlias; - - bmp1 := GetView(bmp,rr); - gb.DrawImageUnscaled(bmp1,0,0); - //gb.Transform := GraphWindowGraphics.Transform; // ??? - bmp1.Dispose; - bmp1 := nil; - - for i:=0 to __l.Count-1 do - begin - g := ObjectABC(__l[i]); - if g.Visible and g.IntersectRect(r) then - g.Draw(g.Left-r.Left,g.Top-r.Top,gb); - end; - - for i:=0 to __lUI.Count-1 do - begin - g := ObjectABC(__lUI[i]); - if g.Visible and g.IntersectRect(r) then - g.Draw(g.Left-r.Left,g.Top-r.Top,gb); - end; - - db := DrawInBuffer; - DrawInBuffer := False; - -// if not __LockDrawingObjects then - //var m := GraphWindowGraphics.Transform; // ??? - //GraphWindowGraphics.ResetTransform; // ??? - GraphWindowGraphics.DrawImage(tb,r.Left,r.Top); - //GraphWindowGraphics.Transform := m; // ??? -/// b.Draw(r.Left,r.Top); - DrawInBuffer := db; - gb.Dispose; - gb := nil; - UnLockGraphics; -end; - -procedure ABCRedrawProc; -begin - {if __LockDrawingObjects then - Redraw - else }RedrawObjects; -end; - -procedure RedrawObjects; -begin - drawRect(new GRectangle(0,0,WindowWidth,WindowHeight)); -end; - -procedure LockDrawingObjects; -begin - __LockDrawingObjects:=True; -end; - -procedure UnLockDrawingObjects; -begin - __LockDrawingObjects:=False; - RedrawObjects; -end; - -procedure ToFront(grobj: ObjectABC); -var ind: integer; -begin -// if grobj is UIElementABC then exit; - if grobj=nil then exit; - ind:=__l.IndexOf(grobj); - if ind=__l.Count-1 then Exit; - if ind=-1 then Exit; -// __l.OwnsObjects:=False; - __l.RemoveAt(ind); - __l.Add(grobj); -// __l.OwnsObjects:=True; - grobj.Redraw; -end; - -procedure ToBack(grobj: ObjectABC); -var ind: integer; -begin -// if grobj is UIElementABC then exit; - if grobj=nil then exit; - ind:=__l.IndexOf(grobj); - if ind=0 then Exit; - if ind=-1 then Exit; -// __l.OwnsObjects:=False; - __l.RemoveAt(ind); - __l.Insert(0,grobj); -// __l.OwnsObjects:=True; - grobj.Redraw; -end; - -function ObjectsCount: integer; -begin - Result:=__l.Count; -end; - -function ObjectUnderPoint(x,y: integer): ObjectABC; -var - i: integer; - g: ObjectABC; -begin - Result:=nil; - for i := Objects.Count-1 downto 0 do - begin - g := Objects[i]; - if g.PtInside(x,y) then - begin - Result:=g; - Exit - end; - end; -end; - -function ObjectUnderPoint(p: Point): ObjectABC; -begin - Result:=ObjectUnderPoint(p.x,p.y); -end; - -procedure SwapPositions(o1,o2: ObjectABC); -var p: Point; -begin - p := o1.Position; - o1.Position := o2.Position; - o2.Position := p; -end; - -function UIElementUnderPoint(x,y: integer): UIElementABC; -var - i: integer; - g: UIElementABC; -begin - Result:=nil; - for i:=__lUI.Count-1 downto 0 do - begin - g := UIElementABC(__lUI[i]); - if g.PtInside(x,y) then - begin - Result := g; - Exit - end; - end; -end; - -//------ ObjectABC ------ -procedure ObjectABC.Init(x,y,w,h: integer; cl: GColor); -begin - fx := x; fy := y; - if w<1 then w := 1; - if h<1 then h := 1; - fw := w; fh := h; - col := cl; - - vis := True; - txt := ''; - txtvis := true; - txtscale := 0.8; - fcol := clBlack; - fname := 'Arial'; - fstyle := fsNormal; - if Self is UIElementABC then - __lUI.Add(Self) - else __l.Add(Self); - Owner := nil; -end; - -procedure ObjectABC.InitBy(g: ObjectABC); -begin - fx := g.fx; fy := g.fy; - fw := g.fw; fh := g.fh; - col := g.col; - - vis := g.Visible; - txt := g.Text; - txtvis := g.TextVisible; - txtscale := g.TextScale; - fname := g.fname; - fstyle := g.fstyle; - if Self is UIElementABC then - __lUI.Add(Self) - else __l.Add(Self); - Owner := g.Owner; -end; - -constructor ObjectABC.Create(x,y,w,h: integer; cl: GColor); -begin - Init(x,y,w,h,cl); -end; - -constructor ObjectABC.Create(g: ObjectABC); -begin - InitBy(g); -end; - -destructor ObjectABC.Destroy; -begin - Visible:=False; - if Owner<>nil then - Exit; - if Self is UIElementABC then - __lUI.Remove(Self) - else __l.Remove(Self); -end; - -procedure ObjectABC.DrawAfterChangeBounds(oldBounds,newBounds: GRectangle); -// Низкоуровневая процедура (не вызывается пользователем). Вызывает перерисовку после изменения объектом своих границ. -var - l,t: integer; - r: GRectangle; -begin - if __LockDrawingObjects then Exit; - l:=0; t:=0; - if Owner<>nil then - begin - CalcOwnerOffset(l,t); - Owner.RecalcBounds; - end; - oldBounds.Offset(l,t); - newBounds.Offset(l,t); - if oldBounds.IntersectsWith(newBounds) then - begin - r := GRectangle.Union(oldBounds,newBounds); - drawRect(r); - end - else - begin - drawRect(newBounds); - drawRect(oldBounds) - end; -end; - -procedure ObjectABC.DrawText(x,y: integer; g: Graphics); -var - tw,th,fs,d: integer; - m: real; - bs: BrushStyleType; -begin - if not TextVisible or (txt='') then - exit; - bs := BrushStyle; - SetBrushStyle(bsClear); - - // ToDo очень много выделений памяти! - GraphABC.SetFontColor(fcol); - GraphABC.SetFontName(fname); - GraphABC.SetFontStyle(fstyle); - SetFontSize(100); - tw := TextWidth(txt); - th := TextHeight(txt); - m := max(tw/Width,th/Height); -// m:=th/Height; - fs := round(txtscale/m*100); - if fs<1 then fs := 1; - SetFontSize(fs); - tw := TextWidth(txt); - th := TextHeight(txt); -{ if fw>50 then - d:=10 - else if fw>20 then - d:=5 - else d:=0;} - if tw > Width-d then - begin - fs := round(fs*(Width-(Height-th)*2)/tw); - SetFontSize(fs); - tw := TextWidth(txt); - th := TextHeight(txt); - end; - //DrawRectangle(x+(Width-tw) div 2,y+(Height-th) div 2,x+(Width-tw) div 2 + tw,y+(Height-th) div 2 + th,g); - TextOut(x+(Width-tw) div 2,y+(Height-th) div 2,txt,g); - SetBrushStyle(bs); -end; - -procedure ObjectABC.Draw(x,y: integer); -begin - Draw(x,y,GraphWindowGraphics); -end; - -procedure ObjectABC.SetCenter(p: Point); -begin - MoveTo(p.x-fw div 2,p.y-fh div 2); -end; - -function ObjectABC.GetCenter: Point; -begin - Result.x := fx + fw div 2; - Result.y := fy + fh div 2; -end; - -procedure ObjectABC.SetPosition(p: Point); -begin - MoveTo(p.x,p.y); -end; - -function ObjectABC.GetPosition: Point; -begin - Result.x := fx; - Result.y := fy; -end; - -procedure ObjectABC.SetX(x: integer); -begin - moveto(x,fy); -end; - -procedure ObjectABC.SetY(y: integer); -begin - moveto(fx,y); -end; - -procedure ObjectABC.SetVis(v: boolean); -begin - if vis=v then Exit; - vis := v; - Redraw; -end; - -procedure ObjectABC.SetFontName(name: string); -begin - if name = fname then Exit; - fname := name; - Redraw; -end; - -procedure ObjectABC.SetFontColor(fc: GColor); -begin - if fcol = fc then Exit; - fcol := fc; - Redraw; -end; - -procedure ObjectABC.SetFontStyle(fs: FontStyleType); -begin - if fs = fstyle then Exit; - fstyle := fs; - Redraw; -end; - -procedure ObjectABC.ObjectABCSetSize(Width,Height: integer); -var r: GRectangle; -begin - if Width<1 then Exit; - if Height<1 then Exit; - if (fw=Width) and (fh=Height) then Exit; - r := Bounds; - fw := Width; - fh := Height; - if not __LockDrawingObjects then - DrawAfterChangeBounds(r,Bounds); -end; - -procedure ObjectABC.SetWidth(Width: integer); -begin - ObjectABCSetSize(Width,Height); -end; - -procedure ObjectABC.SetHeight(Height: integer); -var r: GRectangle; -begin - if Height<1 then Exit; - if fh=Height then Exit; - r := Bounds; - fh := Height; - if not __LockDrawingObjects then - DrawAfterChangeBounds(r,Bounds) -end; - -procedure ObjectABC.SetTxtVis(b: boolean); -begin - if txtvis=b then Exit; - txtvis := b; - Redraw; -end; - -procedure ObjectABC.SetNum(n: integer); -begin - Text := IntToStr(n); -end; - -procedure ObjectABC.SetRealNum(r: real); -begin - Text := string.Format('{0:f1}',r).Replace(',','.'); -end; - -function ObjectABC.GetNum: integer; -var err: integer; -begin - Val(Text,Result,err); - if err<>0 then - Result:=0; -end; - -function ObjectABC.GetRealNum: real; -var err: integer; -begin - Val(Text,Result,err); - if err<>0 then - Result:=0; -end; - -procedure ObjectABC.SetTextScale(r: real); -begin - if txtscale=r then - Exit; - if r<0.01 then - r := 0.01 - else if r>1 then - r := 1; - txtscale := r; - Redraw; -end; - -procedure ObjectABC.SetOwner(o: ContainerABC); -begin - if ow<>nil then - ow.Unlink(Self); - ow := nil; - if o<>nil then - o.Add(Self) -end; - -procedure ObjectABC.SetColor(cl: GColor); -begin - if col=cl then Exit; - col := cl; - Redraw; -end; - -procedure ObjectABC.SetText(t: string); -begin - if txt=t then - exit; - txt := t; - Redraw; -end; - -procedure ObjectABC.InternalDraw; -var b: boolean; -begin - b := DrawInBuffer; - DrawInBuffer := False; - if not __LockDrawingObjects then - Draw(fx,fy); - DrawInBuffer := b; -end; - -procedure ObjectABC.CalcOwnerOffset(var l,t: integer); -var - o: ContainerABC; -begin - l:=0; t:=0; - o:=Owner; - while o<>nil do - begin - l := l + o.Left; - t := t + o.Top; - o:=o.Owner; - end; -end; - -procedure ObjectABC.Redraw; -var - l,t: integer; - r: GRectangle; -begin - if not __LockDrawingObjects then - begin - CalcOwnerOffset(l,t); - r := Bounds; - r.Offset(l,t); - drawRect(r); - end; -end; - -procedure ObjectABC.RedrawNow; -var - l,t: integer; - r: GRectangle; -begin - CalcOwnerOffset(l,t); - r := Bounds; - r.Offset(l,t); - drawRect(r); -end; - -procedure ObjectABC.MoveTo(x,y: integer); -var r,r1: GRectangle; -begin - if (fx=x) and (fy=y) then Exit; - r := Bounds; - setCoords(x,y); - r1 := Bounds; - DrawAfterChangeBounds(r,r1) -end; - -procedure ObjectABC.MoveOn(a,b: integer); -begin - MoveTo(fx+a,fy+b); -end; - -procedure ObjectABC.Move; -begin - MoveOn(dx,dy); -end; - -procedure ObjectABC.SetCoords(x,y: integer); -begin - fx := x; - fy := y; -end; - -procedure ObjectABC.Scale(f: real); -begin -// Assert(f>0,'масштабный коэффициент<0'); - Width := round(Width*f); - Height := round(Height*f); -end; - -procedure ObjectABC.ToFront; -begin - ABCObjects.ToFront(Self); -end; - -procedure ObjectABC.ToBack; -begin - ABCObjects.ToBack(Self); -end; - -function ObjectABC.Bounds: GRectangle; -begin - Result := new GRectangle(fx,fy,fw,fh); -end; - -function ObjectABC.Intersect(g: ObjectABC): boolean; -var - r: GRectangle; - b1,b2: Bitmap; - gb1,gb2: Graphics; -begin -{ Result := IntersectRect(g.Bounds); - if Result=False then exit;} - r := GRectangle.Intersect(Bounds,g.Bounds); - if (r.Width<=0) or (r.Height<=0) then - begin - Result := False; - exit; - end; - //write(r.Width,' ',r.Height,' '); - b1 := new Bitmap(r.Width,r.Height); - gb1 := Graphics.FromImage(b1); - gb1.FillRectangle(Brushes.White,0,0,r.Width,r.Height); - Draw(Left-r.Left,Top-r.Top,gb1); - //GraphWindowGraphics.DrawImage(b1,400,0); - b2 := new Bitmap(r.Width,r.Height); - gb2 := Graphics.FromImage(b2); - GraphABC.Brush.Color := clWhite; - gb2.FillRectangle(Brushes.White,0,0,r.Width,r.Height); - g.Draw(g.Left-r.Left,g.Top-r.Top,gb2); - //GraphWindowGraphics.DrawImage(b2,450,0); - Result := ImageIntersect(b1,b2); -end; - -function ObjectABC.IntersectRect(r: GRectangle): boolean; -begin - Result := r.IntersectsWith(Bounds); -end; - -function ObjectABC.PtInside(x,y: integer): boolean; -begin - Result := Bounds.Contains(x,y); -end; - -//------ BoundedObjectABC ------- -constructor BoundedObjectABC.Create(x,y,w,h: integer; cl: GColor); -begin -// А нужно ли это? - Init(x,y,w,h,cl); -end; - -constructor BoundedObjectABC.Create(g: BoundedObjectABC); -begin - InitBy(g); -end; - -procedure BoundedObjectABC.Init(x,y,w,h: integer; cl: GColor); -begin - inherited Init(x,y,w,h,cl); - bcol := clBlack; - bw := 1; - fil := True; - bor := True; -end; - -procedure BoundedObjectABC.InitBy(g: BoundedObjectABC); -begin - inherited InitBy(g); - bcol := g.bcol; - bw := g.bw; - fil := g.fil; - bor := g.bor; -end; - -procedure BoundedObjectABC.SetBColor(cl: GColor); -begin - if bcol=cl then Exit; - bcol:=cl; - Redraw; -end; - -procedure BoundedObjectABC.SetBW(w: integer); -begin - if bw=w then Exit; - bw:=w; - Redraw; -end; - -function BoundedObjectABC.GetBW: integer; -begin - Result := bw; -end; - -procedure BoundedObjectABC.SetFilled(f: boolean); -begin - if fil=f then Exit; - fil := f; - Redraw; -end; - -procedure BoundedObjectABC.SetBordered(b: boolean); -begin - if bor=b then Exit; - bor := b; - Redraw; -end; - -procedure BoundedObjectABC.SetDrawSettings; -begin - SetBrushColor(Color); - if Fil then - SetBrushStyle(bsSolid) - else SetBrushStyle(bsClear); - if Bor then - SetPenStyle(psSolid) - else SetPenStyle(psClear); - SetPenColor(BCol); - SetPenWidth(bw); -end; - -//------ RectangleABC ------- -constructor RectangleABC.Create(x,y,w,h: integer; cl: GColor); -begin - inherited Init(x,y,w,h,cl); - InternalDraw; -end; - -constructor RectangleABC.Create(g: RectangleABC); -begin - inherited InitBy(g); -end; - -procedure RectangleABC.Draw(x,y: integer; g: Graphics); -var z,z1: integer; -begin - SetDrawSettings; - z := BorderWidth div 2; - z1 := (BorderWidth-1) div 2; - LockGraphics; - GraphABCHelper.Rectangle(x+z,y+z,x+Width-z1,y+Height-z1,g); - DrawText(x,y,g); - UnLockGraphics; -end; - -function RectangleABC.Clone0: ObjectABC; -begin - Result := new RectangleABC(Self); -end; - -function RectangleABC.Clone: RectangleABC; -begin - Result := new RectangleABC(Self); -end; - -//------ SquareABC ------- -constructor SquareABC.Create(x,y,w: integer; cl: GColor); -begin - inherited Create(x,y,w,w,cl); -end; - -constructor SquareABC.Create(g: SquareABC); -begin - inherited Create(g); -end; - -procedure SquareABC.SetWidth(Width: integer); -begin - ObjectABCSetSize(Width,Width); -end; - -procedure SquareABC.SetHeight(Height: integer); -begin - SetWidth(Height); -end; - -procedure SquareABC.Scale(f: real); -begin - Width := round(Width*f); -end; - -function SquareABC.Clone0: ObjectABC; -begin - Result := SquareABC.Create(Self); -end; - -function SquareABC.Clone: SquareABC; -begin - Result := SquareABC.Create(Self); -end; - -//------ EllipseABC ------- -constructor EllipseABC.Create(x,y,w,h: integer; cl: GColor); -begin - inherited Init(x,y,w,h,cl); - InternalDraw; -end; - -constructor EllipseABC.Create(g: EllipseABC); -begin - inherited InitBy(g); -end; - -procedure EllipseABC.Draw(x,y: integer; g: Graphics); -var z,z1: integer; -begin - SetDrawSettings; - z := BorderWidth div 2; - z1 := (BorderWidth-1) div 2; - LockGraphics; - Ellipse(x+z,y+z,x+Width-z1,y+Height-z1,g); - DrawText(x,y,g); - UnLockGraphics; -end; - -function EllipseABC.Clone0: ObjectABC; -begin - Result := new EllipseABC(Self); -end; - -function EllipseABC.Clone: EllipseABC; -begin - Result := new EllipseABC(Self); -end; - -//------ CircleABC ------- -constructor CircleABC.Create(x,y,r: integer; cl: GColor); -begin - inherited Create(x-r,y-r,2*r+1,2*r+1,cl); -end; - -constructor CircleABC.Create(g: CircleABC); -begin - inherited Create(g); -end; - -procedure CircleABC.scale(f: real); -begin - Width := round(Width*f); -end; - -procedure CircleABC.SetWidth(Width: integer); -begin - if Width mod 2 = 0 then - Width := Width - 1; - ObjectABCSetSize(Width,Width); -end; - -procedure CircleABC.SetHeight(Height: integer); -begin - SetWidth(Height); -end; - -function CircleABC.Clone0: ObjectABC; -begin - Result := new CircleABC(Self); -end; - -function CircleABC.Clone: CircleABC; -begin - Result := new CircleABC(Self); -end; - -procedure CircleABC.SetRadius(r: integer); -begin - if Width = 2*r+1 then - Exit; - MoveOn(Width div 2-r, Width div 2-r); - Width := 2*r+1; -end; - -function CircleABC.GetRadius: integer; -begin - Result := Width div 2; -end; - -//------ RoundRectABC ------- -constructor RoundRectABC.Create(x,y,w,h,rr: integer; cl: GColor); -begin - Init(x,y,w,h,rr,cl); - InternalDraw; -end; - -constructor RoundRectABC.Create(g: RoundRectABC); -begin - InitBy(g); -end; - -procedure RoundRectABC.SetRadius(rr: integer); -begin - if r=rr then Exit; - if rr > Width div 2 then - rr := Width div 2; - if rr > Height div 2 then - rr := Height div 2; - r := rr; - Redraw; -end; - -procedure RoundRectABC.Draw(x,y: integer; g: Graphics); -var z,z1: integer; -begin - SetDrawSettings; - z := BorderWidth div 2; - z1 := (BorderWidth-1) div 2; - LockGraphics; - RoundRect(x+z,y+z,x+Width-z1,y+Height-z1,2*r,2*r,g); - DrawText(x,y,g); - UnLockGraphics; -end; - -procedure RoundRectABC.Init(x,y,w,h,rr: integer; cl: GColor); -begin - inherited Init(x,y,w,h,cl); - r := rr; -end; - -procedure RoundRectABC.InitBy(g: RoundRectABC); -begin - inherited InitBy(g); - r := g.r; -end; - -function RoundRectABC.Clone0: ObjectABC; -begin - Result := new RoundRectABC(Self); -end; - -function RoundRectABC.Clone: RoundRectABC; -begin - Result := new RoundRectABC(Self); -end; - -//------ RoundSquareABC ------- -constructor RoundSquareABC.Create(x,y,w,r: integer; cl: GColor); -begin - inherited Create(x,y,w,w,r,cl); -end; - -constructor RoundSquareABC.Create(g: RoundSquareABC); -begin - inherited Create(g); -end; - -procedure RoundSquareABC.SetWidth(Width: integer); -begin - ObjectABCSetSize(Width,Width); -end; - -procedure RoundSquareABC.SetHeight(Height: integer); -begin - ObjectABCSetSize(Height,Height); -end; - -procedure RoundSquareABC.Scale(f: real); -begin - Width := round(Width*f); -end; - -function RoundSquareABC.Clone0: ObjectABC; -begin - Result := new RoundSquareABC(Self); -end; - -function RoundSquareABC.Clone: RoundSquareABC; -begin - Result := new RoundSquareABC(Self); -end; - -//------ TextABC ------- -procedure TextABC.Init(x,y,pt: integer; cl: GColor; txt: string); -var w,h: integer; -begin - SetFontName(fname); - SetFontSize(pt); - w := TextWidth(txt); - h := TextHeight(txt); - inherited Init(x,y,w,h,cl); - tb := True; - bc := clWhite; - pointsz := pt; - Self.txt := txt; -end; - -procedure TextABC.InitBy(g: TextABC); -begin - inherited InitBy(g); - tb := g.tb; - bc := g.bc; - pointsz := g.pointsz; - txt := g.txt; -end; - -constructor TextABC.Create(x,y,pt: integer; txt: string; cl: GColor); -begin - Init(x,y,pt,cl,txt); - InternalDraw; -end; - -constructor TextABC.Create(g: TextABC); -begin - InitBy(g); - InternalDraw; -end; - -procedure TextABC.Draw(x,y: integer; g: Graphics); -//var bs: BrushStyleType; -begin - SetBrushColor(bc); - if tb then - begin -// bs := BrushStyle; - SetBrushStyle(bsClear); - end - else - SetBrushStyle(bsSolid); - SetFontName(fname); - SetFontSize(pointsz); - GraphABC.SetFontColor(Color); - LockGraphics; - TextOut(x,y,Text,g); - UnLockGraphics; -// if tb then -// SetBrushStyle(bs); -end; - -procedure TextABC.SetText(t: string); -var r: GRectangle; -begin - if Text=t then - exit; - r := Bounds; - txt := t; - LockGraphics; - fw := TextWidth(t); - fh := TextHeight(t); - UnLockGraphics; - if not __LockDrawingObjects then - DrawAfterChangeBounds(r,Bounds) -end; - -{procedure TextABC.SetFName(fn: string); -begin - if fname=fn then - exit; - fname:=fn; - SetFontName(fname); - SetFontSize(pointsz); - Width:=TextWidth(Text); - Height:=TextHeight(Text); - Redraw; -end;} - -procedure TextABC.SetFSize(sz: integer); -var r: GRectangle; -begin - if pointsz = sz then - Exit; - pointsz := sz; - r := Bounds; - SetFontName(fname); - SetFontSize(pointsz); - fw := TextWidth(Text); - fh := TextHeight(Text); - if not __LockDrawingObjects then - DrawAfterChangeBounds(r,Bounds) -// Redraw; // это неверно! -end; - -procedure TextABC.SetTB(b: boolean); -begin - if tb=b then Exit; - tb := b; - Redraw; -end; - -procedure TextABC.SetBC(c: GColor); -begin - if bc=c then Exit; - bc := c; - Redraw; -end; - -function TextABC.Clone0: ObjectABC; -begin - Result := TextABC.Create(Self); -end; - -function TextABC.Clone: TextABC; -begin - Result := TextABC.Create(Self); -end; - -//------ RegularPolygonABC ------ -procedure RegularPolygonABC.Init(x,y,r,nn: integer; cl: GColor); -begin - inherited Init(x-r,y-r,2*r+1,2*r+1,cl); - n := nn; - SetLength(a,nn); - angl := 0; -end; - -procedure RegularPolygonABC.InitBy(g: RegularPolygonABC); -begin - inherited InitBy(g); - n := g.n; - SetLength(a,n); - angl := g.angl; -end; - -constructor RegularPolygonABC.Create(x,y,r,nn: integer; cl: GColor); -begin - Init(x,y,r,nn,cl); - InternalDraw; -end; - -constructor RegularPolygonABC.Create(g: RegularPolygonABC); -begin - InitBy(g); -end; - -procedure RegularPolygonABC.Draw(x,y: integer; g: Graphics); -var - i,r,z,x0,y0: integer; - phi: real; -begin - SetDrawSettings; - phi := -90 + Angle; - z := BorderWidth div 2; - r := Width div 2; - r := r - z; - x0 := x + Width div 2; - y0 := y + Width div 2; - for i:=0 to n-1 do - begin - a[i].x := round(r*cos(phi*Pi/180)) + x0; - a[i].y := round(r*sin(phi*Pi/180)) + y0; - phi := phi+360/n; - end; - LockGraphics; - Polygon(a,g); - DrawText(x,y,g); - UnLockGraphics; -end; - -function RegularPolygonABC.PtInside(x,y:integer): boolean; -var - a,x0,y0,dx,dy,pz: integer; - phi: real; - part: real; -begin - part := 360/n; - a := Width div 2 + 1; - x0 := Left + Width div 2; - y0 := Top + Width div 2; - dx := x - x0; - dy := y - y0; - if dx=0 then - begin - if dy<0 then - phi := 0 - else phi := 180; - end - else - begin - phi := 90 + arctan(dy/dx)*180/Pi; - if dx<0 then - phi := phi + 180; - end; - pz := trunc(phi/part); - phi := phi - pz*part; - if phi>part/2 then - phi := part - phi; - Phi := part/2-Phi; - Result := sqrt(dx*dx+dy*dy) < a*cos(part/2/180*Pi)/cos(phi/180*Pi); -end; - -procedure RegularPolygonABC.SetAngle(a: real); -begin - if angl=a then - Exit; - angl := a; - Redraw; -end; - -procedure RegularPolygonABC.SetWidth(Width: integer); -begin - if Width mod 2 = 0 then - Width := Width - 1; // Ширина и высота должны быть нечетными - ObjectABCSetSize(Width,Width); -end; - -procedure RegularPolygonABC.SetHeight(Height: integer); -begin - SetWidth(Height); -end; - -procedure RegularPolygonABC.SetCount(c: integer); -begin - if c<3 then - c := 3; - if c>500 then - c := 500; - if n=c then - Exit; - n := c; - SetLength(a,n); - Redraw; -end; - -function RegularPolygonABC.GetCount: integer; -begin - Result := n; -end; - -procedure RegularPolygonABC.SetRadius(r: integer); -begin - if Width = 2*r+1 then - Exit; - MoveOn(Width div 2-r, Width div 2-r); - Width := 2*r+1; -end; - -function RegularPolygonABC.GetRadius: integer; -begin - Result := Width div 2; -end; - -procedure RegularPolygonABC.Scale(f: real); -begin - Width := round(Width*f); -end; - -function RegularPolygonABC.Clone0: ObjectABC; -begin - Result := RegularPolygonABC.Create(Self); -end; - -function RegularPolygonABC.Clone: RegularPolygonABC; -begin - Result := RegularPolygonABC.Create(Self); -end; - -//------ StarABC ------ -procedure StarABC.Init(x,y,r,r1,nn: integer; cl: GColor); -var rr: integer; -begin - if rRadius then - Exit; - if r_rr = Radius/r1 then - Exit; - r_rr := Radius/r1; - Redraw; -end; - -procedure StarABC.Draw(x,y: integer; g: Graphics); -var - i,r,rr,z,x0,y0: integer; - phi: real; -begin - SetDrawSettings; - phi := -90 + Angle; - z := BorderWidth; - r := Width div 2; - r := r - z; - x0 := x + Width div 2; - y0 := y + Width div 2; - rr := round(r/r_rr); - for i:=0 to Count*2-1 do - begin - if i mod 2 = 0 then - begin - a[i].x := round(r*cos(phi*Pi/180)) + x0; - a[i].y := round(r*sin(phi*Pi/180)) + y0; - end - else - begin - a[i].x := round(rr*cos(phi*Pi/180)) + x0; - a[i].y := round(rr*sin(phi*Pi/180)) + y0; - end; - phi := phi + 360/Count/2; - end; - LockGraphics; - Polygon(a,g); - DrawText(x,y,g); - UnLockGraphics; -end; - -function StarABC.PtInside(x,y: integer): boolean; -var - a,x0,y0,pz: integer; - phi: real; - part,dx,dy,b,c,r: real; -begin - part := 360/Count; - a := Width div 2 + 1; - x0 := Left + Width div 2; - y0 := Top + Width div 2; - dx := x - x0; - dy := y - y0; - if dx=0 then - begin - if dy<0 then - phi := 0 - else phi := 180; - end - else - begin - phi := 90 + arctan(dy/dx)*180/Pi; - if dx<0 then - phi := phi + 180; - end; - pz := trunc(phi/part); - phi := phi - pz*part; - if phi>part/2 then - phi := part - phi; - b := (InternalRadius+1)*cos(part/2*Pi/180); - c := (InternalRadius+1)*sin(part/2*Pi/180); - r := sqrt(dx*dx+dy*dy); - dx := r * cos(phi*Pi/180); - dy := r * sin(phi*Pi/180); - Result := c*(dx-a) < dy*(b-a); -end; - -//------ PictureABC ------ -procedure PictureABC.Init(x,y: integer; fname: string); -begin - sx := 1; - sy := 1; - p := Picture.Create(fname); - p.Transparent := False; - inherited Init(x,y,p.Width,p.Height,clBlack); -end; - -procedure PictureABC.Init(x,y: integer; p: Picture); -begin - sx := 1; - sy := 1; - Self.p := p; - inherited Init(x,y,p.Width,p.Height,clBlack); -end; - -procedure PictureABC.InitBy(g: PictureABC); -begin - inherited InitBy(g); - sx := g.sx; - sy := g.sy; - p := g.p; -end; - -constructor PictureABC.Create(x,y: integer; fname: string); -begin - Init(x,y,fname); - InternalDraw; -end; - -constructor PictureABC.Create(g: PictureABC); -begin - InitBy(g); -end; - -constructor PictureABC.Create(x,y: integer; p: Picture); -begin - sx := 1; - sy := 1; - Self.p := p; - inherited Init(x,y,p.Width,p.Height,clBlack); - InternalDraw; -end; - -procedure PictureABC.DrawAfterChangePicture(var oldRect: GRectangle); -begin - fw := round(abs(sx)*p.Width) + 1; - fh := round(abs(sy)*p.Height) + 1; - if not __LockDrawingObjects then - DrawAfterChangeBounds(oldRect,Bounds) -end; - -procedure PictureABC.ChangePicture(fname: string); -var r: GRectangle; -begin - r := Bounds; - p.Load(fname); - p.Transparent := False; - DrawAfterChangePicture(r); -end; - -procedure PictureABC.ChangePicture(p: Picture); -var r: GRectangle; -begin - r := Bounds; - Self.p := p; - p.Transparent := False; - DrawAfterChangePicture(r); -end; - -procedure PictureABC.Draw(x,y: integer; g: Graphics); -var bw,bh: integer; -begin - LockGraphics; - if (sx=1) and (sy=1) then - p.Draw(x,y,g) - else - begin - bw := p.Width; - bh := p.Height; - if sx<0 then - x := x - round(bw*sx); - if sy<0 then - y := y - round(bh*sy); - p.Draw(x,y,round(bw*sx),round(bh*sy),g); - end; - DrawText(x,y,g); - UnLockGraphics; -end; - -procedure PictureABC.SetWidth(Width: integer); -begin - if Width<=0 then - exit; - if sx>0 then - sx := Width/p.Width - else sx := -Width/p.Width; - inherited SetWidth(Width); -end; - -procedure PictureABC.SetHeight(Height: integer); -begin - if Height<=0 then - exit; - if sy>0 then - sy := Height/p.Height - else sy := -Height/p.Height; - inherited SetHeight(Height); -end; - -procedure PictureABC.SetTransparent(tt: boolean); -begin - if p.Transparent = tt then Exit; - p.Transparent := tt; - Redraw; -end; - -function PictureABC.GetTransparent: boolean; -begin - Result := p.Transparent; -end; - -procedure PictureABC.SetTransparentColor(c: GColor); -begin - if p.TransparentColor = c then Exit; - p.TransparentColor := c; - Redraw; -end; - -function PictureABC.GetTransparentColor: GColor; -begin - Result := p.TransparentColor; -end; - -procedure PictureABC.SetScaleX(ssx: real); -var r: GRectangle; -begin - if sx=ssx then exit; - r := Bounds; - fw := round(abs(ssx)*p.Width)+1; - sx := ssx; - if not __LockDrawingObjects then - DrawAfterChangeBounds(r,Bounds) -end; - -procedure PictureABC.SetScaleY(ssy: real); -var r: GRectangle; -begin - if sy=ssy then exit; - r := Bounds; - fh := round(abs(ssy)*p.Height)+1; - sy := ssy; - if not __LockDrawingObjects then - DrawAfterChangeBounds(r,Bounds) -end; - -procedure PictureABC.Save(fname: string); -begin - p.Save(fname); -end; - -procedure PictureABC.FlipVertical; -begin - p.FlipVertical; - Redraw; -end; - -procedure PictureABC.FlipHorizontal; -begin - p.FlipHorizontal; - Redraw; -end; - -function PictureABC.Clone0: ObjectABC; -begin - Result := new PictureABC(Self) -end; - -function PictureABC.Clone: PictureABC; -begin - Result := new PictureABC(Self) -end; - -//------ MultiPictureABC ------ -procedure MultiPictureABC.Init(x,y: integer; fname: string); -begin - cur := 1; - cnt := 1; - inherited Init(x,y,fname); -end; - -procedure MultiPictureABC.Init(x,y: integer; p: Picture); -begin - cur := 1; - cnt := 1; - inherited Init(x,y,p); -end; - -procedure MultiPictureABC.Init(x,y,w: integer; fname: string); -begin - p := Picture.Create(fname); - p.Transparent := True; - if p.Width mod w <> 0 then - raise Exception.Create('Неверно задана ширина картинки'); - cur := 1; - cnt := p.Width div w; - inherited Init(x,y,p); - fw := w; -end; - -procedure MultiPictureABC.Init(x,y,w: integer; p: Picture); -begin - Self.p := p; - if p.Width mod w <> 0 then - raise Exception.Create('Неверно задана ширина картинки'); - cur := 1; - cnt := p.Width div w; - inherited Init(x,y,p); - fw := w; -end; - -procedure MultiPictureABC.InitBy(g: MultiPictureABC); -begin - inherited InitBy(g); - cur := g.cur; - cnt := g.cnt; -end; - -constructor MultiPictureABC.Create(x,y: integer; fname: string); -begin - Init(x,y,fname); - InternalDraw; -end; - -constructor MultiPictureABC.Create(x,y: integer; p: Picture); -begin - Init(x,y,p); - InternalDraw; -end; - -constructor MultiPictureABC.Create(x,y,w: integer; fname: string); -begin - Init(x,y,w,fname); - InternalDraw; -end; - -constructor MultiPictureABC.Create(x,y,w: integer; p: Picture); -begin - Init(x,y,w,p); - InternalDraw; -end; - -constructor MultiPictureABC.Create(g: MultiPictureABC); -begin - InitBy(g); -end; - -procedure MultiPictureABC.Draw(x,y: integer; g: Graphics); -begin - LockGraphics; - p.Draw(x,y,new System.Drawing.Rectangle((cur-1)*Width,0,Width,Height),g); - UnLockGraphics; -end; - -procedure MultiPictureABC.ChangePicture(fname: string); -begin - p.Load(fname); - cur := 1; - cnt := 1; - Width := p.Width; - Height := p.Height; - Redraw; -end; - -procedure MultiPictureABC.ChangePicture(w: integer; fname: string); -begin - p.Load(fname); - if p.Width mod w <> 0 then - raise Exception.Create('Неверно задана ширина картинки'); - cur := 1; - cnt := p.Width div w; - Width := w; - Height := p.Height; - Redraw; -end; - -procedure MultiPictureABC.Add(fname: string); -var - p1: Picture; - r,r1: System.Drawing.Rectangle; -begin - Inc(cnt); - p1 := Picture.Create(fname); - if (p1.Width<>Width) or (p1.Height<>Height) then - raise Exception.Create('Размеры картинки в файле '+fname+' отличаются от размеров MultiPictureABC'); - p1.Transparent := Transparent; - p.Width := p.Width + Width; - r1 := new System.Drawing.Rectangle(0,0,Width,Height); - r := new System.Drawing.Rectangle((cnt-1)*Width,0,Width,Height); - p.CopyRect(r,p1,r1); -end; - -procedure MultiPictureABC.SetCurrentPicture(i: integer); -begin - if (i<1) or (i>Count) then - raise Exception.Create('Номер картинки '+IntToStr(i)+' находится вне диапазона '+IntToStr(i)+'..'+IntToStr(Count)); - cur := i; - Redraw; -end; - -procedure MultiPictureABC.NextPicture; -begin - if cur>=cnt then - CurrentPicture:=1 - else CurrentPicture:=cur+1 -end; - -procedure MultiPictureABC.PrevPicture; -begin - if cur=1 then - CurrentPicture:=cnt - else CurrentPicture:=cur-1 -end; - -function MultiPictureABC.Clone0: ObjectABC; -begin - Result := new MultiPictureABC(Self); -end; - -function MultiPictureABC.Clone: MultiPictureABC; -begin - Result := new MultiPictureABC(Self); -end; - -//------ ContainerABC ------ -procedure ContainerABC.Init(x,y: integer); -begin - l := new System.Collections.ArrayList; - inherited Init(x,y,0,0,clWhite); -end; - -procedure ContainerABC.InitBy(g: ContainerABC); -var - i: integer; - ob: ObjectABC; -begin - l := new System.Collections.ArrayList; - inherited InitBy(g); - for i:=0 to g.Count-1 do - begin - ob := g[i].Clone0; - ob.Owner := Self; - end; -end; - -constructor ContainerABC.Create(x,y: integer); -begin - Init(x,y); -end; - -constructor ContainerABC.Create(g: ContainerABC); -begin - InitBy(g); -end; - -procedure ContainerABC.SetItem(i: integer; o: ObjectABC); -begin - l[i] := o; -end; - -function ContainerABC.GetItem(i: integer): ObjectABC; -begin - Result := ObjectABC(l[i]) -end; - -procedure ContainerABC.Add(g: ObjectABC); -var - b: boolean; -begin -{ if Self is UIElementABC then - exit;} - b := g.Visible; - g.Visible := False; - __l.Remove(g); - l.Add(g); - g.ow := Self; - g.Visible := b; - RecalcBounds; - Redraw; -end; - -procedure ContainerABC.Remove(g: ObjectABC); -begin - l.Remove(g); -end; - -procedure ContainerABC.Draw(x,y: integer; g: Graphics); -var - i: integer; - ob: ObjectABC; -begin - LockGraphics; - for i:=0 to l.Count-1 do - begin - ob := ObjectABC(l[i]); - if ob.Visible then - ob.Draw(x+ob.Left,y+ob.Top,g); - end; - UnLockGraphics; -end; - -function ContainerABC.PtInside(x,y:integer): boolean; -var - i: integer; - g: ObjectABC; -begin - Result:=False; - for i:=0 to l.Count-1 do - begin - g := ObjectABC(l[i]); - if g.PtInside(x-Left,y-Top) then - begin - Result := True; - Exit; - end; - end; -end; - -procedure ContainerABC.SetWidth(Width: integer); -var - i: integer; - scale: real; - g: ObjectABC; -begin - if Self.Width = 0 then - Exit; - scale := Width/Self.Width; - for i:=0 to l.Count-1 do - begin - g := ObjectABC(l[i]); - g.Left := round(g.Left*scale); - g.Width := round(g.Width*scale); - end; - inherited SetWidth(Width); -end; - -procedure ContainerABC.SetHeight(Height: integer); -var - i: integer; - scale: real; - g: ObjectABC; -begin - if Self.Height=0 then Exit; - scale:=Height/Self.Height; - for i:=1 to l.Count do - begin - g := ObjectABC(l[i]); - g.Top := round(g.Top*scale); - g.Height := round(g.Height*scale); - end; - inherited SetHeight(Height); -end; - -procedure ContainerABC.RecalcBounds; -var - i: integer; - r: GRectangle; -begin - if Count=0 then Exit; - r := ObjectABC(l[0]).Bounds; - for i:=1 to l.Count-1 do - r := GRectangle.Union(r,ObjectABC(l[i]).Bounds); - fx := fx + r.Left; - fy := fy + r.Top; - fw := r.Right - r.Left; - fh := r.Bottom - r.Top; - for i:=0 to l.Count-1 do - ObjectABC(l[i]).SetCoords(ObjectABC(l[i]).Left-r.Left,ObjectABC(l[i]).Top-r.Top); -end; - -procedure ContainerABC.UnLink(g: ObjectABC); -begin - l.Remove(g); - Redraw; - RecalcBounds; -end; - -function ContainerABC.Clone0: ObjectABC; -begin - Result := new ContainerABC(Self); -end; - -function ContainerABC.Clone: ContainerABC; -begin - Result := new ContainerABC(Self); -end; - -function ContainerABC.GetCount: integer; -begin - Result := l.Count; -end; - -//------ BoardABC ------ -procedure BoardABC.Init(x,y,nx,ny,sszx,sszy: integer; cl: GColor); -begin - Self.nx := nx; - Self.ny := ny; - szx := sszx; - szy := sszy; - inherited Init(x,y,nx*szx+1,ny*szy+1,cl); -end; - -procedure BoardABC.InitBy(g: BoardABC); -begin - nx := g.nx; - ny := g.ny; - szx := g.szx; - szy := g.szy; - inherited InitBy(g); -end; - -constructor BoardABC.Create(x,y,nx,ny,sszx,sszy: integer; cl: GColor); -begin - Init(x,y,nx,ny,sszx,sszy,cl); - InternalDraw; -end; - -constructor BoardABC.Create(g: BoardABC); -begin - InitBy(g); -end; - -procedure BoardABC.SetNX(nnx: integer); -var r: GRectangle; -begin - if nx = nnx then - Exit; - r := Bounds; - nx := nnx; - if not __LockDrawingObjects then - DrawAfterChangeBounds(r,Bounds) -end; - -procedure BoardABC.SetNY(nny: integer); -var r: GRectangle; -begin - if ny = nny then - Exit; - r := Bounds; - ny := nny; - if not __LockDrawingObjects then - DrawAfterChangeBounds(r,Bounds) -end; - -procedure BoardABC.SetSzX(sszx: integer); -var r: GRectangle; -begin - if szx = sszx then - Exit; - r := Bounds; - szx := sszx; - if not __LockDrawingObjects then - DrawAfterChangeBounds(r,Bounds) -end; - -procedure BoardABC.SetSzY(sszy: integer); -var r: GRectangle; -begin - if szy = sszy then - Exit; - r := Bounds; - szy := sszy; - if not __LockDrawingObjects then - DrawAfterChangeBounds(r,Bounds) -end; - -procedure BoardABC.Draw(x,y: integer; g: Graphics); -var i: integer; -begin - SetDrawSettings; - LockGraphics; - FillRectangle(x,y,x+Width,y+Height,g); - for i:=0 to nx do - Line(x+i*szx,y,x+i*szx,y+Height-1,g); - for i:=0 to ny do - Line(x,y+i*szy,x+Width-1,y+i*szy,g); - UnLockGraphics; -end; - -function BoardABC.Clone0: ObjectABC; -begin - Result := new BoardABC(Self); -end; - -function BoardABC.Clone: BoardABC; -begin - Result := new BoardABC(Self); -end; - -//------ ObjectBoardABC ------ -procedure ObjectBoardABC.Init(x,y,nn,mm,sszx,sszy: integer; cl: GColor); -var i: integer; -begin - inherited Init(x,y,nn,mm,sszx,sszy,cl); - SetLength(ar,nn*mm); - for i:=0 to nn*mm-1 do - ar[i] := nil; -end; - -procedure ObjectBoardABC.InitBy(g: ObjectBoardABC); -var i: integer; -begin - inherited InitBy(g); - SetLength(ar,g.ar.Length); - for i:=0 to g.ar.Length-1 do - ar[i] := g.ar[i].Clone; -end; - -constructor ObjectBoardABC.Create(x,y,nn,mm,sszx,sszy: integer; cl: GColor); -begin - Init(x,y,nn,mm,sszx,sszy,cl); - InternalDraw; -end; - -constructor ObjectBoardABC.Create(g: ObjectBoardABC); -begin - InitBy(g); -end; - -procedure ObjectBoardABC.CreateRectangleABC(x,y,w,h: integer; c: GColor); -begin - SetObject(x,y,new RectangleABC(0,0,w,h,c)); -end; - -procedure ObjectBoardABC.DestroyObject(x,y: integer); -begin - if Self[x,y]<>nil then - begin - Self[x,y].Destroy; - Self[x,y] := nil; - end; -end; - -procedure ObjectBoardABC.SetObject(x,y: integer; ob: ObjectABC); -begin - ar[(y-1)*DimX + x - 1] := ob; - if ob=nil then - Exit; - ob.dx := x; - ob.dy := y; // использую dx и dy для задания клеточных координат на доске - ob.Center := new Point(Left+CellSizeX*(x-1)+CellSizeX div 2,Top+CellSizeY*(y-1)+CellSizeY div 2); -end; - -function ObjectBoardABC.GetObject(x,y: integer): ObjectABC; -begin - Result := ar[(y-1)*DimX + x - 1]; -end; - -function ObjectBoardABC.GetRectangle(x,y: integer): RectangleABC; -begin - Result := RectangleABC(ar[(y-1)*DimX + x - 1]); -end; - -procedure ObjectBoardABC.SwapObjects(x1,y1,x2,y2: integer); -var - ob1,ob2: ObjectABC; - csx,csy: integer; -begin - ob1 := Self[x1,y1]; - ob2 := Self[x2,y2]; - Self[x1,y1] := ob2; - Self[x2,y2] := ob1; - csx := CellSizeX; - csy := CellSizeY; - - if ob1<>nil then - begin - ob1.dx := x2; - ob1.dy := y2; - ob1.Center := new Point(Left+csx*(x2-1)+csx div 2,Top+csy*(y2-1)+csy div 2); - end; - - if ob2<>nil then - begin - ob2.dx := x1; - ob2.dy := y1; - ob2.Center := new Point(Left+csx*(x1-1)+csx div 2,Top+csy*(y1-1)+csy div 2); - end; -end; - -function ObjectBoardABC.Clone0: ObjectABC; -begin - Result := new ObjectBoardABC(Self); -end; - -function ObjectBoardABC.Clone: ObjectBoardABC; -begin - Result := new ObjectBoardABC(Self); -end; - -//------ ObjectsABCArray ------ -constructor ObjectsABCArray.Create(ll: System.Collections.ArrayList); -begin - l := ll; -end; - -function ObjectsABCArray.GetCount: integer; -begin - Result := l.Count; -end; - -procedure ObjectsABCArray.SetItem(i: integer; o: ObjectABC); -begin - l[i] := o; -end; - -function ObjectsABCArray.GetItem(i: integer): ObjectABC; -begin - Result := ObjectABC(l[i]) -end; - -initialization - __l := new System.Collections.ArrayList; - __lUI := new System.Collections.ArrayList; - Objects := new ObjectsABCArray(__l); - tempbmp := new Bitmap(System.Windows.Forms.Screen.PrimaryScreen.Bounds.Width,System.Windows.Forms.Screen.PrimaryScreen.Bounds.Height); - RedrawProc := ABCRedrawProc; -end. \ No newline at end of file diff --git a/bin/Lib/LibForVB/ABCObjects/GraphABC.pas b/bin/Lib/LibForVB/ABCObjects/GraphABC.pas deleted file mode 100644 index e048d4f68..000000000 --- a/bin/Lib/LibForVB/ABCObjects/GraphABC.pas +++ /dev/null @@ -1,3092 +0,0 @@ -///Модуль предоставляет константы, типы, процедуры, функции и классы для рисования в графическом окне -unit GraphABC; - -//ne udaljat, IB 7.10.08 -#apptype windows -#reference 'System.Windows.Forms.dll' -#reference 'System.Drawing.dll' -//#gendoc true -#savepcu false - -interface - -uses - System, - System.Drawing, - System.Windows.Forms, - System.Drawing.Drawing2D; - -type -/// Тип цвета - Color = System.Drawing.Color; -/// Тип стиля штриховки кисти - HatchStyle = System.Drawing.Drawing2D.HatchStyle; -/// Тип стиля штриховки пера - DashStyle = System.Drawing.Drawing2D.DashStyle; -/// Тип исключения GraphABC - GraphABCException = class(Exception) end; -/// Тип точки - Point = System.Drawing.Point; - -var - clMoneyGreen: Color; - -const - // Default graph window size - defaultWindowWidth = 640; - defaultWindowHeight = 480; - - // Color constants - clAquamarine = Color.Aquamarine; clAzure = Color.Azure; - clBeige = Color.Beige; clBisque = Color.Bisque; - clBlack = Color.Black; clBlanchedAlmond = Color.BlanchedAlmond; - clBlue = Color.Blue; clBlueViolet = Color.BlueViolet; - clBrown = Color.Brown; clBurlyWood = Color.BurlyWood; - clCadetBlue = Color.CadetBlue; clChartreuse = Color.Chartreuse; - clChocolate = Color.Chocolate; clCoral = Color.Coral; - clCornflowerBlue = Color.CornflowerBlue; clCornsilk = Color.Cornsilk; - clCrimson = Color.Crimson; clCyan = Color.Cyan; - clDarkBlue = Color.DarkBlue; clDarkCyan = Color.DarkCyan; - clDarkGoldenrod = Color.DarkGoldenrod; clDarkGray = Color.DarkGray; - clDarkGreen = Color.DarkGreen; clDarkKhaki = Color.DarkKhaki; - clDarkMagenta = Color.DarkMagenta; clDarkOliveGreen = Color.DarkOliveGreen; - clDarkOrange = Color.DarkOrange; clDarkOrchid = Color.DarkOrchid; - clDarkRed = Color.DarkRed; clDarkTurquoise = Color.DarkTurquoise; - clDarkSeaGreen = Color.DarkSeaGreen; clDarkSlateBlue = Color.DarkSlateBlue; - clDarkSlateGray = Color.DarkSlateGray; clDarkViolet = Color.DarkViolet; - clDeepPink = Color.DeepPink; clDarkSalmon = Color.DarkSalmon; - clDeepSkyBlue = Color.DeepSkyBlue; clDimGray = Color.DimGray; - clDodgerBlue = Color.DodgerBlue; clFirebrick = Color.Firebrick; - clFloralWhite = Color.FloralWhite; clForestGreen = Color.ForestGreen; - clFuchsia = Color.Fuchsia; clGainsboro = Color.Gainsboro; - clGhostWhite = Color.GhostWhite; clGold = Color.Gold; - clGoldenrod = Color.Goldenrod; clGray = Color.Gray; - clGreen = Color.Green; clGreenYellow = Color.GreenYellow; - clHoneydew = Color.Honeydew; clHotPink = Color.HotPink; - clIndianRed = Color.IndianRed; clIndigo = Color.Indigo; - clIvory = Color.Ivory; clKhaki = Color.Khaki; - clLavender = Color.Lavender; clLavenderBlush = Color.LavenderBlush; - clLawnGreen = Color.LawnGreen; clLemonChiffon = Color.LemonChiffon; - clLightBlue = Color.LightBlue; clLightCoral = Color.LightCoral; - clLightCyan = Color.LightCyan; clLightGray = Color.LightGray; - clLightGreen = Color.LightGreen; clLightGoldenrodYellow = Color.LightGoldenrodYellow; - clLightPink = Color.LightPink; clLightSalmon = Color.LightSalmon; - clLightSeaGreen = Color.LightSeaGreen; clLightSkyBlue = Color.LightSkyBlue; - clLightSlateGray = Color.LightSlateGray; clLightSteelBlue = Color.LightSteelBlue; - clLightYellow = Color.LightYellow; clLime = Color.Lime; - clLimeGreen = Color.LimeGreen; clLinen = Color.Linen; - clMagenta = Color.Magenta; clMaroon = Color.Maroon; - clMediumBlue = Color.MediumBlue; clMediumOrchid = Color.MediumOrchid; - clMediumAquamarine = Color.MediumAquamarine; clMediumPurple = Color.MediumPurple; - clMediumSeaGreen = Color.MediumSeaGreen; clMediumSlateBlue = Color.MediumSlateBlue; - clPlum = Color.Plum; clMistyRose = Color.MistyRose; - clNavy = Color.Navy; clMidnightBlue = Color.MidnightBlue; - clMintCream = Color.MintCream; clMediumSpringGreen = Color.MediumSpringGreen; - clMoccasin = Color.Moccasin; clNavajoWhite = Color.NavajoWhite; - clMediumTurquoise = Color.MediumTurquoise; clOldLace = Color.OldLace; - clOlive = Color.Olive; clOliveDrab = Color.OliveDrab; - clOrange = Color.Orange; clOrangeRed = Color.OrangeRed; - clOrchid = Color.Orchid; clPaleGoldenrod = Color.PaleGoldenrod; - clPaleGreen = Color.PaleGreen; clPaleTurquoise = Color.PaleTurquoise; - clPaleVioletRed = Color.PaleVioletRed; clPapayaWhip = Color.PapayaWhip; - clPeachPuff = Color.PeachPuff; clPeru = Color.Peru; - clPink = Color.Pink; clMediumVioletRed = Color.MediumVioletRed; - clPowderBlue = Color.PowderBlue; clPurple = Color.Purple; - clRed = Color.Red; clRosyBrown = Color.RosyBrown; - clRoyalBlue = Color.RoyalBlue; clSaddleBrown = Color.SaddleBrown; - clSalmon = Color.Salmon; clSandyBrown = Color.SandyBrown; - clSeaGreen = Color.SeaGreen; clSeaShell = Color.SeaShell; - clSienna = Color.Sienna; clSilver = Color.Silver; - clSkyBlue = Color.SkyBlue; clSlateBlue = Color.SlateBlue; - clSlateGray = Color.SlateGray; clSnow = Color.Snow; - clSpringGreen = Color.SpringGreen; clSteelBlue = Color.SteelBlue; - clTan = Color.Tan; clTeal = Color.Teal; - clThistle = Color.Thistle; clTomato = Color.Tomato; - clTransparent = Color.Transparent; clTurquoise = Color.Turquoise; - clViolet = Color.Violet; clWheat = Color.Wheat; - clWhite = Color.White; clWhiteSmoke = Color.WhiteSmoke; - clYellow = Color.Yellow; clYellowGreen = Color.YellowGreen; - -// Virtual Key Codes - VK_Back = 8; VK_Tab = 9; - VK_LineFeed = 10; VK_Enter = 13; - VK_Return = 13; VK_ShiftKey = 16; VK_ControlKey = 17; - VK_Menu = 18; VK_Pause = 19; VK_CapsLock = 20; - VK_Capital = 20; - VK_Escape = 27; - VK_Space = 32; - VK_Prior = 33; VK_PageUp = 33; VK_PageDown = 34; - VK_Next = 34; VK_End = 35; VK_Home = 36; - VK_Left = 37; VK_Up = 38; VK_Right = 39; - VK_Down = 40; VK_Select = 41; VK_Print = 42; - VK_Snapshot = 44; VK_PrintScreen = 44; - VK_Insert = 45; VK_Delete = 46; VK_Help = 47; - VK_A = 65; VK_B = 66; - VK_C = 67; VK_D = 68; VK_E = 69; - VK_F = 70; VK_G = 71; VK_H = 72; - VK_I = 73; VK_J = 74; VK_K = 75; - VK_L = 76; VK_M = 77; VK_N = 78; - VK_O = 79; VK_P = 80; VK_Q = 81; - VK_R = 82; VK_S = 83; VK_T = 84; - VK_U = 85; VK_V = 86; VK_W = 87; - VK_X = 88; VK_Y = 89; VK_Z = 90; - VK_LWin = 91; VK_RWin = 92; VK_Apps = 93; - VK_Sleep = 95; VK_NumPad0 = 96; VK_NumPad1 = 97; - VK_NumPad2 = 98; VK_NumPad3 = 99; VK_NumPad4 = 100; - VK_NumPad5 = 101; VK_NumPad6 = 102; VK_NumPad7 = 103; - VK_NumPad8 = 104; VK_NumPad9 = 105; VK_Multiply = 106; - VK_Add = 107; VK_Separator = 108; VK_Subtract = 109; - VK_Decimal = 110; VK_Divide = 111; VK_F1 = 112; - VK_F2 = 113; VK_F3 = 114; VK_F4 = 115; - VK_F5 = 116; VK_F6 = 117; VK_F7 = 118; - VK_F8 = 119; VK_F9 = 120; VK_F10 = 121; - VK_F11 = 122; VK_F12 = 123; VK_NumLock = 144; - VK_Scroll = 145; VK_LShiftKey = 160; VK_RShiftKey = 161; - VK_LControlKey = 162; VK_RControlKey = 163; VK_LMenu = 164; - VK_RMenu = 165; - VK_KeyCode = 65535; VK_Shift = 65536; VK_Control = 131072; - VK_Alt = 262144; VK_Modifiers = -65536; - -// Pen style constants - psSolid = DashStyle.Solid; - psClear = DashStyle.Custom; - psDash = DashStyle.Dash; - psDot = DashStyle.Dot; - psDashDot = DashStyle.DashDot; - psDashDotDot = DashStyle.DashDotDot; - -// Pen mode constants - pmCopy = 0; - pmNot = 1; - -// Brush hatch type constants - bhHorizontal = HatchStyle.Horizontal; - bhMin = HatchStyle.Min; - bhVertical = HatchStyle.Vertical; - bhForwardDiagonal = HatchStyle.ForwardDiagonal; - bhBackwardDiagonal = HatchStyle.BackwardDiagonal; - bhCross = HatchStyle.Cross; - bhLargeGrid = HatchStyle.LargeGrid; - bhMax = HatchStyle.Max; - bhDiagonalCross = HatchStyle.DiagonalCross; - bhPercent05 = HatchStyle.Percent05; - bhPercent10 = HatchStyle.Percent10; - bhPercent20 = HatchStyle.Percent20; - bhPercent25 = HatchStyle.Percent25; - bhPercent30 = HatchStyle.Percent30; - bhPercent40 = HatchStyle.Percent40; - bhPercent50 = HatchStyle.Percent50; - bhPercent60 = HatchStyle.Percent60; - bhPercent70 = HatchStyle.Percent70; - bhPercent75 = HatchStyle.Percent75; - bhPercent80 = HatchStyle.Percent80; - bhPercent90 = HatchStyle.Percent90; - bhLightDownwardDiagonal = HatchStyle.LightDownwardDiagonal; - bhLightUpwardDiagonal = HatchStyle.LightUpwardDiagonal; - bhDarkDownwardDiagonal = HatchStyle.DarkDownwardDiagonal; - bhDarkUpwardDiagonal = HatchStyle.DarkUpwardDiagonal; - bhWideDownwardDiagonal = HatchStyle.WideDownwardDiagonal; - bhWideUpwardDiagonal = HatchStyle.WideUpwardDiagonal; - bhLightVertical = HatchStyle.LightVertical; - bhLightHorizontal = HatchStyle.LightHorizontal; - bhNarrowVertical = HatchStyle.NarrowVertical; - bhNarrowHorizontal = HatchStyle.NarrowHorizontal; - bhDarkVertical = HatchStyle.DarkVertical; - bhDarkHorizontal = HatchStyle.DarkHorizontal; - bhDashedDownwardDiagonal = HatchStyle.DashedDownwardDiagonal; - bhDashedUpwardDiagonal = HatchStyle.DashedUpwardDiagonal; - bhDashedHorizontal = HatchStyle.DashedHorizontal; - bhDashedVertical = HatchStyle.DashedVertical; - bhSmallConfetti = HatchStyle.SmallConfetti; - bhLargeConfetti = HatchStyle.LargeConfetti; - bhZigZag = HatchStyle.ZigZag; - bhWave = HatchStyle.Wave; - bhDiagonalBrick = HatchStyle.DiagonalBrick; - bhHorizontalBrick = HatchStyle.HorizontalBrick; - bhWeave = HatchStyle.Weave; - bhPlaid = HatchStyle.Plaid; - bhDivot = HatchStyle.Divot; - bhDottedGrid = HatchStyle.DottedGrid; - bhDottedDiamond = HatchStyle.DottedDiamond; - bhShingle = HatchStyle.Shingle; - bhTrellis = HatchStyle.Trellis; - bhSphere = HatchStyle.Sphere; - bhSmallGrid = HatchStyle.SmallGrid; - bhSmallCheckerBoard = HatchStyle.SmallCheckerBoard; - bhLargeCheckerBoard = HatchStyle.LargeCheckerBoard; - bhOutlinedDiamond = HatchStyle.OutlinedDiamond; - bhSolidDiamond = HatchStyle.SolidDiamond; - -// Font & Brush style constants -type - FontStyleType = (fsNormal, fsBold, fsItalic, fsBoldItalic, fsUnderline, fsBoldUnderline, fsItalicUnderline, fsBoldItalicUnderline); - BrushStyleType = (bsSolid, bsClear, bsHatch, bsGradient, bsNone); - -/// Закрашивает пиксел с координатами (x,y) цветом c -procedure SetPixel(x,y: integer; c: Color); -/// Закрашивает пиксел с координатами (x,y) цветом c -procedure PutPixel(x,y: integer; c: Color); -/// Возвращает цвет пиксела с координатами (x,y) -function GetPixel(x,y: integer): Color; - -/// Устанавливает текущую позицию рисования в точку (x,y) -procedure MoveTo(x,y: integer); -/// Рисует отрезок от текущей позиции до точки (x,y). Текущая позиция переносится в точку (x,y) -procedure LineTo(x,y: integer); -/// Рисует отрезок от текущей позиции до точки (x,y) цветом c. Текущая позиция переносится в точку (x,y) -procedure LineTo(x,y: integer; c: Color); - -/// Рисует отрезок от точки (x1,y1) до точки (x2,y2) -procedure Line(x1,y1,x2,y2: integer); -/// Рисует отрезок от точки (x1,y1) до точки (x2,y2) цветом c -procedure Line(x1,y1,x2,y2: integer; c: Color); - -/// Заполняет внутренность окружности с центром (x,y) и радиусом r -procedure FillCircle(x,y,r: integer); -/// Рисует окружность с центром (x,y) и радиусом r -procedure DrawCircle(x,y,r: integer); -/// Заполняет внутренность эллипса, ограниченного прямоугольником, заданным координатами противоположных вершин (x1,y1) и (x2,y2) -procedure FillEllipse(x1,y1,x2,y2: integer); -/// Рисует границу эллипса, ограниченного прямоугольником, заданным координатами противоположных вершин (x1,y1) и (x2,y2) -procedure DrawEllipse(x1,y1,x2,y2: integer); -/// Заполняет внутренность прямоугольника, заданного координатами противоположных вершин (x1,y1) и (x2,y2) -procedure FillRectangle(x1,y1,x2,y2: integer); -/// Заполняет внутренность прямоугольника, заданного координатами противоположных вершин (x1,y1) и (x2,y2) -procedure FillRect(x1,y1,x2,y2: integer); -/// Рисует границу прямоугольника, заданного координатами противоположных вершин (x1,y1) и (x2,y2) -procedure DrawRectangle(x1,y1,x2,y2: integer); -/// Заполняет внутренность прямоугольника со скругленными краями; (x1,y1) и (x2,y2) задают пару противоположных вершин, а w и h – ширину и высоту эллипса, используемого для скругления краев -procedure FillRoundRect(x1,y1,x2,y2,w,h: integer); -/// Рисует границу прямоугольника со скругленными краями; (x1,y1) и (x2,y2) задают пару противоположных вершин, а w и h – ширину и высоту эллипса, используемого для скругления краев -procedure DrawRoundRect(x1,y1,x2,y2,w,h: integer); - -/// Рисует заполненную окружность с центром (x,y) и радиусом r -procedure Circle(x,y,r: integer); -/// Рисует заполненный эллипс, ограниченный прямоугольником, заданным координатами противоположных вершин (x1,y1) и (x2,y2) -procedure Ellipse(x1,y1,x2,y2: integer); -/// Рисует заполненный прямоугольник, заданный координатами противоположных вершин (x1,y1) и (x2,y2) -procedure Rectangle(x1,y1,x2,y2: integer); -/// Рисует заполненный прямоугольник со скругленными краями; (x1,y1) и (x2,y2) задают пару противоположных вершин, а w и h – ширину и высоту эллипса, используемого для скругления краев -procedure RoundRect(x1,y1,x2,y2,w,h: integer); - -/// Рисует дугу окружности с центром в точке (x,y) и радиусом r, заключенной между двумя лучами, образующими углы a1 и a2 с осью OX (a1 и a2 – вещественные, задаются в градусах и отсчитываются против часовой стрелки) -procedure Arc(x,y,r,a1,a2: integer); -/// Заполняет внутренность сектора окружности, ограниченного дугой с центром в точке (x,y) и радиусом r, заключенной между двумя лучами, образующими углы a1 и a2 с осью OX (a1 и a2 – вещественные, задаются в градусах и отсчитываются против часовой стрелки) -procedure FillPie(x,y,r,a1,a2: integer); -/// Рисует сектор окружности, ограниченный дугой с центром в точке (x,y) и радиусом r, заключенной между двумя лучами, образующими углы a1 и a2 с осью OX (a1 и a2 – вещественные, задаются в градусах и отсчитываются против часовой стрелки) -procedure DrawPie(x,y,r,a1,a2: integer); -/// Рисует заполненный сектор окружности, ограниченный дугой с центром в точке (x,y) и радиусом r, заключенной между двумя лучами, образующими углы a1 и a2 с осью OX (a1 и a2 – вещественные, задаются в градусах и отсчитываются против часовой стрелки) -procedure Pie(x,y,r,a1,a2: integer); - -/// Рисует замкнутую ломаную по точкам, координаты которых заданы в массиве points -procedure DrawPolygon(points: array of Point); -/// Заполняет многоугольник, координаты вершин которого заданы в массиве points -procedure FillPolygon(points: array of Point); -/// Рисует заполненный многоугольник, координаты вершин которого заданы в массиве points -procedure Polygon(points: array of Point); -/// Рисует ломаную по точкам, координаты которых заданы в массиве points -procedure Polyline(points: array of Point); -/// Рисует кривую по точкам, координаты которых заданы в массиве points -procedure Curve(points: array of Point); -/// Рисует замкнутую кривую по точкам, координаты которых заданы в массиве points -procedure DrawClosedCurve(points: array of Point); -/// Заполняет замкнутую кривую по точкам, координаты которых заданы в массиве points -procedure FillClosedCurve(points: array of Point); -/// Рисует заполненную замкнутую кривую по точкам, координаты которых заданы в массиве points -procedure ClosedCurve(points: array of Point); - -/// Выводит строку s в прямоугольник к координатами левого верхнего угла (x,y) -procedure TextOut(x,y: integer; s: string); -/// Заливает область одного цвета цветом c, начиная с точки (x,y). -procedure FloodFill(x,y: integer; c: Color); - -{procedure FillCircle(x,y,r: integer; c: Color); -procedure DrawCircle(x,y,r: integer; c: Color); -procedure FillEllipse(x1,y1,x2,y2: integer; c: Color); -procedure DrawEllipse(x1,y1,x2,y2: integer; c: Color); -procedure FillRectangle(x1,y1,x2,y2: integer; c: Color); -procedure FillRect(x1,y1,x2,y2: integer; c: Color); -procedure DrawRectangle(x1,y1,x2,y2: integer; c: Color); -procedure DrawRoundRect(x1,y1,x2,y2,w,h: integer; c: Color); -procedure FillRoundRect(x1,y1,x2,y2,w,h: integer; c: Color); - -procedure Circle(x,y,r: integer; c: Color); -procedure Ellipse(x1,y1,x2,y2: integer; c: Color); -procedure Rectangle(x1,y1,x2,y2: integer; c: Color); -procedure RoundRect(x1,y1,x2,y2,w,h: integer; c: Color); - -procedure Arc(x,y,r,a1,a2: integer; c: Color); -procedure FillPie(x,y,r,a1,a2: integer; c: Color); -procedure DrawPie(x,y,r,a1,a2: integer; c: Color); -procedure Pie(x,y,r,a1,a2: integer; c: Color); - -procedure DrawPolygon(a: array of Point; c: Color); -procedure FillPolygon(a: array of Point; c: Color); -procedure Polygon(a: array of Point; c: Color); -procedure Polyline(a: array of Point; c: Color);} - -//-------------------------------------------- -//// Цвета -//-------------------------------------------- -/// Возвращает цвет, который содержит красную (r), зеленую (g) и синюю (b) составляющие (r,g и b - в диапазоне от 0 до 255) -function RGB(r,g,b: byte): Color; -/// Возвращает цвет, который содержит красную (r), зеленую (g) и синюю (b) составляющие и прозрачность (a) (a,r,g,b - в диапазоне от 0 до 255) -function ARGB(a,r,g,b: byte): Color; - -/// Возвращает красный цвет с интенсивностью r (r - в диапазоне от 0 до 255) -function RedColor(r: byte): Color; -/// Возвращает зеленый цвет с интенсивностью g (g - в диапазоне от 0 до 255) -function GreenColor(g: byte): Color; -/// Возвращает синий цвет с интенсивностью b (b - в диапазоне от 0 до 255) -function BlueColor(b: byte): Color; -/// Возвращает случайный цвет -function clRandom: Color; - -/// Возвращает красную составляющую цвета -function GetRed(c: Color): integer; -/// Возвращает зеленую составляющую цвета -function GetGreen(c: Color): integer; -/// Возвращает синюю составляющую цвета -function GetBlue(c: Color): integer; -/// Возвращает составляющую прозрачности цвета -function GetAlpha(c: Color): integer; - -//-------------------------------------------- -//// Перья -//-------------------------------------------- -/// Устанавливает цвет текущего пера -procedure SetPenColor(c: Color); -/// Возвращает цвет текущего пера -function PenColor: Color; -/// Устанавливает ширину текущего пера -procedure SetPenWidth(Width: integer); -/// Возвращает ширину текущего пера -function PenWidth: integer; -/// Устанавливает стиль текущего пера -procedure SetPenStyle(style: DashStyle); -/// Возвращает стиль текущего пера -function PenStyle: DashStyle; -/// Устанавливает режим текущего пера -procedure SetPenMode(m: integer); -/// Возвращает режим текущего пера -function PenMode: integer; - -/// Возвращают x-координату текущей позиции рисования -function PenX: integer; -/// Возвращают y-координату текущей позиции рисования -function PenY: integer; - -//-------------------------------------------- -//// Кисти -//-------------------------------------------- -/// Устанавливает цвет текущей кисти -procedure SetBrushColor(c: Color); -/// Возвращает цвет текущей кисти -function BrushColor: Color; -/// Устанавливает цвет текущей кисти -procedure SetBrushStyle(bs: BrushStyleType); -/// Возвращает цвет текущей кисти -function BrushStyle: BrushStyleType; -/// Устанавливает штриховку текущей кисти -procedure SetBrushHatch(bh: HatchStyle); -/// Возвращает штриховку текущей кисти -function BrushHatch: HatchStyle; -/// Устанавливает цвет заднего плана текущей штриховой кисти -procedure SetHatchBrushBackgroundColor(c: Color); -/// Возвращает цвет заднего плана текущей штриховой кисти -function HatchBrushBackgroundColor: Color; -/// Устанавливает второй цвет текущей градиентной кисти -procedure SetGradientBrushSecondColor(c: Color); -/// Возвращает второй цвет текущей градиентной кисти -function GradientBrushSecondColor: Color; - -//-------------------------------------------- -//// Шрифты -//-------------------------------------------- -/// Устанавливает размер текущего шрифта в пунктах -procedure SetFontSize(size: integer); -/// Возвращает размер текущего шрифта в пунктах -function FontSize: integer; -/// Устанавливает имя текущего шрифта -procedure SetFontName(name: string); -/// Возвращает имя текущего шрифта -function FontName: string; -/// Устанавливает цвет текущего шрифта -procedure SetFontColor(c: Color); -/// Возвращает цвет текущего шрифта -function FontColor: Color; -/// Устанавливает стиль текущего шрифта -procedure SetFontStyle(fs: FontStyleType); -/// Возвращает стиль текущего шрифта -function FontStyle: FontStyleType; -/// Возвращает ширину строки s в пикселях при текущих настройках шрифта -function TextWidth(s: string): integer; -/// Возвращает высоту строки s в пикселях при текущих настройках шрифта -function TextHeight(s: string): integer; - -//-------------------------------------------- -//// Графическое окно -//-------------------------------------------- -/// Очищает графическое окно белым цветом -procedure ClearWindow; -/// Очищает графическое окно цветом c -procedure ClearWindow(c: Color); - -/// Возвращает ширину клиентской части графического окна в пикселах -function WindowWidth: integer; -/// Возвращает высоту клиентской части графического окна в пикселах -function WindowHeight: integer; -/// Возвращает отступ графического окна от левого края экрана в пикселах -function WindowLeft: integer; -/// Возвращает отступ графического окна от верхнего края экрана в пикселах -function WindowTop: integer; -/// Возвращает центр графического окна -function WindowCenter: Point; -/// Возвращает True, если графическое окно имеет фиксированный размер, и False в противном случае -function WindowIsFixedSize: boolean; - -/// Устанавливает ширину клиентской части графического окна в пикселах -procedure SetWindowWidth(w: integer); -/// Устанавливает высоту клиентской части графического окна в пикселах -procedure SetWindowHeight(h: integer); -/// Устанавливает отступ графического окна от левого края экрана в пикселах -procedure SetWindowLeft(l: integer); -/// Устанавливает отступ графического окна от верхнего края экрана в пикселах -procedure SetWindowTop(t: integer); -/// Устанавливает, имеет ли графическое окно фиксированный размер -procedure SetWindowIsFixedSize(b: boolean); - -/// Устанавливает размеры клиентской части графического окна в пикселах -procedure SetWindowSize(w,h: integer); -/// Устанавливает отступ графического окна от левого верхнего края экрана в пикселах -procedure SetWindowPos(l,t: integer); - -/// Возвращает ширину графического компонента в пикселах (по умолчанию совпадает с WindowWidth) -function GraphBoxWidth: integer; -/// Возвращает высоту графического компонента в пикселах (по умолчанию совпадает с WindowHeight) -function GraphBoxHeight: integer; -/// Возвращает отступ графического компонента от левого края окна в пикселах -function GraphBoxLeft: integer; -/// Возвращает отступ графического компонента от верхнего края окна в пикселах -function GraphBoxTop: integer; - -/// Возвращает заголовок графического окна -function WindowCaption: string; -/// Возвращает заголовок графического окна -function WindowTitle: string; -/// Устанавливает заголовок графического окна -procedure SetWindowCaption(s: string); -/// Устанавливает заголовок графического окна -procedure SetWindowTitle(s: string); - -/// Устанавливает ширину и высоту клиентской части графического окна в пикселах -procedure InitWindow(Left,Top,Width,Height: integer; BackColor: Color := clWhite); - -/// Сохраняет содержимое графического окна в файл с именем fname -procedure SaveWindow(fname: string); -/// Восстанавливает содержимое графического окна из файла с именем fname -procedure LoadWindow(fname: string); -/// Заполняет содержимое графического окна обоями из файла с именем fname -procedure FillWindow(fname: string); -/// Закрывает графическое окно и завершает приложение -procedure CloseWindow; - -/// Возвращает ширину экрана в пикселях -function ScreenWidth: integer; -/// Возвращает высоту экрана в пикселях -function ScreenHeight: integer; - -/// Центрирует графическое окно по центру экрана -procedure CenterWindow; -/// Максимизирует графическое окно -procedure MaximizeWindow; -/// Сворачивает графическое окно -procedure MinimizeWindow; -/// Возвращает графическое окно к нормальному размеру -procedure NormalizeWindow; - -//-------------------------------------------- -//// Буферизация рисования -//-------------------------------------------- -/// Перерисовывает содержимое графического окна. Вызывается в паре с LockDrawing -procedure Redraw; -///-- -procedure FullRedraw; -/// Блокирует рисование на графическом окне. Перерисовка графического окна выполняется с помощью Redraw -procedure LockDrawing; -/// Снимает блокировку рисования на графическом окне и осуществляет его перерисовку -procedure UnlockDrawing; - -//-------------------------------------------- -//// Сглаживание -//-------------------------------------------- -/// Устанавливает режим сглаживания -procedure SetSmoothing(sm: boolean); -/// Включает режим сглаживания -procedure SetSmoothingOn; -/// Выключает режим сглаживания -procedure SetSmoothingOff; -/// Возвращает True, если режим сглаживания установлен -function SmoothingIsOn: boolean; - -//-------------------------------------------- -//// Вспомогательные подпрограммы -//-------------------------------------------- -/// Блокирует прорисовку графики. Вызывается для синхронизации -procedure LockGraphics; -/// Разблокирует прорисовку графики. Вызывается для синхронизации -procedure UnLockGraphics; - -//------------------------------------------------------------ -//// Подпрограммы для работы с системой координат -//------------------------------------------------------------ -/// Устанавливает начало координат в точку (x0,y0) -procedure SetCoordinateOrigin(x0,y0: integer); -/// Устанавливает масштаб системы координат -procedure SetCoordinateScale(sx,sy: real); -/// Устанавливает поворот системы координат -procedure SetCoordinateAngle(a: real); - -/// Инициализирует графическое окно. Используется для внутренних целей -procedure InitGraphABC; - -type -/// Тип пера GraphABC - GraphABCPen = class - public - _NETPen: System.Drawing.Pen; - procedure SetColor(c: GraphABC.Color); - function GetColor: GraphABC.Color; - procedure SetWidth(w: integer); - function GetWidth: integer; - procedure SetStyle(st: DashStyle); - function GetStyle: DashStyle; - procedure SetMode(m: integer); - function GetMode: integer; - procedure SetNETPen(p: System.Drawing.Pen); - function GetX: integer; - function GetY: integer; - public - /// Текущее перо .NET - property NETPen: System.Drawing.Pen read _NETPen write SetNETPen; - /// Цвет пера - property Color: GraphABC.Color read GetColor write SetColor; - /// Ширина пера - property Width: integer read GetWidth write SetWidth; - /// Стиль пера - property Style: DashStyle read GetStyle write SetStyle; - /// Режим пера - property Mode: integer read GetMode write SetMode; - /// X-координата текущей позиции пера - property X: integer read GetX; - /// Y-координата текущей позиции пера - property Y: integer read GetY; - end; - -/// Тип кисти GraphABC - GraphABCBrush = class - public - _NETBrush: System.Drawing.Brush; - procedure SetNETBrush(b: System.Drawing.Brush); - procedure SetColor(c: GraphABC.Color); - function GetColor: GraphABC.Color; - procedure SetStyle(st: BrushStyleType); - function GetStyle: BrushStyleType; - procedure SetHatch(h: HatchStyle); - function GetHatch: HatchStyle; - procedure SetHatchBackgroundColor(c: GraphABC.Color); - function GetHatchBackgroundColor: GraphABC.Color; - procedure SetGradientSecondColor(c: GraphABC.Color); - function GetGradientSecondColor: GraphABC.Color; - public -/// Текущая кисть .NET - property NETBrush: System.Drawing.Brush read _NETBrush write SetNETBrush; -/// Цвет кисти - property Color: GraphABC.Color read GetColor write SetColor; -/// Стиль кисти - property Style: BrushStyleType read GetStyle write SetStyle; -/// Штриховка кисти - property Hatch: HatchStyle read GetHatch write SetHatch; -/// Цвет заднего плана штриховой кисти - property HatchBackgroundColor: GraphABC.Color read GetHatchBackgroundColor write SetHatchBackgroundColor; -/// Второй цвет градиентной кисти - property GradientSecondColor: GraphABC.Color read GetGradientSecondColor write SetGradientSecondColor; - end; - -/// Тип шрифта GraphABC - GraphABCFont = class - public - _NETFont: System.Drawing.Font; - procedure SetNETFont(f: System.Drawing.Font); - procedure SetColor(c: GraphABC.Color); - function GetColor: GraphABC.Color; - procedure SetStyle(st: FontStyleType); - function GetStyle: FontStyleType; - procedure SetSize(sz: integer); - function GetSize: integer; - procedure SetName(nm: string); - function GetName: string; - public -/// Текущий шрифт .NET - property NETFont: System.Drawing.Font read _NETFont write SetNETFont; - /// Цвет шрифта - property Color: GraphABC.Color read GetColor write SetColor; - /// Стиль шрифта - property Style: FontStyleType read GetStyle write SetStyle; - /// Размер шрифта в пунктах - property Size: integer read GetSize write SetSize; - /// Наименование шрифта - property Name: string read GetName write SetName; - end; - - GraphABCCoordinate = class - public - coef: integer; - procedure SetOriginX(x: integer); - procedure SetOriginY(y: integer); - procedure SetOrigin(p: Point); - procedure SetAngle(a: real); - procedure SetScaleX(sx: real); - procedure SetScaleY(sy: real); - function GetOriginX: integer; - function GetOriginY: integer; - function GetOrigin: Point; - function GetAngle: real; - function GetScaleX: real; - function GetScaleY: real; - function GetMatrix: System.Drawing.Drawing2D.Matrix; - public - constructor; - /// Устанавливает параметры системы координат - procedure SetTransform(x0,y0,angle,sx,sy: real); - /// Устанавливает начало системы координат - procedure SetOrigin(x0,y0: integer); - /// Устанавливает масштаб системы координат - procedure SetScale(sx,sy: real); - /// Устанавливает масштаб системы координат - procedure SetScale(scale: real); - /// Устанавливает правую систему координат (ось OY направлена вверх, ось OX - вправо) - procedure SetMathematic; - /// Устанавливает левую систему координат (ось OY направлена вниз, ось OX - вправо) - procedure SetStandard; - /// X-координата начала координат относительно левого верхнего угла окна - property OriginX: integer read GetOriginX write SetOriginX; - /// Y-координата начала координат относительно левого верхнего угла окна - property OriginY: integer read GetOriginY write SetOriginY; - /// Координаты начала координат относительно левого верхнего угла окна - property Origin: Point read GetOrigin write SetOrigin; - /// Угол поворота системы координат - property Angle: real read GetAngle write SetAngle; - /// Масштаб системы координат по оси X - property ScaleX: real read GetScaleX write SetScaleX; - /// Масштаб системы координат по оси Y - property ScaleY: real read GetScaleY write SetScaleY; - /// Масштаб системы координат по обоим осям - property Scale: real write SetScale; - /// Матрица 3x3 преобразований координат - property Matrix: System.Drawing.Drawing2D.Matrix read GetMatrix; - end; - - GraphABCWindow = class - public - procedure SetLeft(l: integer); - function GetLeft: integer; - procedure SetTop(t: integer); - function GetTop: integer; - procedure SetWidth(w: integer); - function GetWidth: integer; - procedure SetHeight(h: integer); - function GetHeight: integer; - procedure SetCaption(c: string); - function GetCaption: string; - procedure SetIsFixedSize(b: boolean); - function GetIsFixedSize: boolean; - public -/// Отступ графического окна от левого края экрана в пикселах - property Left: integer read GetLeft write SetLeft; -/// Отступ графического окна от верхнего края экрана в пикселах - property Top: integer read GetTop write SetTop; -/// Ширина клиентской части графического окна в пикселах - property Width: integer read GetWidth write SetWidth; -/// Высота клиентской части графического окна в пикселах - property Height: integer read GetHeight write SetHeight; -/// Заголовок графического окна - property Caption: string read GetCaption write SetCaption; -/// Заголовок графического окна - property Title: string read GetCaption write SetCaption; -/// Имеет ли графическое окно фиксированный размер - property IsFixedSize: boolean read GetIsFixedSize write SetIsFixedSize; -/// Очищает графическое окно белым цветом - procedure Clear; -/// Очищает графическое окно цветом c - procedure Clear(c: Color); -/// Устанавливает размеры клиентской части графического окна в пикселах - procedure SetSize(w,h: integer); -/// Устанавливает отступ графического окна от левого верхнего края экрана в пикселах - procedure SetPos(l,t: integer); -/// Устанавливает положение, размеры и цвет графического окна - procedure Init(Left,Top,Width,Height: integer; BackColor: Color := clWhite); -/// Сохраняет содержимое графического окна в файл с именем fname - procedure Save(fname: string); -/// Восстанавливает содержимое графического окна из файла с именем fname - procedure Load(fname: string); -/// Заполняет содержимое графического окна обоями из файла с именем fname - procedure Fill(fname: string); -/// Закрывает графическое окно и завершает приложение - procedure Close; -/// Сворачивает графическое окно - procedure Minimize; -/// Максимизирует графическое окно - procedure Maximize; -/// Возвращает графическое окно к нормальному размеру - procedure Normalize; -/// Центрирует графическое окно по центру экрана - procedure CenterOnScreen; -/// Возвращает центр графического окна - function Center: Point; - end; - -/// Тип рисунка GraphABC - Picture = class - public - bmp,savedbmp: Bitmap; - gb: Graphics; - istransp: boolean; - transpcolor: System.Drawing.Color; - procedure SetWidth(w: integer); - function GetWidth: integer; - procedure SetHeight(h: integer); - function GetHeight: integer; - procedure SetTransparent(b: boolean); - procedure SetTransparentColor(c: GraphABC.Color); - function GetTransparentColor: GraphABC.Color; - public -/// Создает рисунок размера w на h пикселей - constructor Create(w,h: integer); -/// Создает рисунок из файла с именем fname - constructor Create(fname: string); -/// Создает рисунок из прямоугольника r графического окна - constructor Create(r: System.Drawing.Rectangle); // Create from screen -/// Загружает рисунок из файла с именем fname - procedure Load(fname: string); -/// Сохраняет рисунок в файл с именем fname - procedure Save(fname: string); -/// Устанавливает размер рисунка w на h пикселей - procedure SetSize(w,h: integer); -/// Ширина рисунка в пикселах - property Width: integer read GetWidth write SetWidth; -/// Высота рисунка в пикселах - property Height: integer read GetHeight write SetHeight; -/// Прозрачность рисунка; прозрачный цвет задается свойством TransparentColor - property Transparent: boolean read istransp write SetTransparent; -/// Прозрачный цвет рисунка. Должна быть установлена прозрачность Transparent := True - property TransparentColor: GraphABC.Color read GetTransparentColor write SetTransparentColor; -/// Возвращает True, если изображение данного рисунка пересекается с изображением рисунка p, и False в противном случае. Белый цвет считается прозрачным - function Intersect(p: Picture): boolean; -/// Выводит рисунок в позиции (x,y) - procedure Draw(x,y: integer); -/// Выводит рисунок в позиции (x,y) на поверхность рисования g - procedure Draw(x,y: integer; g: Graphics); -/// Выводит рисунок в позиции (x,y), масштабируя его к размеру (w,h) - procedure Draw(x,y,w,h: integer); -/// Выводит рисунок в позиции (x,y), масштабируя его к размеру (w,h), на поверхность рисования g - procedure Draw(x,y,w,h: integer; g: Graphics); -/// Выводит часть рисунка, заключенную в прямоугольнике r, в позиции (x,y) - procedure Draw(x,y: integer; r: System.Drawing.Rectangle); // r - part of Picture -/// Выводит часть рисунка, заключенную в прямоугольнике r, в позиции (x,y) на поверхность рисования g - procedure Draw(x,y: integer; r: System.Drawing.Rectangle; g: Graphics); -/// Выводит часть рисунка, заключенную в прямоугольнике r, в позиции (x,y), масштабируя его к размеру (w,h) - procedure Draw(x,y,w,h: integer; r: System.Drawing.Rectangle); // r - part of Picture -/// Выводит часть рисунка, заключенную в прямоугольнике r, в позиции (x,y), масштабируя его к размеру (w,h), на поверхность рисования g - procedure Draw(x,y,w,h: integer; r: System.Drawing.Rectangle; g: Graphics); -/// Копирует прямоугольник src рисунка p в прямоугольник dst текущего рисунка - procedure CopyRect(dst: System.Drawing.Rectangle; p: Picture; src: System.Drawing.Rectangle); -/// Копирует прямоугольник src битового образа bmp в прямоугольник dst текущего рисунка - procedure CopyRect(dst: System.Drawing.Rectangle; bmp: Bitmap; src: System.Drawing.Rectangle); -/// Зеркально отображает рисунок относительно горизонтальной оси симметрии - procedure FlipHorizontal; -/// Зеркально отображает рисунок относительно вертикальной оси симметрии - procedure FlipVertical; - -/// Закрашивает пиксел (x,y) рисунка цветом c - procedure SetPixel(x,y: integer; c: Color); -/// Закрашивает пиксел (x,y) рисунка цветом c - procedure PutPixel(x,y: integer; c: Color); -/// Возвращает цвет пиксела (x,y) рисунка - function GetPixel(x,y: integer): Color; - -/// Выводит на рисунке отрезок от точки (x1,y1) до точки (x2,y2) - procedure Line(x1,y1,x2,y2: integer); -/// Выводит на рисунке отрезок от точки (x1,y1) до точки (x2,y2) цветом c - procedure Line(x1,y1,x2,y2: integer; c: Color); - -/// Заполняет на рисунке внутренность окружности с центром (x,y) и радиусом r - procedure FillCircle(x,y,r: integer); -/// Выводит на рисунке окружность с центром (x,y) и радиусом r - procedure DrawCircle(x,y,r: integer); -/// Заполняет на рисунке внутренность эллипса, ограниченного прямоугольником, заданным координатами противоположных вершин (x1,y1) и (x2,y2) - procedure FillEllipse(x1,y1,x2,y2: integer); -/// Выводит на рисунке границу эллипса, ограниченного прямоугольником, заданным координатами противоположных вершин (x1,y1) и (x2,y2) - procedure DrawEllipse(x1,y1,x2,y2: integer); -/// Заполняет на рисунке внутренность прямоугольника, заданного координатами противоположных вершин (x1,y1) и (x2,y2) - procedure FillRectangle(x1,y1,x2,y2: integer); -/// Заполняет на рисунке внутренность прямоугольника, заданного координатами противоположных вершин (x1,y1) и (x2,y2) - procedure FillRect(x1,y1,x2,y2: integer); -/// Выводит на рисунке границу ы прямоугольника, заданного координатами противоположных вершин (x1,y1) и (x2,y2) - procedure DrawRectangle(x1,y1,x2,y2: integer); - -/// Выводит на рисунке заполненную окружность с центром (x,y) и радиусом r - procedure Circle(x,y,r: integer); -/// Выводит на рисунке заполненный эллипс, ограниченный прямоугольником, заданным координатами противоположных вершин (x1,y1) и (x2,y2) - procedure Ellipse(x1,y1,x2,y2: integer); -/// Выводит на рисунке заполненный прямоугольник, заданный координатами противоположных вершин (x1,y1) и (x2,y2) - procedure Rectangle(x1,y1,x2,y2: integer); -/// Выводит на рисунке заполненный прямоугольник со скругленными краями; (x1,y1) и (x2,y2) задают пару противоположных вершин, а w и h – ширину и высоту эллипса, используемого для скругления краев - procedure RoundRect(x1,y1,x2,y2,w,h: integer); - -/// Выводит на рисунке дугу окружности с центром в точке (x,y) и радиусом r, заключенной между двумя лучами, образующими углы a1 и a2 с осью OX (a1 и a2 – вещественные, задаются в градусах и отсчитываются против часовой стрелки) - procedure Arc(x,y,r,a1,a2: integer); -/// Заполняет на рисунке внутренность сектора окружности, ограниченного дугой с центром в точке (x,y) и радиусом r, заключенной между двумя лучами, образующими углы a1 и a2 с осью OX (a1 и a2 – вещественные, задаются в градусах и отсчитываются против часовой стрелки) - procedure FillPie(x,y,r,a1,a2: integer); -/// Выводит на рисунке сектор окружности, ограниченный дугой с центром в точке (x,y) и радиусом r, заключенной между двумя лучами, образующими углы a1 и a2 с осью OX (a1 и a2 – вещественные, задаются в градусах и отсчитываются против часовой стрелки) - procedure DrawPie(x,y,r,a1,a2: integer); -/// Выводит на рисунке заполненный сектор окружности, ограниченный дугой с центром в точке (x,y) и радиусом r, заключенной между двумя лучами, образующими углы a1 и a2 с осью OX (a1 и a2 – вещественные, задаются в градусах и отсчитываются против часовой стрелки) - procedure Pie(x,y,r,a1,a2: integer); - -/// Выводит на рисунке замкнутую ломаную по точкам, координаты которых заданы в массиве points - procedure DrawPolygon(points: array of Point); -/// Заполняет на рисунке многоугольник, координаты вершин которого заданы в массиве points - procedure FillPolygon(points: array of Point); -/// Выводит на рисунке заполненный многоугольник, координаты вершин которого заданы в массиве points - procedure Polygon(points: array of Point); -/// Выводит на рисунке ломаную по точкам, координаты которых заданы в массиве points - procedure Polyline(points: array of Point); -/// Выводит на рисунке кривую по точкам, координаты которых заданы в массиве points - procedure Curve(points: array of Point); -/// Выводит на рисунке замкнутую кривую по точкам, координаты которых заданы в массиве points - procedure DrawClosedCurve(points: array of Point); -/// Заполняет на рисунке замкнутую кривую по точкам, координаты которых заданы в массиве points - procedure FillClosedCurve(points: array of Point); -/// Выводит на рисунке заполненную замкнутую кривую по точкам, координаты которых заданы в массиве points - procedure ClosedCurve(points: array of Point); - -/// Выводит на рисунке строку s в прямоугольник к координатами левого верхнего угла (x,y) - procedure TextOut(x,y: integer; s: string); -/// Заливает на рисунке область одного цвета цветом c, начиная с точки (x,y). - procedure FloodFill(x,y: integer; c: Color); - -/// Очищает рисунок белым цветом - procedure Clear; -/// Очищает рисунок цветом c - procedure Clear(c: Color); - end; - -type - ABCControl = class(Control) - private - procedure OnPaint(sender: Object; e: PaintEventArgs); - procedure OnClosing(sender: Object; e: FormClosingEventArgs); - procedure OnMouseDown(sender: Object; e: MouseEventArgs); - procedure OnMouseUp(sender: Object; e: MouseEventArgs); - procedure OnMouseMove(sender: Object; e: MouseEventArgs); - procedure OnKeyDown(sender: Object; e: KeyEventArgs); - procedure OnKeyUp(sender: Object; e: KeyEventArgs); - procedure OnKeyPress(sender: Object; e: KeyPressEventArgs); - procedure OnResize(sender: Object; e: EventArgs); - procedure Init; - protected - function IsInputKey(keyData: Keys): boolean; override; - procedure OnPaintBackground(e: PaintEventArgs); override; begin end; // сами все перерисовываем! - public - constructor (w,h: integer); - end; - -/// Создает рисунок размера w на h пикселов и записывает его в переменную p -procedure CreatePicture(var p: Picture; w,h: integer); -/// Возвращает окно графического приложения -function Window: GraphABCWindow; -/// Возвращает главную форму графического приложения -function MainForm: Form; -/// Возвращает графический компонент -function GraphABCControl: ABCControl; -/// Возвращает текущее перо -function Pen: GraphABCPen; -/// Возвращает текущую кисть -function Brush: GraphABCBrush; -/// Возвращает текущий шрифт -function Font: GraphABCFont; -/// Возвращает систему координат GraphABC -function Coordinate: GraphABCCoordinate; - -function GraphWindowGraphics: Graphics; -function GraphBufferGraphics: Graphics; -function GraphBufferBitmap: Bitmap; - -var -/// Событие нажатия на кнопку мыши. (x,y) - координаты курсора мыши в момент наступления события, mousebutton = 1, если нажата левая кнопка мыши, и 2, если нажата правая кнопка мыши - OnMouseDown: procedure (x,y,mousebutton: integer); -/// Событие отжатия кнопки мыши. (x,y) - координаты курсора мыши в момент наступления события, mousebutton = 1, если отжата левая кнопка мыши, и 2, если отжата правая кнопка мыши - OnMouseUp: procedure (x,y,mousebutton: integer); -/// Событие перемещения мыши. (x,y) - координаты курсора мыши в момент наступления события, mousebutton = 0, если кнопка мыши не нажата, 1, если нажата левая кнопка мыши, и 2, если нажата правая кнопка мыши - OnMouseMove: procedure (x,y,mousebutton: integer); -/// Событие нажатия клавиши - OnKeyDown: procedure (key: integer); -/// Событие отжатия клавиши - OnKeyUp: procedure (key: integer); -/// Событие нажатия символьной клавиши - OnKeyPress: procedure (ch: char); -/// Событие изменения размера графического окна - OnResize: procedure; -/// Событие закрытия графического окна - OnClose: procedure; - -/// Процедурная переменная перерисовки графического окна. Если равна nil, то используется стандартная перерисовка - RedrawProc: procedure; -/// Следует ли рисовать во внеэкранном буфере - DrawInBuffer: boolean := true; - -implementation - -uses - System.Threading, - GraphABCHelper; - -const - FILE_NOT_FOUND_MESSAGE = 'Файл {0} не найден'; - -type - Proc1Integer = procedure(x: integer); - Proc1String = procedure(s: string); - Proc2Integer = procedure(x,y: integer); - Proc1Boolean = procedure(b: boolean); - Proc1BorderStyle = procedure(st: FormBorderStyle); - -var - _Window: GraphABCWindow := new GraphABCWindow; - _MainForm: Form; - _GraphABCControl: ABCControl; - _Pen: GraphABCPen := new GraphABCPen; - _Brush: GraphABCBrush := new GraphABCBrush; - _Font: GraphABCFont := new GraphABCFont; - _Coordinate := new GraphABCCoordinate; - - - __buffer: Bitmap; - bmp: Bitmap; - gr: Graphics; - gbmp: Graphics; - - f: ABCControl; - - CurrentSolidBrush: SolidBrush; - CurrentHatchBrush: HatchBrush; - CurrentGradientBrush: LinearGradientBrush; - PixelBrush: SolidBrush; - - x_coord,y_coord: integer; - NotLockDrawing: boolean; - - StartIsComplete: boolean; - MainFormThread: System.Threading.Thread; - - writecoords: Point; - CurrentWriteFont: System.Drawing.Font; - -// ------------ GraphABCCoordinate ----------------- -constructor GraphABCCoordinate.Create; -begin - // 1 - компьютерная система координат (ось OY - вниз) - // -1 - компьютерная система координат (ось OY - вниз) - coef := 1; -end; - -procedure GraphABCCoordinate.SetTransform(x0,y0,angle,sx,sy: real); -begin - sx := abs(sx); - sy := abs(sy); - angle := DegToRad(angle); - var m11 := sx * cos(angle); - var m12 := coef * sx * sin(angle); - var m21 := - sy * sin(angle); - var m22 := coef * sy * cos(angle); - var m := new System.Drawing.Drawing2D.Matrix(m11,m12,m21,m22,x0,y0); - lock f do - begin - gr.Transform := m; - gbmp.Transform := m; - end; -end; - -procedure GraphABCCoordinate.SetOrigin(x0,y0: integer); -begin - SetTransform(x0,y0,Angle,ScaleX,ScaleY); -end; - -procedure GraphABCCoordinate.SetScale(sx,sy: real); -begin - SetTransform(OriginX,OriginY,Angle,sx,sy); -end; - -procedure GraphABCCoordinate.SetScale(scale: real); -begin - SetScale(scale,scale); -end; - -procedure GraphABCCoordinate.SetMathematic; -begin - coef := -1; - SetTransform(OriginX,OriginY,Angle,ScaleX,ScaleY); -end; - -procedure GraphABCCoordinate.SetStandard; -begin - coef := 1; - SetTransform(OriginX,OriginY,Angle,ScaleX,ScaleY); -end; - -procedure GraphABCCoordinate.SetOriginX(x: integer); -begin - SetOrigin(x,OriginY); -end; - -procedure GraphABCCoordinate.SetOriginY(y: integer); -begin - SetOrigin(OriginX,y); -end; - -procedure GraphABCCoordinate.SetOrigin(p: Point); -begin - SetOrigin(p.x,p.y); -end; - -procedure GraphABCCoordinate.SetAngle(a: real); -begin - SetTransform(OriginX,OriginY,a,ScaleX,ScaleY); -end; - -procedure GraphABCCoordinate.SetScaleX(sx: real); -begin - SetScale(sx,ScaleY); -end; - -procedure GraphABCCoordinate.SetScaleY(sy: real); -begin - SetScale(ScaleX,sy); -end; - -function GraphABCCoordinate.GetOriginX: integer; -begin - lock (f) do - Result := Round(gr.Transform.OffsetX); -end; - -function GraphABCCoordinate.GetOrigin: Point; -begin - Result := new Point(GetOriginX,GetOriginY); -end; - -function GraphABCCoordinate.GetOriginY: integer; -begin - lock(f) do - Result := Round(gr.Transform.OffsetY); -end; - -function GraphABCCoordinate.GetAngle: real; -begin - var a := Coordinate.Matrix.Elements; - Result := ArcSin(a[1]/ScaleY); - if a[0]<0 then - if a[1]>0 then - Result := Pi - Result - else Result := -Pi - Result; - Result *= coef * 180/Pi; -end; - -function GraphABCCoordinate.GetScaleX: real; -begin - var a := Coordinate.Matrix.Elements; - Result := sqrt(sqr(a[0])+sqr(a[1])); -end; - -function GraphABCCoordinate.GetScaleY: real; -begin - var a := Coordinate.Matrix.Elements; - Result := sqrt(sqr(a[2])+sqr(a[3])); -end; - -function GraphABCCoordinate.GetMatrix: System.Drawing.Drawing2D.Matrix; -begin - lock (f) do - Result := gr.Transform; -end; - -procedure SetCoordinateOrigin(x0,y0: integer); -begin - Coordinate.SetOrigin(x0,y0); -end; - -procedure SetCoordinateScale(sx,sy: real); -begin - Coordinate.SetScale(sx,sy); -end; - -procedure SetCoordinateAngle(a: real); -begin - Coordinate.Angle := a; -end; - -{function CurrentABCWindow: ABCWindow; -begin - Result := f; -end; } - -procedure LockGraphics; -begin - Monitor.Enter(f); -end; - -procedure UnLockGraphics; -begin - Monitor.Exit(f); -end; - -procedure SetSmoothingOn; -begin - gr.SmoothingMode := SmoothingMode.AntiAlias; - gbmp.SmoothingMode := SmoothingMode.AntiAlias; -end; - -procedure SetSmoothingOff; -begin - gr.SmoothingMode := SmoothingMode.None; - gbmp.SmoothingMode := SmoothingMode.None; -end; - -procedure SetSmoothing(sm: boolean); -begin - if sm then - SetSmoothingOn - else SetSmoothingOff; -end; - -function SmoothingIsOn: boolean; -begin - Result := gr.SmoothingMode = SmoothingMode.AntiAlias; -end; - -function GraphWindowGraphics: Graphics; -begin - Result := gr; -end; - -function GraphBufferGraphics: Graphics; -begin - Result := gbmp; -end; - -function GraphBufferBitmap: Bitmap; -begin - Result := bmp; -end; - -procedure Swap(var x1,x2: integer); -begin - var t := x1; - x1 := x2; - x2 := t; -end; - -// Graphics Primitives -// ------------ __MyPen ----------------- -procedure GraphABCPen.SetColor(c: GraphABC.Color); -begin - SetPenColor(c); -end; - -function GraphABCPen.GetColor: GraphABC.Color; -begin - Result := PenColor; -end; - -procedure GraphABCPen.SetWidth(w: integer); -begin - SetPenWidth(w); -end; - -function GraphABCPen.GetWidth: integer; -begin - Result := PenWidth; -end; - -procedure GraphABCPen.SetStyle(st: DashStyle); -begin - SetPenStyle(st); -end; - -function GraphABCPen.GetStyle: DashStyle; -begin - Result := PenStyle; -end; - -procedure GraphABCPen.SetMode(m: integer); -begin - SetPenMode(m); -end; - -function GraphABCPen.GetMode: integer; -begin - Result := PenMode; -end; - -procedure GraphABCPen.SetNETPen(p: System.Drawing.Pen); -begin - if p=nil then exit; - _NETPen := p; -end; - -function GraphABCPen.GetX: integer; -begin - Result := PenX; -end; - -function GraphABCPen.GetY: integer; -begin - Result := PenY; -end; - -// ------------ GraphABCBrush ----------------- -procedure GraphABCBrush.SetNETBrush(b: System.Drawing.Brush); -begin - //if b=nil then Exit; - _NETBrush := b; -end; - -procedure GraphABCBrush.SetColor(c: GraphABC.Color); -begin - SetBrushColor(c); -end; - -function GraphABCBrush.GetColor: GraphABC.Color; -begin - Result := BrushColor; -end; - -procedure GraphABCBrush.SetStyle(st: BrushStyleType); -begin - SetBrushStyle(st); -end; - -function GraphABCBrush.GetStyle: BrushStyleType; -begin - Result := BrushStyle; -end; - -procedure GraphABCBrush.SetHatch(h: HatchStyle); -begin - SetBrushHatch(h); -end; - -function GraphABCBrush.GetHatch: HatchStyle; -begin - Result := BrushHatch; -end; - -procedure GraphABCBrush.SetHatchBackgroundColor(c: GraphABC.Color); -begin - SetHatchBrushBackgroundColor(c); -end; - -function GraphABCBrush.GetHatchBackgroundColor: GraphABC.Color; -begin - Result := HatchBrushBackgroundColor; -end; - -procedure GraphABCBrush.SetGradientSecondColor(c: GraphABC.Color); -begin - SetGradientBrushSecondColor(c); -end; - -function GraphABCBrush.GetGradientSecondColor: GraphABC.Color; -begin - Result := GradientBrushSecondColor; -end; - -// ------------ GraphABCFont ----------------- -procedure GraphABCFont.SetNETFont(f: System.Drawing.Font); -begin - if f=nil then Exit; - _NetFont := f; -end; - -procedure GraphABCFont.SetColor(c: GraphABC.Color); -begin - SetFontColor(c); -end; - -function GraphABCFont.GetColor: GraphABC.Color; -begin - Result := FontColor; -end; - -procedure GraphABCFont.SetStyle(st: FontStyleType); -begin - SetFontStyle(st); -end; - -function GraphABCFont.GetStyle: FontStyleType; -begin - Result := FontStyle; -end; - -procedure GraphABCFont.SetSize(sz: integer); -begin - SetFontSize(sz); -end; - -function GraphABCFont.GetSize: integer; -begin - Result := FontSize; -end; - -procedure GraphABCFont.SetName(nm: string); -begin - SetFontName(nm); -end; - -function GraphABCFont.GetName: string; -begin - Result := FontName; -end; - -// Picture -constructor Picture.Create(w,h: integer); -begin - if (w<=0) or (h<=0) then - raise new GraphABCException('w or h <= 0'); - bmp := new Bitmap(w,h); - gb := Graphics.FromImage(bmp); - transpcolor := bmp.GetPixel(0,bmp.Height-1); - istransp := false; - savedbmp := nil; -end; - -constructor Picture.Create(fname: string); -begin - try - bmp := new Bitmap(fname); - except on ex: System.ArgumentException do - raise new System.IO.FileNotFoundException(string.Format(FILE_NOT_FOUND_MESSAGE,fname)); - end; - - gb := Graphics.FromImage(bmp); - transpcolor := bmp.GetPixel(0,bmp.Height-1); - istransp := false; - savedbmp := nil; -end; - -constructor Picture.Create(r: System.Drawing.Rectangle); -// Create from Screen -begin - bmp := new Bitmap(r.Width,r.Height); - gb := Graphics.FromImage(bmp); - gb.CopyFromScreen(r.Left,r.Top,0,0,r.Size); - transpcolor := bmp.GetPixel(0,bmp.Height-1); - istransp := false; - savedbmp := nil; -end; - -procedure Picture.SetWidth(w: integer); -begin - SetSize(w,Height); -end; - -function Picture.GetWidth: integer; -begin - Result := bmp.Width; -end; - -procedure Picture.SetHeight(h: integer); -begin - SetSize(Width,h); -end; - -function Picture.GetHeight: integer; -begin - Result := bmp.Height; -end; - -// Логика установки прозрачности -// 1. Transparent := True - savedbmp:=bmp; bmp:=bmp.Clone; bmp.MakeTransparent(transpcolor); -// 2. Transparent := False - bmp.Dispose; bmp := savedbmp; savedbmp := nil; -// 3. Transparentcolor := c -// a) Если Transparent = False, то просто присвоить -// б) Если Transparent = True, то bmp.Dispose; bmp:=savedbmp.Clone; bmp.MakeTransparent(transpcolor); - -function Picture.GetTransparentColor: Color; -begin - Result := transpcolor; -end; - -procedure Picture.SetTransparentColor(c: Color); -var ob: Object; -begin - if c=TransparentColor then - Exit; - transpcolor := c; - if istransp then - begin - bmp.Dispose; - ob := savedbmp.Clone; - bmp := Bitmap(ob); - bmp.MakeTransparent(transpcolor); - end; -end; - -procedure Picture.SetTransparent(b: boolean); -var ob: Object; -begin - if b = istransp then - Exit; - istransp := b; - if istransp then - begin - savedbmp := bmp; - ob := bmp.Clone; - bmp := Bitmap(ob); - bmp.MakeTransparent(transpcolor); - end - else - begin - bmp.Dispose; - bmp := savedbmp; - savedbmp := nil; - end; -end; - -procedure Picture.Load(fname: string); -begin - bmp.Dispose; - bmp := new Bitmap(fname); - gb := Graphics.FromImage(bmp); - istransp := False; - if savedbmp<>nil then - begin - savedbmp.Dispose; - savedbmp := nil; - end; -end; - -procedure Picture.Save(fname: string); -begin - bmp.Save(fname); -end; - -procedure Picture.SetSize(w,h: integer); -var oldbmp: Bitmap; -begin - oldbmp := bmp; - bmp := new Bitmap(oldbmp,w,h); - gb := Graphics.FromImage(bmp); - gb.DrawImage(oldbmp,0,0); - oldbmp.Dispose; -// TODO не знаю, может, надо что-то делать для прозрачной -{ if istransp then - begin - end} -end; - -function Picture.Intersect(p: Picture): boolean; -begin -// bmp.L - result := false; -// TODO -end; - -procedure Picture.Draw(x,y: integer); -begin - Monitor.Enter(f); - if NotLockDrawing then - gr.DrawImage(bmp,x,y,bmp.Width,bmp.Height); - if DrawInBuffer then - gbmp.DrawImage(bmp,x,y,bmp.Width,bmp.Height); - Monitor.Exit(f); -end; - -procedure Picture.Draw(x,y: integer; g: Graphics); -begin - g.DrawImage(bmp,x,y,bmp.Width,bmp.Height); -end; - -procedure Picture.Draw(x,y,w,h: integer); -// Draw bmp scaled to size w,h -begin - Monitor.Enter(f); - if NotLockDrawing then - gr.DrawImage(bmp,x,y,w,h); - if DrawInBuffer then - gbmp.DrawImage(bmp,x,y,w,h); - Monitor.Exit(f); -end; - -procedure Picture.Draw(x,y,w,h: integer; g: Graphics); -// Draw bmp scaled to size w,h -begin - g.DrawImage(bmp,x,y,w,h); -end; - -procedure Picture.Draw(x,y: integer; r: System.Drawing.Rectangle); -// Draw bmp in rectangle r -begin - Monitor.Enter(f); - if NotLockDrawing then - gr.DrawImage(bmp,x,y,r,GraphicsUnit.Pixel); - if DrawInBuffer then - gbmp.DrawImage(bmp,x,y,r,GraphicsUnit.Pixel); - Monitor.Exit(f); -end; - -procedure Picture.Draw(x,y: integer; r: System.Drawing.Rectangle; g: Graphics); -begin - g.DrawImage(bmp,x,y,r,GraphicsUnit.Pixel); -end; - -procedure Picture.Draw(x,y,w,h: integer; r: System.Drawing.Rectangle); -// Draw rectangle r portion of bmp scaled to size w,h -var - r1: System.Drawing.Rectangle; - tempbmp: Bitmap; -begin - r1 := new System.Drawing.Rectangle(x,y,w,h); - tempbmp := GetView(bmp,r); - Monitor.Enter(f); - if NotLockDrawing then - gr.DrawImage(tempbmp,r1); -// gr.DrawImage(bmp,r1,r,GraphicsUnit.Pixel); - if DrawInBuffer then - gbmp.DrawImage(tempbmp,r1); -// gbmp.DrawImage(bmp,r1,r,GraphicsUnit.Pixel); - Monitor.Exit(f); - tempbmp.Dispose; -end; - -procedure Picture.Draw(x,y,w,h: integer; r: System.Drawing.Rectangle; g: Graphics); -var tempbmp: Bitmap; -begin - tempbmp := GetView(bmp,r); - g.DrawImage(tempbmp,x,y,new System.Drawing.Rectangle(x,y,w,h),GraphicsUnit.Pixel); - tempbmp.Dispose; -end; - -procedure Picture.CopyRect(dst: System.Drawing.Rectangle; p: Picture; src: System.Drawing.Rectangle); -// Copy src portion of p on dst rectangle of this picture -begin - CopyRect(dst,p.bmp,src); -end; - -procedure Picture.CopyRect(dst: System.Drawing.Rectangle; bmp: Bitmap; src: System.Drawing.Rectangle); -var tempbmp: Bitmap; -begin -// Copy src portion of bmp on dst rectangle of this picture - tempbmp := GetView(bmp,src); -// gb.DrawImage(bmp,dst,src,GraphicsUnit.Pixel); - gb.DrawImage(tempbmp,dst); - tempbmp.Dispose; -end; - -procedure Picture.FlipHorizontal; -begin - bmp.RotateFlip(RotateFlipType.RotateNoneFlipX); -end; - -procedure Picture.FlipVertical; -begin - bmp.RotateFlip(RotateFlipType.RotateNoneFlipY); -end; - -procedure Picture.SetPixel(x,y: integer; c: Color); -begin - bmp.SetPixel(x,y,c); -end; - -procedure Picture.PutPixel(x,y: integer; c: Color); -begin - bmp.SetPixel(x,y,c); -end; - -function Picture.GetPixel(x,y: integer): Color; -begin - Result := bmp.GetPixel(x,y); -end; - -procedure Picture.Line(x1,y1,x2,y2: integer); -begin - GraphABCHelper.Line(x1,y1,x2,y2,gb); -end; - -procedure Picture.Line(x1,y1,x2,y2: integer; c: Color); -begin - GraphABCHelper.Line(x1,y1,x2,y2,c,gb); -end; - -procedure Picture.FillCircle(x,y,r: integer); -begin - GraphABCHelper.FillEllipse(x-r,y-r,x+r,y+r,gb); -end; - -procedure Picture.DrawCircle(x,y,r: integer); -begin - GraphABCHelper.DrawEllipse(x-r,y-r,x+r,y+r,gb); -end; - -procedure Picture.FillEllipse(x1,y1,x2,y2: integer); -begin - GraphABCHelper.FillEllipse(x1,y1,x2,y2,gb); -end; - -procedure Picture.DrawEllipse(x1,y1,x2,y2: integer); -begin - GraphABCHelper.DrawEllipse(x1,y1,x2,y2,gb); -end; - -procedure Picture.FillRectangle(x1,y1,x2,y2: integer); -begin - GraphABCHelper.FillRectangle(x1,y1,x2,y2,gb); -end; - -procedure Picture.FillRect(x1,y1,x2,y2: integer); -begin - GraphABCHelper.FillRectangle(x1,y1,x2,y2,gb); -end; - -procedure Picture.DrawRectangle(x1,y1,x2,y2: integer); -begin - GraphABCHelper.DrawRectangle(x1,y1,x2,y2,gb); -end; - -procedure Picture.Circle(x,y,r: integer); -begin - GraphABCHelper.Ellipse(x-r,y-r,x+r,y+r,gb); -end; - -procedure Picture.Ellipse(x1,y1,x2,y2: integer); -begin - GraphABCHelper.Ellipse(x1,y1,x2,y2,gb); -end; - -procedure Picture.Rectangle(x1,y1,x2,y2: integer); -begin - GraphABCHelper.Rectangle(x1,y1,x2,y2,gb); -end; - -procedure Picture.RoundRect(x1,y1,x2,y2,w,h: integer); -begin - GraphABCHelper.RoundRect(x1,y1,x2,y2,w,h,gb); -end; - -procedure Picture.Arc(x,y,r,a1,a2: integer); -begin - GraphABCHelper.Arc(x,y,r,a1,a2,gb); -end; - -procedure Picture.FillPie(x,y,r,a1,a2: integer); -begin - GraphABCHelper.FillPie(x,y,r,a1,a2,gb); -end; - -procedure Picture.DrawPie(x,y,r,a1,a2: integer); -begin - GraphABCHelper.DrawPie(x,y,r,a1,a2,gb); -end; - -procedure Picture.Pie(x,y,r,a1,a2: integer); -begin - GraphABCHelper.Pie(x,y,r,a1,a2,gb); -end; - -procedure Picture.DrawPolygon(points: array of Point); -begin - GraphABCHelper.DrawPolygon(points,gb); -end; - -procedure Picture.FillPolygon(points: array of Point); -begin - GraphABCHelper.FillPolygon(points,gb); -end; - -procedure Picture.Polygon(points: array of Point); -begin - GraphABCHelper.Polygon(points,gb); -end; - -procedure Picture.Polyline(points: array of Point); -begin - GraphABCHelper.Polyline(points,gb); -end; - -procedure Picture.Curve(points: array of Point); -begin - GraphABCHelper.Curve(points,gb); -end; - -procedure Picture.DrawClosedCurve(points: array of Point); -begin - GraphABCHelper.DrawClosedCurve(points,gb); -end; - -procedure Picture.FillClosedCurve(points: array of Point); -begin - GraphABCHelper.FillClosedCurve(points,gb); -end; - -procedure Picture.ClosedCurve(points: array of Point); -begin - GraphABCHelper.ClosedCurve(points,gb); -end; - -procedure Picture.TextOut(x,y: integer; s: string); -begin - GraphABCHelper.TextOut(x,y,s,gb); -end; - -function ExtFloodFill(hdc: IntPtr; x,y: integer; color: integer; filltype: integer): boolean; external 'Gdi32.dll' name 'ExtFloodFill'; -function SelectObject(hdc, hgdiobj: IntPtr): IntPtr; external 'Gdi32.dll' name 'SelectObject'; -function CreateSolidBrush(c: integer): IntPtr; external 'Gdi32.dll' name 'CreateSolidBrush'; -function DeleteObject(obj: IntPtr): integer; external 'Gdi32.dll' name 'DeleteObject'; -function CreateCompatibleDC(obj: IntPtr): IntPtr; external 'Gdi32.dll' name 'CreateCompatibleDC'; - -procedure Picture.FloodFill(x,y: integer; c: Color); -var hdc,hBrush,hOldBrush: IntPtr; -begin - var borderColor: Color := GetPixel(x,y); - - var bc := ColorTranslator.ToWin32(borderColor); - var cc := ColorTranslator.ToWin32(c); - - Monitor.Enter(f); - - hdc := gbmp.GetHDC(); - hBrush := CreateSolidBrush(cc); - - hOldBrush := SelectObject(hdc, hBrush); - ExtFloodFill(hdc, x, y, bc, 1); - SelectObject(hdc, holdBrush); - - DeleteObject(hBrush); - - gr.ReleaseHdc(); - - DeleteObject(hdc); - - Monitor.Exit(f); -end; - -procedure Picture.Clear; -begin - Monitor.Enter(f); - gb.FillRectangle(Brushes.White,0,0,WindowWidth,WindowHeight); - Monitor.Exit(f); -end; - -procedure Picture.Clear(c: Color); -begin - Monitor.Enter(f); - gb.FillRectangle(new SolidBrush(c),0,0,WindowWidth,WindowHeight); - Monitor.Exit(f); -end; - -// ABCControl -function ABCControl.IsInputKey(keyData: Keys): boolean; -begin - Result := True; -end; - -procedure ABCControl.Init; -begin - BackColor := System.Drawing.Color.White; - Dock := DockStyle.Fill; - - Paint += OnPaint; - MouseDown += OnMouseDown; - MouseUp += OnMouseUp; - MouseMove += OnMouseMove; - Resize += OnResize; - KeyDown += OnKeyDown; - KeyUp += OnKeyUp; - KeyPress += OnKeyPress; - -// These Events must be initialised in main form -// FormClosing += OnClosing; - -// Initialization of global vars - - bmp := new Bitmap(Screen.PrimaryScreen.Bounds.Width,Screen.PrimaryScreen.Bounds.Height); - gr := Graphics.FromHwnd(Handle); - gbmp := Graphics.FromImage(bmp); - __buffer:=bmp; - gbmp.FillRectangle(Brushes.White,0,0,Screen.PrimaryScreen.Bounds.Width,Screen.PrimaryScreen.Bounds.Height); - _Pen.NETPen := new System.Drawing.Pen(System.Drawing.Color.Black); - _Font.NETFont := new System.Drawing.Font('Arial',10); - - PixelBrush := new SolidBrush(System.Drawing.Color.Black); - CurrentSolidBrush := new SolidBrush(System.Drawing.Color.White); - CurrentHatchBrush := new HatchBrush(HatchStyle.Cross,System.Drawing.Color.Black,System.Drawing.Color.White); - CurrentGradientBrush := new LinearGradientBrush(new Point(0,0), new Point(600,600),System.Drawing.Color.Black,System.Drawing.Color.White); - _Brush.NETBrush := CurrentSolidBrush; - - CurrentWriteFont := new System.Drawing.Font('Courier New',10); - - NotLockDrawing := True; - //DrawInBuffer := True; - //RedrawProc := nil; -end; - -constructor ABCControl.Create(w,h: integer); -begin - ClientSize := new System.Drawing.Size(w,h); - Init; -end; - -procedure ABCControl.OnPaint(sender: object; e: PaintEventArgs); -begin - Monitor.Enter(f); - if (e <> nil) and NotLockDrawing then - begin - if RedrawProc<>nil then - RedrawProc - else e.Graphics.DrawImage(bmp,0,0); - end; - Monitor.Exit(f); -end; - -procedure ABCControl.OnClosing(sender: object; e: FormClosingEventArgs); -begin - if GraphABC.OnClose<>nil then - GraphABC.OnClose; - NotLockDrawing := False; - //Sleep(0); - Halt; -end; - -procedure ABCControl.OnMouseDown(sender: Object; e: MouseEventArgs); -type MouseButtons = System.Windows.Forms.MouseButtons; -var mb: integer; -begin - if e.Button = MouseButtons.Left then - mb := 1 - else if e.Button = MouseButtons.Right then - mb := 2; - if GraphABC.OnMouseDown<>nil then - GraphABC.OnMouseDown(e.x,e.y,mb); -end; - -procedure ABCControl.OnMouseUp(sender: Object; e: MouseEventArgs); -type MouseButtons = System.Windows.Forms.MouseButtons; -var mb: integer; -begin - if e.Button = MouseButtons.Left then - mb := 1 - else if e.Button = MouseButtons.Right then - mb := 2; - if GraphABC.OnMouseUp<>nil then - GraphABC.OnMouseUp(e.x,e.y,mb); -end; - -procedure ABCControl.OnMouseMove(sender: Object; e: MouseEventArgs); -type MouseButtons = System.Windows.Forms.MouseButtons; -var mb: integer; -begin - if e.Button = MouseButtons.Left then - mb := 1 - else if e.Button = MouseButtons.Right then - mb := 2; - if GraphABC.OnMouseMove<>nil then - GraphABC.OnMouseMove(e.x,e.y,mb); -end; - -procedure ABCControl.OnKeyDown(sender: Object; e: KeyEventArgs); -begin - if GraphABC.OnKeyDown<>nil then - GraphABC.OnKeyDown(integer(e.KeyCode)); -end; - -procedure ABCControl.OnKeyUp(sender: Object; e: KeyEventArgs); -begin - if GraphABC.OnKeyUp<>nil then - GraphABC.OnKeyUp(integer(e.KeyCode)); -end; - -procedure ABCControl.OnKeyPress(sender: Object; e: KeyPressEventArgs); -begin - if GraphABC.OnKeyPress<>nil then - GraphABC.OnKeyPress(e.KeyChar); -end; - -procedure ResizeHelper; -var t: SmoothingMode; -begin - Monitor.Enter(f); - t := gr.SmoothingMode; - var m := gr.Transform; - gr := Graphics.FromHwnd(f.Handle); - gr.Transform := m; - gr.SmoothingMode := t; - Monitor.Exit(f); -end; - -procedure ABCControl.OnResize(sender: Object; e: EventArgs); -begin - ResizeHelper; - if GraphABC.OnResize<>nil then - GraphABC.OnResize; -end; - -// Primitives -procedure SetPixel(x,y: integer; c: Color); -var b: boolean; -begin - lock f do begin - if NotLockDrawing then begin - b := SmoothingIsOn; - SetSmoothingOff; - PixelBrush.Color := c; - gr.FillRectangle(PixelBrush,x,y,1,1); - SetSmoothing(b); - end; - if DrawInBuffer then - bmp.SetPixel(x,y,c); - end; -end; - -procedure PutPixel(x,y: integer; c: Color); -var b: boolean; -begin - Monitor.Enter(f); - b := SmoothingIsOn; - SetSmoothingOff; - PixelBrush.Color := c; - if NotLockDrawing then - gr.FillRectangle(PixelBrush,x,y,1,1); - if DrawInBuffer then - gbmp.FillRectangle(PixelBrush,x,y,1,1); - SetSmoothing(b); - Monitor.Exit(f); -end; - -function GetPixel(x,y: integer): Color; -begin - Monitor.Enter(f); - Result := bmp.GetPixel(x,y); - Monitor.Exit(f); -end; - -procedure MoveTo(x,y: integer); -begin - x_coord := x; - y_coord := y; -end; - -procedure LineTo(x,y: integer); -begin - Line(x_coord,y_coord,x,y); - x_coord := x; - y_coord := y; -end; - -procedure LineTo(x,y: integer; c: Color); -begin - Line(x_coord,y_coord,x,y,c); - x_coord := x; - y_coord := y; -end; - -procedure Line(x1,y1,x2,y2: integer; c: Color); -begin - Monitor.Enter(f); - if NotLockDrawing then - Line(x1,y1,x2,y2,c,gr); - if DrawInBuffer then - Line(x1,y1,x2,y2,c,gbmp); - Monitor.Exit(f); -end; - -procedure Line(x1,y1,x2,y2: integer); -begin - Monitor.Enter(f); - if NotLockDrawing then - Line(x1,y1,x2,y2,gr); - if DrawInBuffer then - Line(x1,y1,x2,y2,gbmp); - Monitor.Exit(f); -end; - -procedure FillCircle(x,y,r: integer); -begin - FillEllipse(x-r,y-r,x+r,y+r); -end; - -procedure DrawCircle(x,y,r: integer); -begin - DrawEllipse(x-r,y-r,x+r,y+r); -end; - -procedure Circle(x,y,r: integer); -begin - Ellipse(x-r,y-r,x+r,y+r); -end; - -procedure FillEllipse(x1,y1,x2,y2: integer); -begin - Monitor.Enter(f); - if NotLockDrawing then - FillEllipse(x1,y1,x2,y2,gr); - if DrawInBuffer then - FillEllipse(x1,y1,x2,y2,gbmp); - Monitor.Exit(f); -end; - -procedure DrawEllipse(x1,y1,x2,y2: integer); -begin - Monitor.Enter(f); - if NotLockDrawing then - DrawEllipse(x1,y1,x2,y2,gr); - if DrawInBuffer then - DrawEllipse(x1,y1,x2,y2,gbmp); - Monitor.Exit(f); -end; - -procedure Ellipse(x1,y1,x2,y2: integer); -begin - if Brush.NETBrush <> nil then - FillEllipse(x1,y1,x2,y2); - if Pen.NETPen.DashStyle <> DashStyle.Custom then - DrawEllipse(x1,y1,x2,y2); -end; - -procedure FillRectangle(x1,y1,x2,y2: integer); -begin - Monitor.Enter(f); - if NotLockDrawing then - FillRectangle(x1,y1,x2,y2,gr); - if DrawInBuffer then - FillRectangle(x1,y1,x2,y2,gbmp); - Monitor.Exit(f); -end; - -procedure DrawRectangle(x1,y1,x2,y2: integer); -begin - Monitor.Enter(f); - if NotLockDrawing then - DrawRectangle(x1,y1,x2,y2,gr); - if DrawInBuffer then - DrawRectangle(x1,y1,x2,y2,gbmp); - Monitor.Exit(f); -end; - -procedure Rectangle(x1,y1,x2,y2: integer); -begin - if x1>x2 then - Swap(x1,x2); - if y1>y2 then - Swap(y1,y2); - if Brush.NETBrush <> nil then - FillRectangle(x1,y1,x2-1,y2-1); - if Pen.NETPen.DashStyle <> DashStyle.Custom then - DrawRectangle(x1,y1,x2,y2); -end; - -procedure DrawRoundRect(x1,y1,x2,y2,w,h: integer); -begin - Monitor.Enter(f); - if NotLockDrawing then - DrawRoundRect(x1,y1,x2,y2,w,h,gr); - if DrawInBuffer then - DrawRoundRect(x1,y1,x2,y2,w,h,gbmp); - Monitor.Exit(f); -end; - -procedure FillRoundRect(x1,y1,x2,y2,w,h: integer); -begin - Monitor.Enter(f); - if NotLockDrawing then - FillRoundRect(x1,y1,x2,y2,w,h,gr); - if DrawInBuffer then - FillRoundRect(x1,y1,x2,y2,w,h,gbmp); - Monitor.Exit(f); -end; - -procedure RoundRect(x1,y1,x2,y2,w,h: integer); -begin - if Brush.NETBrush <> nil then - FillRoundRect(x1,y1,x2,y2,w,h); - if Pen.NETPen.DashStyle <> DashStyle.Custom then - DrawRoundRect(x1,y1,x2,y2,w,h); -end; - -procedure Arc(x,y,r,a1,a2: integer); -begin - Monitor.Enter(f); - if NotLockDrawing then - Arc(x,y,r,a1,a2,gr); - if DrawInBuffer then - Arc(x,y,r,a1,a2,gbmp); - Monitor.Exit(f); -end; - -procedure FillPie(x,y,r,a1,a2: integer); -begin - Monitor.Enter(f); - if NotLockDrawing then - FillPie(x,y,r,a1,a2,gr); - if DrawInBuffer then - FillPie(x,y,r,a1,a2,gbmp); - Monitor.Exit(f); -end; - -procedure DrawPie(x,y,r,a1,a2: integer); -begin - Monitor.Enter(f); - if NotLockDrawing then - DrawPie(x,y,r,a1,a2,gr); - if DrawInBuffer then - DrawPie(x,y,r,a1,a2,gbmp); - Monitor.Exit(f); -end; - -procedure Pie(x,y,r,a1,a2: integer); -begin - if Brush.NETBrush <> nil then - FillPie(x,y,r,a1,a2); - if Pen.NETPen.DashStyle <> DashStyle.Custom then - DrawPie(x,y,r,a1,a2); -end; - -procedure TextOut(x,y: integer; s: string); -begin - Monitor.Enter(f); - if NotLockDrawing then - TextOut(x,y,s,gr); - if DrawInBuffer then - TextOut(x,y,s,gbmp); - Monitor.Exit(f); -end; - -procedure DrawPolygon(points: array of Point); -begin - Monitor.Enter(f); - if NotLockDrawing then - DrawPolygon(points,gr); - if DrawInBuffer then - DrawPolygon(points,gbmp); - Monitor.Exit(f); -end; - -procedure FillPolygon(points: array of Point); -begin - Monitor.Enter(f); - if NotLockDrawing then - FillPolygon(points,gr); - if DrawInBuffer then - FillPolygon(points,gbmp); - Monitor.Exit(f); -end; - -procedure Polygon(points: array of Point); -begin - if Brush.NETBrush <> nil then - FillPolygon(points); - if Pen.NETPen.DashStyle <> DashStyle.Custom then - DrawPolygon(points); -end; - -procedure Polyline(points: array of Point); -begin - Monitor.Enter(f); - if NotLockDrawing then - Polyline(points,gr); - if DrawInBuffer then - Polyline(points,gbmp); - Monitor.Exit(f); -end; - -procedure Curve(points: array of Point); -begin - Monitor.Enter(f); - if NotLockDrawing then - Curve(points,gr); - if DrawInBuffer then - Curve(points,gbmp); - Monitor.Exit(f); -end; - -procedure DrawClosedCurve(points: array of Point); -begin - Monitor.Enter(f); - if NotLockDrawing then - DrawClosedCurve(points,gr); - if DrawInBuffer then - DrawClosedCurve(points,gbmp); - Monitor.Exit(f); -end; - -procedure FillClosedCurve(points: array of Point); -begin - Monitor.Enter(f); - if NotLockDrawing then - FillClosedCurve(points,gr); - if DrawInBuffer then - FillClosedCurve(points,gbmp); - Monitor.Exit(f); -end; - -procedure ClosedCurve(points: array of Point); -begin - Monitor.Enter(f); - if NotLockDrawing then - ClosedCurve(points,gr); - if DrawInBuffer then - ClosedCurve(points,gbmp); - Monitor.Exit(f); -end; - -// Fills -procedure FloodFill(x,y: integer; c: Color); -var hdc,hBrush,hOldBrush: IntPtr; -begin - var borderColor: Color := GetPixel(x,y); -// var bc: integer := integer(borderColor.R) + (integer(borderColor.G) shl 8) + (integer(borderColor.B) shl 16); -// var cc: integer := integer(c.R) + (integer(c.G) shl 8) + (integer(c.B) shl 16); - - var bc := ColorTranslator.ToWin32(borderColor); - var cc := ColorTranslator.ToWin32(c); - - Monitor.Enter(f); - - hdc := gr.GetHDC(); - hBrush := CreateSolidBrush(cc); - - hOldBrush := SelectObject(hdc, hBrush); - ExtFloodFill(hdc, x, y, bc, 1); - SelectObject(hdc, holdBrush); - - var hbmp := bmp.GetHbitmap(); // Создается GDI Bitmap - var memdc: IntPtr := CreateCompatibleDC(hdc); - SelectObject(memdc,hbmp); - - hOldBrush := SelectObject(memdc, hBrush); - ExtFloodFill(memdc, x, y, bc, 1); - SelectObject(hdc, holdBrush); - - var bmp1 := Bitmap.FromHbitmap(hbmp); - gbmp.DrawImage(bmp1,0,0); - - bmp1.Dispose(); -// bmp := Bitmap.FromHbitmap(hbmp); - - DeleteObject(memdc); - DeleteObject(hbmp); - DeleteObject(hBrush); - - gr.ReleaseHdc(); - - DeleteObject(hdc); - - Monitor.Exit(f); -end; - -procedure FillRect(x1,y1,x2,y2: integer); -begin - FillRectangle(x1,y1,x2,y2); -end; - -// Colors -function RGB(r,g,b: byte): Color; -begin - Result := System.Drawing.Color.FromArgb(r,g,b); -end; - -//------------------------------------------------------------------------------ -// Color from component -//------------------------------------------------------------------------------ -const AlphaBase = $FF000000; - -function RedColor(r: byte): Color; -begin - Result := System.Drawing.Color.FromArgb(AlphaBase or (r shl 16)); -end; - -function GreenColor(g: byte): Color; -begin - Result := System.Drawing.Color.FromArgb(AlphaBase or (g shl 8)); -end; - -function BlueColor(b: byte): Color; -begin - Result := System.Drawing.Color.FromArgb(AlphaBase or b); -end; -//------------------------------------------------------------------------------ - -function ARGB(a,r,g,b: byte) : Color; -begin - Result := System.Drawing.Color.FromArgb(a,r,g,b); -// Result := ((((r shl 16) or (g shl 8)) or b) or (a shl 24)) and -1; -end; - -function clRandom: Color; -begin - Result:=System.Drawing.Color.FromArgb(255,PABCSystem.Random(255),PABCSystem.Random(255),PABCSystem.Random(255)); -end; - -function GetRed(c: Color): integer; -begin - Result := c.R; -// Result := (c shr 16) and 255; -end; - -function GetGreen(c: Color): integer; -begin - Result := c.G; -// Result := (c shr 8) and 255; -end; - -function GetBlue(c: Color): integer; -begin - Result := c.B; -// Result := c and 255; -end; - -function GetAlpha(c: Color): integer; -begin - Result := c.A; -end; - -// Pens -procedure SetPenColor(c: Color); -begin - //if Pen.NETPen.Color <> c then - lock f do - Pen.NETPen.Color := c; -end; - -function PenColor: Color; -begin - Result := Pen.NETPen.Color; -end; - -procedure SetPenWidth(Width: integer); -begin - lock f do - Pen.NETPen.Width := Width; -end; - -function PenWidth: integer; -begin - Result := round(Pen.NETPen.Width); -end; - -procedure SetPenStyle(style: DashStyle); -begin - LockGraphics; -// try - case style of - psSolid: Pen.NETPen.DashStyle := DashStyle.Solid; - psClear: Pen.NETPen.DashStyle := DashStyle.Custom; - psDash: Pen.NETPen.DashStyle := DashStyle.Dash; - psDot: Pen.NETPen.DashStyle := DashStyle.Dot; - psDashDot: Pen.NETPen.DashStyle := DashStyle.DashDot; - psDashDotDot: Pen.NETPen.DashStyle := DashStyle.DashDotDot; - end; -{ except - on e: System.InvalidOperationException do - writeln(e); - end;} - UnLockGraphics; -end; - -function PenStyle: DashStyle; -begin - case Pen.NETPen.DashStyle of - DashStyle.Solid: Result := psSolid; - DashStyle.Dash: Result := psDash; - DashStyle.Dot: Result := psDot; - DashStyle.DashDot: Result := psDashDot; - DashStyle.DashDotDot: Result := psDashDotDot; - DashStyle.Custom: Result := psClear; - end; -end; - -procedure SetPenMode(m: integer); -begin -// TODO -end; - -function PenMode: integer; -begin - result := -1; -// TODO -end; - -function PenX: integer; -begin - Result := x_coord; -end; - -function PenY: integer; -begin - Result := y_coord; -end; - -// Brushes -procedure SetBrushColor(c: Color); -begin - LockGraphics; - if Brush.NETBrush = CurrentHatchBrush then - begin - CurrentHatchBrush := new HatchBrush(CurrentHatchBrush.HatchStyle,c,CurrentHatchBrush.BackgroundColor); - Brush.NETBrush := CurrentHatchBrush; - end - else - begin -// try - CurrentSolidBrush.Color := c; -{ except - on e: System.InvalidOperationException do - writeln(e.StackTrace); - end;} - CurrentGradientBrush.LinearColors[0] := CurrentSolidBrush.Color; - end; - UnLockGraphics; -end; - -function BrushColor: Color; -begin - if Brush.NETBrush = CurrentHatchBrush then - Result := CurrentHatchBrush.ForegroundColor - else Result := CurrentSolidBrush.Color; -end; - -procedure SetBrushStyle(bs: BrushStyleType); -begin - lock f do - case bs of - bsSolid: Brush.NETBrush := CurrentSolidBrush; - bsClear: Brush.NETBrush := nil; - bsHatch: Brush.NETBrush := CurrentHatchBrush; - bsGradient: Brush.NETBrush := CurrentGradientBrush; - end; -end; - -function BrushStyle: BrushStyleType; -begin - Result := bsNone; // Если кисть устанавливалась явным присваиванием NETBrush - if Brush.NETBrush = CurrentSolidBrush then - Result := bsSolid - else if Brush.NETBrush = nil then - Result := bsClear - else if Brush.NETBrush = CurrentHatchBrush then - Result := bsHatch - else if Brush.NETBrush = CurrentGradientBrush then - Result := bsGradient; -end; - -procedure SetBrushHatch(bh: HatchStyle); -begin - lock f do - begin - var flag := CurrentHatchBrush = Brush.NETBrush; - CurrentHatchBrush := new HatchBrush(HatchStyle(bh),CurrentHatchBrush.ForegroundColor,CurrentHatchBrush.BackgroundColor); - if flag then - Brush.NETBrush := CurrentHatchBrush; - end; -end; - -function BrushHatch: HatchStyle; -begin - Result := CurrentHatchBrush.HatchStyle; -end; - -procedure SetHatchBrushBackgroundColor(c: Color); -var flag: boolean; -begin - lock f do - begin - flag := CurrentHatchBrush = Brush.NETBrush; - CurrentHatchBrush := new HatchBrush(CurrentHatchBrush.HatchStyle,CurrentHatchBrush.ForegroundColor,c); - if flag then - Brush.NETBrush := CurrentHatchBrush; - end; -end; - -function HatchBrushBackgroundColor: Color; -begin - Result := CurrentHatchBrush.BackgroundColor; -end; - -procedure SetGradientBrushSecondColor(c: Color); -begin - lock f do - CurrentGradientBrush.LinearColors[1] := c; -end; - -function GradientBrushSecondColor: Color; -begin - Result := CurrentGradientBrush.LinearColors[1]; -end; - -// Fonts -procedure SetFontSize(size: integer); -begin - Font.NETFont := new System.Drawing.Font(Font.NETFont.Name,Convert.ToSingle(size),Font.NETFont.Style); -end; - -function FontSize: integer; -begin - Result := round(Font.NETFont.SizeInPoints); -end; - -procedure SetFontName(name: string); -begin - lock f do - Font.NETFont := new System.Drawing.Font(name,Font.NETFont.SizeInPoints,Font.NETFont.Style); -end; - -function FontName: string; -begin - Result := Font.NETFont.Name; -end; - -procedure SetFontColor(c: Color); -begin - lock f do - CurrentTextBrush.Color := c; -end; - -function FontColor: Color; -begin - Result := CurrentTextBrush.Color; -end; - -procedure SetFontStyle(fs: FontStyleType); -begin - lock f do - Font.NETFont := new System.Drawing.Font(Font.NETFont.name,Font.NETFont.SizeInPoints,System.Drawing.FontStyle(integer(fs))); -end; - -function FontStyle: FontStyleType; -begin - Result := FontStyleType(integer(Font.NETFont.Style)); -end; - -function TextWidth(s: string): integer; -begin -// добавил 1. Без нее рисует, занимая 1 лишний пиксел - Result := round(gr.MeasureString(s,Font.NETFont,0,new StringFormat(StringFormat.GenericTypographic)).Width) + 1; -end; - -function TextHeight(s: string): integer; -begin - Result := round(gr.MeasureString(s,Font.NETFont).Height); -end; - -// Window -procedure ClearWindow; -begin - ClearWindow(clWhite); -end; - -procedure ClearWindow(c: Color); -var i: Color; -begin - Monitor.Enter(f); - i := BrushColor; - SetBrushColor(c); - var m := gr.Transform; - gr.ResetTransform; - gbmp.ResetTransform; - FillRect(0,0,GraphABCControl.Width,GraphABCControl.Height); - gr.Transform := m; - gbmp.Transform := m; - SetBrushColor(i); - Monitor.Exit(f); -end; - -function WindowLeft: integer; -begin - Result := MainForm.Left; -end; - -function WindowTop: integer; -begin - Result := MainForm.Top; -end; - -function WindowCenter: Point; -begin - Result := new Point(WindowWidth div 2,WindowHeight div 2); -end; - -function WindowIsFixedSize: boolean; -begin - Result := (MainForm.FormBorderStyle = FormBorderStyle.FixedSingle) and (MainForm.MaximizeBox = False); -end; - -function WindowWidth: integer; -begin - Result := MainForm.ClientSize.Width; -end; - -function WindowHeight: integer; -begin - Result := MainForm.ClientSize.Height; -end; - -procedure SetWindowWidth(w: integer); -begin - SetWindowSize(w,MainForm.ClientSize.Height); -end; - -procedure SetWindowHeight(h: integer); -begin - SetWindowSize(MainForm.ClientSize.Width,h); -end; - -procedure SetWindowLeft(l: integer); -begin - SetWindowPos(l,MainForm.Top); -end; - -procedure SetWindowTop(t: integer); -begin - SetWindowPos(MainForm.Left,t); -end; - -procedure SetMaximizeBoxInternal(b: boolean); -begin - MainForm.MaximizeBox := b; -end; - -procedure SetBorderStyleInternal(st : FormBorderStyle); -begin - MainForm.FormBorderStyle := st; -end; - -procedure SetWindowIsFixedSize(b: boolean); -var p : Proc1Boolean; - q : Proc1BorderStyle; -begin - p := SetMaximizeBoxInternal; - q := SetBorderStyleInternal; - if b then - MainForm.Invoke(q,FormBorderStyle.FixedSingle) - else MainForm.Invoke(q,FormBorderStyle.Sizable); - MainForm.Invoke(p,not b); -end; - -procedure ChangeFormPos(l,t: integer); // вспомогательная -begin - MainForm.Left := l; - MainForm.Top := t; -end; - -procedure SetWindowPos(l,t: integer); -var p: Proc2Integer; -begin - p := ChangeFormPos; - f.Invoke(p,l,t); -end; - -procedure ChangeFormClientSize(w,h: integer); // вспомогательная -begin - MainForm.ClientSize := new System.Drawing.Size(w,h); - ResizeHelper; -end; - -procedure SetWindowSize(w,h: integer); -var p: Proc2Integer; -begin - p := ChangeFormClientSize; - f.Invoke(p,w,h); - //ResizeHelper; -end; - -function GraphBoxWidth: integer; -begin - Result := f.Width; -end; - -function GraphBoxHeight: integer; -begin - Result := f.Height; -end; - -function GraphBoxLeft: integer; -begin - Result := f.Left; -end; - -function GraphBoxTop: integer; -begin - Result := f.Top; -end; - -function WindowCaption: string; -begin - Result := MainForm.Text; -end; - -function WindowTitle: string; -begin - Result := MainForm.Text; -end; - -procedure InitWindow(Left,Top,Width,Height: integer; BackColor: Color); -begin - SetWindowSize(Width, Height); - SetWindowPos(Left, Top); - SetBrushColor(BackColor); - FillRectangle(0, 0, Width, Height); -end; - -procedure ChangeFormTitle(s: string); -begin - MainForm.Text := s; -end; - -procedure SetWindowTitle(s: string); -var p: Proc1String; -begin - p := ChangeFormTitle; - f.Invoke(p,s); -end; - -procedure SetWindowCaption(s: string); -begin - SetWindowTitle(s); -end; - -procedure SaveWindow(fname: string); -begin - var tempbmp := GetView(bmp,new System.Drawing.Rectangle(0,0,Window.Width,Window.Height)); - tempbmp.Save(fname); - tempbmp.Dispose; -end; - -procedure LoadWindow(fname: string); -begin - var b: Bitmap := new Bitmap(fname); - SetWindowSize(b.Width,b.Height); - Monitor.Enter(f); - gr.DrawImage(b,0,0); - gbmp.DrawImage(b,0,0); - Monitor.Exit(f); -end; - -procedure FillWindow(fname: string); -begin - Monitor.Enter(f); - var b: System.Drawing.Brush := Brush.NETBrush; - Brush.NETBrush := new TextureBrush(Bitmap.FromFile(fname)); - FillRect(0,0,GraphABCControl.Width,GraphABCControl.Height); - Brush.NETBrush := b; - Monitor.Exit(f); -end; - -procedure CloseWindow; -begin -// MainForm.Close; - Halt; -end; - -function ScreenWidth: integer; -begin - Result := Screen.PrimaryScreen.Bounds.Width; -end; - -function ScreenHeight: integer; -begin - Result := Screen.PrimaryScreen.Bounds.Height; -end; - -procedure CenterWindow; -begin - SetWindowPos((ScreenWidth - MainForm.Width) div 2, (ScreenHeight - MainForm.Height) div 2); -end; - -procedure MaximizeWindow; -begin - MainForm.WindowState := FormWindowState.Maximized; -end; - -procedure MinimizeWindow; -begin - MainForm.WindowState := FormWindowState.Minimized; -end; - -procedure NormalizeWindow; -begin - MainForm.WindowState := FormWindowState.Normal -end; - -// BufferedDraw -procedure Redraw; -var tempbmp: Bitmap; -begin - //TODO Без этого падает если свернуто - if MainForm.WindowState=FormWindowState.Minimized then - exit; - tempbmp := GetView(bmp,new System.Drawing.Rectangle(0,0,WindowWidth,WindowHeight)); - Monitor.Enter(f); - if gr<>nil then - begin - var m := gr.Transform; - gr.ResetTransform; - gr.DrawImage(tempbmp,0,0); - gr.Transform := m; - end; - Monitor.Exit(f); -end; -procedure FullRedraw; -begin - Monitor.Enter(f); - if gr<>nil then - gr.DrawImage(bmp,0,0); - Monitor.Exit(f); -end; - -procedure LockDrawing; -begin - NotLockDrawing := False; -end; - -procedure UnlockDrawing; -begin - NotLockDrawing := True; - Redraw; -end; - -procedure InitForm; -begin - f := new ABCControl(defaultWindowWidth,defaultWindowHeight); - _MainForm := new Form; - _MainForm.Text := 'GraphABC.NET'; - _MainForm.ClientSize := new Size(defaultWindowWidth,defaultWindowHeight); -// _MainForm.BackColor := Color.White; - _MainForm.Controls.Add(f); - _MainForm.TopMost := True; - _MainForm.StartPosition := FormStartPosition.CenterScreen; - _MainForm.FormClosing += f.OnClosing; -end; - -procedure InitForm0; -begin - InitForm; - StartIsComplete := True; - Application.Run(MainForm); -end; - -function RobotUnitUsed: boolean; -var t: &Type; -begin - t := System.Reflection.Assembly.GetExecutingAssembly.GetType('Robot.Robot'); - if t=nil then - result := false - else - result := t.GetField('__IS_ROBOT_UNIT') <> nil; -end; - -procedure HideForm; -begin - _MainForm.Hide; -end; - -procedure CreatePicture(var p: Picture; w,h: integer); -begin - p := new Picture(w,h); -end; - -function Window: GraphABCWindow; -begin - Result := _Window; -end; - -function MainForm: Form; -begin - Result := _MainForm; -end; - -function GraphABCControl: ABCControl; -begin - Result := _GraphABCControl; -end; - -function Pen: GraphABCPen; -begin - Result := _Pen; -end; - -function Brush: GraphABCBrush; -begin - Result := _Brush; -end; - -function Font: GraphABCFont; -begin - Result := _Font; -end; - -function Coordinate: GraphABCCoordinate; -begin - Result := _Coordinate; -end; - -procedure GraphABCWindow.SetLeft(l: integer); -begin - SetWindowLeft(l); -end; - -function GraphABCWindow.GetLeft: integer; -begin - Result := WindowLeft; -end; - -procedure GraphABCWindow.SetTop(t: integer); -begin - SetWindowTop(t); -end; - -function GraphABCWindow.GetTop: integer; -begin - Result := WindowTop; -end; - -procedure GraphABCWindow.SetWidth(w: integer); -begin - SetWindowWidth(w); -end; - -function GraphABCWindow.GetWidth: integer; -begin - Result := WindowWidth; -end; - -procedure GraphABCWindow.SetHeight(h: integer); -begin - SetWindowHeight(h); -end; - -function GraphABCWindow.GetHeight: integer; -begin - Result := WindowHeight; -end; - -procedure GraphABCWindow.SetCaption(c: string); -begin - SetWindowCaption(c); -end; - -function GraphABCWindow.GetCaption: string; -begin - Result := WindowCaption; -end; - -procedure GraphABCWindow.SetIsFixedSize(b: boolean); -begin - SetWindowIsFixedSize(b); -end; - -function GraphABCWindow.GetIsFixedSize: boolean; -begin - Result := WindowIsFixedSize; -end; - -procedure GraphABCWindow.Clear; -begin - ClearWindow; -end; - -procedure GraphABCWindow.Clear(c: Color); -begin - ClearWindow(c); -end; - -procedure GraphABCWindow.SetSize(w,h: integer); -begin - SetWindowSize(w,h) -end; - -procedure GraphABCWindow.SetPos(l,t: integer); -begin - SetWindowPos(l,t) -end; - -procedure GraphABCWindow.Init(Left,Top,Width,Height: integer; BackColor: Color); -begin - InitWindow(Left,Top,Width,Height,BackColor); -end; - -procedure GraphABCWindow.Save(fname: string); -begin - SaveWindow(fname); -end; - -procedure GraphABCWindow.Load(fname: string); -begin - LoadWindow(fname); -end; - -procedure GraphABCWindow.Fill(fname: string); -begin - FillWindow(fname); -end; - -procedure GraphABCWindow.Close; -begin - CloseWindow -end; - -procedure GraphABCWindow.Minimize; -begin - MinimizeWindow -end; - -procedure GraphABCWindow.Maximize; -begin - MaximizeWindow; -end; - -procedure GraphABCWindow.Normalize; -begin - NormalizeWindow; -end; - -procedure GraphABCWindow.CenterOnScreen; -begin - CenterWindow; -end; - -function GraphABCWindow.Center: Point; -begin - Result := WindowCenter; -end; - -var firstcall := True; - -procedure InitGraphABC; -begin - if not firstcall then exit; - firstcall := False; - clMoneyGreen := RGB(192,220,192); - StartIsComplete := False; - MainFormThread := new System.Threading.Thread(InitForm0); - MainFormThread.Start; - while not StartIsComplete do - Sleep(30); - Sleep(30); - SetSmoothingOn; - _GraphABCControl := f; -end; - -initialization - InitGraphABC; -finalization -// Application.Run(MainWindow); -end. \ No newline at end of file diff --git a/bin/Lib/LibForVB/ABCObjects/GraphABCHelper.pas b/bin/Lib/LibForVB/ABCObjects/GraphABCHelper.pas deleted file mode 100644 index 0a033eb35..000000000 --- a/bin/Lib/LibForVB/ABCObjects/GraphABCHelper.pas +++ /dev/null @@ -1,380 +0,0 @@ -unit GraphABCHelper; - -//#apptype windows -#reference 'System.Windows.Forms.dll' -#reference 'System.Drawing.dll' -#savepcu false - -interface - -uses System.Drawing; - -type Color = System.Drawing.Color; - -// Primitives -procedure Line(x1,y1,x2,y2: integer; gr: Graphics); -procedure Line(x1,y1,x2,y2: integer; c: Color; gr: Graphics); - -procedure FillEllipse(x1,y1,x2,y2: integer; gr: Graphics); -procedure DrawEllipse(x1,y1,x2,y2: integer; gr: Graphics); -procedure FillRectangle(x1,y1,x2,y2: integer; gr: Graphics); -procedure FillRect(x1,y1,x2,y2: integer; gr: Graphics); -procedure DrawRectangle(x1,y1,x2,y2: integer; gr: Graphics); -procedure FillCircle(x,y,r: integer; gr: Graphics); -procedure DrawCircle(x,y,r: integer; gr: Graphics); -procedure DrawRoundRect(x1,y1,x2,y2,w,h: integer; gr: Graphics); -procedure FillRoundRect(x1,y1,x2,y2,w,h: integer; gr: Graphics); - -procedure Ellipse(x1,y1,x2,y2: integer; gr: Graphics); -procedure Rectangle(x1,y1,x2,y2: integer; gr: Graphics); -procedure Circle(x,y,r: integer; gr: Graphics); -procedure RoundRect(x1,y1,x2,y2,w,h: integer; gr: Graphics); - -procedure Arc(x,y,r,a1,a2: integer; gr: Graphics); -procedure Pie(x,y,r,a1,a2: integer; gr: Graphics); -procedure FillPie(x,y,r,a1,a2: integer; gr: Graphics); -procedure DrawPie(x,y,r,a1,a2: integer; gr: Graphics); - -procedure DrawPolygon(a: array of Point; gr: Graphics); -procedure FillPolygon(a: array of Point; gr: Graphics); -procedure Polygon(a: array of Point; gr: Graphics); -procedure Polyline(a: array of Point; gr: Graphics); -procedure Curve(a: array of Point; gr: Graphics); -procedure DrawClosedCurve(a: array of Point; gr: Graphics); -procedure FillClosedCurve(a: array of Point; gr: Graphics); -procedure ClosedCurve(a: array of Point; gr: Graphics); - -procedure TextOut(x,y: integer; s: string; gr: Graphics); - -function GetView(b: Bitmap; r: System.Drawing.Rectangle): Bitmap; -function ImageIntersect(b1,b2: Bitmap): boolean; - -var - CurrentTextBrush: SolidBrush; - -implementation - -uses System, System.Drawing, System.Drawing.Drawing2D, GraphABC; - -var - sf: StringFormat; - ColorLinePen: System.Drawing.Pen; - -function ImageIntersect(b1,b2: Bitmap): boolean; -// Предполагается, что b1 и b2 - одного размера -type - RGB = record - r,g,b: byte; - end; - PRGB = ^uint32; -label 1; -var - ptr1,ptr2: pointer; - iptr1,iptr2: integer; - p1,p2: PRGB; - rect: System.Drawing.Rectangle; - bmpData1,bmpData2: System.Drawing.Imaging.BitmapData; -begin - rect := new System.Drawing.Rectangle(0,0,b1.Width,b1.Height); - bmpData1 := b1.LockBits(rect, System.Drawing.Imaging.ImageLockMode.ReadWrite, b1.PixelFormat); - ptr1 := bmpData1.Scan0.ToPointer; - iptr1 := integer(ptr1); - - bmpData2 := b2.LockBits(rect, System.Drawing.Imaging.ImageLockMode.ReadWrite, b2.PixelFormat); - ptr2 := bmpData2.Scan0.ToPointer; - iptr2 := integer(ptr2); - - var pixelFormatSize := Image.GetPixelFormatSize(b1.PixelFormat) div 8; - var Offset := bmpData1.stride - b1.Width * pixelFormatSize; - - Result := False; - for var y:=0 to b1.Height-1 do - begin - for var x:=0 to b1.Width-1 do - begin - p1 := PRGB(pointer(iptr1)); - p2 := PRGB(pointer(iptr2)); - //writeln(p1^.R,' ',p1^.G,' ',p1^.B,' ',p2^.R,' ',p2^.G,' ',p2^.B); -// if ((p1^.R and p1^.G and p1^.B)<>$FF) and ((p2^.R and p2^.G and p2^.B)<>$FF) then - if (p1^<>$FFFFFFFF) and (p2^<>$FFFFFFFF) then - begin - Result := True; - goto 1; - end; - iptr1 += pixelFormatSize; - iptr2 += pixelFormatSize; - end; - iptr1 += Offset; - iptr2 += Offset; - end; -1: - b2.UnlockBits(bmpData1); - b1.UnlockBits(bmpData1); -end; - -function GetView(b: Bitmap; r: System.Drawing.Rectangle): Bitmap; -var - w,h,stride,padding,pixelFormatSize: integer; - ptr,start: System.IntPtr; - rect: System.Drawing.Rectangle; - bmpData: System.Drawing.Imaging.BitmapData; -begin - w := b.Width; - h := b.Height; - rect := new System.Drawing.Rectangle(0,0,w,h); - bmpData := b.LockBits(rect, System.Drawing.Imaging.ImageLockMode.ReadWrite, b.PixelFormat); - - ptr := bmpData.Scan0; - b.UnlockBits(bmpData); - - pixelFormatSize := Image.GetPixelFormatSize(b.PixelFormat) div 8; - - start := (System.IntPtr)(integer(ptr) + w * pixelFormatSize * r.Y + r.X * pixelFormatSize); - - stride := w * pixelFormatSize; - padding := stride mod 4; - if padding<>0 then - stride := stride + 4 - padding; //pad out to multiple of 4 - - Result := new Bitmap(r.Width,r.Height,stride,b.PixelFormat,start); -end; - -procedure Swap(var x1,x2: integer); -var t: integer; -begin - t := x1; - x1 := x2; - x2 := t; -end; - -// Graphics Primitives -procedure Line(x1,y1,x2,y2: integer; c: Color; gr: Graphics); -begin - ColorLinePen.Color := c; - gr.DrawLine(ColorLinePen,x1,y1,x2,y2); -end; - -procedure Line(x1,y1,x2,y2: integer; gr: Graphics); -begin - gr.DrawLine(Pen.NETPen,x1,y1,x2,y2); -end; - -procedure FillRectangle(x1,y1,x2,y2: integer; gr: Graphics); -var sm: SmoothingMode; -begin - if x1>x2 then - Swap(x1,x2); - if y1>y2 then - Swap(y1,y2); - sm := gr.SmoothingMode; - gr.SmoothingMode := SmoothingMode.None; - if Brush.NETBrush<>nil then - gr.FillRectangle(Brush.NETBrush,x1,y1,x2-x1,y2-y1); - gr.SmoothingMode := sm; -end; - -procedure FillRect(x1,y1,x2,y2: integer; gr: Graphics); -begin - FillRectangle(x1,y1,x2,y2,gr); -end; - -procedure DrawRectangle(x1,y1,x2,y2: integer; gr: Graphics); -begin - if x1>x2 then - Swap(x1,x2); - if y1>y2 then - Swap(y1,y2); - gr.DrawRectangle(Pen.NETPen,x1,y1,x2-x1-1,y2-y1-1); -end; - -procedure Rectangle(x1,y1,x2,y2: integer; gr: Graphics); -begin - if Brush.NETBrush <> nil then - FillRectangle(x1,y1,x2-1,y2-1,gr); - if Pen.NETPen.DashStyle <> DashStyle.Custom then - DrawRectangle(x1,y1,x2,y2,gr); -end; - -procedure DrawEllipse(x1,y1,x2,y2: integer; gr: Graphics); -begin - if x1>x2 then - Swap(x1,x2); - if y1>y2 then - Swap(y1,y2); - gr.DrawEllipse(Pen.NETPen,x1,y1,x2-x1-1,y2-y1-1); -end; - -procedure FillEllipse(x1,y1,x2,y2: integer; gr: Graphics); -begin - if x1>x2 then - Swap(x1,x2); - if y1>y2 then - Swap(y1,y2); - gr.FillEllipse(Brush.NETBrush,x1,y1,x2-x1-1,y2-y1-1); -end; - -procedure Ellipse(x1,y1,x2,y2: integer; gr: Graphics); -begin - if Brush.NETBrush <> nil then - FillEllipse(x1,y1,x2,y2,gr); - if Pen.NETPen.DashStyle <> DashStyle.Custom then - DrawEllipse(x1,y1,x2,y2,gr); -end; - -procedure DrawCircle(x,y,r: integer; gr: Graphics); -begin - gr.DrawEllipse(Pen.NETPen,x-r,y-r,x+r,y+r); -end; - -procedure FillCircle(x,y,r: integer; gr: Graphics); -begin - gr.FillEllipse(Brush.NETBrush,x-r,y-r,x+r,y+r); -end; - -procedure Circle(x,y,r: integer; gr: Graphics); -begin - FillCircle(x,y,r,gr); - DrawCircle(x,y,r,gr); -end; - -function CreatePathForDrawRoundRect(x1,y1,x2,y2,w,h: integer): GraphicsPath; -var xx,yy: integer; -begin - if x1>x2 then - Swap(x1,x2); - if y1>y2 then - Swap(y1,y2); - xx := w div 2; - yy := h div 2; - Result := new GraphicsPath(); - Result.AddLine(x1 + xx, y1, x2 - xx, y1); - Result.AddArc(x2 - w - 1, y1, w, h, 270, 90); - Result.AddLine(x2 - 1, y1 + yy, x2 - 1, y2 - yy); - Result.AddArc(x2 - w - 1, y2 - h - 1, w, h, 0, 90); - Result.AddLine(x2 - xx, y2 - 1, x1 + xx, y2 - 1); - Result.AddArc(x1, y2 - h - 1, w, h, 90, 90); - Result.AddLine(x1, y2 - yy, x1, y1 + yy); - Result.AddArc(x1, y1, w, h, 180, 90); - Result.CloseFigure(); -end; - -procedure DrawRoundRect(x1,y1,x2,y2,w,h: integer; gr: Graphics); -var path: GraphicsPath; -begin - path := CreatePathForDrawRoundRect(x1,y1,x2,y2,w,h); - gr.DrawPath(Pen.NETPen, path); - path.Dispose; -end; - -procedure FillRoundRect(x1,y1,x2,y2,w,h: integer; gr: Graphics); -var path: GraphicsPath; -begin - path := CreatePathForDrawRoundRect(x1,y1,x2,y2,w,h); - gr.FillPath(Brush.NETBrush, path); - path.Dispose; -end; - -procedure RoundRect(x1,y1,x2,y2,w,h: integer; gr: Graphics); -begin - if Brush.NETBrush <> nil then - FillRoundRect(x1,y1,x2,y2,w,h,gr); - if Pen.NETPen.DashStyle <> DashStyle.Custom then - DrawRoundRect(x1,y1,x2,y2,w,h,gr); -end; - -procedure Arc(x,y,r,a1,a2: integer; gr: Graphics); -begin - a1:=360-a1; - a2:=360-a2; - if a2 nil then - FillPie(x,y,r,a1,a2,gr); - if Pen.NETPen.DashStyle <> DashStyle.Custom then - DrawPie(x,y,r,a1,a2,gr); -end; - -procedure DrawPolygon(a: array of Point; gr: Graphics); -begin - gr.DrawPolygon(Pen.NETPen,a); -end; - -procedure FillPolygon(a: array of Point; gr: Graphics); -begin - gr.FillPolygon(Brush.NETBrush,a); -end; - -procedure Polygon(a: array of Point; gr: Graphics); -begin - if Brush.NETBrush <> nil then - FillPolygon(a,gr); - if Pen.NETPen.DashStyle <> DashStyle.Custom then - DrawPolygon(a,gr); -end; - -procedure Polyline(a: array of Point; gr: Graphics); -begin - gr.DrawLines(Pen.NETPen,a); -end; - -procedure Curve(a: array of Point; gr: Graphics); -begin - gr.DrawCurve(Pen.NETPen,a); -end; - -procedure DrawClosedCurve(a: array of Point; gr: Graphics); -begin - gr.DrawClosedCurve(Pen.NETPen,a); -end; - -procedure FillClosedCurve(a: array of Point; gr: Graphics); -begin - gr.FillClosedCurve(Brush.NETBrush,a); -end; - -procedure ClosedCurve(a: array of Point; gr: Graphics); -begin - if Brush.NETBrush <> nil then - FillClosedCurve(a,gr); - if Pen.NETPen.DashStyle <> DashStyle.Custom then - DrawClosedCurve(a,gr); -end; - -procedure TextOut(x,y: integer; s: string; gr: Graphics); -var sz: SizeF; -begin - sz := gr.MeasureString(s,Font.NETFont,0,sf); - if Brush.NETBrush <> nil then - FillRectangle(x,y,x+round(sz.Width),y+round(sz.Height)+1,gr); - gr.DrawString(s,Font.NETFont,CurrentTextBrush,x,y,sf); -end; - -initialization - sf := new StringFormat(StringFormat.GenericTypographic); - sf.FormatFlags := StringFormatFlags.MeasureTrailingSpaces; - CurrentTextBrush := new SolidBrush(System.Drawing.Color.Black); - ColorLinePen := new System.Drawing.Pen(System.Drawing.Color.Black); -end. \ No newline at end of file diff --git a/bin/Lib/LibForVB/GraphABC/GraphABC.pas b/bin/Lib/LibForVB/GraphABC/GraphABC.pas deleted file mode 100644 index ce5b85d02..000000000 --- a/bin/Lib/LibForVB/GraphABC/GraphABC.pas +++ /dev/null @@ -1,3092 +0,0 @@ -///Модуль предоставляет константы, типы, процедуры, функции и классы для рисования в графическом окне -library GraphABC; - -//ne udaljat, IB 7.10.08 -#apptype windows -#reference 'System.Windows.Forms.dll' -#reference 'System.Drawing.dll' -//#gendoc true -#savepcu false - -interface - -uses - System, - System.Drawing, - System.Windows.Forms, - System.Drawing.Drawing2D; - -type -/// Тип цвета - Color = System.Drawing.Color; -/// Тип стиля штриховки кисти - HatchStyle = System.Drawing.Drawing2D.HatchStyle; -/// Тип стиля штриховки пера - DashStyle = System.Drawing.Drawing2D.DashStyle; -/// Тип исключения GraphABC - GraphABCException = class(Exception) end; -/// Тип точки - Point = System.Drawing.Point; - -var - clMoneyGreen: Color; - -const - // Default graph window size - defaultWindowWidth = 640; - defaultWindowHeight = 480; - - // Color constants - clAquamarine = Color.Aquamarine; clAzure = Color.Azure; - clBeige = Color.Beige; clBisque = Color.Bisque; - clBlack = Color.Black; clBlanchedAlmond = Color.BlanchedAlmond; - clBlue = Color.Blue; clBlueViolet = Color.BlueViolet; - clBrown = Color.Brown; clBurlyWood = Color.BurlyWood; - clCadetBlue = Color.CadetBlue; clChartreuse = Color.Chartreuse; - clChocolate = Color.Chocolate; clCoral = Color.Coral; - clCornflowerBlue = Color.CornflowerBlue; clCornsilk = Color.Cornsilk; - clCrimson = Color.Crimson; clCyan = Color.Cyan; - clDarkBlue = Color.DarkBlue; clDarkCyan = Color.DarkCyan; - clDarkGoldenrod = Color.DarkGoldenrod; clDarkGray = Color.DarkGray; - clDarkGreen = Color.DarkGreen; clDarkKhaki = Color.DarkKhaki; - clDarkMagenta = Color.DarkMagenta; clDarkOliveGreen = Color.DarkOliveGreen; - clDarkOrange = Color.DarkOrange; clDarkOrchid = Color.DarkOrchid; - clDarkRed = Color.DarkRed; clDarkTurquoise = Color.DarkTurquoise; - clDarkSeaGreen = Color.DarkSeaGreen; clDarkSlateBlue = Color.DarkSlateBlue; - clDarkSlateGray = Color.DarkSlateGray; clDarkViolet = Color.DarkViolet; - clDeepPink = Color.DeepPink; clDarkSalmon = Color.DarkSalmon; - clDeepSkyBlue = Color.DeepSkyBlue; clDimGray = Color.DimGray; - clDodgerBlue = Color.DodgerBlue; clFirebrick = Color.Firebrick; - clFloralWhite = Color.FloralWhite; clForestGreen = Color.ForestGreen; - clFuchsia = Color.Fuchsia; clGainsboro = Color.Gainsboro; - clGhostWhite = Color.GhostWhite; clGold = Color.Gold; - clGoldenrod = Color.Goldenrod; clGray = Color.Gray; - clGreen = Color.Green; clGreenYellow = Color.GreenYellow; - clHoneydew = Color.Honeydew; clHotPink = Color.HotPink; - clIndianRed = Color.IndianRed; clIndigo = Color.Indigo; - clIvory = Color.Ivory; clKhaki = Color.Khaki; - clLavender = Color.Lavender; clLavenderBlush = Color.LavenderBlush; - clLawnGreen = Color.LawnGreen; clLemonChiffon = Color.LemonChiffon; - clLightBlue = Color.LightBlue; clLightCoral = Color.LightCoral; - clLightCyan = Color.LightCyan; clLightGray = Color.LightGray; - clLightGreen = Color.LightGreen; clLightGoldenrodYellow = Color.LightGoldenrodYellow; - clLightPink = Color.LightPink; clLightSalmon = Color.LightSalmon; - clLightSeaGreen = Color.LightSeaGreen; clLightSkyBlue = Color.LightSkyBlue; - clLightSlateGray = Color.LightSlateGray; clLightSteelBlue = Color.LightSteelBlue; - clLightYellow = Color.LightYellow; clLime = Color.Lime; - clLimeGreen = Color.LimeGreen; clLinen = Color.Linen; - clMagenta = Color.Magenta; clMaroon = Color.Maroon; - clMediumBlue = Color.MediumBlue; clMediumOrchid = Color.MediumOrchid; - clMediumAquamarine = Color.MediumAquamarine; clMediumPurple = Color.MediumPurple; - clMediumSeaGreen = Color.MediumSeaGreen; clMediumSlateBlue = Color.MediumSlateBlue; - clPlum = Color.Plum; clMistyRose = Color.MistyRose; - clNavy = Color.Navy; clMidnightBlue = Color.MidnightBlue; - clMintCream = Color.MintCream; clMediumSpringGreen = Color.MediumSpringGreen; - clMoccasin = Color.Moccasin; clNavajoWhite = Color.NavajoWhite; - clMediumTurquoise = Color.MediumTurquoise; clOldLace = Color.OldLace; - clOlive = Color.Olive; clOliveDrab = Color.OliveDrab; - clOrange = Color.Orange; clOrangeRed = Color.OrangeRed; - clOrchid = Color.Orchid; clPaleGoldenrod = Color.PaleGoldenrod; - clPaleGreen = Color.PaleGreen; clPaleTurquoise = Color.PaleTurquoise; - clPaleVioletRed = Color.PaleVioletRed; clPapayaWhip = Color.PapayaWhip; - clPeachPuff = Color.PeachPuff; clPeru = Color.Peru; - clPink = Color.Pink; clMediumVioletRed = Color.MediumVioletRed; - clPowderBlue = Color.PowderBlue; clPurple = Color.Purple; - clRed = Color.Red; clRosyBrown = Color.RosyBrown; - clRoyalBlue = Color.RoyalBlue; clSaddleBrown = Color.SaddleBrown; - clSalmon = Color.Salmon; clSandyBrown = Color.SandyBrown; - clSeaGreen = Color.SeaGreen; clSeaShell = Color.SeaShell; - clSienna = Color.Sienna; clSilver = Color.Silver; - clSkyBlue = Color.SkyBlue; clSlateBlue = Color.SlateBlue; - clSlateGray = Color.SlateGray; clSnow = Color.Snow; - clSpringGreen = Color.SpringGreen; clSteelBlue = Color.SteelBlue; - clTan = Color.Tan; clTeal = Color.Teal; - clThistle = Color.Thistle; clTomato = Color.Tomato; - clTransparent = Color.Transparent; clTurquoise = Color.Turquoise; - clViolet = Color.Violet; clWheat = Color.Wheat; - clWhite = Color.White; clWhiteSmoke = Color.WhiteSmoke; - clYellow = Color.Yellow; clYellowGreen = Color.YellowGreen; - -// Virtual Key Codes - VK_Back = 8; VK_Tab = 9; - VK_LineFeed = 10; VK_Enter = 13; - VK_Return = 13; VK_ShiftKey = 16; VK_ControlKey = 17; - VK_Menu = 18; VK_Pause = 19; VK_CapsLock = 20; - VK_Capital = 20; - VK_Escape = 27; - VK_Space = 32; - VK_Prior = 33; VK_PageUp = 33; VK_PageDown = 34; - VK_Next = 34; VK_End = 35; VK_Home = 36; - VK_Left = 37; VK_Up = 38; VK_Right = 39; - VK_Down = 40; VK_Select = 41; VK_Print = 42; - VK_Snapshot = 44; VK_PrintScreen = 44; - VK_Insert = 45; VK_Delete = 46; VK_Help = 47; - VK_A = 65; VK_B = 66; - VK_C = 67; VK_D = 68; VK_E = 69; - VK_F = 70; VK_G = 71; VK_H = 72; - VK_I = 73; VK_J = 74; VK_K = 75; - VK_L = 76; VK_M = 77; VK_N = 78; - VK_O = 79; VK_P = 80; VK_Q = 81; - VK_R = 82; VK_S = 83; VK_T = 84; - VK_U = 85; VK_V = 86; VK_W = 87; - VK_X = 88; VK_Y = 89; VK_Z = 90; - VK_LWin = 91; VK_RWin = 92; VK_Apps = 93; - VK_Sleep = 95; VK_NumPad0 = 96; VK_NumPad1 = 97; - VK_NumPad2 = 98; VK_NumPad3 = 99; VK_NumPad4 = 100; - VK_NumPad5 = 101; VK_NumPad6 = 102; VK_NumPad7 = 103; - VK_NumPad8 = 104; VK_NumPad9 = 105; VK_Multiply = 106; - VK_Add = 107; VK_Separator = 108; VK_Subtract = 109; - VK_Decimal = 110; VK_Divide = 111; VK_F1 = 112; - VK_F2 = 113; VK_F3 = 114; VK_F4 = 115; - VK_F5 = 116; VK_F6 = 117; VK_F7 = 118; - VK_F8 = 119; VK_F9 = 120; VK_F10 = 121; - VK_F11 = 122; VK_F12 = 123; VK_NumLock = 144; - VK_Scroll = 145; VK_LShiftKey = 160; VK_RShiftKey = 161; - VK_LControlKey = 162; VK_RControlKey = 163; VK_LMenu = 164; - VK_RMenu = 165; - VK_KeyCode = 65535; VK_Shift = 65536; VK_Control = 131072; - VK_Alt = 262144; VK_Modifiers = -65536; - -// Pen style constants - psSolid = DashStyle.Solid; - psClear = DashStyle.Custom; - psDash = DashStyle.Dash; - psDot = DashStyle.Dot; - psDashDot = DashStyle.DashDot; - psDashDotDot = DashStyle.DashDotDot; - -// Pen mode constants - pmCopy = 0; - pmNot = 1; - -// Brush hatch type constants - bhHorizontal = HatchStyle.Horizontal; - bhMin = HatchStyle.Min; - bhVertical = HatchStyle.Vertical; - bhForwardDiagonal = HatchStyle.ForwardDiagonal; - bhBackwardDiagonal = HatchStyle.BackwardDiagonal; - bhCross = HatchStyle.Cross; - bhLargeGrid = HatchStyle.LargeGrid; - bhMax = HatchStyle.Max; - bhDiagonalCross = HatchStyle.DiagonalCross; - bhPercent05 = HatchStyle.Percent05; - bhPercent10 = HatchStyle.Percent10; - bhPercent20 = HatchStyle.Percent20; - bhPercent25 = HatchStyle.Percent25; - bhPercent30 = HatchStyle.Percent30; - bhPercent40 = HatchStyle.Percent40; - bhPercent50 = HatchStyle.Percent50; - bhPercent60 = HatchStyle.Percent60; - bhPercent70 = HatchStyle.Percent70; - bhPercent75 = HatchStyle.Percent75; - bhPercent80 = HatchStyle.Percent80; - bhPercent90 = HatchStyle.Percent90; - bhLightDownwardDiagonal = HatchStyle.LightDownwardDiagonal; - bhLightUpwardDiagonal = HatchStyle.LightUpwardDiagonal; - bhDarkDownwardDiagonal = HatchStyle.DarkDownwardDiagonal; - bhDarkUpwardDiagonal = HatchStyle.DarkUpwardDiagonal; - bhWideDownwardDiagonal = HatchStyle.WideDownwardDiagonal; - bhWideUpwardDiagonal = HatchStyle.WideUpwardDiagonal; - bhLightVertical = HatchStyle.LightVertical; - bhLightHorizontal = HatchStyle.LightHorizontal; - bhNarrowVertical = HatchStyle.NarrowVertical; - bhNarrowHorizontal = HatchStyle.NarrowHorizontal; - bhDarkVertical = HatchStyle.DarkVertical; - bhDarkHorizontal = HatchStyle.DarkHorizontal; - bhDashedDownwardDiagonal = HatchStyle.DashedDownwardDiagonal; - bhDashedUpwardDiagonal = HatchStyle.DashedUpwardDiagonal; - bhDashedHorizontal = HatchStyle.DashedHorizontal; - bhDashedVertical = HatchStyle.DashedVertical; - bhSmallConfetti = HatchStyle.SmallConfetti; - bhLargeConfetti = HatchStyle.LargeConfetti; - bhZigZag = HatchStyle.ZigZag; - bhWave = HatchStyle.Wave; - bhDiagonalBrick = HatchStyle.DiagonalBrick; - bhHorizontalBrick = HatchStyle.HorizontalBrick; - bhWeave = HatchStyle.Weave; - bhPlaid = HatchStyle.Plaid; - bhDivot = HatchStyle.Divot; - bhDottedGrid = HatchStyle.DottedGrid; - bhDottedDiamond = HatchStyle.DottedDiamond; - bhShingle = HatchStyle.Shingle; - bhTrellis = HatchStyle.Trellis; - bhSphere = HatchStyle.Sphere; - bhSmallGrid = HatchStyle.SmallGrid; - bhSmallCheckerBoard = HatchStyle.SmallCheckerBoard; - bhLargeCheckerBoard = HatchStyle.LargeCheckerBoard; - bhOutlinedDiamond = HatchStyle.OutlinedDiamond; - bhSolidDiamond = HatchStyle.SolidDiamond; - -// Font & Brush style constants -type - FontStyleType = (fsNormal, fsBold, fsItalic, fsBoldItalic, fsUnderline, fsBoldUnderline, fsItalicUnderline, fsBoldItalicUnderline); - BrushStyleType = (bsSolid, bsClear, bsHatch, bsGradient, bsNone); - -/// Закрашивает пиксел с координатами (x,y) цветом c -procedure SetPixel(x,y: integer; c: Color); -/// Закрашивает пиксел с координатами (x,y) цветом c -procedure PutPixel(x,y: integer; c: Color); -/// Возвращает цвет пиксела с координатами (x,y) -function GetPixel(x,y: integer): Color; - -/// Устанавливает текущую позицию рисования в точку (x,y) -procedure MoveTo(x,y: integer); -/// Рисует отрезок от текущей позиции до точки (x,y). Текущая позиция переносится в точку (x,y) -procedure LineTo(x,y: integer); -/// Рисует отрезок от текущей позиции до точки (x,y) цветом c. Текущая позиция переносится в точку (x,y) -procedure LineTo(x,y: integer; c: Color); - -/// Рисует отрезок от точки (x1,y1) до точки (x2,y2) -procedure Line(x1,y1,x2,y2: integer); -/// Рисует отрезок от точки (x1,y1) до точки (x2,y2) цветом c -procedure Line(x1,y1,x2,y2: integer; c: Color); - -/// Заполняет внутренность окружности с центром (x,y) и радиусом r -procedure FillCircle(x,y,r: integer); -/// Рисует окружность с центром (x,y) и радиусом r -procedure DrawCircle(x,y,r: integer); -/// Заполняет внутренность эллипса, ограниченного прямоугольником, заданным координатами противоположных вершин (x1,y1) и (x2,y2) -procedure FillEllipse(x1,y1,x2,y2: integer); -/// Рисует границу эллипса, ограниченного прямоугольником, заданным координатами противоположных вершин (x1,y1) и (x2,y2) -procedure DrawEllipse(x1,y1,x2,y2: integer); -/// Заполняет внутренность прямоугольника, заданного координатами противоположных вершин (x1,y1) и (x2,y2) -procedure FillRectangle(x1,y1,x2,y2: integer); -/// Заполняет внутренность прямоугольника, заданного координатами противоположных вершин (x1,y1) и (x2,y2) -procedure FillRect(x1,y1,x2,y2: integer); -/// Рисует границу прямоугольника, заданного координатами противоположных вершин (x1,y1) и (x2,y2) -procedure DrawRectangle(x1,y1,x2,y2: integer); -/// Заполняет внутренность прямоугольника со скругленными краями; (x1,y1) и (x2,y2) задают пару противоположных вершин, а w и h – ширину и высоту эллипса, используемого для скругления краев -procedure FillRoundRect(x1,y1,x2,y2,w,h: integer); -/// Рисует границу прямоугольника со скругленными краями; (x1,y1) и (x2,y2) задают пару противоположных вершин, а w и h – ширину и высоту эллипса, используемого для скругления краев -procedure DrawRoundRect(x1,y1,x2,y2,w,h: integer); - -/// Рисует заполненную окружность с центром (x,y) и радиусом r -procedure Circle(x,y,r: integer); -/// Рисует заполненный эллипс, ограниченный прямоугольником, заданным координатами противоположных вершин (x1,y1) и (x2,y2) -procedure Ellipse(x1,y1,x2,y2: integer); -/// Рисует заполненный прямоугольник, заданный координатами противоположных вершин (x1,y1) и (x2,y2) -procedure Rectangle(x1,y1,x2,y2: integer); -/// Рисует заполненный прямоугольник со скругленными краями; (x1,y1) и (x2,y2) задают пару противоположных вершин, а w и h – ширину и высоту эллипса, используемого для скругления краев -procedure RoundRect(x1,y1,x2,y2,w,h: integer); - -/// Рисует дугу окружности с центром в точке (x,y) и радиусом r, заключенной между двумя лучами, образующими углы a1 и a2 с осью OX (a1 и a2 – вещественные, задаются в градусах и отсчитываются против часовой стрелки) -procedure Arc(x,y,r,a1,a2: integer); -/// Заполняет внутренность сектора окружности, ограниченного дугой с центром в точке (x,y) и радиусом r, заключенной между двумя лучами, образующими углы a1 и a2 с осью OX (a1 и a2 – вещественные, задаются в градусах и отсчитываются против часовой стрелки) -procedure FillPie(x,y,r,a1,a2: integer); -/// Рисует сектор окружности, ограниченный дугой с центром в точке (x,y) и радиусом r, заключенной между двумя лучами, образующими углы a1 и a2 с осью OX (a1 и a2 – вещественные, задаются в градусах и отсчитываются против часовой стрелки) -procedure DrawPie(x,y,r,a1,a2: integer); -/// Рисует заполненный сектор окружности, ограниченный дугой с центром в точке (x,y) и радиусом r, заключенной между двумя лучами, образующими углы a1 и a2 с осью OX (a1 и a2 – вещественные, задаются в градусах и отсчитываются против часовой стрелки) -procedure Pie(x,y,r,a1,a2: integer); - -/// Рисует замкнутую ломаную по точкам, координаты которых заданы в массиве points -procedure DrawPolygon(points: array of Point); -/// Заполняет многоугольник, координаты вершин которого заданы в массиве points -procedure FillPolygon(points: array of Point); -/// Рисует заполненный многоугольник, координаты вершин которого заданы в массиве points -procedure Polygon(points: array of Point); -/// Рисует ломаную по точкам, координаты которых заданы в массиве points -procedure Polyline(points: array of Point); -/// Рисует кривую по точкам, координаты которых заданы в массиве points -procedure Curve(points: array of Point); -/// Рисует замкнутую кривую по точкам, координаты которых заданы в массиве points -procedure DrawClosedCurve(points: array of Point); -/// Заполняет замкнутую кривую по точкам, координаты которых заданы в массиве points -procedure FillClosedCurve(points: array of Point); -/// Рисует заполненную замкнутую кривую по точкам, координаты которых заданы в массиве points -procedure ClosedCurve(points: array of Point); - -/// Выводит строку s в прямоугольник к координатами левого верхнего угла (x,y) -procedure TextOut(x,y: integer; s: string); -/// Заливает область одного цвета цветом c, начиная с точки (x,y). -procedure FloodFill(x,y: integer; c: Color); - -{procedure FillCircle(x,y,r: integer; c: Color); -procedure DrawCircle(x,y,r: integer; c: Color); -procedure FillEllipse(x1,y1,x2,y2: integer; c: Color); -procedure DrawEllipse(x1,y1,x2,y2: integer; c: Color); -procedure FillRectangle(x1,y1,x2,y2: integer; c: Color); -procedure FillRect(x1,y1,x2,y2: integer; c: Color); -procedure DrawRectangle(x1,y1,x2,y2: integer; c: Color); -procedure DrawRoundRect(x1,y1,x2,y2,w,h: integer; c: Color); -procedure FillRoundRect(x1,y1,x2,y2,w,h: integer; c: Color); - -procedure Circle(x,y,r: integer; c: Color); -procedure Ellipse(x1,y1,x2,y2: integer; c: Color); -procedure Rectangle(x1,y1,x2,y2: integer; c: Color); -procedure RoundRect(x1,y1,x2,y2,w,h: integer; c: Color); - -procedure Arc(x,y,r,a1,a2: integer; c: Color); -procedure FillPie(x,y,r,a1,a2: integer; c: Color); -procedure DrawPie(x,y,r,a1,a2: integer; c: Color); -procedure Pie(x,y,r,a1,a2: integer; c: Color); - -procedure DrawPolygon(a: array of Point; c: Color); -procedure FillPolygon(a: array of Point; c: Color); -procedure Polygon(a: array of Point; c: Color); -procedure Polyline(a: array of Point; c: Color);} - -//-------------------------------------------- -//// Цвета -//-------------------------------------------- -/// Возвращает цвет, который содержит красную (r), зеленую (g) и синюю (b) составляющие (r,g и b - в диапазоне от 0 до 255) -function RGB(r,g,b: byte): Color; -/// Возвращает цвет, который содержит красную (r), зеленую (g) и синюю (b) составляющие и прозрачность (a) (a,r,g,b - в диапазоне от 0 до 255) -function ARGB(a,r,g,b: byte): Color; - -/// Возвращает красный цвет с интенсивностью r (r - в диапазоне от 0 до 255) -function RedColor(r: byte): Color; -/// Возвращает зеленый цвет с интенсивностью g (g - в диапазоне от 0 до 255) -function GreenColor(g: byte): Color; -/// Возвращает синий цвет с интенсивностью b (b - в диапазоне от 0 до 255) -function BlueColor(b: byte): Color; -/// Возвращает случайный цвет -function clRandom: Color; - -/// Возвращает красную составляющую цвета -function GetRed(c: Color): integer; -/// Возвращает зеленую составляющую цвета -function GetGreen(c: Color): integer; -/// Возвращает синюю составляющую цвета -function GetBlue(c: Color): integer; -/// Возвращает составляющую прозрачности цвета -function GetAlpha(c: Color): integer; - -//-------------------------------------------- -//// Перья -//-------------------------------------------- -/// Устанавливает цвет текущего пера -procedure SetPenColor(c: Color); -/// Возвращает цвет текущего пера -function PenColor: Color; -/// Устанавливает ширину текущего пера -procedure SetPenWidth(Width: integer); -/// Возвращает ширину текущего пера -function PenWidth: integer; -/// Устанавливает стиль текущего пера -procedure SetPenStyle(style: DashStyle); -/// Возвращает стиль текущего пера -function PenStyle: DashStyle; -/// Устанавливает режим текущего пера -procedure SetPenMode(m: integer); -/// Возвращает режим текущего пера -function PenMode: integer; - -/// Возвращают x-координату текущей позиции рисования -function PenX: integer; -/// Возвращают y-координату текущей позиции рисования -function PenY: integer; - -//-------------------------------------------- -//// Кисти -//-------------------------------------------- -/// Устанавливает цвет текущей кисти -procedure SetBrushColor(c: Color); -/// Возвращает цвет текущей кисти -function BrushColor: Color; -/// Устанавливает цвет текущей кисти -procedure SetBrushStyle(bs: BrushStyleType); -/// Возвращает цвет текущей кисти -function BrushStyle: BrushStyleType; -/// Устанавливает штриховку текущей кисти -procedure SetBrushHatch(bh: HatchStyle); -/// Возвращает штриховку текущей кисти -function BrushHatch: HatchStyle; -/// Устанавливает цвет заднего плана текущей штриховой кисти -procedure SetHatchBrushBackgroundColor(c: Color); -/// Возвращает цвет заднего плана текущей штриховой кисти -function HatchBrushBackgroundColor: Color; -/// Устанавливает второй цвет текущей градиентной кисти -procedure SetGradientBrushSecondColor(c: Color); -/// Возвращает второй цвет текущей градиентной кисти -function GradientBrushSecondColor: Color; - -//-------------------------------------------- -//// Шрифты -//-------------------------------------------- -/// Устанавливает размер текущего шрифта в пунктах -procedure SetFontSize(size: integer); -/// Возвращает размер текущего шрифта в пунктах -function FontSize: integer; -/// Устанавливает имя текущего шрифта -procedure SetFontName(name: string); -/// Возвращает имя текущего шрифта -function FontName: string; -/// Устанавливает цвет текущего шрифта -procedure SetFontColor(c: Color); -/// Возвращает цвет текущего шрифта -function FontColor: Color; -/// Устанавливает стиль текущего шрифта -procedure SetFontStyle(fs: FontStyleType); -/// Возвращает стиль текущего шрифта -function FontStyle: FontStyleType; -/// Возвращает ширину строки s в пикселях при текущих настройках шрифта -function TextWidth(s: string): integer; -/// Возвращает высоту строки s в пикселях при текущих настройках шрифта -function TextHeight(s: string): integer; - -//-------------------------------------------- -//// Графическое окно -//-------------------------------------------- -/// Очищает графическое окно белым цветом -procedure ClearWindow; -/// Очищает графическое окно цветом c -procedure ClearWindow(c: Color); - -/// Возвращает ширину клиентской части графического окна в пикселах -function WindowWidth: integer; -/// Возвращает высоту клиентской части графического окна в пикселах -function WindowHeight: integer; -/// Возвращает отступ графического окна от левого края экрана в пикселах -function WindowLeft: integer; -/// Возвращает отступ графического окна от верхнего края экрана в пикселах -function WindowTop: integer; -/// Возвращает центр графического окна -function WindowCenter: Point; -/// Возвращает True, если графическое окно имеет фиксированный размер, и False в противном случае -function WindowIsFixedSize: boolean; - -/// Устанавливает ширину клиентской части графического окна в пикселах -procedure SetWindowWidth(w: integer); -/// Устанавливает высоту клиентской части графического окна в пикселах -procedure SetWindowHeight(h: integer); -/// Устанавливает отступ графического окна от левого края экрана в пикселах -procedure SetWindowLeft(l: integer); -/// Устанавливает отступ графического окна от верхнего края экрана в пикселах -procedure SetWindowTop(t: integer); -/// Устанавливает, имеет ли графическое окно фиксированный размер -procedure SetWindowIsFixedSize(b: boolean); - -/// Устанавливает размеры клиентской части графического окна в пикселах -procedure SetWindowSize(w,h: integer); -/// Устанавливает отступ графического окна от левого верхнего края экрана в пикселах -procedure SetWindowPos(l,t: integer); - -/// Возвращает ширину графического компонента в пикселах (по умолчанию совпадает с WindowWidth) -function GraphBoxWidth: integer; -/// Возвращает высоту графического компонента в пикселах (по умолчанию совпадает с WindowHeight) -function GraphBoxHeight: integer; -/// Возвращает отступ графического компонента от левого края окна в пикселах -function GraphBoxLeft: integer; -/// Возвращает отступ графического компонента от верхнего края окна в пикселах -function GraphBoxTop: integer; - -/// Возвращает заголовок графического окна -function WindowCaption: string; -/// Возвращает заголовок графического окна -function WindowTitle: string; -/// Устанавливает заголовок графического окна -procedure SetWindowCaption(s: string); -/// Устанавливает заголовок графического окна -procedure SetWindowTitle(s: string); - -/// Устанавливает ширину и высоту клиентской части графического окна в пикселах -procedure InitWindow(Left,Top,Width,Height: integer; BackColor: Color := clWhite); - -/// Сохраняет содержимое графического окна в файл с именем fname -procedure SaveWindow(fname: string); -/// Восстанавливает содержимое графического окна из файла с именем fname -procedure LoadWindow(fname: string); -/// Заполняет содержимое графического окна обоями из файла с именем fname -procedure FillWindow(fname: string); -/// Закрывает графическое окно и завершает приложение -procedure CloseWindow; - -/// Возвращает ширину экрана в пикселях -function ScreenWidth: integer; -/// Возвращает высоту экрана в пикселях -function ScreenHeight: integer; - -/// Центрирует графическое окно по центру экрана -procedure CenterWindow; -/// Максимизирует графическое окно -procedure MaximizeWindow; -/// Сворачивает графическое окно -procedure MinimizeWindow; -/// Возвращает графическое окно к нормальному размеру -procedure NormalizeWindow; - -//-------------------------------------------- -//// Буферизация рисования -//-------------------------------------------- -/// Перерисовывает содержимое графического окна. Вызывается в паре с LockDrawing -procedure Redraw; -///-- -procedure FullRedraw; -/// Блокирует рисование на графическом окне. Перерисовка графического окна выполняется с помощью Redraw -procedure LockDrawing; -/// Снимает блокировку рисования на графическом окне и осуществляет его перерисовку -procedure UnlockDrawing; - -//-------------------------------------------- -//// Сглаживание -//-------------------------------------------- -/// Устанавливает режим сглаживания -procedure SetSmoothing(sm: boolean); -/// Включает режим сглаживания -procedure SetSmoothingOn; -/// Выключает режим сглаживания -procedure SetSmoothingOff; -/// Возвращает True, если режим сглаживания установлен -function SmoothingIsOn: boolean; - -//-------------------------------------------- -//// Вспомогательные подпрограммы -//-------------------------------------------- -/// Блокирует прорисовку графики. Вызывается для синхронизации -procedure LockGraphics; -/// Разблокирует прорисовку графики. Вызывается для синхронизации -procedure UnLockGraphics; - -//------------------------------------------------------------ -//// Подпрограммы для работы с системой координат -//------------------------------------------------------------ -/// Устанавливает начало координат в точку (x0,y0) -procedure SetCoordinateOrigin(x0,y0: integer); -/// Устанавливает масштаб системы координат -procedure SetCoordinateScale(sx,sy: real); -/// Устанавливает поворот системы координат -procedure SetCoordinateAngle(a: real); - -/// Инициализирует графическое окно. Используется для внутренних целей -procedure InitGraphABC; - -type -/// Тип пера GraphABC - GraphABCPen = class - public - _NETPen: System.Drawing.Pen; - procedure SetColor(c: GraphABC.Color); - function GetColor: GraphABC.Color; - procedure SetWidth(w: integer); - function GetWidth: integer; - procedure SetStyle(st: DashStyle); - function GetStyle: DashStyle; - procedure SetMode(m: integer); - function GetMode: integer; - procedure SetNETPen(p: System.Drawing.Pen); - function GetX: integer; - function GetY: integer; - public - /// Текущее перо .NET - property NETPen: System.Drawing.Pen read _NETPen write SetNETPen; - /// Цвет пера - property Color: GraphABC.Color read GetColor write SetColor; - /// Ширина пера - property Width: integer read GetWidth write SetWidth; - /// Стиль пера - property Style: DashStyle read GetStyle write SetStyle; - /// Режим пера - property Mode: integer read GetMode write SetMode; - /// X-координата текущей позиции пера - property X: integer read GetX; - /// Y-координата текущей позиции пера - property Y: integer read GetY; - end; - -/// Тип кисти GraphABC - GraphABCBrush = class - public - _NETBrush: System.Drawing.Brush; - procedure SetNETBrush(b: System.Drawing.Brush); - procedure SetColor(c: GraphABC.Color); - function GetColor: GraphABC.Color; - procedure SetStyle(st: BrushStyleType); - function GetStyle: BrushStyleType; - procedure SetHatch(h: HatchStyle); - function GetHatch: HatchStyle; - procedure SetHatchBackgroundColor(c: GraphABC.Color); - function GetHatchBackgroundColor: GraphABC.Color; - procedure SetGradientSecondColor(c: GraphABC.Color); - function GetGradientSecondColor: GraphABC.Color; - public -/// Текущая кисть .NET - property NETBrush: System.Drawing.Brush read _NETBrush write SetNETBrush; -/// Цвет кисти - property Color: GraphABC.Color read GetColor write SetColor; -/// Стиль кисти - property Style: BrushStyleType read GetStyle write SetStyle; -/// Штриховка кисти - property Hatch: HatchStyle read GetHatch write SetHatch; -/// Цвет заднего плана штриховой кисти - property HatchBackgroundColor: GraphABC.Color read GetHatchBackgroundColor write SetHatchBackgroundColor; -/// Второй цвет градиентной кисти - property GradientSecondColor: GraphABC.Color read GetGradientSecondColor write SetGradientSecondColor; - end; - -/// Тип шрифта GraphABC - GraphABCFont = class - public - _NETFont: System.Drawing.Font; - procedure SetNETFont(f: System.Drawing.Font); - procedure SetColor(c: GraphABC.Color); - function GetColor: GraphABC.Color; - procedure SetStyle(st: FontStyleType); - function GetStyle: FontStyleType; - procedure SetSize(sz: integer); - function GetSize: integer; - procedure SetName(nm: string); - function GetName: string; - public -/// Текущий шрифт .NET - property NETFont: System.Drawing.Font read _NETFont write SetNETFont; - /// Цвет шрифта - property Color: GraphABC.Color read GetColor write SetColor; - /// Стиль шрифта - property Style: FontStyleType read GetStyle write SetStyle; - /// Размер шрифта в пунктах - property Size: integer read GetSize write SetSize; - /// Наименование шрифта - property Name: string read GetName write SetName; - end; - - GraphABCCoordinate = class - public - coef: integer; - procedure SetOriginX(x: integer); - procedure SetOriginY(y: integer); - procedure SetOrigin(p: Point); - procedure SetAngle(a: real); - procedure SetScaleX(sx: real); - procedure SetScaleY(sy: real); - function GetOriginX: integer; - function GetOriginY: integer; - function GetOrigin: Point; - function GetAngle: real; - function GetScaleX: real; - function GetScaleY: real; - function GetMatrix: System.Drawing.Drawing2D.Matrix; - public - constructor; - /// Устанавливает параметры системы координат - procedure SetTransform(x0,y0,angle,sx,sy: real); - /// Устанавливает начало системы координат - procedure SetOrigin(x0,y0: integer); - /// Устанавливает масштаб системы координат - procedure SetScale(sx,sy: real); - /// Устанавливает масштаб системы координат - procedure SetScale(scale: real); - /// Устанавливает правую систему координат (ось OY направлена вверх, ось OX - вправо) - procedure SetMathematic; - /// Устанавливает левую систему координат (ось OY направлена вниз, ось OX - вправо) - procedure SetStandard; - /// X-координата начала координат относительно левого верхнего угла окна - property OriginX: integer read GetOriginX write SetOriginX; - /// Y-координата начала координат относительно левого верхнего угла окна - property OriginY: integer read GetOriginY write SetOriginY; - /// Координаты начала координат относительно левого верхнего угла окна - property Origin: Point read GetOrigin write SetOrigin; - /// Угол поворота системы координат - property Angle: real read GetAngle write SetAngle; - /// Масштаб системы координат по оси X - property ScaleX: real read GetScaleX write SetScaleX; - /// Масштаб системы координат по оси Y - property ScaleY: real read GetScaleY write SetScaleY; - /// Масштаб системы координат по обоим осям - property Scale: real write SetScale; - /// Матрица 3x3 преобразований координат - property Matrix: System.Drawing.Drawing2D.Matrix read GetMatrix; - end; - - GraphABCWindow = class - public - procedure SetLeft(l: integer); - function GetLeft: integer; - procedure SetTop(t: integer); - function GetTop: integer; - procedure SetWidth(w: integer); - function GetWidth: integer; - procedure SetHeight(h: integer); - function GetHeight: integer; - procedure SetCaption(c: string); - function GetCaption: string; - procedure SetIsFixedSize(b: boolean); - function GetIsFixedSize: boolean; - public -/// Отступ графического окна от левого края экрана в пикселах - property Left: integer read GetLeft write SetLeft; -/// Отступ графического окна от верхнего края экрана в пикселах - property Top: integer read GetTop write SetTop; -/// Ширина клиентской части графического окна в пикселах - property Width: integer read GetWidth write SetWidth; -/// Высота клиентской части графического окна в пикселах - property Height: integer read GetHeight write SetHeight; -/// Заголовок графического окна - property Caption: string read GetCaption write SetCaption; -/// Заголовок графического окна - property Title: string read GetCaption write SetCaption; -/// Имеет ли графическое окно фиксированный размер - property IsFixedSize: boolean read GetIsFixedSize write SetIsFixedSize; -/// Очищает графическое окно белым цветом - procedure Clear; -/// Очищает графическое окно цветом c - procedure Clear(c: Color); -/// Устанавливает размеры клиентской части графического окна в пикселах - procedure SetSize(w,h: integer); -/// Устанавливает отступ графического окна от левого верхнего края экрана в пикселах - procedure SetPos(l,t: integer); -/// Устанавливает положение, размеры и цвет графического окна - procedure Init(Left,Top,Width,Height: integer; BackColor: Color := clWhite); -/// Сохраняет содержимое графического окна в файл с именем fname - procedure Save(fname: string); -/// Восстанавливает содержимое графического окна из файла с именем fname - procedure Load(fname: string); -/// Заполняет содержимое графического окна обоями из файла с именем fname - procedure Fill(fname: string); -/// Закрывает графическое окно и завершает приложение - procedure Close; -/// Сворачивает графическое окно - procedure Minimize; -/// Максимизирует графическое окно - procedure Maximize; -/// Возвращает графическое окно к нормальному размеру - procedure Normalize; -/// Центрирует графическое окно по центру экрана - procedure CenterOnScreen; -/// Возвращает центр графического окна - function Center: Point; - end; - -/// Тип рисунка GraphABC - Picture = class - public - bmp,savedbmp: Bitmap; - gb: Graphics; - istransp: boolean; - transpcolor: System.Drawing.Color; - procedure SetWidth(w: integer); - function GetWidth: integer; - procedure SetHeight(h: integer); - function GetHeight: integer; - procedure SetTransparent(b: boolean); - procedure SetTransparentColor(c: GraphABC.Color); - function GetTransparentColor: GraphABC.Color; - public -/// Создает рисунок размера w на h пикселей - constructor Create(w,h: integer); -/// Создает рисунок из файла с именем fname - constructor Create(fname: string); -/// Создает рисунок из прямоугольника r графического окна - constructor Create(r: System.Drawing.Rectangle); // Create from screen -/// Загружает рисунок из файла с именем fname - procedure Load(fname: string); -/// Сохраняет рисунок в файл с именем fname - procedure Save(fname: string); -/// Устанавливает размер рисунка w на h пикселей - procedure SetSize(w,h: integer); -/// Ширина рисунка в пикселах - property Width: integer read GetWidth write SetWidth; -/// Высота рисунка в пикселах - property Height: integer read GetHeight write SetHeight; -/// Прозрачность рисунка; прозрачный цвет задается свойством TransparentColor - property Transparent: boolean read istransp write SetTransparent; -/// Прозрачный цвет рисунка. Должна быть установлена прозрачность Transparent := True - property TransparentColor: GraphABC.Color read GetTransparentColor write SetTransparentColor; -/// Возвращает True, если изображение данного рисунка пересекается с изображением рисунка p, и False в противном случае. Белый цвет считается прозрачным - function Intersect(p: Picture): boolean; -/// Выводит рисунок в позиции (x,y) - procedure Draw(x,y: integer); -/// Выводит рисунок в позиции (x,y) на поверхность рисования g - procedure Draw(x,y: integer; g: Graphics); -/// Выводит рисунок в позиции (x,y), масштабируя его к размеру (w,h) - procedure Draw(x,y,w,h: integer); -/// Выводит рисунок в позиции (x,y), масштабируя его к размеру (w,h), на поверхность рисования g - procedure Draw(x,y,w,h: integer; g: Graphics); -/// Выводит часть рисунка, заключенную в прямоугольнике r, в позиции (x,y) - procedure Draw(x,y: integer; r: System.Drawing.Rectangle); // r - part of Picture -/// Выводит часть рисунка, заключенную в прямоугольнике r, в позиции (x,y) на поверхность рисования g - procedure Draw(x,y: integer; r: System.Drawing.Rectangle; g: Graphics); -/// Выводит часть рисунка, заключенную в прямоугольнике r, в позиции (x,y), масштабируя его к размеру (w,h) - procedure Draw(x,y,w,h: integer; r: System.Drawing.Rectangle); // r - part of Picture -/// Выводит часть рисунка, заключенную в прямоугольнике r, в позиции (x,y), масштабируя его к размеру (w,h), на поверхность рисования g - procedure Draw(x,y,w,h: integer; r: System.Drawing.Rectangle; g: Graphics); -/// Копирует прямоугольник src рисунка p в прямоугольник dst текущего рисунка - procedure CopyRect(dst: System.Drawing.Rectangle; p: Picture; src: System.Drawing.Rectangle); -/// Копирует прямоугольник src битового образа bmp в прямоугольник dst текущего рисунка - procedure CopyRect(dst: System.Drawing.Rectangle; bmp: Bitmap; src: System.Drawing.Rectangle); -/// Зеркально отображает рисунок относительно горизонтальной оси симметрии - procedure FlipHorizontal; -/// Зеркально отображает рисунок относительно вертикальной оси симметрии - procedure FlipVertical; - -/// Закрашивает пиксел (x,y) рисунка цветом c - procedure SetPixel(x,y: integer; c: Color); -/// Закрашивает пиксел (x,y) рисунка цветом c - procedure PutPixel(x,y: integer; c: Color); -/// Возвращает цвет пиксела (x,y) рисунка - function GetPixel(x,y: integer): Color; - -/// Выводит на рисунке отрезок от точки (x1,y1) до точки (x2,y2) - procedure Line(x1,y1,x2,y2: integer); -/// Выводит на рисунке отрезок от точки (x1,y1) до точки (x2,y2) цветом c - procedure Line(x1,y1,x2,y2: integer; c: Color); - -/// Заполняет на рисунке внутренность окружности с центром (x,y) и радиусом r - procedure FillCircle(x,y,r: integer); -/// Выводит на рисунке окружность с центром (x,y) и радиусом r - procedure DrawCircle(x,y,r: integer); -/// Заполняет на рисунке внутренность эллипса, ограниченного прямоугольником, заданным координатами противоположных вершин (x1,y1) и (x2,y2) - procedure FillEllipse(x1,y1,x2,y2: integer); -/// Выводит на рисунке границу эллипса, ограниченного прямоугольником, заданным координатами противоположных вершин (x1,y1) и (x2,y2) - procedure DrawEllipse(x1,y1,x2,y2: integer); -/// Заполняет на рисунке внутренность прямоугольника, заданного координатами противоположных вершин (x1,y1) и (x2,y2) - procedure FillRectangle(x1,y1,x2,y2: integer); -/// Заполняет на рисунке внутренность прямоугольника, заданного координатами противоположных вершин (x1,y1) и (x2,y2) - procedure FillRect(x1,y1,x2,y2: integer); -/// Выводит на рисунке границу ы прямоугольника, заданного координатами противоположных вершин (x1,y1) и (x2,y2) - procedure DrawRectangle(x1,y1,x2,y2: integer); - -/// Выводит на рисунке заполненную окружность с центром (x,y) и радиусом r - procedure Circle(x,y,r: integer); -/// Выводит на рисунке заполненный эллипс, ограниченный прямоугольником, заданным координатами противоположных вершин (x1,y1) и (x2,y2) - procedure Ellipse(x1,y1,x2,y2: integer); -/// Выводит на рисунке заполненный прямоугольник, заданный координатами противоположных вершин (x1,y1) и (x2,y2) - procedure Rectangle(x1,y1,x2,y2: integer); -/// Выводит на рисунке заполненный прямоугольник со скругленными краями; (x1,y1) и (x2,y2) задают пару противоположных вершин, а w и h – ширину и высоту эллипса, используемого для скругления краев - procedure RoundRect(x1,y1,x2,y2,w,h: integer); - -/// Выводит на рисунке дугу окружности с центром в точке (x,y) и радиусом r, заключенной между двумя лучами, образующими углы a1 и a2 с осью OX (a1 и a2 – вещественные, задаются в градусах и отсчитываются против часовой стрелки) - procedure Arc(x,y,r,a1,a2: integer); -/// Заполняет на рисунке внутренность сектора окружности, ограниченного дугой с центром в точке (x,y) и радиусом r, заключенной между двумя лучами, образующими углы a1 и a2 с осью OX (a1 и a2 – вещественные, задаются в градусах и отсчитываются против часовой стрелки) - procedure FillPie(x,y,r,a1,a2: integer); -/// Выводит на рисунке сектор окружности, ограниченный дугой с центром в точке (x,y) и радиусом r, заключенной между двумя лучами, образующими углы a1 и a2 с осью OX (a1 и a2 – вещественные, задаются в градусах и отсчитываются против часовой стрелки) - procedure DrawPie(x,y,r,a1,a2: integer); -/// Выводит на рисунке заполненный сектор окружности, ограниченный дугой с центром в точке (x,y) и радиусом r, заключенной между двумя лучами, образующими углы a1 и a2 с осью OX (a1 и a2 – вещественные, задаются в градусах и отсчитываются против часовой стрелки) - procedure Pie(x,y,r,a1,a2: integer); - -/// Выводит на рисунке замкнутую ломаную по точкам, координаты которых заданы в массиве points - procedure DrawPolygon(points: array of Point); -/// Заполняет на рисунке многоугольник, координаты вершин которого заданы в массиве points - procedure FillPolygon(points: array of Point); -/// Выводит на рисунке заполненный многоугольник, координаты вершин которого заданы в массиве points - procedure Polygon(points: array of Point); -/// Выводит на рисунке ломаную по точкам, координаты которых заданы в массиве points - procedure Polyline(points: array of Point); -/// Выводит на рисунке кривую по точкам, координаты которых заданы в массиве points - procedure Curve(points: array of Point); -/// Выводит на рисунке замкнутую кривую по точкам, координаты которых заданы в массиве points - procedure DrawClosedCurve(points: array of Point); -/// Заполняет на рисунке замкнутую кривую по точкам, координаты которых заданы в массиве points - procedure FillClosedCurve(points: array of Point); -/// Выводит на рисунке заполненную замкнутую кривую по точкам, координаты которых заданы в массиве points - procedure ClosedCurve(points: array of Point); - -/// Выводит на рисунке строку s в прямоугольник к координатами левого верхнего угла (x,y) - procedure TextOut(x,y: integer; s: string); -/// Заливает на рисунке область одного цвета цветом c, начиная с точки (x,y). - procedure FloodFill(x,y: integer; c: Color); - -/// Очищает рисунок белым цветом - procedure Clear; -/// Очищает рисунок цветом c - procedure Clear(c: Color); - end; - -type - ABCControl = class(Control) - private - procedure OnPaint(sender: Object; e: PaintEventArgs); - procedure OnClosing(sender: Object; e: FormClosingEventArgs); - procedure OnMouseDown(sender: Object; e: MouseEventArgs); - procedure OnMouseUp(sender: Object; e: MouseEventArgs); - procedure OnMouseMove(sender: Object; e: MouseEventArgs); - procedure OnKeyDown(sender: Object; e: KeyEventArgs); - procedure OnKeyUp(sender: Object; e: KeyEventArgs); - procedure OnKeyPress(sender: Object; e: KeyPressEventArgs); - procedure OnResize(sender: Object; e: EventArgs); - procedure Init; - protected - function IsInputKey(keyData: Keys): boolean; override; - procedure OnPaintBackground(e: PaintEventArgs); override; begin end; // сами все перерисовываем! - public - constructor (w,h: integer); - end; - -/// Создает рисунок размера w на h пикселов и записывает его в переменную p -procedure CreatePicture(var p: Picture; w,h: integer); -/// Возвращает окно графического приложения -function Window: GraphABCWindow; -/// Возвращает главную форму графического приложения -function MainForm: Form; -/// Возвращает графический компонент -function GraphABCControl: ABCControl; -/// Возвращает текущее перо -function Pen: GraphABCPen; -/// Возвращает текущую кисть -function Brush: GraphABCBrush; -/// Возвращает текущий шрифт -function Font: GraphABCFont; -/// Возвращает систему координат GraphABC -function Coordinate: GraphABCCoordinate; - -function GraphWindowGraphics: Graphics; -function GraphBufferGraphics: Graphics; -function GraphBufferBitmap: Bitmap; - -var -/// Событие нажатия на кнопку мыши. (x,y) - координаты курсора мыши в момент наступления события, mousebutton = 1, если нажата левая кнопка мыши, и 2, если нажата правая кнопка мыши - OnMouseDown: procedure (x,y,mousebutton: integer); -/// Событие отжатия кнопки мыши. (x,y) - координаты курсора мыши в момент наступления события, mousebutton = 1, если отжата левая кнопка мыши, и 2, если отжата правая кнопка мыши - OnMouseUp: procedure (x,y,mousebutton: integer); -/// Событие перемещения мыши. (x,y) - координаты курсора мыши в момент наступления события, mousebutton = 0, если кнопка мыши не нажата, 1, если нажата левая кнопка мыши, и 2, если нажата правая кнопка мыши - OnMouseMove: procedure (x,y,mousebutton: integer); -/// Событие нажатия клавиши - OnKeyDown: procedure (key: integer); -/// Событие отжатия клавиши - OnKeyUp: procedure (key: integer); -/// Событие нажатия символьной клавиши - OnKeyPress: procedure (ch: char); -/// Событие изменения размера графического окна - OnResize: procedure; -/// Событие закрытия графического окна - OnClose: procedure; - -/// Процедурная переменная перерисовки графического окна. Если равна nil, то используется стандартная перерисовка - RedrawProc: procedure; -/// Следует ли рисовать во внеэкранном буфере - DrawInBuffer: boolean := true; - -implementation - -uses - System.Threading, - GraphABCHelper; - -const - FILE_NOT_FOUND_MESSAGE = 'Файл {0} не найден'; - -type - Proc1Integer = procedure(x: integer); - Proc1String = procedure(s: string); - Proc2Integer = procedure(x,y: integer); - Proc1Boolean = procedure(b: boolean); - Proc1BorderStyle = procedure(st: FormBorderStyle); - -var - _Window: GraphABCWindow := new GraphABCWindow; - _MainForm: Form; - _GraphABCControl: ABCControl; - _Pen: GraphABCPen := new GraphABCPen; - _Brush: GraphABCBrush := new GraphABCBrush; - _Font: GraphABCFont := new GraphABCFont; - _Coordinate := new GraphABCCoordinate; - - - __buffer: Bitmap; - bmp: Bitmap; - gr: Graphics; - gbmp: Graphics; - - f: ABCControl; - - CurrentSolidBrush: SolidBrush; - CurrentHatchBrush: HatchBrush; - CurrentGradientBrush: LinearGradientBrush; - PixelBrush: SolidBrush; - - x_coord,y_coord: integer; - NotLockDrawing: boolean; - - StartIsComplete: boolean; - MainFormThread: System.Threading.Thread; - - writecoords: Point; - CurrentWriteFont: System.Drawing.Font; - -// ------------ GraphABCCoordinate ----------------- -constructor GraphABCCoordinate.Create; -begin - // 1 - компьютерная система координат (ось OY - вниз) - // -1 - компьютерная система координат (ось OY - вниз) - coef := 1; -end; - -procedure GraphABCCoordinate.SetTransform(x0,y0,angle,sx,sy: real); -begin - sx := abs(sx); - sy := abs(sy); - angle := DegToRad(angle); - var m11 := sx * cos(angle); - var m12 := coef * sx * sin(angle); - var m21 := - sy * sin(angle); - var m22 := coef * sy * cos(angle); - var m := new System.Drawing.Drawing2D.Matrix(m11,m12,m21,m22,x0,y0); - lock f do - begin - gr.Transform := m; - gbmp.Transform := m; - end; -end; - -procedure GraphABCCoordinate.SetOrigin(x0,y0: integer); -begin - SetTransform(x0,y0,Angle,ScaleX,ScaleY); -end; - -procedure GraphABCCoordinate.SetScale(sx,sy: real); -begin - SetTransform(OriginX,OriginY,Angle,sx,sy); -end; - -procedure GraphABCCoordinate.SetScale(scale: real); -begin - SetScale(scale,scale); -end; - -procedure GraphABCCoordinate.SetMathematic; -begin - coef := -1; - SetTransform(OriginX,OriginY,Angle,ScaleX,ScaleY); -end; - -procedure GraphABCCoordinate.SetStandard; -begin - coef := 1; - SetTransform(OriginX,OriginY,Angle,ScaleX,ScaleY); -end; - -procedure GraphABCCoordinate.SetOriginX(x: integer); -begin - SetOrigin(x,OriginY); -end; - -procedure GraphABCCoordinate.SetOriginY(y: integer); -begin - SetOrigin(OriginX,y); -end; - -procedure GraphABCCoordinate.SetOrigin(p: Point); -begin - SetOrigin(p.x,p.y); -end; - -procedure GraphABCCoordinate.SetAngle(a: real); -begin - SetTransform(OriginX,OriginY,a,ScaleX,ScaleY); -end; - -procedure GraphABCCoordinate.SetScaleX(sx: real); -begin - SetScale(sx,ScaleY); -end; - -procedure GraphABCCoordinate.SetScaleY(sy: real); -begin - SetScale(ScaleX,sy); -end; - -function GraphABCCoordinate.GetOriginX: integer; -begin - lock (f) do - Result := Round(gr.Transform.OffsetX); -end; - -function GraphABCCoordinate.GetOrigin: Point; -begin - Result := new Point(GetOriginX,GetOriginY); -end; - -function GraphABCCoordinate.GetOriginY: integer; -begin - lock(f) do - Result := Round(gr.Transform.OffsetY); -end; - -function GraphABCCoordinate.GetAngle: real; -begin - var a := Coordinate.Matrix.Elements; - Result := ArcSin(a[1]/ScaleY); - if a[0]<0 then - if a[1]>0 then - Result := Pi - Result - else Result := -Pi - Result; - Result *= coef * 180/Pi; -end; - -function GraphABCCoordinate.GetScaleX: real; -begin - var a := Coordinate.Matrix.Elements; - Result := sqrt(sqr(a[0])+sqr(a[1])); -end; - -function GraphABCCoordinate.GetScaleY: real; -begin - var a := Coordinate.Matrix.Elements; - Result := sqrt(sqr(a[2])+sqr(a[3])); -end; - -function GraphABCCoordinate.GetMatrix: System.Drawing.Drawing2D.Matrix; -begin - lock (f) do - Result := gr.Transform; -end; - -procedure SetCoordinateOrigin(x0,y0: integer); -begin - Coordinate.SetOrigin(x0,y0); -end; - -procedure SetCoordinateScale(sx,sy: real); -begin - Coordinate.SetScale(sx,sy); -end; - -procedure SetCoordinateAngle(a: real); -begin - Coordinate.Angle := a; -end; - -{function CurrentABCWindow: ABCWindow; -begin - Result := f; -end; } - -procedure LockGraphics; -begin - Monitor.Enter(f); -end; - -procedure UnLockGraphics; -begin - Monitor.Exit(f); -end; - -procedure SetSmoothingOn; -begin - gr.SmoothingMode := SmoothingMode.AntiAlias; - gbmp.SmoothingMode := SmoothingMode.AntiAlias; -end; - -procedure SetSmoothingOff; -begin - gr.SmoothingMode := SmoothingMode.None; - gbmp.SmoothingMode := SmoothingMode.None; -end; - -procedure SetSmoothing(sm: boolean); -begin - if sm then - SetSmoothingOn - else SetSmoothingOff; -end; - -function SmoothingIsOn: boolean; -begin - Result := gr.SmoothingMode = SmoothingMode.AntiAlias; -end; - -function GraphWindowGraphics: Graphics; -begin - Result := gr; -end; - -function GraphBufferGraphics: Graphics; -begin - Result := gbmp; -end; - -function GraphBufferBitmap: Bitmap; -begin - Result := bmp; -end; - -procedure Swap(var x1,x2: integer); -begin - var t := x1; - x1 := x2; - x2 := t; -end; - -// Graphics Primitives -// ------------ __MyPen ----------------- -procedure GraphABCPen.SetColor(c: GraphABC.Color); -begin - SetPenColor(c); -end; - -function GraphABCPen.GetColor: GraphABC.Color; -begin - Result := PenColor; -end; - -procedure GraphABCPen.SetWidth(w: integer); -begin - SetPenWidth(w); -end; - -function GraphABCPen.GetWidth: integer; -begin - Result := PenWidth; -end; - -procedure GraphABCPen.SetStyle(st: DashStyle); -begin - SetPenStyle(st); -end; - -function GraphABCPen.GetStyle: DashStyle; -begin - Result := PenStyle; -end; - -procedure GraphABCPen.SetMode(m: integer); -begin - SetPenMode(m); -end; - -function GraphABCPen.GetMode: integer; -begin - Result := PenMode; -end; - -procedure GraphABCPen.SetNETPen(p: System.Drawing.Pen); -begin - if p=nil then exit; - _NETPen := p; -end; - -function GraphABCPen.GetX: integer; -begin - Result := PenX; -end; - -function GraphABCPen.GetY: integer; -begin - Result := PenY; -end; - -// ------------ GraphABCBrush ----------------- -procedure GraphABCBrush.SetNETBrush(b: System.Drawing.Brush); -begin - //if b=nil then Exit; - _NETBrush := b; -end; - -procedure GraphABCBrush.SetColor(c: GraphABC.Color); -begin - SetBrushColor(c); -end; - -function GraphABCBrush.GetColor: GraphABC.Color; -begin - Result := BrushColor; -end; - -procedure GraphABCBrush.SetStyle(st: BrushStyleType); -begin - SetBrushStyle(st); -end; - -function GraphABCBrush.GetStyle: BrushStyleType; -begin - Result := BrushStyle; -end; - -procedure GraphABCBrush.SetHatch(h: HatchStyle); -begin - SetBrushHatch(h); -end; - -function GraphABCBrush.GetHatch: HatchStyle; -begin - Result := BrushHatch; -end; - -procedure GraphABCBrush.SetHatchBackgroundColor(c: GraphABC.Color); -begin - SetHatchBrushBackgroundColor(c); -end; - -function GraphABCBrush.GetHatchBackgroundColor: GraphABC.Color; -begin - Result := HatchBrushBackgroundColor; -end; - -procedure GraphABCBrush.SetGradientSecondColor(c: GraphABC.Color); -begin - SetGradientBrushSecondColor(c); -end; - -function GraphABCBrush.GetGradientSecondColor: GraphABC.Color; -begin - Result := GradientBrushSecondColor; -end; - -// ------------ GraphABCFont ----------------- -procedure GraphABCFont.SetNETFont(f: System.Drawing.Font); -begin - if f=nil then Exit; - _NetFont := f; -end; - -procedure GraphABCFont.SetColor(c: GraphABC.Color); -begin - SetFontColor(c); -end; - -function GraphABCFont.GetColor: GraphABC.Color; -begin - Result := FontColor; -end; - -procedure GraphABCFont.SetStyle(st: FontStyleType); -begin - SetFontStyle(st); -end; - -function GraphABCFont.GetStyle: FontStyleType; -begin - Result := FontStyle; -end; - -procedure GraphABCFont.SetSize(sz: integer); -begin - SetFontSize(sz); -end; - -function GraphABCFont.GetSize: integer; -begin - Result := FontSize; -end; - -procedure GraphABCFont.SetName(nm: string); -begin - SetFontName(nm); -end; - -function GraphABCFont.GetName: string; -begin - Result := FontName; -end; - -// Picture -constructor Picture.Create(w,h: integer); -begin - if (w<=0) or (h<=0) then - raise new GraphABCException('w or h <= 0'); - bmp := new Bitmap(w,h); - gb := Graphics.FromImage(bmp); - transpcolor := bmp.GetPixel(0,bmp.Height-1); - istransp := false; - savedbmp := nil; -end; - -constructor Picture.Create(fname: string); -begin - try - bmp := new Bitmap(fname); - except on ex: System.ArgumentException do - raise new System.IO.FileNotFoundException(string.Format(FILE_NOT_FOUND_MESSAGE,fname)); - end; - - gb := Graphics.FromImage(bmp); - transpcolor := bmp.GetPixel(0,bmp.Height-1); - istransp := false; - savedbmp := nil; -end; - -constructor Picture.Create(r: System.Drawing.Rectangle); -// Create from Screen -begin - bmp := new Bitmap(r.Width,r.Height); - gb := Graphics.FromImage(bmp); - gb.CopyFromScreen(r.Left,r.Top,0,0,r.Size); - transpcolor := bmp.GetPixel(0,bmp.Height-1); - istransp := false; - savedbmp := nil; -end; - -procedure Picture.SetWidth(w: integer); -begin - SetSize(w,Height); -end; - -function Picture.GetWidth: integer; -begin - Result := bmp.Width; -end; - -procedure Picture.SetHeight(h: integer); -begin - SetSize(Width,h); -end; - -function Picture.GetHeight: integer; -begin - Result := bmp.Height; -end; - -// Логика установки прозрачности -// 1. Transparent := True - savedbmp:=bmp; bmp:=bmp.Clone; bmp.MakeTransparent(transpcolor); -// 2. Transparent := False - bmp.Dispose; bmp := savedbmp; savedbmp := nil; -// 3. Transparentcolor := c -// a) Если Transparent = False, то просто присвоить -// б) Если Transparent = True, то bmp.Dispose; bmp:=savedbmp.Clone; bmp.MakeTransparent(transpcolor); - -function Picture.GetTransparentColor: Color; -begin - Result := transpcolor; -end; - -procedure Picture.SetTransparentColor(c: Color); -var ob: Object; -begin - if c=TransparentColor then - Exit; - transpcolor := c; - if istransp then - begin - bmp.Dispose; - ob := savedbmp.Clone; - bmp := Bitmap(ob); - bmp.MakeTransparent(transpcolor); - end; -end; - -procedure Picture.SetTransparent(b: boolean); -var ob: Object; -begin - if b = istransp then - Exit; - istransp := b; - if istransp then - begin - savedbmp := bmp; - ob := bmp.Clone; - bmp := Bitmap(ob); - bmp.MakeTransparent(transpcolor); - end - else - begin - bmp.Dispose; - bmp := savedbmp; - savedbmp := nil; - end; -end; - -procedure Picture.Load(fname: string); -begin - bmp.Dispose; - bmp := new Bitmap(fname); - gb := Graphics.FromImage(bmp); - istransp := False; - if savedbmp<>nil then - begin - savedbmp.Dispose; - savedbmp := nil; - end; -end; - -procedure Picture.Save(fname: string); -begin - bmp.Save(fname); -end; - -procedure Picture.SetSize(w,h: integer); -var oldbmp: Bitmap; -begin - oldbmp := bmp; - bmp := new Bitmap(oldbmp,w,h); - gb := Graphics.FromImage(bmp); - gb.DrawImage(oldbmp,0,0); - oldbmp.Dispose; -// TODO не знаю, может, надо что-то делать для прозрачной -{ if istransp then - begin - end} -end; - -function Picture.Intersect(p: Picture): boolean; -begin -// bmp.L - result := false; -// TODO -end; - -procedure Picture.Draw(x,y: integer); -begin - Monitor.Enter(f); - if NotLockDrawing then - gr.DrawImage(bmp,x,y,bmp.Width,bmp.Height); - if DrawInBuffer then - gbmp.DrawImage(bmp,x,y,bmp.Width,bmp.Height); - Monitor.Exit(f); -end; - -procedure Picture.Draw(x,y: integer; g: Graphics); -begin - g.DrawImage(bmp,x,y,bmp.Width,bmp.Height); -end; - -procedure Picture.Draw(x,y,w,h: integer); -// Draw bmp scaled to size w,h -begin - Monitor.Enter(f); - if NotLockDrawing then - gr.DrawImage(bmp,x,y,w,h); - if DrawInBuffer then - gbmp.DrawImage(bmp,x,y,w,h); - Monitor.Exit(f); -end; - -procedure Picture.Draw(x,y,w,h: integer; g: Graphics); -// Draw bmp scaled to size w,h -begin - g.DrawImage(bmp,x,y,w,h); -end; - -procedure Picture.Draw(x,y: integer; r: System.Drawing.Rectangle); -// Draw bmp in rectangle r -begin - Monitor.Enter(f); - if NotLockDrawing then - gr.DrawImage(bmp,x,y,r,GraphicsUnit.Pixel); - if DrawInBuffer then - gbmp.DrawImage(bmp,x,y,r,GraphicsUnit.Pixel); - Monitor.Exit(f); -end; - -procedure Picture.Draw(x,y: integer; r: System.Drawing.Rectangle; g: Graphics); -begin - g.DrawImage(bmp,x,y,r,GraphicsUnit.Pixel); -end; - -procedure Picture.Draw(x,y,w,h: integer; r: System.Drawing.Rectangle); -// Draw rectangle r portion of bmp scaled to size w,h -var - r1: System.Drawing.Rectangle; - tempbmp: Bitmap; -begin - r1 := new System.Drawing.Rectangle(x,y,w,h); - tempbmp := GetView(bmp,r); - Monitor.Enter(f); - if NotLockDrawing then - gr.DrawImage(tempbmp,r1); -// gr.DrawImage(bmp,r1,r,GraphicsUnit.Pixel); - if DrawInBuffer then - gbmp.DrawImage(tempbmp,r1); -// gbmp.DrawImage(bmp,r1,r,GraphicsUnit.Pixel); - Monitor.Exit(f); - tempbmp.Dispose; -end; - -procedure Picture.Draw(x,y,w,h: integer; r: System.Drawing.Rectangle; g: Graphics); -var tempbmp: Bitmap; -begin - tempbmp := GetView(bmp,r); - g.DrawImage(tempbmp,x,y,new System.Drawing.Rectangle(x,y,w,h),GraphicsUnit.Pixel); - tempbmp.Dispose; -end; - -procedure Picture.CopyRect(dst: System.Drawing.Rectangle; p: Picture; src: System.Drawing.Rectangle); -// Copy src portion of p on dst rectangle of this picture -begin - CopyRect(dst,p.bmp,src); -end; - -procedure Picture.CopyRect(dst: System.Drawing.Rectangle; bmp: Bitmap; src: System.Drawing.Rectangle); -var tempbmp: Bitmap; -begin -// Copy src portion of bmp on dst rectangle of this picture - tempbmp := GetView(bmp,src); -// gb.DrawImage(bmp,dst,src,GraphicsUnit.Pixel); - gb.DrawImage(tempbmp,dst); - tempbmp.Dispose; -end; - -procedure Picture.FlipHorizontal; -begin - bmp.RotateFlip(RotateFlipType.RotateNoneFlipX); -end; - -procedure Picture.FlipVertical; -begin - bmp.RotateFlip(RotateFlipType.RotateNoneFlipY); -end; - -procedure Picture.SetPixel(x,y: integer; c: Color); -begin - bmp.SetPixel(x,y,c); -end; - -procedure Picture.PutPixel(x,y: integer; c: Color); -begin - bmp.SetPixel(x,y,c); -end; - -function Picture.GetPixel(x,y: integer): Color; -begin - Result := bmp.GetPixel(x,y); -end; - -procedure Picture.Line(x1,y1,x2,y2: integer); -begin - GraphABCHelper.Line(x1,y1,x2,y2,gb); -end; - -procedure Picture.Line(x1,y1,x2,y2: integer; c: Color); -begin - GraphABCHelper.Line(x1,y1,x2,y2,c,gb); -end; - -procedure Picture.FillCircle(x,y,r: integer); -begin - GraphABCHelper.FillEllipse(x-r,y-r,x+r,y+r,gb); -end; - -procedure Picture.DrawCircle(x,y,r: integer); -begin - GraphABCHelper.DrawEllipse(x-r,y-r,x+r,y+r,gb); -end; - -procedure Picture.FillEllipse(x1,y1,x2,y2: integer); -begin - GraphABCHelper.FillEllipse(x1,y1,x2,y2,gb); -end; - -procedure Picture.DrawEllipse(x1,y1,x2,y2: integer); -begin - GraphABCHelper.DrawEllipse(x1,y1,x2,y2,gb); -end; - -procedure Picture.FillRectangle(x1,y1,x2,y2: integer); -begin - GraphABCHelper.FillRectangle(x1,y1,x2,y2,gb); -end; - -procedure Picture.FillRect(x1,y1,x2,y2: integer); -begin - GraphABCHelper.FillRectangle(x1,y1,x2,y2,gb); -end; - -procedure Picture.DrawRectangle(x1,y1,x2,y2: integer); -begin - GraphABCHelper.DrawRectangle(x1,y1,x2,y2,gb); -end; - -procedure Picture.Circle(x,y,r: integer); -begin - GraphABCHelper.Ellipse(x-r,y-r,x+r,y+r,gb); -end; - -procedure Picture.Ellipse(x1,y1,x2,y2: integer); -begin - GraphABCHelper.Ellipse(x1,y1,x2,y2,gb); -end; - -procedure Picture.Rectangle(x1,y1,x2,y2: integer); -begin - GraphABCHelper.Rectangle(x1,y1,x2,y2,gb); -end; - -procedure Picture.RoundRect(x1,y1,x2,y2,w,h: integer); -begin - GraphABCHelper.RoundRect(x1,y1,x2,y2,w,h,gb); -end; - -procedure Picture.Arc(x,y,r,a1,a2: integer); -begin - GraphABCHelper.Arc(x,y,r,a1,a2,gb); -end; - -procedure Picture.FillPie(x,y,r,a1,a2: integer); -begin - GraphABCHelper.FillPie(x,y,r,a1,a2,gb); -end; - -procedure Picture.DrawPie(x,y,r,a1,a2: integer); -begin - GraphABCHelper.DrawPie(x,y,r,a1,a2,gb); -end; - -procedure Picture.Pie(x,y,r,a1,a2: integer); -begin - GraphABCHelper.Pie(x,y,r,a1,a2,gb); -end; - -procedure Picture.DrawPolygon(points: array of Point); -begin - GraphABCHelper.DrawPolygon(points,gb); -end; - -procedure Picture.FillPolygon(points: array of Point); -begin - GraphABCHelper.FillPolygon(points,gb); -end; - -procedure Picture.Polygon(points: array of Point); -begin - GraphABCHelper.Polygon(points,gb); -end; - -procedure Picture.Polyline(points: array of Point); -begin - GraphABCHelper.Polyline(points,gb); -end; - -procedure Picture.Curve(points: array of Point); -begin - GraphABCHelper.Curve(points,gb); -end; - -procedure Picture.DrawClosedCurve(points: array of Point); -begin - GraphABCHelper.DrawClosedCurve(points,gb); -end; - -procedure Picture.FillClosedCurve(points: array of Point); -begin - GraphABCHelper.FillClosedCurve(points,gb); -end; - -procedure Picture.ClosedCurve(points: array of Point); -begin - GraphABCHelper.ClosedCurve(points,gb); -end; - -procedure Picture.TextOut(x,y: integer; s: string); -begin - GraphABCHelper.TextOut(x,y,s,gb); -end; - -function ExtFloodFill(hdc: IntPtr; x,y: integer; color: integer; filltype: integer): boolean; external 'Gdi32.dll' name 'ExtFloodFill'; -function SelectObject(hdc, hgdiobj: IntPtr): IntPtr; external 'Gdi32.dll' name 'SelectObject'; -function CreateSolidBrush(c: integer): IntPtr; external 'Gdi32.dll' name 'CreateSolidBrush'; -function DeleteObject(obj: IntPtr): integer; external 'Gdi32.dll' name 'DeleteObject'; -function CreateCompatibleDC(obj: IntPtr): IntPtr; external 'Gdi32.dll' name 'CreateCompatibleDC'; - -procedure Picture.FloodFill(x,y: integer; c: Color); -var hdc,hBrush,hOldBrush: IntPtr; -begin - var borderColor: Color := GetPixel(x,y); - - var bc := ColorTranslator.ToWin32(borderColor); - var cc := ColorTranslator.ToWin32(c); - - Monitor.Enter(f); - - hdc := gbmp.GetHDC(); - hBrush := CreateSolidBrush(cc); - - hOldBrush := SelectObject(hdc, hBrush); - ExtFloodFill(hdc, x, y, bc, 1); - SelectObject(hdc, holdBrush); - - DeleteObject(hBrush); - - gr.ReleaseHdc(); - - DeleteObject(hdc); - - Monitor.Exit(f); -end; - -procedure Picture.Clear; -begin - Monitor.Enter(f); - gb.FillRectangle(Brushes.White,0,0,WindowWidth,WindowHeight); - Monitor.Exit(f); -end; - -procedure Picture.Clear(c: Color); -begin - Monitor.Enter(f); - gb.FillRectangle(new SolidBrush(c),0,0,WindowWidth,WindowHeight); - Monitor.Exit(f); -end; - -// ABCControl -function ABCControl.IsInputKey(keyData: Keys): boolean; -begin - Result := True; -end; - -procedure ABCControl.Init; -begin - BackColor := System.Drawing.Color.White; - Dock := DockStyle.Fill; - - Paint += OnPaint; - MouseDown += OnMouseDown; - MouseUp += OnMouseUp; - MouseMove += OnMouseMove; - Resize += OnResize; - KeyDown += OnKeyDown; - KeyUp += OnKeyUp; - KeyPress += OnKeyPress; - -// These Events must be initialised in main form -// FormClosing += OnClosing; - -// Initialization of global vars - - bmp := new Bitmap(Screen.PrimaryScreen.Bounds.Width,Screen.PrimaryScreen.Bounds.Height); - gr := Graphics.FromHwnd(Handle); - gbmp := Graphics.FromImage(bmp); - __buffer:=bmp; - gbmp.FillRectangle(Brushes.White,0,0,Screen.PrimaryScreen.Bounds.Width,Screen.PrimaryScreen.Bounds.Height); - _Pen.NETPen := new System.Drawing.Pen(System.Drawing.Color.Black); - _Font.NETFont := new System.Drawing.Font('Arial',10); - - PixelBrush := new SolidBrush(System.Drawing.Color.Black); - CurrentSolidBrush := new SolidBrush(System.Drawing.Color.White); - CurrentHatchBrush := new HatchBrush(HatchStyle.Cross,System.Drawing.Color.Black,System.Drawing.Color.White); - CurrentGradientBrush := new LinearGradientBrush(new Point(0,0), new Point(600,600),System.Drawing.Color.Black,System.Drawing.Color.White); - _Brush.NETBrush := CurrentSolidBrush; - - CurrentWriteFont := new System.Drawing.Font('Courier New',10); - - NotLockDrawing := True; - //DrawInBuffer := True; - //RedrawProc := nil; -end; - -constructor ABCControl.Create(w,h: integer); -begin - ClientSize := new System.Drawing.Size(w,h); - Init; -end; - -procedure ABCControl.OnPaint(sender: object; e: PaintEventArgs); -begin - Monitor.Enter(f); - if (e <> nil) and NotLockDrawing then - begin - if RedrawProc<>nil then - RedrawProc - else e.Graphics.DrawImage(bmp,0,0); - end; - Monitor.Exit(f); -end; - -procedure ABCControl.OnClosing(sender: object; e: FormClosingEventArgs); -begin - if GraphABC.OnClose<>nil then - GraphABC.OnClose; - NotLockDrawing := False; - //Sleep(0); - Halt; -end; - -procedure ABCControl.OnMouseDown(sender: Object; e: MouseEventArgs); -type MouseButtons = System.Windows.Forms.MouseButtons; -var mb: integer; -begin - if e.Button = MouseButtons.Left then - mb := 1 - else if e.Button = MouseButtons.Right then - mb := 2; - if GraphABC.OnMouseDown<>nil then - GraphABC.OnMouseDown(e.x,e.y,mb); -end; - -procedure ABCControl.OnMouseUp(sender: Object; e: MouseEventArgs); -type MouseButtons = System.Windows.Forms.MouseButtons; -var mb: integer; -begin - if e.Button = MouseButtons.Left then - mb := 1 - else if e.Button = MouseButtons.Right then - mb := 2; - if GraphABC.OnMouseUp<>nil then - GraphABC.OnMouseUp(e.x,e.y,mb); -end; - -procedure ABCControl.OnMouseMove(sender: Object; e: MouseEventArgs); -type MouseButtons = System.Windows.Forms.MouseButtons; -var mb: integer; -begin - if e.Button = MouseButtons.Left then - mb := 1 - else if e.Button = MouseButtons.Right then - mb := 2; - if GraphABC.OnMouseMove<>nil then - GraphABC.OnMouseMove(e.x,e.y,mb); -end; - -procedure ABCControl.OnKeyDown(sender: Object; e: KeyEventArgs); -begin - if GraphABC.OnKeyDown<>nil then - GraphABC.OnKeyDown(integer(e.KeyCode)); -end; - -procedure ABCControl.OnKeyUp(sender: Object; e: KeyEventArgs); -begin - if GraphABC.OnKeyUp<>nil then - GraphABC.OnKeyUp(integer(e.KeyCode)); -end; - -procedure ABCControl.OnKeyPress(sender: Object; e: KeyPressEventArgs); -begin - if GraphABC.OnKeyPress<>nil then - GraphABC.OnKeyPress(e.KeyChar); -end; - -procedure ResizeHelper; -var t: SmoothingMode; -begin - Monitor.Enter(f); - t := gr.SmoothingMode; - var m := gr.Transform; - gr := Graphics.FromHwnd(f.Handle); - gr.Transform := m; - gr.SmoothingMode := t; - Monitor.Exit(f); -end; - -procedure ABCControl.OnResize(sender: Object; e: EventArgs); -begin - ResizeHelper; - if GraphABC.OnResize<>nil then - GraphABC.OnResize; -end; - -// Primitives -procedure SetPixel(x,y: integer; c: Color); -var b: boolean; -begin - lock f do begin - if NotLockDrawing then begin - b := SmoothingIsOn; - SetSmoothingOff; - PixelBrush.Color := c; - gr.FillRectangle(PixelBrush,x,y,1,1); - SetSmoothing(b); - end; - if DrawInBuffer then - bmp.SetPixel(x,y,c); - end; -end; - -procedure PutPixel(x,y: integer; c: Color); -var b: boolean; -begin - Monitor.Enter(f); - b := SmoothingIsOn; - SetSmoothingOff; - PixelBrush.Color := c; - if NotLockDrawing then - gr.FillRectangle(PixelBrush,x,y,1,1); - if DrawInBuffer then - gbmp.FillRectangle(PixelBrush,x,y,1,1); - SetSmoothing(b); - Monitor.Exit(f); -end; - -function GetPixel(x,y: integer): Color; -begin - Monitor.Enter(f); - Result := bmp.GetPixel(x,y); - Monitor.Exit(f); -end; - -procedure MoveTo(x,y: integer); -begin - x_coord := x; - y_coord := y; -end; - -procedure LineTo(x,y: integer); -begin - Line(x_coord,y_coord,x,y); - x_coord := x; - y_coord := y; -end; - -procedure LineTo(x,y: integer; c: Color); -begin - Line(x_coord,y_coord,x,y,c); - x_coord := x; - y_coord := y; -end; - -procedure Line(x1,y1,x2,y2: integer; c: Color); -begin - Monitor.Enter(f); - if NotLockDrawing then - Line(x1,y1,x2,y2,c,gr); - if DrawInBuffer then - Line(x1,y1,x2,y2,c,gbmp); - Monitor.Exit(f); -end; - -procedure Line(x1,y1,x2,y2: integer); -begin - Monitor.Enter(f); - if NotLockDrawing then - Line(x1,y1,x2,y2,gr); - if DrawInBuffer then - Line(x1,y1,x2,y2,gbmp); - Monitor.Exit(f); -end; - -procedure FillCircle(x,y,r: integer); -begin - FillEllipse(x-r,y-r,x+r,y+r); -end; - -procedure DrawCircle(x,y,r: integer); -begin - DrawEllipse(x-r,y-r,x+r,y+r); -end; - -procedure Circle(x,y,r: integer); -begin - Ellipse(x-r,y-r,x+r,y+r); -end; - -procedure FillEllipse(x1,y1,x2,y2: integer); -begin - Monitor.Enter(f); - if NotLockDrawing then - FillEllipse(x1,y1,x2,y2,gr); - if DrawInBuffer then - FillEllipse(x1,y1,x2,y2,gbmp); - Monitor.Exit(f); -end; - -procedure DrawEllipse(x1,y1,x2,y2: integer); -begin - Monitor.Enter(f); - if NotLockDrawing then - DrawEllipse(x1,y1,x2,y2,gr); - if DrawInBuffer then - DrawEllipse(x1,y1,x2,y2,gbmp); - Monitor.Exit(f); -end; - -procedure Ellipse(x1,y1,x2,y2: integer); -begin - if Brush.NETBrush <> nil then - FillEllipse(x1,y1,x2,y2); - if Pen.NETPen.DashStyle <> DashStyle.Custom then - DrawEllipse(x1,y1,x2,y2); -end; - -procedure FillRectangle(x1,y1,x2,y2: integer); -begin - Monitor.Enter(f); - if NotLockDrawing then - FillRectangle(x1,y1,x2,y2,gr); - if DrawInBuffer then - FillRectangle(x1,y1,x2,y2,gbmp); - Monitor.Exit(f); -end; - -procedure DrawRectangle(x1,y1,x2,y2: integer); -begin - Monitor.Enter(f); - if NotLockDrawing then - DrawRectangle(x1,y1,x2,y2,gr); - if DrawInBuffer then - DrawRectangle(x1,y1,x2,y2,gbmp); - Monitor.Exit(f); -end; - -procedure Rectangle(x1,y1,x2,y2: integer); -begin - if x1>x2 then - Swap(x1,x2); - if y1>y2 then - Swap(y1,y2); - if Brush.NETBrush <> nil then - FillRectangle(x1,y1,x2-1,y2-1); - if Pen.NETPen.DashStyle <> DashStyle.Custom then - DrawRectangle(x1,y1,x2,y2); -end; - -procedure DrawRoundRect(x1,y1,x2,y2,w,h: integer); -begin - Monitor.Enter(f); - if NotLockDrawing then - DrawRoundRect(x1,y1,x2,y2,w,h,gr); - if DrawInBuffer then - DrawRoundRect(x1,y1,x2,y2,w,h,gbmp); - Monitor.Exit(f); -end; - -procedure FillRoundRect(x1,y1,x2,y2,w,h: integer); -begin - Monitor.Enter(f); - if NotLockDrawing then - FillRoundRect(x1,y1,x2,y2,w,h,gr); - if DrawInBuffer then - FillRoundRect(x1,y1,x2,y2,w,h,gbmp); - Monitor.Exit(f); -end; - -procedure RoundRect(x1,y1,x2,y2,w,h: integer); -begin - if Brush.NETBrush <> nil then - FillRoundRect(x1,y1,x2,y2,w,h); - if Pen.NETPen.DashStyle <> DashStyle.Custom then - DrawRoundRect(x1,y1,x2,y2,w,h); -end; - -procedure Arc(x,y,r,a1,a2: integer); -begin - Monitor.Enter(f); - if NotLockDrawing then - Arc(x,y,r,a1,a2,gr); - if DrawInBuffer then - Arc(x,y,r,a1,a2,gbmp); - Monitor.Exit(f); -end; - -procedure FillPie(x,y,r,a1,a2: integer); -begin - Monitor.Enter(f); - if NotLockDrawing then - FillPie(x,y,r,a1,a2,gr); - if DrawInBuffer then - FillPie(x,y,r,a1,a2,gbmp); - Monitor.Exit(f); -end; - -procedure DrawPie(x,y,r,a1,a2: integer); -begin - Monitor.Enter(f); - if NotLockDrawing then - DrawPie(x,y,r,a1,a2,gr); - if DrawInBuffer then - DrawPie(x,y,r,a1,a2,gbmp); - Monitor.Exit(f); -end; - -procedure Pie(x,y,r,a1,a2: integer); -begin - if Brush.NETBrush <> nil then - FillPie(x,y,r,a1,a2); - if Pen.NETPen.DashStyle <> DashStyle.Custom then - DrawPie(x,y,r,a1,a2); -end; - -procedure TextOut(x,y: integer; s: string); -begin - Monitor.Enter(f); - if NotLockDrawing then - TextOut(x,y,s,gr); - if DrawInBuffer then - TextOut(x,y,s,gbmp); - Monitor.Exit(f); -end; - -procedure DrawPolygon(points: array of Point); -begin - Monitor.Enter(f); - if NotLockDrawing then - DrawPolygon(points,gr); - if DrawInBuffer then - DrawPolygon(points,gbmp); - Monitor.Exit(f); -end; - -procedure FillPolygon(points: array of Point); -begin - Monitor.Enter(f); - if NotLockDrawing then - FillPolygon(points,gr); - if DrawInBuffer then - FillPolygon(points,gbmp); - Monitor.Exit(f); -end; - -procedure Polygon(points: array of Point); -begin - if Brush.NETBrush <> nil then - FillPolygon(points); - if Pen.NETPen.DashStyle <> DashStyle.Custom then - DrawPolygon(points); -end; - -procedure Polyline(points: array of Point); -begin - Monitor.Enter(f); - if NotLockDrawing then - Polyline(points,gr); - if DrawInBuffer then - Polyline(points,gbmp); - Monitor.Exit(f); -end; - -procedure Curve(points: array of Point); -begin - Monitor.Enter(f); - if NotLockDrawing then - Curve(points,gr); - if DrawInBuffer then - Curve(points,gbmp); - Monitor.Exit(f); -end; - -procedure DrawClosedCurve(points: array of Point); -begin - Monitor.Enter(f); - if NotLockDrawing then - DrawClosedCurve(points,gr); - if DrawInBuffer then - DrawClosedCurve(points,gbmp); - Monitor.Exit(f); -end; - -procedure FillClosedCurve(points: array of Point); -begin - Monitor.Enter(f); - if NotLockDrawing then - FillClosedCurve(points,gr); - if DrawInBuffer then - FillClosedCurve(points,gbmp); - Monitor.Exit(f); -end; - -procedure ClosedCurve(points: array of Point); -begin - Monitor.Enter(f); - if NotLockDrawing then - ClosedCurve(points,gr); - if DrawInBuffer then - ClosedCurve(points,gbmp); - Monitor.Exit(f); -end; - -// Fills -procedure FloodFill(x,y: integer; c: Color); -var hdc,hBrush,hOldBrush: IntPtr; -begin - var borderColor: Color := GetPixel(x,y); -// var bc: integer := integer(borderColor.R) + (integer(borderColor.G) shl 8) + (integer(borderColor.B) shl 16); -// var cc: integer := integer(c.R) + (integer(c.G) shl 8) + (integer(c.B) shl 16); - - var bc := ColorTranslator.ToWin32(borderColor); - var cc := ColorTranslator.ToWin32(c); - - Monitor.Enter(f); - - hdc := gr.GetHDC(); - hBrush := CreateSolidBrush(cc); - - hOldBrush := SelectObject(hdc, hBrush); - ExtFloodFill(hdc, x, y, bc, 1); - SelectObject(hdc, holdBrush); - - var hbmp := bmp.GetHbitmap(); // Создается GDI Bitmap - var memdc: IntPtr := CreateCompatibleDC(hdc); - SelectObject(memdc,hbmp); - - hOldBrush := SelectObject(memdc, hBrush); - ExtFloodFill(memdc, x, y, bc, 1); - SelectObject(hdc, holdBrush); - - var bmp1 := Bitmap.FromHbitmap(hbmp); - gbmp.DrawImage(bmp1,0,0); - - bmp1.Dispose(); -// bmp := Bitmap.FromHbitmap(hbmp); - - DeleteObject(memdc); - DeleteObject(hbmp); - DeleteObject(hBrush); - - gr.ReleaseHdc(); - - DeleteObject(hdc); - - Monitor.Exit(f); -end; - -procedure FillRect(x1,y1,x2,y2: integer); -begin - FillRectangle(x1,y1,x2,y2); -end; - -// Colors -function RGB(r,g,b: byte): Color; -begin - Result := System.Drawing.Color.FromArgb(r,g,b); -end; - -//------------------------------------------------------------------------------ -// Color from component -//------------------------------------------------------------------------------ -const AlphaBase = $FF000000; - -function RedColor(r: byte): Color; -begin - Result := System.Drawing.Color.FromArgb(AlphaBase or (r shl 16)); -end; - -function GreenColor(g: byte): Color; -begin - Result := System.Drawing.Color.FromArgb(AlphaBase or (g shl 8)); -end; - -function BlueColor(b: byte): Color; -begin - Result := System.Drawing.Color.FromArgb(AlphaBase or b); -end; -//------------------------------------------------------------------------------ - -function ARGB(a,r,g,b: byte) : Color; -begin - Result := System.Drawing.Color.FromArgb(a,r,g,b); -// Result := ((((r shl 16) or (g shl 8)) or b) or (a shl 24)) and -1; -end; - -function clRandom: Color; -begin - Result:=System.Drawing.Color.FromArgb(255,PABCSystem.Random(255),PABCSystem.Random(255),PABCSystem.Random(255)); -end; - -function GetRed(c: Color): integer; -begin - Result := c.R; -// Result := (c shr 16) and 255; -end; - -function GetGreen(c: Color): integer; -begin - Result := c.G; -// Result := (c shr 8) and 255; -end; - -function GetBlue(c: Color): integer; -begin - Result := c.B; -// Result := c and 255; -end; - -function GetAlpha(c: Color): integer; -begin - Result := c.A; -end; - -// Pens -procedure SetPenColor(c: Color); -begin - //if Pen.NETPen.Color <> c then - lock f do - Pen.NETPen.Color := c; -end; - -function PenColor: Color; -begin - Result := Pen.NETPen.Color; -end; - -procedure SetPenWidth(Width: integer); -begin - lock f do - Pen.NETPen.Width := Width; -end; - -function PenWidth: integer; -begin - Result := round(Pen.NETPen.Width); -end; - -procedure SetPenStyle(style: DashStyle); -begin - LockGraphics; -// try - case style of - psSolid: Pen.NETPen.DashStyle := DashStyle.Solid; - psClear: Pen.NETPen.DashStyle := DashStyle.Custom; - psDash: Pen.NETPen.DashStyle := DashStyle.Dash; - psDot: Pen.NETPen.DashStyle := DashStyle.Dot; - psDashDot: Pen.NETPen.DashStyle := DashStyle.DashDot; - psDashDotDot: Pen.NETPen.DashStyle := DashStyle.DashDotDot; - end; -{ except - on e: System.InvalidOperationException do - writeln(e); - end;} - UnLockGraphics; -end; - -function PenStyle: DashStyle; -begin - case Pen.NETPen.DashStyle of - DashStyle.Solid: Result := psSolid; - DashStyle.Dash: Result := psDash; - DashStyle.Dot: Result := psDot; - DashStyle.DashDot: Result := psDashDot; - DashStyle.DashDotDot: Result := psDashDotDot; - DashStyle.Custom: Result := psClear; - end; -end; - -procedure SetPenMode(m: integer); -begin -// TODO -end; - -function PenMode: integer; -begin - result := -1; -// TODO -end; - -function PenX: integer; -begin - Result := x_coord; -end; - -function PenY: integer; -begin - Result := y_coord; -end; - -// Brushes -procedure SetBrushColor(c: Color); -begin - LockGraphics; - if Brush.NETBrush = CurrentHatchBrush then - begin - CurrentHatchBrush := new HatchBrush(CurrentHatchBrush.HatchStyle,c,CurrentHatchBrush.BackgroundColor); - Brush.NETBrush := CurrentHatchBrush; - end - else - begin -// try - CurrentSolidBrush.Color := c; -{ except - on e: System.InvalidOperationException do - writeln(e.StackTrace); - end;} - CurrentGradientBrush.LinearColors[0] := CurrentSolidBrush.Color; - end; - UnLockGraphics; -end; - -function BrushColor: Color; -begin - if Brush.NETBrush = CurrentHatchBrush then - Result := CurrentHatchBrush.ForegroundColor - else Result := CurrentSolidBrush.Color; -end; - -procedure SetBrushStyle(bs: BrushStyleType); -begin - lock f do - case bs of - bsSolid: Brush.NETBrush := CurrentSolidBrush; - bsClear: Brush.NETBrush := nil; - bsHatch: Brush.NETBrush := CurrentHatchBrush; - bsGradient: Brush.NETBrush := CurrentGradientBrush; - end; -end; - -function BrushStyle: BrushStyleType; -begin - Result := bsNone; // Если кисть устанавливалась явным присваиванием NETBrush - if Brush.NETBrush = CurrentSolidBrush then - Result := bsSolid - else if Brush.NETBrush = nil then - Result := bsClear - else if Brush.NETBrush = CurrentHatchBrush then - Result := bsHatch - else if Brush.NETBrush = CurrentGradientBrush then - Result := bsGradient; -end; - -procedure SetBrushHatch(bh: HatchStyle); -begin - lock f do - begin - var flag := CurrentHatchBrush = Brush.NETBrush; - CurrentHatchBrush := new HatchBrush(HatchStyle(bh),CurrentHatchBrush.ForegroundColor,CurrentHatchBrush.BackgroundColor); - if flag then - Brush.NETBrush := CurrentHatchBrush; - end; -end; - -function BrushHatch: HatchStyle; -begin - Result := CurrentHatchBrush.HatchStyle; -end; - -procedure SetHatchBrushBackgroundColor(c: Color); -var flag: boolean; -begin - lock f do - begin - flag := CurrentHatchBrush = Brush.NETBrush; - CurrentHatchBrush := new HatchBrush(CurrentHatchBrush.HatchStyle,CurrentHatchBrush.ForegroundColor,c); - if flag then - Brush.NETBrush := CurrentHatchBrush; - end; -end; - -function HatchBrushBackgroundColor: Color; -begin - Result := CurrentHatchBrush.BackgroundColor; -end; - -procedure SetGradientBrushSecondColor(c: Color); -begin - lock f do - CurrentGradientBrush.LinearColors[1] := c; -end; - -function GradientBrushSecondColor: Color; -begin - Result := CurrentGradientBrush.LinearColors[1]; -end; - -// Fonts -procedure SetFontSize(size: integer); -begin - Font.NETFont := new System.Drawing.Font(Font.NETFont.Name,Convert.ToSingle(size),Font.NETFont.Style); -end; - -function FontSize: integer; -begin - Result := round(Font.NETFont.SizeInPoints); -end; - -procedure SetFontName(name: string); -begin - lock f do - Font.NETFont := new System.Drawing.Font(name,Font.NETFont.SizeInPoints,Font.NETFont.Style); -end; - -function FontName: string; -begin - Result := Font.NETFont.Name; -end; - -procedure SetFontColor(c: Color); -begin - lock f do - CurrentTextBrush.Color := c; -end; - -function FontColor: Color; -begin - Result := CurrentTextBrush.Color; -end; - -procedure SetFontStyle(fs: FontStyleType); -begin - lock f do - Font.NETFont := new System.Drawing.Font(Font.NETFont.name,Font.NETFont.SizeInPoints,System.Drawing.FontStyle(integer(fs))); -end; - -function FontStyle: FontStyleType; -begin - Result := FontStyleType(integer(Font.NETFont.Style)); -end; - -function TextWidth(s: string): integer; -begin -// добавил 1. Без нее рисует, занимая 1 лишний пиксел - Result := round(gr.MeasureString(s,Font.NETFont,0,new StringFormat(StringFormat.GenericTypographic)).Width) + 1; -end; - -function TextHeight(s: string): integer; -begin - Result := round(gr.MeasureString(s,Font.NETFont).Height); -end; - -// Window -procedure ClearWindow; -begin - ClearWindow(clWhite); -end; - -procedure ClearWindow(c: Color); -var i: Color; -begin - Monitor.Enter(f); - i := BrushColor; - SetBrushColor(c); - var m := gr.Transform; - gr.ResetTransform; - gbmp.ResetTransform; - FillRect(0,0,GraphABCControl.Width,GraphABCControl.Height); - gr.Transform := m; - gbmp.Transform := m; - SetBrushColor(i); - Monitor.Exit(f); -end; - -function WindowLeft: integer; -begin - Result := MainForm.Left; -end; - -function WindowTop: integer; -begin - Result := MainForm.Top; -end; - -function WindowCenter: Point; -begin - Result := new Point(WindowWidth div 2,WindowHeight div 2); -end; - -function WindowIsFixedSize: boolean; -begin - Result := (MainForm.FormBorderStyle = FormBorderStyle.FixedSingle) and (MainForm.MaximizeBox = False); -end; - -function WindowWidth: integer; -begin - Result := MainForm.ClientSize.Width; -end; - -function WindowHeight: integer; -begin - Result := MainForm.ClientSize.Height; -end; - -procedure SetWindowWidth(w: integer); -begin - SetWindowSize(w,MainForm.ClientSize.Height); -end; - -procedure SetWindowHeight(h: integer); -begin - SetWindowSize(MainForm.ClientSize.Width,h); -end; - -procedure SetWindowLeft(l: integer); -begin - SetWindowPos(l,MainForm.Top); -end; - -procedure SetWindowTop(t: integer); -begin - SetWindowPos(MainForm.Left,t); -end; - -procedure SetMaximizeBoxInternal(b: boolean); -begin - MainForm.MaximizeBox := b; -end; - -procedure SetBorderStyleInternal(st : FormBorderStyle); -begin - MainForm.FormBorderStyle := st; -end; - -procedure SetWindowIsFixedSize(b: boolean); -var p : Proc1Boolean; - q : Proc1BorderStyle; -begin - p := SetMaximizeBoxInternal; - q := SetBorderStyleInternal; - if b then - MainForm.Invoke(q,FormBorderStyle.FixedSingle) - else MainForm.Invoke(q,FormBorderStyle.Sizable); - MainForm.Invoke(p,not b); -end; - -procedure ChangeFormPos(l,t: integer); // вспомогательная -begin - MainForm.Left := l; - MainForm.Top := t; -end; - -procedure SetWindowPos(l,t: integer); -var p: Proc2Integer; -begin - p := ChangeFormPos; - f.Invoke(p,l,t); -end; - -procedure ChangeFormClientSize(w,h: integer); // вспомогательная -begin - MainForm.ClientSize := new System.Drawing.Size(w,h); - ResizeHelper; -end; - -procedure SetWindowSize(w,h: integer); -var p: Proc2Integer; -begin - p := ChangeFormClientSize; - f.Invoke(p,w,h); - //ResizeHelper; -end; - -function GraphBoxWidth: integer; -begin - Result := f.Width; -end; - -function GraphBoxHeight: integer; -begin - Result := f.Height; -end; - -function GraphBoxLeft: integer; -begin - Result := f.Left; -end; - -function GraphBoxTop: integer; -begin - Result := f.Top; -end; - -function WindowCaption: string; -begin - Result := MainForm.Text; -end; - -function WindowTitle: string; -begin - Result := MainForm.Text; -end; - -procedure InitWindow(Left,Top,Width,Height: integer; BackColor: Color); -begin - SetWindowSize(Width, Height); - SetWindowPos(Left, Top); - SetBrushColor(BackColor); - FillRectangle(0, 0, Width, Height); -end; - -procedure ChangeFormTitle(s: string); -begin - MainForm.Text := s; -end; - -procedure SetWindowTitle(s: string); -var p: Proc1String; -begin - p := ChangeFormTitle; - f.Invoke(p,s); -end; - -procedure SetWindowCaption(s: string); -begin - SetWindowTitle(s); -end; - -procedure SaveWindow(fname: string); -begin - var tempbmp := GetView(bmp,new System.Drawing.Rectangle(0,0,Window.Width,Window.Height)); - tempbmp.Save(fname); - tempbmp.Dispose; -end; - -procedure LoadWindow(fname: string); -begin - var b: Bitmap := new Bitmap(fname); - SetWindowSize(b.Width,b.Height); - Monitor.Enter(f); - gr.DrawImage(b,0,0); - gbmp.DrawImage(b,0,0); - Monitor.Exit(f); -end; - -procedure FillWindow(fname: string); -begin - Monitor.Enter(f); - var b: System.Drawing.Brush := Brush.NETBrush; - Brush.NETBrush := new TextureBrush(Bitmap.FromFile(fname)); - FillRect(0,0,GraphABCControl.Width,GraphABCControl.Height); - Brush.NETBrush := b; - Monitor.Exit(f); -end; - -procedure CloseWindow; -begin -// MainForm.Close; - Halt; -end; - -function ScreenWidth: integer; -begin - Result := Screen.PrimaryScreen.Bounds.Width; -end; - -function ScreenHeight: integer; -begin - Result := Screen.PrimaryScreen.Bounds.Height; -end; - -procedure CenterWindow; -begin - SetWindowPos((ScreenWidth - MainForm.Width) div 2, (ScreenHeight - MainForm.Height) div 2); -end; - -procedure MaximizeWindow; -begin - MainForm.WindowState := FormWindowState.Maximized; -end; - -procedure MinimizeWindow; -begin - MainForm.WindowState := FormWindowState.Minimized; -end; - -procedure NormalizeWindow; -begin - MainForm.WindowState := FormWindowState.Normal -end; - -// BufferedDraw -procedure Redraw; -var tempbmp: Bitmap; -begin - //TODO Без этого падает если свернуто - if MainForm.WindowState=FormWindowState.Minimized then - exit; - tempbmp := GetView(bmp,new System.Drawing.Rectangle(0,0,WindowWidth,WindowHeight)); - Monitor.Enter(f); - if gr<>nil then - begin - var m := gr.Transform; - gr.ResetTransform; - gr.DrawImage(tempbmp,0,0); - gr.Transform := m; - end; - Monitor.Exit(f); -end; -procedure FullRedraw; -begin - Monitor.Enter(f); - if gr<>nil then - gr.DrawImage(bmp,0,0); - Monitor.Exit(f); -end; - -procedure LockDrawing; -begin - NotLockDrawing := False; -end; - -procedure UnlockDrawing; -begin - NotLockDrawing := True; - Redraw; -end; - -procedure InitForm; -begin - f := new ABCControl(defaultWindowWidth,defaultWindowHeight); - _MainForm := new Form; - _MainForm.Text := 'GraphABC.NET'; - _MainForm.ClientSize := new Size(defaultWindowWidth,defaultWindowHeight); -// _MainForm.BackColor := Color.White; - _MainForm.Controls.Add(f); - _MainForm.TopMost := True; - _MainForm.StartPosition := FormStartPosition.CenterScreen; - _MainForm.FormClosing += f.OnClosing; -end; - -procedure InitForm0; -begin - InitForm; - StartIsComplete := True; - Application.Run(MainForm); -end; - -function RobotUnitUsed: boolean; -var t: &Type; -begin - t := System.Reflection.Assembly.GetExecutingAssembly.GetType('Robot.Robot'); - if t=nil then - result := false - else - result := t.GetField('__IS_ROBOT_UNIT') <> nil; -end; - -procedure HideForm; -begin - _MainForm.Hide; -end; - -procedure CreatePicture(var p: Picture; w,h: integer); -begin - p := new Picture(w,h); -end; - -function Window: GraphABCWindow; -begin - Result := _Window; -end; - -function MainForm: Form; -begin - Result := _MainForm; -end; - -function GraphABCControl: ABCControl; -begin - Result := _GraphABCControl; -end; - -function Pen: GraphABCPen; -begin - Result := _Pen; -end; - -function Brush: GraphABCBrush; -begin - Result := _Brush; -end; - -function Font: GraphABCFont; -begin - Result := _Font; -end; - -function Coordinate: GraphABCCoordinate; -begin - Result := _Coordinate; -end; - -procedure GraphABCWindow.SetLeft(l: integer); -begin - SetWindowLeft(l); -end; - -function GraphABCWindow.GetLeft: integer; -begin - Result := WindowLeft; -end; - -procedure GraphABCWindow.SetTop(t: integer); -begin - SetWindowTop(t); -end; - -function GraphABCWindow.GetTop: integer; -begin - Result := WindowTop; -end; - -procedure GraphABCWindow.SetWidth(w: integer); -begin - SetWindowWidth(w); -end; - -function GraphABCWindow.GetWidth: integer; -begin - Result := WindowWidth; -end; - -procedure GraphABCWindow.SetHeight(h: integer); -begin - SetWindowHeight(h); -end; - -function GraphABCWindow.GetHeight: integer; -begin - Result := WindowHeight; -end; - -procedure GraphABCWindow.SetCaption(c: string); -begin - SetWindowCaption(c); -end; - -function GraphABCWindow.GetCaption: string; -begin - Result := WindowCaption; -end; - -procedure GraphABCWindow.SetIsFixedSize(b: boolean); -begin - SetWindowIsFixedSize(b); -end; - -function GraphABCWindow.GetIsFixedSize: boolean; -begin - Result := WindowIsFixedSize; -end; - -procedure GraphABCWindow.Clear; -begin - ClearWindow; -end; - -procedure GraphABCWindow.Clear(c: Color); -begin - ClearWindow(c); -end; - -procedure GraphABCWindow.SetSize(w,h: integer); -begin - SetWindowSize(w,h) -end; - -procedure GraphABCWindow.SetPos(l,t: integer); -begin - SetWindowPos(l,t) -end; - -procedure GraphABCWindow.Init(Left,Top,Width,Height: integer; BackColor: Color); -begin - InitWindow(Left,Top,Width,Height,BackColor); -end; - -procedure GraphABCWindow.Save(fname: string); -begin - SaveWindow(fname); -end; - -procedure GraphABCWindow.Load(fname: string); -begin - LoadWindow(fname); -end; - -procedure GraphABCWindow.Fill(fname: string); -begin - FillWindow(fname); -end; - -procedure GraphABCWindow.Close; -begin - CloseWindow -end; - -procedure GraphABCWindow.Minimize; -begin - MinimizeWindow -end; - -procedure GraphABCWindow.Maximize; -begin - MaximizeWindow; -end; - -procedure GraphABCWindow.Normalize; -begin - NormalizeWindow; -end; - -procedure GraphABCWindow.CenterOnScreen; -begin - CenterWindow; -end; - -function GraphABCWindow.Center: Point; -begin - Result := WindowCenter; -end; - -var firstcall := True; - -procedure InitGraphABC; -begin - if not firstcall then exit; - firstcall := False; - clMoneyGreen := RGB(192,220,192); - StartIsComplete := False; - MainFormThread := new System.Threading.Thread(InitForm0); - MainFormThread.Start; - while not StartIsComplete do - Sleep(30); - Sleep(30); - SetSmoothingOn; - _GraphABCControl := f; -end; - -initialization - InitGraphABC; -finalization -// Application.Run(MainWindow); -end. \ No newline at end of file diff --git a/bin/Lib/LibForVB/GraphABC/GraphABCHelper.pas b/bin/Lib/LibForVB/GraphABC/GraphABCHelper.pas deleted file mode 100644 index 0a033eb35..000000000 --- a/bin/Lib/LibForVB/GraphABC/GraphABCHelper.pas +++ /dev/null @@ -1,380 +0,0 @@ -unit GraphABCHelper; - -//#apptype windows -#reference 'System.Windows.Forms.dll' -#reference 'System.Drawing.dll' -#savepcu false - -interface - -uses System.Drawing; - -type Color = System.Drawing.Color; - -// Primitives -procedure Line(x1,y1,x2,y2: integer; gr: Graphics); -procedure Line(x1,y1,x2,y2: integer; c: Color; gr: Graphics); - -procedure FillEllipse(x1,y1,x2,y2: integer; gr: Graphics); -procedure DrawEllipse(x1,y1,x2,y2: integer; gr: Graphics); -procedure FillRectangle(x1,y1,x2,y2: integer; gr: Graphics); -procedure FillRect(x1,y1,x2,y2: integer; gr: Graphics); -procedure DrawRectangle(x1,y1,x2,y2: integer; gr: Graphics); -procedure FillCircle(x,y,r: integer; gr: Graphics); -procedure DrawCircle(x,y,r: integer; gr: Graphics); -procedure DrawRoundRect(x1,y1,x2,y2,w,h: integer; gr: Graphics); -procedure FillRoundRect(x1,y1,x2,y2,w,h: integer; gr: Graphics); - -procedure Ellipse(x1,y1,x2,y2: integer; gr: Graphics); -procedure Rectangle(x1,y1,x2,y2: integer; gr: Graphics); -procedure Circle(x,y,r: integer; gr: Graphics); -procedure RoundRect(x1,y1,x2,y2,w,h: integer; gr: Graphics); - -procedure Arc(x,y,r,a1,a2: integer; gr: Graphics); -procedure Pie(x,y,r,a1,a2: integer; gr: Graphics); -procedure FillPie(x,y,r,a1,a2: integer; gr: Graphics); -procedure DrawPie(x,y,r,a1,a2: integer; gr: Graphics); - -procedure DrawPolygon(a: array of Point; gr: Graphics); -procedure FillPolygon(a: array of Point; gr: Graphics); -procedure Polygon(a: array of Point; gr: Graphics); -procedure Polyline(a: array of Point; gr: Graphics); -procedure Curve(a: array of Point; gr: Graphics); -procedure DrawClosedCurve(a: array of Point; gr: Graphics); -procedure FillClosedCurve(a: array of Point; gr: Graphics); -procedure ClosedCurve(a: array of Point; gr: Graphics); - -procedure TextOut(x,y: integer; s: string; gr: Graphics); - -function GetView(b: Bitmap; r: System.Drawing.Rectangle): Bitmap; -function ImageIntersect(b1,b2: Bitmap): boolean; - -var - CurrentTextBrush: SolidBrush; - -implementation - -uses System, System.Drawing, System.Drawing.Drawing2D, GraphABC; - -var - sf: StringFormat; - ColorLinePen: System.Drawing.Pen; - -function ImageIntersect(b1,b2: Bitmap): boolean; -// Предполагается, что b1 и b2 - одного размера -type - RGB = record - r,g,b: byte; - end; - PRGB = ^uint32; -label 1; -var - ptr1,ptr2: pointer; - iptr1,iptr2: integer; - p1,p2: PRGB; - rect: System.Drawing.Rectangle; - bmpData1,bmpData2: System.Drawing.Imaging.BitmapData; -begin - rect := new System.Drawing.Rectangle(0,0,b1.Width,b1.Height); - bmpData1 := b1.LockBits(rect, System.Drawing.Imaging.ImageLockMode.ReadWrite, b1.PixelFormat); - ptr1 := bmpData1.Scan0.ToPointer; - iptr1 := integer(ptr1); - - bmpData2 := b2.LockBits(rect, System.Drawing.Imaging.ImageLockMode.ReadWrite, b2.PixelFormat); - ptr2 := bmpData2.Scan0.ToPointer; - iptr2 := integer(ptr2); - - var pixelFormatSize := Image.GetPixelFormatSize(b1.PixelFormat) div 8; - var Offset := bmpData1.stride - b1.Width * pixelFormatSize; - - Result := False; - for var y:=0 to b1.Height-1 do - begin - for var x:=0 to b1.Width-1 do - begin - p1 := PRGB(pointer(iptr1)); - p2 := PRGB(pointer(iptr2)); - //writeln(p1^.R,' ',p1^.G,' ',p1^.B,' ',p2^.R,' ',p2^.G,' ',p2^.B); -// if ((p1^.R and p1^.G and p1^.B)<>$FF) and ((p2^.R and p2^.G and p2^.B)<>$FF) then - if (p1^<>$FFFFFFFF) and (p2^<>$FFFFFFFF) then - begin - Result := True; - goto 1; - end; - iptr1 += pixelFormatSize; - iptr2 += pixelFormatSize; - end; - iptr1 += Offset; - iptr2 += Offset; - end; -1: - b2.UnlockBits(bmpData1); - b1.UnlockBits(bmpData1); -end; - -function GetView(b: Bitmap; r: System.Drawing.Rectangle): Bitmap; -var - w,h,stride,padding,pixelFormatSize: integer; - ptr,start: System.IntPtr; - rect: System.Drawing.Rectangle; - bmpData: System.Drawing.Imaging.BitmapData; -begin - w := b.Width; - h := b.Height; - rect := new System.Drawing.Rectangle(0,0,w,h); - bmpData := b.LockBits(rect, System.Drawing.Imaging.ImageLockMode.ReadWrite, b.PixelFormat); - - ptr := bmpData.Scan0; - b.UnlockBits(bmpData); - - pixelFormatSize := Image.GetPixelFormatSize(b.PixelFormat) div 8; - - start := (System.IntPtr)(integer(ptr) + w * pixelFormatSize * r.Y + r.X * pixelFormatSize); - - stride := w * pixelFormatSize; - padding := stride mod 4; - if padding<>0 then - stride := stride + 4 - padding; //pad out to multiple of 4 - - Result := new Bitmap(r.Width,r.Height,stride,b.PixelFormat,start); -end; - -procedure Swap(var x1,x2: integer); -var t: integer; -begin - t := x1; - x1 := x2; - x2 := t; -end; - -// Graphics Primitives -procedure Line(x1,y1,x2,y2: integer; c: Color; gr: Graphics); -begin - ColorLinePen.Color := c; - gr.DrawLine(ColorLinePen,x1,y1,x2,y2); -end; - -procedure Line(x1,y1,x2,y2: integer; gr: Graphics); -begin - gr.DrawLine(Pen.NETPen,x1,y1,x2,y2); -end; - -procedure FillRectangle(x1,y1,x2,y2: integer; gr: Graphics); -var sm: SmoothingMode; -begin - if x1>x2 then - Swap(x1,x2); - if y1>y2 then - Swap(y1,y2); - sm := gr.SmoothingMode; - gr.SmoothingMode := SmoothingMode.None; - if Brush.NETBrush<>nil then - gr.FillRectangle(Brush.NETBrush,x1,y1,x2-x1,y2-y1); - gr.SmoothingMode := sm; -end; - -procedure FillRect(x1,y1,x2,y2: integer; gr: Graphics); -begin - FillRectangle(x1,y1,x2,y2,gr); -end; - -procedure DrawRectangle(x1,y1,x2,y2: integer; gr: Graphics); -begin - if x1>x2 then - Swap(x1,x2); - if y1>y2 then - Swap(y1,y2); - gr.DrawRectangle(Pen.NETPen,x1,y1,x2-x1-1,y2-y1-1); -end; - -procedure Rectangle(x1,y1,x2,y2: integer; gr: Graphics); -begin - if Brush.NETBrush <> nil then - FillRectangle(x1,y1,x2-1,y2-1,gr); - if Pen.NETPen.DashStyle <> DashStyle.Custom then - DrawRectangle(x1,y1,x2,y2,gr); -end; - -procedure DrawEllipse(x1,y1,x2,y2: integer; gr: Graphics); -begin - if x1>x2 then - Swap(x1,x2); - if y1>y2 then - Swap(y1,y2); - gr.DrawEllipse(Pen.NETPen,x1,y1,x2-x1-1,y2-y1-1); -end; - -procedure FillEllipse(x1,y1,x2,y2: integer; gr: Graphics); -begin - if x1>x2 then - Swap(x1,x2); - if y1>y2 then - Swap(y1,y2); - gr.FillEllipse(Brush.NETBrush,x1,y1,x2-x1-1,y2-y1-1); -end; - -procedure Ellipse(x1,y1,x2,y2: integer; gr: Graphics); -begin - if Brush.NETBrush <> nil then - FillEllipse(x1,y1,x2,y2,gr); - if Pen.NETPen.DashStyle <> DashStyle.Custom then - DrawEllipse(x1,y1,x2,y2,gr); -end; - -procedure DrawCircle(x,y,r: integer; gr: Graphics); -begin - gr.DrawEllipse(Pen.NETPen,x-r,y-r,x+r,y+r); -end; - -procedure FillCircle(x,y,r: integer; gr: Graphics); -begin - gr.FillEllipse(Brush.NETBrush,x-r,y-r,x+r,y+r); -end; - -procedure Circle(x,y,r: integer; gr: Graphics); -begin - FillCircle(x,y,r,gr); - DrawCircle(x,y,r,gr); -end; - -function CreatePathForDrawRoundRect(x1,y1,x2,y2,w,h: integer): GraphicsPath; -var xx,yy: integer; -begin - if x1>x2 then - Swap(x1,x2); - if y1>y2 then - Swap(y1,y2); - xx := w div 2; - yy := h div 2; - Result := new GraphicsPath(); - Result.AddLine(x1 + xx, y1, x2 - xx, y1); - Result.AddArc(x2 - w - 1, y1, w, h, 270, 90); - Result.AddLine(x2 - 1, y1 + yy, x2 - 1, y2 - yy); - Result.AddArc(x2 - w - 1, y2 - h - 1, w, h, 0, 90); - Result.AddLine(x2 - xx, y2 - 1, x1 + xx, y2 - 1); - Result.AddArc(x1, y2 - h - 1, w, h, 90, 90); - Result.AddLine(x1, y2 - yy, x1, y1 + yy); - Result.AddArc(x1, y1, w, h, 180, 90); - Result.CloseFigure(); -end; - -procedure DrawRoundRect(x1,y1,x2,y2,w,h: integer; gr: Graphics); -var path: GraphicsPath; -begin - path := CreatePathForDrawRoundRect(x1,y1,x2,y2,w,h); - gr.DrawPath(Pen.NETPen, path); - path.Dispose; -end; - -procedure FillRoundRect(x1,y1,x2,y2,w,h: integer; gr: Graphics); -var path: GraphicsPath; -begin - path := CreatePathForDrawRoundRect(x1,y1,x2,y2,w,h); - gr.FillPath(Brush.NETBrush, path); - path.Dispose; -end; - -procedure RoundRect(x1,y1,x2,y2,w,h: integer; gr: Graphics); -begin - if Brush.NETBrush <> nil then - FillRoundRect(x1,y1,x2,y2,w,h,gr); - if Pen.NETPen.DashStyle <> DashStyle.Custom then - DrawRoundRect(x1,y1,x2,y2,w,h,gr); -end; - -procedure Arc(x,y,r,a1,a2: integer; gr: Graphics); -begin - a1:=360-a1; - a2:=360-a2; - if a2 nil then - FillPie(x,y,r,a1,a2,gr); - if Pen.NETPen.DashStyle <> DashStyle.Custom then - DrawPie(x,y,r,a1,a2,gr); -end; - -procedure DrawPolygon(a: array of Point; gr: Graphics); -begin - gr.DrawPolygon(Pen.NETPen,a); -end; - -procedure FillPolygon(a: array of Point; gr: Graphics); -begin - gr.FillPolygon(Brush.NETBrush,a); -end; - -procedure Polygon(a: array of Point; gr: Graphics); -begin - if Brush.NETBrush <> nil then - FillPolygon(a,gr); - if Pen.NETPen.DashStyle <> DashStyle.Custom then - DrawPolygon(a,gr); -end; - -procedure Polyline(a: array of Point; gr: Graphics); -begin - gr.DrawLines(Pen.NETPen,a); -end; - -procedure Curve(a: array of Point; gr: Graphics); -begin - gr.DrawCurve(Pen.NETPen,a); -end; - -procedure DrawClosedCurve(a: array of Point; gr: Graphics); -begin - gr.DrawClosedCurve(Pen.NETPen,a); -end; - -procedure FillClosedCurve(a: array of Point; gr: Graphics); -begin - gr.FillClosedCurve(Brush.NETBrush,a); -end; - -procedure ClosedCurve(a: array of Point; gr: Graphics); -begin - if Brush.NETBrush <> nil then - FillClosedCurve(a,gr); - if Pen.NETPen.DashStyle <> DashStyle.Custom then - DrawClosedCurve(a,gr); -end; - -procedure TextOut(x,y: integer; s: string; gr: Graphics); -var sz: SizeF; -begin - sz := gr.MeasureString(s,Font.NETFont,0,sf); - if Brush.NETBrush <> nil then - FillRectangle(x,y,x+round(sz.Width),y+round(sz.Height)+1,gr); - gr.DrawString(s,Font.NETFont,CurrentTextBrush,x,y,sf); -end; - -initialization - sf := new StringFormat(StringFormat.GenericTypographic); - sf.FormatFlags := StringFormatFlags.MeasureTrailingSpaces; - CurrentTextBrush := new SolidBrush(System.Drawing.Color.Black); - ColorLinePen := new System.Drawing.Pen(System.Drawing.Color.Black); -end. \ No newline at end of file diff --git a/bin/Lib/LibForVB/build.bat b/bin/Lib/LibForVB/build.bat deleted file mode 100644 index 454d58309..000000000 --- a/bin/Lib/LibForVB/build.bat +++ /dev/null @@ -1,11 +0,0 @@ - -cd ABCObjects -..\..\..\pabcnetc.exe ABCObjects.pas - -cd .. - -cd GraphABC -..\..\..\pabcnetc.exe GraphABC.pas - - -cd .. \ No newline at end of file diff --git a/bin/Lib/SPythonHidden.pas b/bin/Lib/SPython/SPythonHidden.pas similarity index 100% rename from bin/Lib/SPythonHidden.pas rename to bin/Lib/SPython/SPythonHidden.pas diff --git a/bin/Lib/SPythonSystem.pas b/bin/Lib/SPython/SPythonSystem.pas similarity index 100% rename from bin/Lib/SPythonSystem.pas rename to bin/Lib/SPython/SPythonSystem.pas diff --git a/bin/Lib/SPythonSystemPys.pys b/bin/Lib/SPython/SPythonSystemPys.pys similarity index 100% rename from bin/Lib/SPythonSystemPys.pys rename to bin/Lib/SPython/SPythonSystemPys.pys diff --git a/bin/Lib/itertools.pys b/bin/Lib/SPython/itertools.pys similarity index 100% rename from bin/Lib/itertools.pys rename to bin/Lib/SPython/itertools.pys diff --git a/bin/Lib/math.pys b/bin/Lib/SPython/math.pys similarity index 100% rename from bin/Lib/math.pys rename to bin/Lib/SPython/math.pys diff --git a/bin/Lib/random1.pys b/bin/Lib/SPython/random1.pys similarity index 100% rename from bin/Lib/random1.pys rename to bin/Lib/SPython/random1.pys diff --git a/bin/Lib/time1.pas b/bin/Lib/SPython/time1.pas similarity index 100% rename from bin/Lib/time1.pas rename to bin/Lib/SPython/time1.pas diff --git a/bin/TestRunner.exe b/bin/TestRunner.exe index a49798a84..42ccfb274 100644 Binary files a/bin/TestRunner.exe and b/bin/TestRunner.exe differ diff --git a/bin/TestRunner.pas b/bin/TestRunner.pas index 1983e1efd..fc7b26c9e 100644 --- a/bin/TestRunner.pas +++ b/bin/TestRunner.pas @@ -42,10 +42,13 @@ begin Result := new LanguageTestsInfo(languageInformation.Name, languageInformation.FilesExtensions, languageInformation.CommentSymbol); end; -function GetLibDir: string; +function GetLibDir(languageName : string): string; begin var dir := Path.GetDirectoryName(GetEXEFileName()); - Result := dir + PathSeparator + 'Lib'; + if languageName <> 'PascalABC.NET' then + Result := dir + PathSeparator + 'Lib' + PathSeparator + languageName + else + Result := dir + PathSeparator + 'Lib'; end; function GetFilesByExtensions(path: string; extensions: array of string; searchOption: SearchOption := System.IO.SearchOption.TopDirectoryOnly): array of string; @@ -454,7 +457,7 @@ end; procedure CopyLibFiles; begin - var files := GetFilesByExtensions(GetLibDir(), CurrentLanguageInfo.languageExtensions); + var files := GetFilesByExtensions(GetLibDir(CurrentLanguageInfo.languageName), CurrentLanguageInfo.languageExtensions); foreach f: string in files do begin &File.Copy(f, TestSuiteDir + PathSeparator + 'CompilationSamples' + PathSeparator + Path.GetFileName(f), true); @@ -482,7 +485,7 @@ end; begin //DeletePABCSystemPCU; try - Languages.Integration.LanguageIntegrator.LoadStandardLanguages(); + Languages.Integration.LanguageIntegrator.LoadAllLanguages(); TestSuiteDir := System.Environment.CurrentDirectory; diff --git a/pabcnetc/ConsoleCompiler.cs b/pabcnetc/ConsoleCompiler.cs index 1db8943d0..549b4a03b 100644 --- a/pabcnetc/ConsoleCompiler.cs +++ b/pabcnetc/ConsoleCompiler.cs @@ -6,6 +6,7 @@ using System.IO; using System.Collections.Generic; using System.Linq; using System.Globalization; +using Languages.Facade; namespace PascalABCCompiler { @@ -370,17 +371,17 @@ namespace PascalABCCompiler //GC.Collect(); WriteColorText(Compiler.Banner + "\nCopyright (c) 2005-2026 by Ivan Bondarev, Stanislav Mikhalkovich\n", ConsoleColor.Green); Console.WriteLine("OK {0}ms", (DateTime.Now - ldt).TotalMilliseconds); - if (Compiler.SupportedSourceFiles.Length == 0) + if (LanguageProvider.Instance.Languages.Count == 0) WriteColorText(StringResourcesGet("ERROR_PARSERS_NOT_FOUND")+Environment.NewLine, ConsoleColor.Red); Compiler.InternalDebug.SkipPCUErrors = false; } public static void ShowConnectedParsers() { - if (Compiler.SupportedSourceFiles.Length > 0) + if (LanguageProvider.Instance.Languages.Count > 0) { Console.Write(StringResourcesGet("CONNECTED_PARSERS")); - foreach (PascalABCCompiler.SupportedSourceFile ssf in Compiler.SupportedSourceFiles) - Console.Write(ssf+"; "); + foreach (ILanguage lang in LanguageProvider.Instance.Languages) + Console.Write(FormatTools.LanguageAndExtensionsFormatted(lang.Name, lang.FilesExtensions)+"; "); Console.WriteLine(); } } diff --git a/pabcnetc_clear/ConsoleCompiler.cs b/pabcnetc_clear/ConsoleCompiler.cs index dc6999e0a..ceb7d71d7 100644 --- a/pabcnetc_clear/ConsoleCompiler.cs +++ b/pabcnetc_clear/ConsoleCompiler.cs @@ -28,16 +28,16 @@ namespace PascalABCCompiler return StringResources.Get(StringsPrefix + Key); } - public static void ShowConnectedParsers() + /*public static void ShowConnectedParsers() { - if (Compiler.SupportedSourceFiles.Length > 0) + if (LanguageProvider.Instance.Languages.Count > 0) { Console.Write(StringResourcesGet("CONNECTED_PARSERS")); - foreach (PascalABCCompiler.SupportedSourceFile ssf in Compiler.SupportedSourceFiles) - Console.Write(ssf+"; "); + foreach (ILanguage lang in LanguageProvider.Instance.Languages) + Console.Write(FormatTools.LanguageAndExtensionsFormatted(lang.Name, lang.FilesExtensions)+"; "); Console.WriteLine(); } - } + }*/ public static bool CheckAndSplitDirective(string directive, out string name, out string value) {