// (C) Персональная интеллектуальная онлайн среда "ЭЙДОС-X Professional" (Система "Эйдос-Хpro"), ADS-mADStxt, beta-version, rel: 23.05.2025. // (C) Автор и разработчик: д.э.н., к.т.н., профессор Луценко Евгений Вениаминович, Россия, Краснодар. * Of course, as they say, "The world did not come together in a wedge" on the Eidos system. There are many very decent artificial intelligence systems. * Nevertheless, the Universal Cognitive Analytical system "Eidos-X++" differs from most of these systems in at least some of the following parameters:: * - it is universal and can be applied in many subject areas, as it is developed in a universal formulation that does not depend on the subject area (http://lc.kubagro.ru/aidos/index.htm ). This is ensured due to the fact that the system has 6 automated software interfaces (API, subsystem 2.3.2), which provide input to the system from external sources (datasets) of various types of data: tabular, textual and graphical. Using the API, external numeric, textual, and graphical data measured in textual (nominal, dichotomous, and ordinal) and numeric (interval, and ratio) scales and in various units of measurement are entered into the Eidos system and converted into a single standard form of descriptive and classification tokens, which are then processed in a completely uniform manner by the computing core of the system. "Eidos". This processing includes the creation of statistical and system-cognitive domain models and solving various problems using these models. * - The Eidos system is a software tool for Automated system-cognitive analysis (ASC-analysis) and is an automated system, i.e. it assumes direct human participation in real time in the process of creating models and using them to solve problems of identification, forecasting, decision-making and research of a subject area by studying its model (automatic systems they work without such human involvement); * - it is one of the first and most popular domestic personal-level artificial intelligence systems, i.e. it does not require special training from the user in the field of artificial intelligence technologies and programming: there is an act of introduction of the Eidos system in 1987 (http://lc.kubagro.ru/aidos/aidos02/PR-4.htm ); * - it really works, provides stable identification in a comparable form of the strength and direction of cause-and-effect relationships in incomplete noisy interdependent (nonlinear) data of very large dimensions of numerical and non-numerical nature, measured in various types of scales (nominal, ordinal and numerical) and in various units of measurement (i.e. does not impose strict requirements on the data which cannot be executed, but processes the data that is available); * - has a "zero entry threshold": * - contains a large number of intelligent on-premises (i.e., supplied with installation) and cloud-based educational and scientific Eidos applications (currently there are 31 and more than 443, respectively: (http://lc.kubagro.ru/Source_data_applications/WebAppls.htm ) (http://lc.kubagro.ru/aidos/Presentation_Aidos-online.pdf , http://lc.kubagro.ru/Presentation_LutsenkoEV.pdf ); * - it is in full open free access (http://lc.kubagro.ru/aidos/_Aidos-X.htm ), and with up-to-date source texts (http://lc.kubagro.ru/__AidosALL.txt ): open license: CC BY-SA 4.0 (https://creativecommons.org/licenses/by-sa/4.0 /), and this means that anyone can use it, without any additional permission from the primary copyright holder - the author and the developer. systems "Eidos" Prof. E.V.Lutsenko (note that the Eidos system was created entirely using only licensed tool software and has 34 certificates from ROSPATENT of the Russian Federation); * - it is an "interpreter of intelligent models", i.e., on the one hand, it is a tool shell that allows you to create intelligent applications based on a configurator of statistical and system-cognitive models without any programming, and on the other hand, it is a run-time system or execution environment that ensures the operation of these intelligent applications in an adaptive mode.; * - to master the Eidos system yourself, it is enough to download from the page: http://lc.kubagro.ru/Installation_Eidos.php and install the full version of the system, and then download and install one of the intelligent cloud Eidos applications from the Eidos cloud in 1.3 mode (http://lc.kubagro.ru/Source_data_applications/WebAppls.htm ) and execute it following the description of the application. This is usually a readme.pdf file in the following folder: c:\Aidos-X\AID_DATA\Inp_data . To study, it is better to choose the newest applications, the author of which is Professor E.V.Lutsenko. In addition, on the page: http://lc.kubagro.ru/aidos/How_to_make_your_own_cloud_Eidos-application.pdf There are more than 320 one-and-a-half and three-hour video classes (in Russian) and many other educational materials and examples describing intelligent Eidos applications: http://lc.kubagro.ru/Video_lessons_by_Prof.E.V.Lutsenko/Catalog .php; * - on the page: http://lc.kubagro.ru/aidos/_Aidos-X.htm There are many thematic collections of publications on the applications of the Eidos system in a wide variety of subject areas. * - supports on-line knowledge accumulation and exchange environment, widely used all over the world (http://lc.kubagro.ru/map5.php ); * - Provides multilingual interface support in 51 languages. The language databases are included in the installation and can be updated automatically.; * - implements the most computationally time-consuming operations of model synthesis and recognition using a graphics processor (GPU), which in some tasks accelerates the solution of these tasks by several thousand times, which really ensures intelligent processing of big data, big information and big knowledge (the graphics processor must be on the NVIDIA chipset, i.e. support the language OpenGL); * - provides the transformation of the initial empirical data into information, and it into knowledge and the solution using this knowledge of the tasks of identification, forecasting, decision support and research of the subject area by studying its system-cognitive model, while generating a very large number of tabular and graphical output forms (development of cognitive graphics), many of which there are no analogues in other systems (examples of forms can be found in the work: http://lc.kubagro.ru/aidos/aidos18_LLS/aidos18_LLS.pdf ); * - it imitates the human way of thinking well and is a tool of cognition: it gives analytical results that are understandable to experts based on their experience, intuition and professional competence, if these experts already exist, and if they do not exist yet, it still gives the correct results of cognition, which will be recognized by future experts when they appear.; * - instead of imposing practically impossible requirements on the initial data (such as the normality of the distribution, absolute accuracy and complete repetitions of all combinations of factor values and their complete independence and additivity), automated system cognitive analysis (ASK analysis) suggests making sense of the data that exists without any preliminary processing, and thus thus, transform them into information, and then transform this information into knowledge by applying it to achieve goals (i.e. for decision-making and management) and solving classification problems, decision support and meaningful empirical research of the modeled subject area. * What is the strength of the approach implemented in the Eidos system? The fact is that it implements an approach whose effectiveness does not depend on what we think about the subject area or whether we think at all. It forms models directly based on empirical data, rather than based on our understanding of the mechanisms for implementing patterns in these data. That is why Eidos models are effective even if our ideas about the subject area are erroneous or even absent. * This is the weakness of this approach implemented in the Eidos system. Models of the Eidos system are phenomenological models that reflect empirical patterns in the facts of the training sample, i.e. they do not reflect the causal mechanism of determination, but only the fact and nature of determination. A meaningful explanation of these empirical patterns is already being formulated by experts at the theoretical level of knowledge in meaningful scientific laws. ******************** #include "adsdbe.ch" // ADSDBE = ADS SERVER ENGINE ******************** #include "inkey.ch" #include "dcdir.ch" #include "appevent.ch" #include "xbp.ch" #include "dll.ch" #include "dccursor.ch" #Include "thread.ch" #include "class.ch" #include "dmlb.ch" #include "fileio.ch" #include "dctree.ch" *#include "SystemMetrics.ch" *#include "axcdxcmx.ch" // Графика ActiveX #include "collat.ch" #include "common.ch" #include "dbedit.ch" #include "Dbfdbe.ch" #include "dcapp.ch" #include "dcbitmap.ch" #include "dccargo.ch" #include "dcdialog.ch" #include "dcdir.ch" #include "dcfiles.ch" #include "dcgra.ch" #include "dcgraph.ch" // графика #include "BdColors.Ch" // графика #include "dccolors.ch" // графика #include "dcprint.ch" // графика #include "Dcicon.ch" #include "dcmsg.ch" #include "dcpick.ch" #include "deldbe.ch" #include "directry.ch" #include "dmlb.ch" #include "express.ch" #include "fileio.ch" #include "font.ch" #include "gra.ch" #include "inkey.ch" #include "memvar.ch" #include "natmsg.ch" #include "prompt.ch" #include '_dcdbfil.ch' #include "set.ch" #include "std.ch" #include "xbp.ch" #include '_dcappe.ch' #include 'dcscope.ch' #include '_dcstru.ch' #include 'dcfields.ch' #include 'dccolor.ch' *#include "Fileio.ch" // Max_DB *#include "rmchart.ch" // Графика ActiveX #include "dcads.ch" *#include "dll.ch" #define SW_HIDE 0 #define SW_NORMAL 1 #define SW_SHOWMINIMIZED 2 #define SW_SHOWMAXIMIZED 3 #define SW_MAXIMIZE 3 #define SW_SHOWNOACTIVATE 4 #define SW_SHOW 5 #define SW_MINIMIZE 6 #define SW_SHOWMINNOACTIVE 7 #define SW_SHOWNA 8 #define SW_RESTORE 9 #define SW_SHOWDEFAULT 10 #define SE_ERR_FNF 2 #define SE_ERR_PNF 3 #define SE_ERR_ACCESSDENIED 5 #define SE_ERR_OOM 8 #define SE_ERR_DLLNOTFOUND 32 #define SE_ERR_SHARE 6 #define SE_ERR_ASSOCINCOMPLETE 27 #define SE_ERR_DDETIMEOUT 28 #define SE_ERR_DDEFAIL 29 #define SE_ERR_DDEBUSY 30 #define SE_ERR_NOASSOC 31 #define ERROR_BAD_FORMAT 11 #pragma Library( "ASINet10.lib" ) // 2.0 // Для альтернативного и неальтернативного выбора в просмотре таблиц *#define BMP_CHECKED "check1.bmp" *#define BMP_UNCHECKED "check2.bmp" *#define BMP_RACHECKED "radio1.bmp" *#define BMP_RAUNCHECKED "radio2.bmp" *#include "test.ch" #define BMP_CHECKED 10002 #define BMP_UNCHECKED 10003 #define BMP_RACHECKED 10004 #define BMP_RAUNCHECKED 10005 #pragma library( "ascom10.lib" ) #pragma library( "dclip1.lib" ) #pragma library( "dclip2.lib" ) #pragma library( "dclipx.lib" ) #pragma library( "xbtbase1.lib" ) #pragma library( "xbtbase2.lib" ) #pragma library( "xppui2.lib" ) #pragma library( "XPPRT0.LIB" ) #Pragma Library("Taskbar.lib") #xtranslate NTrim() => LTrim(Str()) #define USE_HTTPCLIENT // comment out to try Method2 //#include "Imgview.ch" /* * We use user defined events */ #define xbeDS_DirChanged xbeP_User + 100 #define xbeFS_FileMarked xbeP_User + 101 #define xbeFS_FileSelected xbeP_User + 102 #define DCAREAMSG_1 'Invalid Expression in Index Key:' /* * This directive calculates a centered position */ #xtrans CenterPos( , ) => ; { Int( (\[1] - \[1]) / 2 ) ; , Int( (\[2] - \[2]) / 2 ) } #define DC_RDDMSG_1 'Invalid RDD selection - '+cSuperRdd #define DC_RDDMSG_2 'DBE Name Description' #define DC_RDDMSG_3 'Select a Database Driver' *#define ADSDBE_MEMOFILE_EXT (DBE_USER+1) // RO *#define ADSDBE_INDEX_EXT (DBE_USER+2) // RW *#define ADSDBE_TBL_MODE (DBE_USER+3) // RW *#define ADSDBE_LOCK_MODE (DBE_USER+4) // RW *#define ADSDBE_RIGHTS_MODE (DBE_USER+5) // RW *#define ADSDBE_MEMOBLOCKSIZE (DBE_USER+6) // RW *#define ADSDBE_PASSWORD (DBE_USER+7) // RW // Return types of ADSDBE_TBL_MODE *#define ADSDBE_NTX 1 *#define ADSDBE_CDX 2 *#define ADSDBE_ADT 3 // Для опредедения разрешения монитора от Джимми #define DESKTOPVERTRES 117 #define DESKTOPHORZRES 118 // Excel Orientation #DEFINE xlLandscape 2 #DEFINE xlPortrait 1 #DEFINE xlWorkbookNormal -4143 #DEFINE xlCellTypeLastCell 11 #DEFINE SRCCOPY 0xCC0020 // Для быстрой графики Роджера #define KEYEVENTF_KEYUP 0x02 #define VK_MENU 0x12 #define VK_SNAPSHOT 0x2C #DEFINE VK_LBUTTON 0x01 #DEFINE VK_RBUTTON 0x02 * Для CSV=>DBF конвертера *#include "ot4xb.ch" // => ot4xb.dll => www.xbwin.com #ifndef CRLF #define CRLF chr(13)+chr(10) #endif * Klasse zum sequentiellen Einlesen groбer Dateien *#IF .t. // zum Einbinden in eigenes Projekt, .f. setzen ! MEMVAR dCBROWSE, dCEDIT, dCCOLOR STATIC snHdll // Для быстрой графики Роджера ******************************************************************************** PROCEDURE AppSys // Рабочий стол остается окном приложения RETURN ******************************************************************************** *************************************************************************** PROCEDURE DBESYS() // Overload the default DBESYS for your required DBE *************************************************************************** * IF .NOT. FILE('_ADS.txt') * PUBLIC mADStxt := 'OFF' // Advantage Database Server (ADS) не используется * StrFile(mADStxt, '_ADS.txt') * ELSE * mADStxt = FileStr('_ADS.txt') * IF mADStxt = 'OFF' .OR. mADStxt = 'ON' * ELSE * PUBLIC mADStxt := 'OFF' // Advantage Database Server (ADS) не используется * StrFile(mADStxt, '_ADS.txt') * ENDIF * ENDIF * MsgBox(mADStxt) * IF mADStxt = 'OFF' * IF ! DbeLoad( "NTXDBE") // load engine for DBF files * msgbox( "Database Engine NTXDBE not loaded" , "STOP" ) * QUIT * ENDIF * DbeBuild( "DBFNTX", "DBFDBE", "NTXDBE" ) // DBE=DBFNTX * DbeSetDefault("DBFNTX") // ADS OFF * ENDIF * IF mADStxt = 'ON' * MsgBox(mADStxt) * //----- FOXCDX: DBF-FPT-CDX * IF ! DbeLoad( "FOXDBE", .T.) // load engine for DBF files * msgbox( "Database Engine FOXDBE not loaded" , "STOP" ) * QUIT * ENDIF * IF ! DbeLoad( "CDXDBE", .T.) // load engine for DBF files * msgbox( "Database Engine CDXDBE not loaded" , "STOP" ) * QUIT * ENDIF * DbeBuild( "FOXCDX", "FOXDBE", "CDXDBE" ) // DBE=FOXCDX * *** DbeSetDefault("FOXCDX") // OFF * //----- DBFNTX: DBF-DBT-NTX * // ADS client engine and ALS Local Server engine exist * // Overload the default DBESYS for your required DBE * // system for working with DBF/NTX files on both server and client * IF ! DbeLoad( "DBFDBE") // load engine for DBF files * msgbox( "Database Engine DBFDBE not loaded" , "STOP" ) * QUIT * ENDIF * IF ! DbeLoad( "NTXDBE") // load engine for DBF files * msgbox( "Database Engine NTXDBE not loaded" , "STOP" ) * QUIT * ENDIF * DbeBuild( "DBFNTX", "DBFDBE", "NTXDBE" ) // DBE=DBFNTX * *** DbeSetDefault("DBFNTX") // OFF //----- ADSDBE: DBF-DBT-NTX // there must be ACE32.DLL otherwise it breaks here !!! // mora postojati ACE32.DLL inaиe ovde pukne !!! //----------------------------------------------------- IF ! DbeLoad( "ADSDBE", .F.) // load engine for ADS msgbox( "Database Engine ADSDBE not loaded" , "STOP" ) QUIT ENDIF *********************** DbeSetDefault("ADSDBE") // ON *********************** * ENDIF RETURN ******************************************************************************** ******************************************************************************** ******************************************************************************** FUNCTION Main() LOCAL GetList[0], GetOptions, nColor, oMessageBox, oMenuWords, oDlg, ; oMenuBar,oMenu1,oMenu2,oMenu3,oMenu4,oMenu5,oMenu6,oMenu7,; oMenu3_3, nKey := 0, oWebBrowser DC_IconDefault(1000) PRIVATE cTime1 := Time() // 11:23:46 PRIVATE mCorrLaunch := 'OFF' // oScrTime := DC_WaitOn('Метка-1: '+SubStr( Time()-cTime1, 1, 2)+':'+SubStr( Time()-cTime1, 4, 2)+':'+SubStr( Time()-cTime1, 7, 2),,,,,,,,,,,.F.) Xb2NetKey() // <<<===################# ** Выбор сообщения на титульной видеограмме (сейчас 1-го из 6) IF .NOT. FILE("_11.txt") m11txt=1;StrFile(STR(m11txt), '_11.txt') ELSE m11txt = VAL(ALLTRIM(FileStr('_11.txt'))) ENDIF ** Включение/отключение модуля проверки корректности запуска системы "Эйдос", т.е. "__AIDOS-X.exe" IF .NOT. FILE("Checking_the_correctness_of_the_module_launch__AIDOS-X.txt") mCorrLaunch = 'ON';StrFile(mCorrLaunch, 'Checking_the_correctness_of_the_module_launch__AIDOS-X.txt') aMess := {} AADD(aMess, 'Студенты и некоторые другие пользователи иногда запускают систему "Эйдос" некорректно: ') AADD(aMess, '- в папке загрузки или на рабочем столе; ') AADD(aMess, '- в архиве инсталляции системы "Эйдос", который скачали с сайта разработчика; ') AADD(aMess, '- в папке, в пути на которую встречаются пробелы и кириллица. ') AADD(aMess, 'Кроме того иногда систему запускают в одной и той же папке несколько раз, чего делать нельзя ') AADD(aMess, '(ее можно запускать несколько раз одновременно на одном компьютере, но в разных папках). ') AADD(aMess,'') AADD(aMess, 'Некорректный запуск системы "Эйдос" вызывает ошибку исполнения. Поэтому приходится проверять ') AADD(aMess, 'корректность запуска системы "Эйдос". Однако эта проверка занимает довольно много времени. ') AADD(aMess, 'Поэтому она оставлена только в модуле запуска системы: "___START_AIDOS-X.exe", а в исполнимом') AADD(aMess, 'модуле самой системы "__AIDOS-X.exe" она включается/отключается в зависимости от содержания ') AADD(aMess, 'текстового файла: "Checking_the_correctness_of_the_module_launch__AIDOS-X.txt": "ON"/"OFF". ') AADD(aMess,'') AADD(aMess, 'Отметим, что модуль запуска системы: "___START_AIDOS-X.exe" кроме проверки корректности ') AADD(aMess, 'запуска системы еще проверяет целостность исполнимого молуля системы "__AIDOS-X.exe" и ') AADD(aMess, 'наличие обновлений на сайте автора и разработчика системы проф.Е.В.Луценко. Если обновления ') AADD(aMess, 'есть, то они скачиваются, разархивируются и устанавливаются автоматически. ') LB_Warning(aMess, '(C°) Система "Эйдос-Х++"') ELSE mCorrLaunch = ALLTRIM(FileStr('Checking_the_correctness_of_the_module_launch__AIDOS-X.txt')) ENDIF IF mCorrLaunch = 'ON' DO CASE CASE m11txt = 1 oScr := DC_WaitOn('Проверка корректности запуска модуля: "__AIDOS-X.exe". Немного подождите!',,,,,,,,,,,.F.) CASE m11txt = 2 oScr := DC_WaitOn('Checking the correctness of the module launch: "__AIDOS-X.exe". Wait a few seconds!',,,,,,,,,,,.F.) CASE m11txt = 3 oScr := DC_WaitOn('Проверка корректности запуска модуля: "__AIDOS-X.exe". Немного подождите!',,,,,,,,,,,.F.) CASE m11txt = 4 oScr := DC_WaitOn('Checking the correctness of the module launch: "__AIDOS-X.exe". Wait a few seconds!',,,,,,,,,,,.F.) OTHERWISE oScr := DC_WaitOn('Проверка корректности запуска модуля: "__AIDOS-X.exe". Немного подождите!',,,,,,,,,,,.F.) ENDCASE ENDIF ************************************************************************************************************************************************* mFTP = 'ON' StrFile(mFTP, '_FTP.txt') *mFTP = FileStr('_FTP.txt') PRIVATE cFtpServer := "94.25.18.114" // ftp-адрес моего сайта http://lc.kubagro.ru/ из любой сети: внешней или внутренней сети КубГАУ oFtp := FTPClient():new( cFtpServer, Ftp_User, Ftp_Passw ) // Соединение с моим сайтом и авторизация IF .NOT. oFtp:connect() // Есть соединение с моим сайтом и авторизация? IF mCorrLaunch = 'ON' DC_Impl(oScr) ENDIF LB_Warning('Нет соединения с FTP-сервером обновлений системы "Эйдос" или нет авторизации', '(C°) Система "Эйдос-Х++"' ) mFTP = 'OFF' StrFile(mFTP, '_FTP.txt') * mFTP = FileStr('_FTP.txt') ELSE oFtp:curDir("public_html") aFileUpd := oFtp:Directory("Downloads.exe") IF LEN(aFileUpd) = 0 * DC_Impl(oScr) LB_Warning('Похоже доступ к FTP-серверу отсутствует или на нем нет файла обновлений "Downloads.exe"', '(C°) Система "Эйдос-Х++"') mFTP = 'OFF' StrFile(mFTP, '_FTP.txt') * mFTP = FileStr('_FTP.txt') ENDIF ENDIF oFtp:disconnect() ************************************************************************************************************************************************* * http://lc.kubagro.ru/ // Новый хостинг IF .NOT. FILE('_ADS.txt') PUBLIC mADStxt := 'OFF' // Advantage Database Server (ADS) не используется StrFile(mADStxt, '_ADS.txt') ELSE mADStxt = FileStr('_ADS.txt') IF mADStxt = 'OFF' .OR. mADStxt = 'ON' ELSE PUBLIC mADStxt := 'OFF' // Advantage Database Server (ADS) не используется StrFile(mADStxt, '_ADS.txt') ENDIF ENDIF ADS_SERVER_START() DO CASE CASE mADStxt = 'OFF' DbeSetDefault("DBFNTX") // ADS OFF CASE mADStxt = 'ON' DbeSetDefault("ADSDBE") // ADS ON ENDCASE * BigData() // Функция для отладки работы с большими данными (DBF-файлы >>> 2 Gb) <<<===############################# CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций PUBLIC Disk_name := DISKNAME() PUBLIC Cur_dir := CURDIR() PUBLIC Disk_dir := Disk_name+":\"+Cur_dir // Путь на папку с системой * DIRCHANGE(Disk_dir) // Папка с исполнимым модулем системы Эйдос * IF mCorrLaunch = 'ON' IF .F. // Эта проверка должна проводиться только в ___START_AIDOS-X.exe *************************************************************************************************************** ***** Если система Эйдос уже запущена выдать сообщение об этом и выйти **************************************** ***** Предотвращение повторного запуска __aidos-x.exe ********************************************************* RunShell('/C c:\Windows\System32\TaskList.exe /V /FO CSV > TaskList.csv',,.F.,.T.) // .F. - чтобы программа не продожалась дальше, пока не закончится перевод aTaskList := {} // Все программы, запущенные на компьютере nHandle := DC_txtOpen( 'TaskList.csv' ) DO WHILE !DC_TxtEOF( nHandle ) // Начало цикла по строкам mLine = DC_TxtLine( nHandle ) // Выделить строку из текстового файла mPosExe = AT('.exe', mLine) IF mPosExe > 0 mPos = AT('","', mLine) mModName = SUBSTR(mLine,2,mPos-2) * MsgBox(ConvToOemCP(mLine)) * MsgBox(mModName) IF ASCAN(aTaskList, mModName) = 0 // Каждая программа запоминается только один раз AADD (aTaskList, mModName) ENDIF ENDIF DC_TxtSkip( nHandle, 1 ) ENDDO DC_TxtClose( nHandle ) IF mCorrLaunch = 'ON' DC_Impl(oScr) ENDIF ASORT(aTaskList) * DC_DebugQout( aTaskList ) // <<<===################### mFlagAidos = .F. // Система Эйдос не запущена IF ASCAN(aTaskList, '__aidos-x.exe') > 0 // Каждая программа запускается только один раз. mFlagAidos = .T. // Система Эйдос уже запущена. Ясное дело, эта ведь проверка проводится в системе "Эйдос". Она должна проводиться только в ___START_AIDOS-X.exe ENDIF * IF DC_IsAppRunning('XbpDialog', '(C) Система "Эйдос"', '__aidos-x.exe',.T.) IF mFlagAidos aMess := {} AADD(aMess, 'Система "Эйдос" уже запущена в папке: "'+ConvToOemCP(ALLTRIM(Disk_dir))+'\"' ) AADD(aMess, 'Нельзя запускать исполнимый модуль системы: "_aidos-x.exe"') AADD(aMess, 'в одной и той же папке несколько раз в одной папке, т.к. ') AADD(aMess, 'система будет пытаться одновременно обращаться к одним и ') AADD(aMess, 'тем же базам данных, что вызывает ошибку исполнения. ') IF mCorrLaunch = 'ON' DC_Impl(oScr) ENDIF LB_Warning(aMess, '(C°) Система "Эйдос"') QUIT ENDIF ***** Если система Эйдос уже запущена в данной папке выдать сообщение об этом и выйти ************************* *************************************************************************************************************** ENDIF * ****************************************** * ****** Обработка ошибки ****************** * bError := ErrorBlock( {|e| Break(e)} ) // установить новый кодовый блок обработки ошибок * BEGIN SEQUENCE // код нормального исполнения * *** код нормального исполнения * *** * *** * RECOVER // код обработки ошибки * aMess := {} * AADD(aMess, L('При распознавании была попытка превышения максимального допустимого объема БД 2 Гб.')) // НАПРИМЕР * AADD(aMess, L('Необходимо уменьшить количество классов или/и объектов распознаваемой выборки !!! ')) * AADD(aMess, L('Можно также исключить из результатов распознавания наименее достоверные (режим 3.5)')) * DC_Impl(oScr) * LB_Warning(aMess) ** EXIT * ENDSEQUENCE * ErrorBlock( bError ) // переустановить старый кодовый * ****************************************** * ****************************************** * DC_Impl(oScrTime);oScrTime := DC_WaitOn('Метка-2: '+SubStr( Time()-cTime1, 1, 2)+':'+SubStr( Time()-cTime1, 4, 2)+':'+SubStr( Time()-cTime1, 7, 2),,,,,,,,,,,.F.) ***** Удаление старых версий файла START_AIDOS запуска и обновления системы Эйдос, если они есть <<<===####################### CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * aDir := Directory("*START_AIDOS-X*.exe") // С ADS не работает mNStartAidos = ADIR("*START_AIDOS-X*.exe") // С ADS работает PRIVATE aFileName[mNStartAidos], aFileSize[mNStartAidos], aFileDate[mNStartAidos], aFileTime[mNStartAidos] ADIR("*START_AIDOS-X*.exe", aFileName, aFileSize, aFileDate, aFileTime) * DC_Impl(oScr) * LB_Warning(aFileName, 'Эксперименты с "BigData.dbf"') aStructure := { { 'File_Num ', "C", 8, 0 }, ; { 'File_Name', "C", 40, 0 }, ; // ___START_AIDOS-X_2021_10_26.exe { 'File_Size', "N", 10, 0 }, ; { 'File_Date', "C", 8, 0 }, ; { 'File_Time', "C", 8, 0 }, ; { 'Delete ', "C", 1, 0 } } DbCreate( "StartAidos.dbf", aStructure, "DBFNTX" ) // ALL NB !!! * DbCreate( "StartAidos", aStructure ) // ALL NB !!! * USE ("StartAidos.dbf") NEW SHARED ALIAS "START_AIDOS" USE StartAidos EXCLUSIVE NEW IF LEN(aFileName) > 0 * FOR j := 1 TO Len(aDir) // С ADS не работает * APPEND BLANK * REPLACE File_Num WITH ALLTRIM(STR(j)) * REPLACE File_Name WITH aDir[j,F_NAME] * REPLACE File_Size WITH aDir[j,F_SIZE] * REPLACE File_Date WITH DTOS(aDir[j,F_WRITE_DATE]) * REPLACE File_Time WITH aDir[j,F_WRITE_TIME] * REPLACE Delete WITH 'Y' * NEXT FOR j := 1 TO Len(aFileName) // С ADS работает APPEND BLANK REPLACE File_Num WITH ALLTRIM(STR(j)) REPLACE File_Name WITH aFileName[j] REPLACE File_Size WITH aFileSize[j] REPLACE File_Date WITH DTOS(aFileDate[j]) REPLACE File_Time WITH aFileTime[j] REPLACE Delete WITH 'Y' NEXT INDEX ON File_Date+File_Time TO StartAidos DBGOBOTTOM() REPLACE Delete WITH 'N' mFileName = ALLTRIM(File_Name) * MsgBox(mFileName) DBGOTOP() DO WHILE .NOT. EOF() IF Delete = 'Y' ERASE(File_Name) ENDIF DBSKIP(1) ENDDO CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций IF mFileName <> "___START_AIDOS-X.exe" * COPY FILE (mFileName) TO ('___START_AIDOS-X.exe') // <<<===########################## Без ADS ADS_CopyFile(mFileName, '___START_AIDOS-X.exe', .F., .T.) // Скопировать новый файл запуска со стандартным именем и удалить новый файл с ADS ERASE(mFileName) ENDIF ENDIF ****************************************************************************************************************************** * DC_Impl(oScrTime);oScrTime := DC_WaitOn('Метка-2.1: '+SubStr( Time()-cTime1, 1, 2)+':'+SubStr( Time()-cTime1, 4, 2)+':'+SubStr( Time()-cTime1, 7, 2),,,,,,,,,,,.F.) ** Если ранее язык интерфейса не был задан - то задать русский, ** если был - то использовать тот, который был задан ** Если нет языковых баз - то создать их и задать текущим русский язык SET EXACT ON // Присравнении .T. если совпадают все символы, включая совпадение длины PUBLIC aLang_ru := {} // Массив для поиска русских текстовых элементов PUBLIC aLang_xx := {} // Массив для поиска нерусских текстовых элементов PUBLIC aNumUses := {} // Число использований j-го текстового элемента CreateDBLang() // На этой функции очень большая задержка во времени исполнения <<<===################################################### * DC_Impl(oScrTime);oScrTime := DC_WaitOn('Метка-2.1.1: '+SubStr( Time()-cTime1, 1, 2)+':'+SubStr( Time()-cTime1, 4, 2)+':'+SubStr( Time()-cTime1, 7, 2),,,,,,,,,,,.F.) * ZapDir('cygwin', .T.) // Он теперь не нужен, т.к. Гугл закрыл бесплатный on-line переводчик // Задать стиль кнопок ************************ * oConfig := DC_XbpPushButtonXPConfig():new() * oConfig:radius := 10 * oConfig:bgColor := GRA_CLR_CYAN * DC_PushButtonStyle( oConfig ) * oButtonConfig := DC_XbpPushButtonXPDefault():new() * DC_PushButtonStyle( oButtonConfig ) * DC_PushButtonStyle(1) * DC_PushButtonStyle(2) SET DECIMALS TO 15 SET DATE GERMAN SET ESCAPE On SET COLLATION TO SYSTEM // Руссификация *SET COLLATION TO ASCII // Руссификация ****** Системные переменные (общие переменные среды, переменые окружения) * DC_Impl(oScrTime);oScrTime := DC_WaitOn('Метка-2.2: '+SubStr( Time()-cTime1, 1, 2)+':'+SubStr( Time()-cTime1, 4, 2)+':'+SubStr( Time()-cTime1, 7, 2),,,,,,,,,,,.F.) PUBLIC Flag_SysAdmin := .F., M_KodSysAdmin := 0 // .T. - SysAdmin PUBLIC Flag_AdmAppl := .F., M_KodAdmAppls := 0 // .T. - AdmApplications PUBLIC Flag_User := .F., M_KodAdmAppls := 0 // .T. - User PUBLIC RegimSys := 1, n := 0 // EXCLUSIVE-1, SHARED-2 PUBLIC Ar_MainWind[2], M_Language // Парамеры главного окна и язык интерфейса PUBLIC GradRad := 3.14159265358979323846 / 180 // Коэффициент перевода аргументов тригонометрических функций из градусов в радианы PUBLIC aCalcInf[10] ;AFILL(aCalcInf,.F.) // Массив с информацией о расчитанных стат.моделях и моделях знаний PUBLIC Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } PUBLIC M_CurrInf := 4 // Номер текущей стат.модели или моделях знаний PUBLIC M_Inf := Ar_Model[M_CurrInf] PUBLIC aVerifInf[10];AFILL(aVerifInf,.F.) // Массив с информацией о верифицированных стат.моделях и моделях знаний PUBLIC aInstLab[30];AFILL(aInstLab,.T.) // Массив с информацией об установленных (как приложения) лабораторных работах с копируемыми БД PUBLIC M_CurrLab := 0 // Номер установленой лаб.работы с формируемыми БД PUBLIC aSay[30], Mess97, Mess98, Mess99 // Массив сообщений отображаемых стадий исполнения (до 30 на экране) PUBLIC Time_progress, Wsego, oProgress, lOk PUBLIC nEvery := 100 // Количество корректировок прогресс-бар PUBLIC mDeltaSpectr := 90 // Неиспользуемая часть высокочастотного спектра PUBLIC mWindow := 17, M_NewAppl := '' // Интервал (окно) сглаживания PUBLIC aPres := ; { { XBP_PP_COL_HA_FGCLR, GRA_CLR_WHITE },; // Header FG Color { XBP_PP_COL_HA_BGCLR, GRA_CLR_DARKGRAY },; // Header BG Color { XBP_PP_COL_FA_FGCLR, GRA_CLR_YELLOW },; // Footer FG Color { XBP_PP_COL_FA_BGCLR, GRA_CLR_DARKGRAY },; // Footer BG Color { XBP_PP_COL_DA_ROWSEPARATOR, XBPCOL_SEP_DOTTED },; // Row Sep { XBP_PP_COL_DA_COLSEPARATOR, XBPCOL_SEP_DOTTED },; // Col Sep { XBP_PP_COL_HA_ALIGNMENT, XBPALIGN_LEFT },; // Header alignment { XBP_PP_COL_DA_ROWHEIGHT, 20 },; // Row Height { XBP_PP_COL_DA_CELLHEIGHT, 20 } } // Cell Height ******************************************************************************************************** ****** Определить размеры экрана в пикселях разными способами и выбрать минимальные значения, но не нули ******************************************************************************************************** * DC_Impl(oScrTime);oScrTime := DC_WaitOn('Метка-2.3: '+SubStr( Time()-cTime1, 1, 2)+':'+SubStr( Time()-cTime1, 4, 2)+':'+SubStr( Time()-cTime1, 7, 2),,,,,,,,,,,.F.) PUBLIC hDC := GetDC(0) PUBLIC nDHORZRES := GetDeviceCaps( hDC, DESKTOPHORZRES ) // native Monitor Size ! от Джимми PUBLIC nDVERTRES := GetDeviceCaps( hDC, DESKTOPVERTRES ) // native Monitor Size ! aWidth := {} aHeight := {} ******** 1-й способ стандартный ************ AADD(aWidth, AppDeskTop():currentSize()[1]) // current screen size width in pixels AADD(aHeight, AppDeskTop():currentSize()[2]) // current screen size height in pixels ******** 2-й способ от Роджера ************* aWorkArea := DC_GetWorkArea() AADD(aWidth, aWorkArea[3] - aWorkArea[1]) AADD(aHeight, aWorkArea[4] - aWorkArea[2]) ******** 3-й способ от Джимми ************** AppDesktop():Currentsize() AADD(aWidth, nDHORZRES) AADD(aHeight, nDVERTRES) ReleaseDC( 0, hDC ) ******************************************** nWidth = +4096 nHeight = +4096 FOR j=1 TO LEN(aWidth) IF aWidth[j] > 0 nWidth = MIN(nWidth, aWidth[j]) ENDIF IF aHeight[j] > 0 nHeight = MIN(nHeight, aHeight[j]) ENDIF NEXT // Если разрешение экрана выше, чем размеры изображения, то увеличивать его не надо (масштабирование только в сторону уменьшения) * LB_Warning(aWidth) // Отладка ################### * LB_Warning(aHeight) ******************************************************************************************************** * DC_Impl(oScrTime);oScrTime := DC_WaitOn('Метка-3: '+SubStr( Time()-cTime1, 1, 2)+':'+SubStr( Time()-cTime1, 4, 2)+':'+SubStr( Time()-cTime1, 7, 2),,,,,,,,,,,.F.) PUBLIC aColor := {} // Все используемые цвета AADD(aColor, BD_BLUEMIST) // GraMakeRGBColor({195,238,255}) // BLUE 001 AADD(aColor, BD_PALETURQUOISE) // GraMakeRGBColor({175,238,238}) // BLUE 002 AADD(aColor, BD_PALEBLUE) // GraMakeRGBColor({140,223,255}) // BLUE 003 AADD(aColor, BD_FADEDBLUE) // GraMakeRGBColor({127,222,255}) // BLUE 004 AADD(aColor, BD_LIGHTBLUESKY) // GraMakeRGBColor({135,206,235}) // BLUE 005 AADD(aColor, BD_ISLANDBLUE) // GraMakeRGBColor({053,179,255}) // BLUE 006 AADD(aColor, BD_DODGERBLUE) // GraMakeRGBColor({030,144,255}) // BLUE 007 AADD(aColor, BD_PASTELBLUE) // GraMakeRGBColor({002,131,254}) // BLUE 008 AADD(aColor, BD_AZURE) // GraMakeRGBColor({000,127,255}) // BLUE 009### AADD(aColor, BD_ROYALBLUE) // GraMakeRGBColor({065,105,225}) // BLUE 010 AADD(aColor, BD_XBP_BLUE) // 2 // BLUE 011 AADD(aColor, BD_RICHBLUE) // GraMakeRGBColor({000,000,255}) // BLUE 012### AADD(aColor, BD_TLCDEEPBLUE) // GraMakeRGBColor({000,030,144}) // BLUE 013 AADD(aColor, BD_NAVYBLUE) // GraMakeRGBColor({000,000,128}) // BLUE 014### AADD(aColor, BD_DARKBLUE) // GraMakeRGBColor({000,000,087}) // BLUE 015############# AADD(aColor, BD_MIDNIGHTBLUE) // GraMakeRGBColor({025,025,112}) // BLUE 016 AADD(aColor, BD_NIGHT) // GraMakeRGBColor({036,026,068}) // OTHER 017 AADD(aColor, BD_SKYBLUE) // GraMakeRGBColor({209,241,255}) // BLUE 018 AADD(aColor, BD_ICEBLUE) // GraMakeRGBColor({209,253,255}) // BLUE 019 AADD(aColor, BD_TLCLIGHTBLUE) // GraMakeRGBColor({198,255,255}) // BLUE 020 AADD(aColor, BD_WISPBLUE) // GraMakeRGBColor({221,226,255}) // BLUE 021 AADD(aColor, BD_BLUEHINT) // GraMakeRGBColor({208,216,255}) // BLUE 022 AADD(aColor, BD_LIGHTSTEELBLUE) // GraMakeRGBColor({202,225,255}) // BLUE 023 AADD(aColor, BD_ROCKGREY) // GraMakeRGBColor({185,211,238}) // GREY 024 AADD(aColor, BD_CLEARBLUE) // GraMakeRGBColor({156,210,255}) // BLUE 025 AADD(aColor, BD_BLUESTEEL) // GraMakeRGBColor({117,186,229}) // BLUE 026 AADD(aColor, BD_CORNFLOWERBLUE) // GraMakeRGBColor({100,149,237}) // BLUE 027 AADD(aColor, BD_TLCDARKBLUE) // GraMakeRGBColor({075,116,171}) // BLUE 028### AADD(aColor, BD_TURQUOISE) // GraMakeRGBColor({064,244,208}) // BLUE 029 AADD(aColor, BD_TLCBLUE) // GraMakeRGBColor({075,268,200}) // BLUE 030 AADD(aColor, BD_TEAL) // GraMakeRGBColor({014,255,212}) // TEAL 031 AADD(aColor, BD_AQUAMARINE) // GraMakeRGBColor({000,255,232}) // BLUE 032 AADD(aColor, BD_XBP_CYAN) // 6 // CYAN 033 AADD(aColor, BD_LIGHTBLUE) // GraMakeRGBColor({014,240,255}) // BLUE 034 AADD(aColor, BD_ICEGREEN) // GraMakeRGBColor({222,255,189}) // GREEN 035 AADD(aColor, BD_GREENFROSTING) // GraMakeRGBColor({217,255,179}) // GREEN 036 AADD(aColor, BD_GREENHINT) // GraMakeRGBColor({204,255,191}) // GREEN 037 AADD(aColor, BD_PALETEAL) // GraMakeRGBColor({188,255,211}) // TEAL 038 AADD(aColor, BD_LIGHTTEAL) // GraMakeRGBColor({165,255,210}) // TEAL 039 AADD(aColor, BD_SEAFOAM) // GraMakeRGBColor({135,255,169}) // OTHER 040 AADD(aColor, BD_PALEGREEN) // GraMakeRGBColor({118,255,171}) // GREEN 041 AADD(aColor, BD_LEDGER) // GraMakeRGBColor({152,255,153}) // GREEN 042 AADD(aColor, BD_COLDGREEN) // GraMakeRGBColor({175,255,127}) // GREEN 043 AADD(aColor, BD_WISPGREEN) // GraMakeRGBColor({175,255,118}) // GREEN 044 AADD(aColor, BD_ISLANDGREEN) // GraMakeRGBColor({135,255,101}) // GREEN 045 AADD(aColor, BD_PASTELGREEN) // GraMakeRGBColor({135,255,000}) // GREEN 046 AADD(aColor, BD_LAWNGREEN) // GraMakeRGBColor({124,252,000}) // GREEN 047 AADD(aColor, BD_RICHGREEN) // GraMakeRGBColor({151,246,096}) // GREEN 048 AADD(aColor, BD_XBP_GREEN) // 5 // GREEN 049### AADD(aColor, BD_LIGHTGREEN) // GraMakeRGBColor({054,255,134}) // GREEN 050 AADD(aColor, BD_FADEDTEAL) // GraMakeRGBColor({103,214,171}) // TEAL 051 AADD(aColor, BD_BLUEGREY) // GraMakeRGBColor({135,183,169}) // BLUE 052 AADD(aColor, BD_LIGHTSEAGREEN) // GraMakeRGBColor({032,178,170}) // GREEN 053 AADD(aColor, BD_XBP_DARKCYAN) // 13 // CYAN 054### AADD(aColor, BD_CLEARGREEN) // GraMakeRGBColor({171,212,159}) // GREEN 055 AADD(aColor, BD_EARTHGREEN) // GraMakeRGBColor({153,173,092}) // GREEN 056 AADD(aColor, BD_MUDGREEN) // GraMakeRGBColor({153,173,000}) // GREEN 057### AADD(aColor, BD_LEAFYGREEN) // GraMakeRGBColor({129,153,040}) // GREEN 058 AADD(aColor, BD_MONEYLIGHTGREY) // GraMakeRGBColor({146,163,127}) // GREEN 059 AADD(aColor, BD_MONEYLIGHTGREEN) // GraMakeRGBColor({126,152,117}) // GREEN 060 AADD(aColor, BD_ASPARAGUS) // GraMakeRGBColor({123,160,091}) // OTHER 061 AADD(aColor, BD_DANKGREEN) // GraMakeRGBColor({077,123,084}) // GREEN 062 AADD(aColor, BD_MONEYGREENGREY) // GraMakeRGBColor({054,084,056}) // GREEN 063 AADD(aColor, BD_MONEYGREEN) // GraMakeRGBColor({024,050,021}) // GREEN 064### AADD(aColor, BD_CHARTREUSE) // GraMakeRGBColor({113,198,113}) // TEAL 065 AADD(aColor, BD_EMERALDGREEN) // GraMakeRGBColor({081,200,120}) // GREEN 066 AADD(aColor, BD_DEEPGREEN) // GraMakeRGBColor({054,194,114}) // GREEN 067 AADD(aColor, BD_FORESTGREEN) // GraMakeRGBColor({034,139,034}) // GREEN 068### AADD(aColor, BD_SEAGREEN) // GraMakeRGBColor({046,139,087}) // GREEN 069### AADD(aColor, BD_DARKGREEN) // GraMakeRGBColor({000,100,000}) // GREEN 070### AADD(aColor, BD_BISQUE) // GraMakeRGBColor({255,228,196}) // OTHER 071 AADD(aColor, BD_ANTIQUEWHITE) // GraMakeRGBColor({250,235,215}) // OTHER 072 AADD(aColor, BD_BONE) // GraMakeRGBColor({249,246,210}) // OTHER 073 AADD(aColor, BD_PEACH) // GraMakeRGBColor({255,230,188}) // OTHER 074 AADD(aColor, BD_PALEGOLDENROD) // GraMakeRGBColor({238,232,170}) // OTHER 075 AADD(aColor, BD_LIGHTGOLDENROD) // GraMakeRGBColor({238,221,130}) // OTHER 076 AADD(aColor, BD_BANANA) // GraMakeRGBColor({227,207,087}) // OTHER 077 AADD(aColor, BD_BURLYWOOD) // GraMakeRGBColor({222,184,135}) // OTHER 078 AADD(aColor, BD_PERU) // GraMakeRGBColor({205,133,063}) // OTHER 079 AADD(aColor, BD_COPPER) // GraMakeRGBColor({184,115,051}) // OTHER 080### AADD(aColor, BD_BROWN) // GraMakeRGBColor({150,075,000}) // OTHER 081### AADD(aColor, BD_MILKCHOCOLATE) // GraMakeRGBColor({112,046,000}) // OTHER 082### AADD(aColor, BD_AUBURN) // GraMakeRGBColor({113,047,044}) // OTHER 083 AADD(aColor, BD_CHOCOLATE) // GraMakeRGBColor({068,000,000}) // OTHER 084### AADD(aColor, BD_DARKWHEAT) // GraMakeRGBColor({205,186,150}) // OTHER 085 AADD(aColor, BD_DARKERWHEAT) // GraMakeRGBColor({194,182,133}) // OTHER 086 AADD(aColor, BD_LAZYGREEN) // GraMakeRGBColor({204,210,158}) // GREEN 087 AADD(aColor, BD_ECRU) // GraMakeRGBColor({178,188,121}) // OTHER 088 AADD(aColor, BD_FATIGUES) // GraMakeRGBColor({153,173,109}) // OTHER 089 AADD(aColor, BD_BRASS) // GraMakeRGBColor({181,166,066}) // OTHER 090 AADD(aColor, BD_GOLDENROD) // GraMakeRGBColor({218,165,032}) // OTHER 091 AADD(aColor, BD_DARKGOLDENROD) // GraMakeRGBColor({184,134,011}) // OTHER 092### AADD(aColor, BD_LIGHTCORAL) // GraMakeRGBColor({240,128,128}) // OTHER 093### AADD(aColor, BD_LIGHTSALMON) // GraMakeRGBColor({255,160,122}) // OTHER 094 AADD(aColor, BD_KHAKI) // GraMakeRGBColor({189,183,107}) // OTHER 095 AADD(aColor, BD_DARKKHAKI) // GraMakeRGBColor({197,185,115}) // OTHER 096 AADD(aColor, BD_CLOUD) // GraMakeRGBColor({245,245,240}) // OTHER 097 AADD(aColor, BD_IVORY) // GraMakeRGBColor({252,246,229}) // OTHER 098 AADD(aColor, BD_LINEN) // GraMakeRGBColor({253,240,230}) // OTHER 099 AADD(aColor, BD_LEMONCREME) // GraMakeRGBColor({255,250,205}) // OTHER 100 AADD(aColor, BD_CREME) // GraMakeRGBColor({249,246,189}) // TAN 101 AADD(aColor, BD_EGGSHELL) // GraMakeRGBColor({252,230,201}) // OTHER 102 AADD(aColor, BD_CORNSILK) // GraMakeRGBColor({238,232,205}) // OTHER 103 AADD(aColor, BD_SAND) // GraMakeRGBColor({232,228,216}) // OTHER 104 AADD(aColor, BD_KEYLIME) // GraMakeRGBColor({175,246,084}) // OTHER 105 AADD(aColor, BD_LIME) // GraMakeRGBColor({153,235,000}) // OTHER 106 AADD(aColor, BD_RICHLIME) // GraMakeRGBColor({087,255,000}) // OTHER 107 AADD(aColor, BD_MAGENTA) // GraMakeRGBColor({205,000,205}) // OTHER 108### AADD(aColor, BD_EGGPLANT) // GraMakeRGBColor({153,000,102}) // OTHER 109### AADD(aColor, BD_MAROON) // GraMakeRGBColor({139,028,098}) // OTHER 110 AADD(aColor, BD_MANGO) // GraMakeRGBColor({255,091,039}) // OTHER 111### AADD(aColor, BD_SANDYBROWN) // GraMakeRGBColor({244,164,096}) // OTHER 112### AADD(aColor, BD_SUNSET) // GraMakeRGBColor({245,160,014}) // OTHER 113 AADD(aColor, BD_MANGOCREME) // GraMakeRGBColor({255,129,063}) // OTHER 114 AADD(aColor, BD_SALMON) // GraMakeRGBColor({250,128,114}) // OTHER 115 AADD(aColor, BD_MISTYROSE) // GraMakeRGBColor({255,228,225}) // OTHER 116 AADD(aColor, BD_MOSS) // GraMakeRGBColor({200,201,001}) // OTHER 117 AADD(aColor, BD_OFFWHITE) // GraMakeRGBColor({255,255,235}) // OTHER 118 AADD(aColor, BD_PINKSAND) // GraMakeRGBColor({255,204,220}) // OTHER 119 AADD(aColor, BD_PINKROSE) // GraMakeRGBColor({255,184,255}) // OTHER 120 AADD(aColor, BD_ORCHID) // GraMakeRGBColor({218,112,214}) // OTHER 121 AADD(aColor, BD_FUSHIA) // GraMakeRGBColor({193,084,193}) // OTHER 122### AADD(aColor, BD_INDIGO) // GraMakeRGBColor({075,000,130}) // OTHER 123############# AADD(aColor, BD_PINEBARK) // GraMakeRGBColor({167,158,125}) // OTHER 124 AADD(aColor, BD_SANDSTONE) // GraMakeRGBColor({204,204,153}) // OTHER 125 AADD(aColor, BD_SANDYCORAL) // GraMakeRGBColor({214,213,189}) // OTHER 126 AADD(aColor, BD_JOURNALGREEN) // GraMakeRGBColor({220,232,210}) // GREEN 127 AADD(aColor, BD_SEASHELL) // GraMakeRGBColor({255,245,238}) // OTHER 128 AADD(aColor, BD_SNOW) // GraMakeRGBColor({255,250,255}) // OTHER 129 AADD(aColor, BD_WHEAT) // GraMakeRGBColor({245,222,179}) // OTHER 130 AADD(aColor, BD_PALEDESSERT) // GraMakeRGBColor({223,211,183}) // TAN 131 AADD(aColor, BD_LIGHTDESSERT) // GraMakeRGBColor({211,202,170}) // TAN 132 AADD(aColor, BD_DESSERT) // GraMakeRGBColor({211,202,183}) // TAN 133 AADD(aColor, BD_FADEDDESSERT) // GraMakeRGBColor({211,202,193}) // TAN 134 AADD(aColor, BD_XBP_PALEGRAY) // 15 // GREY 135 AADD(aColor, BD_SILVER) // GraMakeRGBColor({192,192,192}) // OTHER 136 AADD(aColor, BD_BRIGHTGREY) // GraMakeRGBColor({197,193,170}) // GREY 137 AADD(aColor, BD_GREY) // GraMakeRGBColor({188,188,176}) // GREY 138 AADD(aColor, BD_LIGHTGREY) // GraMakeRGBColor({230,231,232}) // GREY 139 AADD(aColor, BD_ICEGREY) // GraMakeRGBColor({236,242,234}) // GREY 140 AADD(aColor, BD_MICROSOFTGREY) // GraMakeRGBColor({224,223,227}) // GREY 141 AADD(aColor, BD_DEFAULTGREY) // GraMakeRGBColor({212,208,200}) // GREY 142 AADD(aColor, BD_WASHGREY) // GraMakeRGBColor({210,210,210}) // GREY 143 AADD(aColor, BD_SLATEGREY) // GraMakeRGBColor({158,182,205}) // GREY 144 AADD(aColor, BD_SILVERBLUE) // GraMakeRGBColor({131,156,165}) // OTHER 145 AADD(aColor, BD_GREYGREEN) // GraMakeRGBColor({153,173,174}) // GREY 146 AADD(aColor, BD_DARKGREY) // GraMakeRGBColor({090,091,080}) // GREY 147 AADD(aColor, BD_DULLGREY) // GraMakeRGBColor({087,091,090}) // GREY 148 AADD(aColor, BD_FRAMEGREY) // GraMakeRGBColor({148,148,148}) // GREY 149 AADD(aColor, BD_LINEGREY) // GraMakeRGBColor({128,128,128}) // GREY 150 AADD(aColor, BD_CREMESICLE) // GraMakeRGBColor({239,246,121}) // TAN 151 AADD(aColor, BD_FADEDGOLD) // GraMakeRGBColor({255,227,109}) // GOLD 152 AADD(aColor, BD_LIGHTGOLD) // GraMakeRGBColor({255,227,000}) // GOLD 153 AADD(aColor, BD_GOLD) // GraMakeRGBColor({255,217,000}) // GOLD 154 AADD(aColor, BD_TLCGOLD) // GraMakeRGBColor({255,197,000}) // GOLD 155 AADD(aColor, BD_ORANGE) // GraMakeRGBColor({255,160,000}) // ORANGE 156### AADD(aColor, BD_ORANGEPEEL) // GraMakeRGBColor({255,126,003}) // ORANGE 157### AADD(aColor, BD_BURNTORANGE) // GraMakeRGBColor({204,085,000}) // ORANGE 158### AADD(aColor, BD_LIGHTORANGE) // GraMakeRGBColor({255,180,000}) // ORANGE 159 AADD(aColor, BD_PALEORANGE) // GraMakeRGBColor({255,156,000}) // ORANGE 160 AADD(aColor, BD_TAN) // GraMakeRGBColor({244,226,171}) // TAN 161 AADD(aColor, BD_LIGHTTAN) // GraMakeRGBColor({244,225,199}) // TAN 162 AADD(aColor, BD_PALEYELLOW) // GraMakeRGBColor({255,255,210}) // YELLOW 163 AADD(aColor, BD_FLATYELLOW) // GraMakeRGBColor({255,255,193}) // YELLOW 164 AADD(aColor, BD_FADEDYELLOW) // GraMakeRGBColor({255,255,185}) // YELLOW 165 AADD(aColor, BD_HINTYELLOW) // GraMakeRGBColor({255,255,153}) // YELLOW 166 AADD(aColor, BD_LIGHTYELLOW) // GraMakeRGBColor({255,255,130}) // YELLOW 167 AADD(aColor, BD_YELLOW) // GraMakeRGBColor({255,229,053}) // YELLOW 168 AADD(aColor, BD_SUNNYYELLOW) // GraMakeRGBColor({255,255,000}) // YELLOW 169 AADD(aColor, BD_DEEPYELLOW) // GraMakeRGBColor({216,189,000}) // YELLOW 170 AADD(aColor, BD_DARKYELLOW) // GraMakeRGBColor({196,179,000}) // YELLOW 171 AADD(aColor, BD_OLIVEDRAB) // GraMakeRGBColor({142,142,056}) // GREEN 172 AADD(aColor, BD_XBP_BROWN) // 14 // TAN 173### AADD(aColor, BD_PINKCOTTON) // GraMakeRGBColor({255,215,255}) // PINK 174 AADD(aColor, BD_PUFFINK) // GraMakeRGBColor({241,185,213}) // PINK 175 AADD(aColor, BD_PALEPURPLE) // GraMakeRGBColor({231,160,226}) // PURPLE 176 AADD(aColor, BD_LIGHTPURPLE) // GraMakeRGBColor({210,152,206}) // PURPLE 177 AADD(aColor, BD_FUCHSIA) // GraMakeRGBColor({229,070,183}) // PINK 178 AADD(aColor, BD_HOTPINK) // GraMakeRGBColor({229,070,129}) // PINK 179### AADD(aColor, BD_XBP_PINK) // 4 // PINK 180### AADD(aColor, BD_XBP_DARKPINK) // 11 // PINK 181### AADD(aColor, BD_REDHINT) // GraMakeRGBColor({255,213,231}) // RED 182 AADD(aColor, BD_LAZYPURPLE) // GraMakeRGBColor({248,201,245}) // PURPLE 183 AADD(aColor, BD_WISPRED) // GraMakeRGBColor({239,195,228}) // RED 184 AADD(aColor, BD_FADEDPURPLE) // GraMakeRGBColor({241,187,241}) // PURPLE 185 AADD(aColor, BD_COTTONCANDYRED) // GraMakeRGBColor({255,147,156}) // RED 186 AADD(aColor, BD_PALERED) // GraMakeRGBColor({255,147,156}) // RED 187 AADD(aColor, BD_DEEPRED) // GraMakeRGBColor({229,070,097}) // RED 188 AADD(aColor, BD_RED) // 3 // RED 189 AADD(aColor, BD_CANDYRED) // GraMakeRGBColor({255,000,000}) // RED 190### AADD(aColor, BD_LIGHTRED) // GraMakeRGBColor({255,050,039}) // RED 191### AADD(aColor, BD_DARKRED) // GraMakeRGBColor({168,000,000}) // RED 192 AADD(aColor, BD_CRIMSON) // GraMakeRGBColor({220,020,060}) // RED 193### AADD(aColor, BD_INDIANRED) // GraMakeRGBColor({176,023,031}) // RED 194### AADD(aColor, BD_LAVENDER) // GraMakeRGBColor({230,230,250}) // OTHER 195 AADD(aColor, BD_PURPLEHINT) // GraMakeRGBColor({207,211,255}) // PURPLE 196 AADD(aColor, BD_COOLPURPLE) // GraMakeRGBColor({209,198,255}) // PURPLE 197 AADD(aColor, BD_PURPLE) // GraMakeRGBColor({188,151,255}) // PURPLE 198 AADD(aColor, BD_GRAPE) // GraMakeRGBColor({135,116,169}) // OTHER 199 AADD(aColor, BD_SLATEBLUE) // GraMakeRGBColor({113,113,198}) // BLUE 200 AADD(aColor, BD_FLATPURPLE) // GraMakeRGBColor({135,097,169}) // PURPLE 201 AADD(aColor, BD_AMETHYST) // GraMakeRGBColor({153,102,204}) // OTHER 202 AADD(aColor, BD_SIENNA) // GraMakeRGBColor({160,082,452}) // OTHER 203 AADD(aColor, BD_BLUEVIOLET) // GraMakeRGBColor({138,043,226}) // BLUE 204### AADD(aColor, BD_BRIGHTPURPLE) // GraMakeRGBColor({112,046,253}) // PURPLE 205### AADD(aColor, BD_DEEPPURPLE) // GraMakeRGBColor({117,007,229}) // PURPLE 206### AADD(aColor, BD_BEET) // GraMakeRGBColor({142,056,142}) // PURPLE 207 AADD(aColor, BD_TINTEDPURPLE) // GraMakeRGBColor({112,045,107}) // PURPLE 208 AADD(aColor, BD_RICHPURPLE) // GraMakeRGBColor({168,045,119}) // PURPLE 209### AADD(aColor, BD_OUTLOOKBUTT) // GraMakeRGBColor({236,233,216}) // OTHER 210 AADD(aColor, BD_OUTLOOKBGD) // GraMakeRGBColor({227,239,255}) // OTHER 211 AADD(aColor, BD_OUTLOOKRIBDARK) // GraMakeRGBColor({166,188,217}) // OTHER 212 AADD(aColor, BD_OUTLOOKRIBLIGHT) // GraMakeRGBColor({191,219,255}) // OTHER 213 AADD(aColor, BD_OUTLOOKMARGIN) // GraMakeRGBColor({101,147,207}) // OTHER 214 AADD(aColor, BD_SMSBGD) // GraMakeRGBColor({197,231,183}) // OTHER 215 AADD(aColor, BD_SMSRIBDARK) // GraMakeRGBColor({103,195,071}) // OTHER 216### AADD(aColor, BD_SMSRIBLIGHT) // GraMakeRGBColor({174,224,159}) // OTHER 217 AADD(aColor, BD_SMSRIBMARGIN) // GraMakeRGBColor({062,147,104}) // OTHER 218### AADD(aColor, BD_TRUE) // -4 // AAA 219 AADD(aColor, BD_WHITE) // 0 // AAA 220 AADD(aColor, BD_BACKGROUND) // -2 // AAA 221 AADD(aColor, BD_BLACK) // 1 // AAA 222############# AADD(aColor, BD_NEUTRAL) // -1 // AAA 223 AADD(aColor, BD_FALSE) // -5 // AAA 224 PUBLIC aColIndex := {} // Цвета, используемые для построения графиков AADD(aColIndex, 9) // GraMakeRGBColor({000,127,255}) // BLUE 009### AADD(aColIndex, 12) // GraMakeRGBColor({000,000,255}) // BLUE 012### AADD(aColIndex, 49) // 5 // GREEN 049### AADD(aColIndex, 54) // 13 // CYAN 054### AADD(aColIndex, 57) // GraMakeRGBColor({153,173,000}) // GREEN 057### AADD(aColIndex, 70) // GraMakeRGBColor({000,100,000}) // GREEN 070### AADD(aColIndex, 81) // GraMakeRGBColor({150,075,000}) // OTHER 081### AADD(aColIndex, 93) // GraMakeRGBColor({240,128,128}) // OTHER 093### AADD(aColIndex, 108) // GraMakeRGBColor({205,000,205}) // OTHER 108### AADD(aColIndex, 109) // GraMakeRGBColor({153,000,102}) // OTHER 109### AADD(aColIndex, 111) // GraMakeRGBColor({255,091,039}) // OTHER 111### AADD(aColIndex, 112) // GraMakeRGBColor({244,164,096}) // OTHER 112### AADD(aColIndex, 122) // GraMakeRGBColor({193,084,193}) // OTHER 122### AADD(aColIndex, 156) // GraMakeRGBColor({255,160,000}) // ORANGE 156### AADD(aColIndex, 157) // GraMakeRGBColor({255,126,003}) // ORANGE 157### AADD(aColIndex, 158) // GraMakeRGBColor({204,085,000}) // ORANGE 158### AADD(aColIndex, 173) // 14 // TAN 173### AADD(aColIndex, 179) // GraMakeRGBColor({229,070,129}) // PINK 179### AADD(aColIndex, 180) // 4 // PINK 180### AADD(aColIndex, 190) // GraMakeRGBColor({255,000,000}) // RED 190### AADD(aColIndex, 191) // GraMakeRGBColor({255,050,039}) // RED 191### AADD(aColIndex, 194) // GraMakeRGBColor({176,023,031}) // RED 194### AADD(aColIndex, 206) // GraMakeRGBColor({117,007,229}) // PURPLE 206### AADD(aColIndex, 216) // GraMakeRGBColor({103,195,071}) // OTHER 216### AADD(aColIndex, 218) // GraMakeRGBColor({062,147,104}) // OTHER 218### AADD(aColor, BD_BLACK) // 1 // AAA 222############# ***** Рекогносцировка ************************************************ CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций PUBLIC Disk_name := DISKNAME() PUBLIC Cur_dir := CURDIR() PUBLIC Disk_dir := Disk_name+":\"+Cur_dir // Путь на папку с системой * InstallFonts() // Установка шрифтов, независимых от Windows * MsgBox('Шрифты установлены!') * DC_Impl(oScrTime);oScrTime := DC_WaitOn('Метка-4: '+SubStr( Time()-cTime1, 1, 2)+':'+SubStr( Time()-cTime1, 4, 2)+':'+SubStr( Time()-cTime1, 7, 2),,,,,,,,,,,.F.) IF mCorrLaunch = 'ON' *************************************************************************************************************** ***** Если путь на папку с системой содержит русские символы (кириллицу) или пробел, то выдать сообщение и завершить работу ***** Допустимы только символы с кодами: 48-57, 65-90, 97-122, а также символы: -_:\ mFlagErr = .F. mFlag32 = .F. mCharErr = '' FOR j=1 TO 255 DO CASE CASE 48 <= j .AND. j <= 57 // Цифры: 0-9 CASE 65 <= j .AND. j <= 90 // Заглавные латинские буквы: A-Z CASE 97 <= j .AND. j <= 122 // Строчные латинские буквы: a-z CASE j = 45 .OR. j = 95 .OR. j = 58 .OR. j = 92 // -_:\ OTHERWISE IF AT(CHR(j), Disk_dir) > 0 mFlagErr = .T. mCharErr = mCharErr + CHR(j) // Недопустимые символы ENDIF ENDCASE NEXT IF mFlagErr aMess := {} AADD(aMess, L('Система запущена в папке: "'+ConvToOemCP(ALLTRIM(Disk_dir))+'\"' )) AADD(aMess, L('Путь на папку с системой содержит недопустимые символы (они приведены между линиями):')) AADD(aMess, REPLICATE('-',135)) AADD(aMess, ConvToOemCP(mCharErr)) AADD(aMess, REPLICATE('-',135)) AADD(aMess, IF(AT(' ', Disk_dir) > 0,L(', а также символ: "пробел".'),'')) AADD(aMess, L('Для нормальной работы системы необходимо, чтобы путь на папку с системой был допустимым для' )) AADD(aMess, L('DOS и UNIX: не содержал недопустимых символов: "+=[]:;,./\?*<>|", пробела и кириллицы. ' )) AADD(aMess, L('Желательно разархивировать ее в корневом каталоге любого диска, например: "d:\Aidos-X\". ' )) AADD(aMess, L('Нельзя запускать исполнимый модуль: "_aidos-x.exe" в одной папке несколько раз, т.к. это ' )) AADD(aMess, L('вызывает конфликт обращения к базам данных, занятых исполнимым модулем, запущенным ранее. ' )) AADD(aMess, L('Папка, в которой запущена система, должна быть доступна на запись, т.к. система модифирует ' )) AADD(aMess, L('свои файлы и базы данных. Настройки политик безопасности MS Windows должны быть установлены' )) AADD(aMess, L('на "слабые", т.к. система "Эйдос" для ускорения работы обращается к файлам без API Windows,' )) AADD(aMess, L('а Windows расценивает это как угрозу безопасности' )) DC_Impl(oScr) LB_Warning(aMess, L('(C) Система "Эйдос"')) ADS_SERVER_QUIT() QUIT ENDIF ***** Если путь на папку с системой содержит русские символы или пробел, то выдать сообщение и завершить работу *************************************************************************************************************** *************************************************************************************************************** ***** Если похоже, что система запущена из архива (в диск Disk_dir есть c:\Users\1\AppData\Local\Temp\_tc\), ***** то выдать сообщение и завершить работу IF AT('Users' , Disk_dir) > 0 .AND. ; AT('AppData', Disk_dir) > 0 .OR. ; AT('Local' , Disk_dir) > 0 .OR. ; AT('Temp' , Disk_dir) > 0 .OR. ; AT('_tc' , Disk_dir) > 0 aMess := {} AADD(aMess, L('Система запущена в папке: "')+ConvToOemCP(ALLTRIM(Disk_dir))+'\"' ) AADD(aMess, L(' ')) AADD(aMess, L('Вид пути на папку с системой позволяет предположить, что система запущена из архива.' )) AADD(aMess, L('Если это действительно так, то ряд функций системы не будет реализоваться в полном объеме.' )) AADD(aMess, L('Для нормальной работы системы необходимо, чтобы путь на папку с системой был допустимым для' )) AADD(aMess, L('DOS и UNIX: не содержал недопустимых символов: "+=[]:;,./\?*<>|", пробела и русских букв.' )) AADD(aMess, L('Желательно разархивировать ее в корневом каталоге любого диска, например: "d:\Aidos-X\". ' )) AADD(aMess, L('Нельзя запускать исполнимый модуль: "_aidos-x.exe" в одной папке несколько раз, т.к. это ' )) AADD(aMess, L('вызывает конфликт обращения к базам данных, занятых исполнимым модулем, запущенным ранее. ' )) AADD(aMess, L('Папка, в которой запущена система, должна быть доступна на запись, т.к. система модифирует ' )) AADD(aMess, L('свои файлы и базы данных. Настройки политик безопасности MS Windows должны быть установлены' )) AADD(aMess, L('на "слабые", т.к. система "Эйдос" для ускорения работы обращается к файлам без API Windows,' )) AADD(aMess, L('а Windows расценивает это как угрозу безопасности' )) DC_Impl(oScr) LB_Warning(aMess, L('(C) Система "Эйдос"')) ADS_SERVER_QUIT() QUIT ENDIF ***** Если похоже, что система запущена из архива, то выдать сообщение и завершить работу *************************************************************************************************************** *************************************************************************************************************** ***** Если похоже, что система запущена в папке загрузки (в диск Disk_dir есть c:\Users\1\Downloads ), ***** или на работчем столе (в диск Disk_dir есть c:\Users\1\Desktop, то выдать сообщение и завершить работу IF AT('Users' , Disk_dir) > 0 .AND. ; AT('Downloads', Disk_dir) > 0 .OR. ; AT('Desktop' , Disk_dir) > 0 .OR. ; AT('Загрузки' , Disk_dir) > 0 aMess := {} AADD(aMess, L('Система запущена в папке: "')+ConvToOemCP(ALLTRIM(Disk_dir))+'\"' ) AADD(aMess, ' ') AADD(aMess, L('Вид пути на папку с системой позволяет предположить, что она запущена из папки загрузки или' )) AADD(aMess, L('с рабочего стола. Если это так, то ряд функций системы могут реализоваться не в полном объеме.')) AADD(aMess, L('Для нормальной работы системы необходимо, чтобы путь на папку с системой был допустимым для' )) AADD(aMess, L('DOS и UNIX: не содержал недопустимых символов: "+=[]:;,./\?*<>|", пробела и русских букв.' )) AADD(aMess, L('Желательно разархивировать ее в корневом каталоге любого диска, например: "d:\Aidos-X\". ' )) AADD(aMess, L('Нельзя запускать исполнимый модуль: "_aidos-x.exe" в одной папке несколько раз, т.к. это ' )) AADD(aMess, L('вызывает конфликт обращения к базам данных, занятых исполнимым модулем, запущенным ранее. ' )) AADD(aMess, L('Папка, в которой запущена система, должна быть доступна на запись, т.к. система модифирует ' )) AADD(aMess, L('свои файлы и базы данных. Настройки политик безопасности MS Windows должны быть установлены' )) AADD(aMess, L('на "слабые", т.к. система "Эйдос" для ускорения работы обращается к файлам без API Windows,' )) AADD(aMess, L('а Windows расценивает это как угрозу безопасности' )) DC_Impl(oScr) LB_Warning(aMess, '(C) Система "Эйдос"') ADS_SERVER_QUIT() QUIT ENDIF ***** Если похоже, что система запущена из архива, то выдать сообщение и завершить работу *************************************************************************************************************** ****************************************************************************************************************************** ** Запуск procexp.exe, если он есть (вместо диспетчера задач, т.к. он может быть заблокирован, да и вообще хорошая вещь от MS) ** Проверять контрольную сумму, если есть файл с контрольной суммой, или делать файл с контрольной суммой, если его нет RunShell('/C c:\Windows\System32\TaskList.exe /V /FO CSV > TaskList.csv',,.F.,.T.) // .F. - чтобы программа не продожалась дальше, пока не закончится перевод aTaskList := {} // Все программы, запущенные на компьютере nHandle := DC_txtOpen( 'TaskList.csv' ) DO WHILE !DC_TxtEOF( nHandle ) // Начало цикла по строкам mLine = DC_TxtLine( nHandle ) // Выделить строку из текстового файла mPosExe = AT('.exe', mLine) IF mPosExe > 0 mPos = AT('","', mLine) mModName = SUBSTR(mLine,2,mPos-2) * MsgBox(ConvToOemCP(mLine)) * MsgBox(mModName) * IF ASCAN(aTaskList, mModName) = 0 // Каждая программа запоминается только один раз AADD (aTaskList, mModName) * ENDIF ENDIF DC_TxtSkip( nHandle, 1 ) ENDDO DC_TxtClose( nHandle ) * DC_Impl(oScr) * LB_Warning(aTaskList, '(C°) Система "Эйдос-Х++"') mFlagprocexp64 = .F. // Программа procexp64.exe не запущена IF ASCAN(aTaskList, 'procexp64.exe') > 0 // Каждая программа запоминается только один раз mFlagprocexp64 = .T. // Программа procexp64.exe запущена ENDIF cFile = 'procexp.exe' IF FILE(cFile) IF .NOT. FILE('_CheckSumProcExp.txt') // Если файла с контрольной суммой нет, то создать его StrFile(ALLTRIM(STR(FILECHECK(cFile))), '_CheckSumProcExp.txt') ELSE // Если файл с контрольной суммой есть, то проверить его совпадение и выдать сообщение, если он отличается mCheckSum = VAL(FileStr('_CheckSumProcExp.txt')) IF FILECHECK(cFile) = mCheckSum * IF .NOT. DC_IsAppRunning('XbpDialog', '(C) Система "Эйдос"', 'procexp64.exe',.T.) // Запускать procexp.exe только один раз IF .NOT. mFlagprocexp64 // Если программа procexp64.exe не запущена, то запустить ее RunShell("/t", "procexp.exe", .T.) // Спасибо Вольфгангу Цирику ENDIF ELSE aMess := {} AADD(aMess, L('EXE-модуль утилиты MS Process Explorer несанкционированно изменен,')) AADD(aMess, L('Поэтому ее работоспособность не гарантируется и она не запущена !!')) DC_Impl(oScr) LB_Warning(aMess,'(С°) "Эйдос-Х++"') ENDIF ENDIF ENDIF * WTF ****************************************************************************************************************************** ENDIF *************************************************************************************************************** ***** Если система Эйдос уже запущена в данной папке выдать сообщение об этом и выйти PUBLIC M_ApplsPath := ALLTRIM(Disk_dir)+"\AID_DATA" IF .NOT. FILE("PathGrAp.dbf") // запуск системы Эйдос <<<===################################################ GenDbfPaths() ELSE IF .NOT. FILE("Path_kod.ntx").OR.; .NOT. FILE("PathDefa.ntx").OR.; .NOT. FILE("PathName.ntx").OR.; .NOT. FILE("PathCrea.ntx") GenNtxPaths() ENDIF * USE PathGrAp INDEX Path_kod, PathDefa, PathName, PathCrea EXCLUSIVE NEW * * 1 2 3 4 aMess := {} AADD(aMess, L('Это окно появилось потому, что система "Эйдос" уже запущена в папке: "'+ConvToOemCP(ALLTRIM(Disk_dir))+'\", а вы' )) AADD(aMess, L('попытались запустить систему повторно, наверное не дождавшись появления стартового окна.' )) AADD(aMess, L('')) AADD(aMess, L('НЕЛЬЗЯ запускать исполнимый модуль системы: "_aidos-x.exe" в одной папке несколько раз, т.к. система будет пытаться' )) AADD(aMess, L('одновременно обращаться к одним и тем же базам данных, что вызывает конфликт. Но в других папках это вполне возможно.')) AADD(aMess, L('')) AADD(aMess, L('По этой же причине в системе "Эйдос" НЕЛЬЗЯ запускать и несколько режимов из главного меню одновременно, т.е. сначала')) AADD(aMess, L('надо завершить работу (закрыть) ранее запущенный из главного меню режим и только уже после этого запускать новый.' )) AADD(aMess, L('')) AADD(aMess, L('Процесс запуска системы "Эйдос" довольно ДЛИТЕЛЬНЫЙ, т.к. при этом выполняется много разных проверок корректности ' )) AADD(aMess, L('места запуска системы:' )) AADD(aMess, L('- запущена ли система в папке загрузки;' )) AADD(aMess, L('- запущена ли система в папке на рабочем столе;' )) AADD(aMess, L('- запущена ли система в скачанном архиве, в котором она находится;' )) AADD(aMess, L('- есть ли в полном пути на исполнимый модуль системы "__aidos-x.exe" пробелы и кириллица.' )) AADD(aMess, L('')) AADD(aMess, L('Кроме того при запуске системы "Эйдос" определяются все запущенные на этот момент приложения и после ее запуска' )) AADD(aMess, L('закрывается браузер, открывающийся при обращении системы к своему FTP-серверу, если он до этого не был открыт.' )) AADD(aMess, L('Если же он был открыт, то запускается сайт проф.Е.В.Луценко: http://lc.kubagro.ru/.' )) AADD(aMess, L('')) AADD(aMess, L('При запуске системы "Эйдос" запускается также "procexp.exe" (Process Explorer v16.43: http://www.sysinternals.com/).' )) AADD(aMess, L('Process Explorer представляет собой программу, функционально полностью эквивалентную диспетчеру задач. Он запускается')) AADD(aMess, L('потому, что на многих компьютерах, на которых используется система "Эйдос", стандартный диспетчер задач заблокирован.')) AADD(aMess, L('Process Explorer также запускается довольно долго. Система "Эйдос" запускает его только если он еще не был запущен.' )) bError := ErrorBlock( {|e| Break(e)} ) // установить новый кодовый блок обработки ошибок. Если система Эйдос уже запущена в текущей папке, то возникает ошибка открытия БД BEGIN SEQUENCE *** Попытка запуска системы Эйдос ***************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE PathGrAp SHARED NEW // Если система Эйдос уже запущена в текущей папке, то возникает ошибка открытия БД <<<===################################################ IF Neterr() DC_Impl(oScr) LB_Warning(aMess, L('(C) Система "Эйдос"')) ADS_SERVER_QUIT() QUIT ENDIF *************************************************************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE PathGrAp EXCLUSIVE NEW // Если система Эйдос уже запущена в текущей папке, то возникает ошибка открытия БД <<<===################################################ DBGOTOP() DO WHILE .NOT. EOF() IF LEN(ALLTRIM(By_default)) > 0 REPLACE By_default WITH "W" M_ApplsPath = UPPER(ALLTRIM(PathGrApps)) * MsgBox(M_ApplsPath) EXIT ENDIF DBSKIP(1) ENDDO ****** При запуске системы проверить, существует ли база приложений Appls.dbf, ****** и, если существует, найти текущее приложение и присвоить глобальным переменным ****** значения пути на него и его имени, а если не существует, то создать ****** и записать в виде файлов в текщей папке с исполнимым модулем системы PUBLIC M_PathAppl := "", M_NameAppl := "" IF .NOT. FILE("Appls.dbf") GenDbfAppls() ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Appls EXCLUSIVE NEW // Если система Эйдос уже запущена в текущей папке, то возникает ошибка открытия БД <<<===################################################ SELECT Appls DBGOTOP() DO WHILE .NOT. EOF() IF LEN(ALLTRIM(By_default)) > 0 REPLACE By_default WITH "W" M_PathAppl = ALLTRIM(Path_Appl) // Путь на текущее приложение M_NameAppl = ALLTRIM(Name_Appl) EXIT ENDIF DBSKIP(1) ENDDO RECOVER // Система Эйдос уже запущена в этой папке ********************* * EXIT // код обработки ошибок. Если система Эйдос уже запущена в данной папке выдать сообщение об этом и выйти DC_Impl(oScr) LB_Warning(aMess, L('(C) Система "Эйдос"')) ADS_SERVER_QUIT() QUIT ENDSEQUENCE ErrorBlock( bError ) // переустановить старый кодовый ENDIF ***** Если система Эйдос уже запущена в данной папке выдать сообщение об этом и выйти *************************************************************************************************************** * DC_Impl(oScrTime);oScrTime := DC_WaitOn('Метка-5: '+SubStr( Time()-cTime1, 1, 2)+':'+SubStr( Time()-cTime1, 4, 2)+':'+SubStr( Time()-cTime1, 7, 2),,,,,,,,,,,.F.) // Путь на папку с приложениями, можно сетевую или в Internet, // считывать сразу при запуске системы, а если его нет, // то создать папку БД приложений БД путей по умолчанию. Папка с группой приложений AID_DATA: // В последующем СисАдмин может в режиме 1.5 поменять путь на папку с текущей группой приложений когда угодно DIRCHANGE(Disk_dir) // Папка с исполнимым модулем системы Эйдос **************************************** IF FILE("cygwin\bin\Print_receipt.prg") ERASE("cygwin\bin\Print_receipt.prg") ENDIF IF FILE("cygwin\bin\Translator.prg") ERASE("cygwin\bin\Translator.prg") ENDIF **************************************** IF FILEDATE("AID_DATA",16) = CTOD("//") DIRMAKE("AID_DATA") ENDIF DIRCHANGE("AID_DATA") // Перейти в папку со всеми БД: AID_DATA // Создание ВСЕХ папок внутри Aid_data IF FILEDATE("Inp_data",16) = CTOD("//") DIRMAKE("Inp_data") ENDIF IF FILEDATE("Inp_rasp",16) = CTOD("//") DIRMAKE("Inp_rasp") ENDIF IF FILEDATE("OldAppls",16) = CTOD("//") DIRMAKE("OldAppls") ENDIF IF FILEDATE("BackGround",16) = CTOD("//") DIRMAKE("BackGround") // Скачать по FTP с моего сайта и записать в эту папку фоны главного меню ENDIF IF FILEDATE("BackGround2",16) = CTOD("//") DIRMAKE("BackGround2") // Скачать по FTP с моего сайта и записать в эту папку фоны главного меню ENDIF IF FILEDATE("Screenshots",16) = CTOD("//") DIRMAKE("Screenshots") ENDIF IF FILEDATE("LabWorks",16) = CTOD("//") DIRMAKE("LabWorks") Mess = L('В папке с БД приложений "AID_DATA" не было папки "LabWorks" для исходных БД лабораторных работ. Обратитесь за ними к разработчику!') DC_Impl(oScr) LB_Warning(Mess, L("1.3. Установка лабораторных работ" )) ENDIF DIRCHANGE("LabWorks") // Перейти в папку с исходными БД лабораторных работ FOR j=1 TO 30 M_Name = "LabW"+STRTRAN(STR(j,4)," ","0") IF FILEDATE("M_Name",16) = CTOD("//") DIRMAKE(M_Name) ENDIF NEXT DIRCHANGE(Disk_dir) *** При запуске программы: подготовка фонов главного окна для отображения ****** aBitmaps1 := Directory(Disk_dir+'\Aid_data\BackGround\*.jpg') aBitmaps2 := Directory(Disk_dir+'\Aid_data\BackGround2\*.jpg') IF LEN(aBitmaps2) > 0 FOR j=1 TO LEN(aBitmaps2) ERASE(Disk_dir+'\Aid_data\BackGround2\'+aBitmaps2[j, F_NAME]) NEXT ENDIF IF LEN(aBitmaps1) > 0 FOR j=1 TO LEN(aBitmaps1) COPY FILE (Disk_dir+'\Aid_data\BackGround\'+aBitmaps1[j, F_NAME]) TO (Disk_dir+'\Aid_data\BackGround2\'+aBitmaps1[j, F_NAME]) NEXT ENDIF ** Если БД пользователей существует, то можно попытаться авторизоваться сразу, до запуска главного меню. ** Если это получится, то можно запустить меню с цветовой схемой данного пользователя, ** а иначе - с цветовой схемой по умолчанию Cf1 = 000;Cf2 = 000;Cf3 = 000;Cb1 = 025;Cb2 = 255;Cb3 = 204 IF FILE("Users.dbf") // БД администраторов приложений и паролей доступа к ним: Users.dbf IF mCorrLaunch = 'ON' DC_Impl(oScr) ENDIF M_KodAdmAppls = F1_1() // Запуск первого окна CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Users INDEX Use_kod EXCLUSIVE NEW SET ORDER TO 1;T=DBSEEK(STR(M_KodAdmAppls,8)) IF T * 000 000 000 025 255 204 * 12345678901234567890123 * 1 5 9 13 17 21 Cf1 = VAL(SUBSTR(ColorSchem, 1,3)) Cf2 = VAL(SUBSTR(ColorSchem, 5,3)) Cf3 = VAL(SUBSTR(ColorSchem, 9,3)) Cb1 = VAL(SUBSTR(ColorSchem,13,3)) Cb2 = VAL(SUBSTR(ColorSchem,17,3)) Cb3 = VAL(SUBSTR(ColorSchem,21,3)) ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций ELSE GenDbfUsers() ENDIF * DC_Impl(oScrTime);oScrTime := DC_WaitOn('Метка-6: '+SubStr( Time()-cTime1, 1, 2)+':'+SubStr( Time()-cTime1, 4, 2)+':'+SubStr( Time()-cTime1, 7, 2),,,,,,,,,,,.F.) * oScr := DC_WaitOn(L('Идет загрузка объединенного модуля "__AIDOS-PY.exe" пайтон-функций системы "Эйдос". Немного подождите!'),,,,,,,,,,,.F.) // Программа запускается в фоновом режиме (асинхронно, резидентно) и на заднем плане и ход основной программы продолжается * LC_RunShellTT("__AIDOS-PY.exe",717400306) // Мой вариант реализации функций в одном модуле на Питоне. * DC_Impl(oScr) ********************************************************************************************************************* // Отметка в базе данных test_strings.txt на сайте: http://lc.kubagro.ru реквизитов посетителя // и переход (редирект) на основной сайт: http://lc.kubagro.ru ЕСЛИ ЕСТЬ INTERNET* ********************************************************************************************************************* n=0 IF .NOT. InternetGetConnectedState( @n, 0 ) == 0 * MsgBox('==='+OSVER()+'===') DO CASE CASE OSVER() = ' 6. 1' // Windows 7 * ShellOpenFile( 'http://lc.kubagro.ru/index_aidos.php' ) // Решение от Regan Cawkwell DC_SpawnURL( 'http://lc.kubagro.ru/index_aidos.php', .T., .T. ) // Решение Роджера. Hаботает под Windows 7, но не работает под Windows 10 aMess := {} AADD(aMess, L('Вы запустили систему "Эйдос" на компьютере с MS Windows 7!!!' )) AADD(aMess, L('С 2023 года система "Эйдос" развивается на языке Питон 3.12.' )) AADD(aMess, L('Поэтому новые режимы, сделанные на Питоне могут не работать.' )) AADD(aMess, L('Для режимов на Питоне нужна MS Windows 10 или выше. ' )) LB_Warning(aMess, L('(C°) Система "Эйдос"')) CASE OSVER() = ' 6. 2' // Windows 10 * MsgBox(OSVER()) * Использование маленькой программы на Питоне url_py.exe для обращения к по Internet-адресу, находящемуся в файле: url_py.txt или в буфере обмена * StrFile('http://lc.kubagro.ru/index_aidos.php', 'url_py.txt') * LC_RunShell("__url_py.exe", 1061128944, "url_py") // Мой вариант на Питоне в системе __AIDOS-PY.exe LC_RunUrl('http://lc.kubagro.ru/index_aidos.php') OTHERWISE // Windows 11 и т.д. * StrFile('http://lc.kubagro.ru/index_aidos.php', 'url_py.txt') * LC_RunShell("__url_py.exe", 1061128944, "url_py") // Мой вариант на Питоне в системе __AIDOS-PY.exe LC_RunUrl('http://lc.kubagro.ru/index_aidos.php') ENDCASE IF mCorrLaunch = 'ON' RunShell('/C c:\Windows\System32\TaskList.exe /V /FO CSV > TaskList1.csv',,.F.,.T.) // .F. - чтобы программа не продожалась дальше, пока не закончится перевод ****** Обработка ошибки ****************** * bError := ErrorBlock( {|e| Break(e)} ) // установить новый кодовый блок обработки ошибок * BEGIN SEQUENCE // код нормального исполнения * *** код нормального исполнения * ShellOpenFile( 'http://lc.kubagro.ru/index_aidos.php', .T., .T. ) // Решение Роджера. Не работает под Windows-8, а в 7 и 10 работает но не всегда <<<===################## * ShellOpenFile( 'http://lc.kubagro.ru/index_aidos.php' ) // Решение от Regan Cawkwell * cFile := LoadFromURL('http://lc.kubagro.ru/index_aidos.php') // Считывает страницу сайта в текстовую переменную * MsgBox(cFile) * MsgBox('STOP') * ShellOpenFile( 'http://lc.kubagro.ru/index_aidos.php' ) * RECOVER // код обработки ошибки * aMess := {} * AADD(aMess, L('При обращении к Эйдос-облаку возникла ошибка. Это повлияет только на отметку места запуска системы ')) // НАПРИМЕР * AADD(aMess, L('"Эйдос" на карте мира. Можно сделать это вручную, выйдя на сайт: http://lc.kubagro.ru/index_aidos.php')) * DC_Impl(oScr) * LB_Warning(aMess) * EXIT * ENDSEQUENCE * ErrorBlock( bError ) // переустановить старый кодовый * ****************************************** MILLISEC(100) RunShell('/C c:\Windows\System32\TaskList.exe /V /FO CSV > TaskList2.csv',,.F.,.T.) // .F. - чтобы программа не продолжалась дальше, пока не закончится перевод ******* Определить, какой браузер открылся (установленный по умолчанию) и его принудительно закрыть, если он не был открыт до запуска системы Эйдос ************** aTaskList1 := {} // Все программы, запущенные на компьютере ДО обращения к FTP-серверу nHandle := DC_txtOpen( 'TaskList1.csv' ) DO WHILE !DC_TxtEOF( nHandle ) // Начало цикла по строкам mLine = DC_TxtLine( nHandle ) // Выделить строку из текстового файла mPosExe = AT('.exe', mLine) IF mPosExe > 0 mPos = AT('","', mLine) mModName = SUBSTR(mLine,2,mPos-2) * MsgBox(ConvToOemCP(mLine)) * MsgBox(mModName) * IF ASCAN(aTaskList1, mModName) = 0 // Каждая программа запоминается только один раз AADD (aTaskList1, mModName) * ENDIF ENDIF DC_TxtSkip( nHandle, 1 ) ENDDO DC_TxtClose( nHandle ) aTaskList2 := {} // Все программы, запущенные на компьютере ПОСЛЕ обращения к FTP-серверу nHandle := DC_txtOpen( 'TaskList2.csv' ) DO WHILE !DC_TxtEOF( nHandle ) // Начало цикла по строкам mLine = DC_TxtLine( nHandle ) // Выделить строку из текстового файла mPosExe = AT('.exe', mLine) IF mPosExe > 0 mPos = AT('","', mLine) mModName = SUBSTR(mLine,2,mPos-2) * MsgBox(ConvToOemCP(mLine)) * MsgBox(mModName) * IF ASCAN(aTaskList2, mModName) = 0 // Каждая программа запоминается только один раз AADD (aTaskList2, mModName) * ENDIF ENDIF DC_TxtSkip( nHandle, 1 ) ENDDO DC_TxtClose( nHandle ) aBrowsers := {} // Наименования exe-модулей различных браузеров. ДОБАВИТЬ их как можно больше AADD(aBrowsers, 'opera.exe' ) AADD(aBrowsers, 'firefox.exe' ) AADD(aBrowsers, 'chrome.exe' ) AADD(aBrowsers, 'iexplore.exe') aTaskList12 := {} // Только новые программы, запущенные на компьютере ПОСЛЕ обращения к FTP-серверу, их и надо принудительно закрыть FOR j=1 TO LEN(aTaskList2) IF ASCAN(aTaskList1, aTaskList2[j]) = 0 // Новая программа, запущенная на компьютере ПОСЛЕ обращения к FTP-серверу IF ASCAN(aBrowsers, aTaskList2[j]) > 0 // Запоминать только названия exe-модулей браузеров * IF ASCAN(aTaskList12, aTaskList2[j]) = 0 // Каждая новая программа запоминается только один раз AADD (aTaskList12, aTaskList2[j]) * ENDIF ENDIF ENDIF NEXT IF LEN(aTaskList12) > 0 FOR j=1 TO LEN(aTaskList12) DO CASE CASE aTaskList12[j] = 'opera.exe' RunShell('/F /IM ' + 'opera.exe' ,'c:\Windows\System32\taskKill.exe',.T.,.F.) // принудительно закрыть новую программу: aTaskList12[j] CASE aTaskList12[j] = 'firefox.exe' RunShell('/F /IM ' + 'firefox.exe' ,'c:\Windows\System32\taskKill.exe',.T.,.F.) // принудительно закрыть новую программу: aTaskList12[j] CASE aTaskList12[j] = 'chrome.exe' RunShell('/F /IM ' + 'chrome.exe' ,'c:\Windows\System32\taskKill.exe',.T.,.F.) // принудительно закрыть новую программу: aTaskList12[j] CASE aTaskList12[j] = 'iexplore.exe' RunShell('/F /IM ' + 'iexplore.exe','c:\Windows\System32\taskKill.exe',.T.,.F.) // принудительно закрыть новую программу: aTaskList12[j] ENDCASE NEXT ENDIF ENDIF ENDIF ********************************************************************************************************************* ********************************************************************************************************************* // Цветовая схема главного меню fColor := GraMakeRGBColor({ Cf1,Cf2,Cf3 }) bColor := GraMakeRGBColor({ Cb1,Cb2,Cb3 }) DC_ReadGuiHandler( {|a,b,c,d,e,f|LogHandler(a,b,c,d,e,f)}) DC_XbpMenuConfig( ; { GRA_CLR_WHITE,; // 1 - Sub Menu Background Color fColor,; // 2 - Sub Menu Vertical Bar Foreground Color bColor,; // 3 - Sub Menu Vertical Bar Background Color GRA_CLR_BLACK,; // 4 - Sub Menu Outline Color '8.MS Sans Serif Bold', ; // 5 - Sub Menu Vertical Bar Font .F., ; '8.MS Sans Serif', ; // 6 - Sub Menu Check Character Font 'b', ; // 7 - Sub Menu Check Character fColor,; // 8 - Menu Bar Foreground Color bColor, ; // 9 - Menu Bar Background Color GRA_CLR_BLACK,; // 10 - Sub Menu Foreground Color '8.MS Sans Serif' } ) // 11 - Menu Bar Font ** Если ранее параметры главного окна не были заданы - то задать 1280 х 720, ** если были - то использовать те, которые были заданы // Здесь можно было бы узнать текущее разрешение видеокарты и сделать пропорции главного окна под них IF FILE("_MainWind.arx") Ar_MainWind = DC_ARestore("_MainWind.arx") W_MainWind = Ar_MainWind[1] H_MainWind = Ar_MainWind[2] ELSE Ar_MainWind[1] = 1280 Ar_MainWind[2] = 720 W_MainWind = Ar_MainWind[1] H_MainWind = Ar_MainWind[2] DC_ASave(Ar_MainWind, "_MainWind.arx") ENDIF * DbStrUpDate() // Обновление структур всех основных баз данных с сохранением информации в них #################################################### ********************************************************************************************************* *********** Создание среды многоуровневого иерархического меню системы Эйдос **************************** ********************************************************************************************************* * DC_Impl(oScrTime);oScrTime := DC_WaitOn('Метка-7: '+SubStr( Time()-cTime1, 1, 2)+':'+SubStr( Time()-cTime1, 4, 2)+':'+SubStr( Time()-cTime1, 7, 2),,,,,,,,,,,.F.) ********* ############################################################################################################################################# ********* Если папка, на которую прописан путь с системой, не совпадает с папкой, в которой фактически находится система, то привести их в соответствие ********* Надо учесть, что папка с базами данных приложений Aid_data может находится не в папке с исполнимым модулем системы ########################## ********* ############################################################################################################################################# DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций IF .NOT. FILE("PathSystem.dbf") aStructure := { { "PathSystem", "C", 250, 0 } } DbCreate( 'PathSystem', aStructure ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE PathSystem EXCLUSIVE NEW APPEND BLANK REPLACE PathSystem WITH 'Система запущена в данной папке впервые' ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE PathSystem EXCLUSIVE NEW IF PathSystem <> Disk_dir // Запомнить текущее положение системы в БД PathSystem.dbf ZAP APPEND BLANK REPLACE PathSystem WITH Disk_dir // Сначала удалить ВСЕ папки с приложениями, используя путь на фактическое расположение БД AID_DATA, // а потом пересоздать БД: PathGrAp.DBF, Appls.dbf и Users.dbf Zap_Appls() GenDbfPaths() GenDbfUsers() aMess := {} AADD(aMess, L('Была произведена локализация системы, т.е. удалены все приложения')) AADD(aMess, L('и пользователи и прописаны пути по фактическому положению системы')) AADD(aMess, L('т.к. система впервые запущена в папке: "'+ALLTRIM(Disk_dir)+'\"' )) * DC_Impl(oScr) LB_Warning(aMess, L('(C) Первый запуск системы "Эйдос" в папке') ) ENDIF * DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы * mPathSystem = STRTRAN(M_ApplsPath,"\AID_DATA","") // Папка, на которую в БД прописан путь, как на папку с системой * mDiskDir = DISKNAME()+":\"+CURDIR() // Папка, в которой фактически находится система * IF mDiskDir <> mApplsPath // Выполнить режим 1.11 * // Сначала удалить ВСЕ папки с приложениями, используя путь на фактическое расположение БД AID_DATA, * // а потом пересоздать БД: PathGrAp.DBF, Appls.dbf и Users.dbf * Zap_Appls() * GenDbfPaths() * GenDbfUsers() * aMess := {} * AADD(aMess, L('Была произведена локализация системы, т.е. удалены все приложения')) * AADD(aMess, L('и пользователи и прописаны пути по фактическому положению системы')) * AADD(aMess, L('т.к. система впервые запущена в папке: "'+ALLTRIM(mDiskDir)+'\"' )) * DC_Impl(oScr) * LB_Warning(aMess, L('(C) Первый запуск системы "Эйдос" в папке') ) * ENDIF *************************************************************** ***** БД, открытые перед запуском главного меню (главная среда) ***** Восстанавливать их после выхода из функций главного меню *************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** PUBLIC aSaveMainM := DC_DataSave() // Сохранение вычислительной среды (открытые и текущие БД и индексы) в памяти DC_ASave(aSaveMainM, "_SaveMainM.arx") // Сохранение вычислительной среды (открытые и текущие БД и индексы) на диске * ExternalControl = F5_11() // Режим внешнего управления по таймеру. Возможно надо запускать либо его, либо главное меню * IF ExternalControl * aMess := {} * AADD(aMess, L('Запущен режим внешнего управления системой "Эйдос-Х++"')) * AADD(aMess, L('Для выхода из данного режима достаточно нажать "OK"')) * DC_Impl(oScr) * LB_Warning(aMess, L('(c) Универсальная когнитивная аналитическая система "ЭЙДОС-X++"')) ** mFN = 'F2_3_1()' ** &(mFN) * zTimer:destroy() // Закрытие режима внешнего управления * ELSE ********************************************************************************************************* ********************************************************************************************************* *********** Многоуровневое иерархическое меню системы Эйдос ********************************************* ********************************************************************************************************* ********************************************************************************************************* GradFonStart(1) // Организация смены фона главного окна по таймеру sms := {} AADD(sms, L('Чтобы запустить данный режим')) AADD(sms, L('сначала завершите предыдущий')) cmc = L('(C) Система "Эйдос"') Running(.F.) *********************************************************************** * F2_3_2_12() // Прогнозирование ЗМТ по методике Натальи Чередниченко * QUIT *********************************************************************** * ****** Обработка ошибки ****************** * bErrorMM := ErrorBlock( {|e| Break(e)} ) // установить новый кодовый блок обработки ошибок * BEGIN SEQUENCE // код нормального исполнения * *** код нормального исполнения * *** * *** * RECOVER // код обработки ошибки * aMess := {} * AADD(aMess, L('При распознавании была попытка превышения максимального допустимого объема БД 2 Гб.')) // НАПРИМЕР * AADD(aMess, L('Необходимо уменьшить количество классов или/и объектов распознаваемой выборки !!! ')) * AADD(aMess, L('Можно также исключить из результатов распознавания наименее достоверные (режим 3.5)')) * DC_Impl(oScr) * LB_Warning(aMess) ** EXIT * ENDSEQUENCE * ErrorBlock( bErrorMM ) // переустановить старый кодовый блок обработки ошибок ****************************************** IF mCorrLaunch = 'ON' DC_Impl(oScr) ENDIF * DC_Impl(oScrTime);oScrTime := DC_WaitOn('Метка-8: '+SubStr( Time()-cTime1, 1, 2)+':'+SubStr( Time()-cTime1, 4, 2)+':'+SubStr( Time()-cTime1, 7, 2),,,,,,,,,,,.F.) * DC_Impl(oScrTime) DCMENUBAR oMenuBar OWNERDRAW BARBITMAP 'Checkers.bmp' DCSUBMENU oMenu1 PROMPT L('1. Администрирование') PARENT oMenuBar MESSAGE L('Подсистема администрирования') * DCMENUITEM SEPARATOR PARENT oMenu1 DCMENUITEM L('1.1. Авторизация ') PARENT oMenu1 ACTION {|| IF( !Running(), F1_1(),LB_Warning(sms,cmc)) } MESSAGE L('Авторизация сисадмина, администратора приложения или пользователя') DCMENUITEM L('1.2. Регистрация администратора приложения ') PARENT oMenu1 ACTION {|| IF( !Running(), F1_2(),LB_Warning(sms,cmc)) } MESSAGE L('Регистрация и удаление регистрации администраторов приложений и задание паролей пользователей. Этот режим доступен только системному администратору и администраторам приложений') DCMENUITEM L('1.3. Диспетчер приложений ') PARENT oMenu1 ACTION {|| IF( !Running(), F1_3(),LB_Warning(sms,cmc)) } MESSAGE L('Это подсистема администрирования приложений. Она предназначена для создания новых приложений, как пустых, так и на основе учебных примеров (лабораторных работ), имеющихся в системе, а также для выбора приложения для работы из уже имеющихся и удаления приложения. Выбор приложения для работы осуществляется путем отметки его любым символом. Удалять любые приложения разрешается только сисадмину, а Администратору приложений - только те, которые он сам создал') DCMENUITEM SEPARATOR PARENT oMenu1 * DCMENUITEM L('1.4. Выбор режима использования системы ') PARENT oMenu1 ACTION {|| IF( !Running(), F1_4()old,LB_Warning(sms,cmc)) } MESSAGE L('Монопольный или многопользовательский (задается при инсталляции системы, но может быть изменен когда угодно сисадмином)') DCMENUITEM L('1.4. Multi-language support ') PARENT oMenu1 ACTION {|| IF( !Running(), F1_4(),LB_Warning(sms,cmc)) } MESSAGE L('Данный режим обеспечивает: 1) задание текущего языка интерфейса (по умолчанию - русский); 2) корректировку локальной языковой базы данных по текущему языку (улучшение перевода); 3) объединение локальных и облачных языковых баз данных') DCMENUITEM L('1.5. Задание путей на папки с группами приложений') PARENT oMenu1 ACTION {|| IF( !Running(), F1_5(),LB_Warning(sms,cmc)) } MESSAGE L('Папки с различными группами приложениями могут быть на локальном компьютере, в локальной сети или в Internet. Пути на них задаются сисадмином при инсталляции системы и могут быть изменены им когда угодно. Один из этих путей, а именно первый из отмеченный специальных символов, считается текущим и используется при СОЗДАНИИ приложений в диспетчере приложений 1.3, а в последующем при запуске приложений на исполнение пути берутся уже из БД диспетчера приложений') DCMENUITEM L('1.6. Задание цветовой схемы главного меню ') PARENT oMenu1 ACTION {|| IF( !Running(), F1_6(),LB_Warning(sms,cmc)) } MESSAGE L('Задается по умолчанию если в папке с системой нет файла: ColorSch.arx при инсталляции системы, но может быть изменена когда угодно сисадмином') DCMENUITEM L('1.7. Задание размера главного окна в пикселях ') PARENT oMenu1 ACTION {|| IF( !Running(), F1_7(),LB_Warning(sms,cmc)) } MESSAGE L('Задается по умолчанию 1024 x 769 если в папке с системой нет файла: _MainWind.arx при инсталляции системы, но может быть изменена когда угодно сисадмином') DCMENUITEM L('1.8. Задание градиентных фонов главного окна ') PARENT oMenu1 ACTION {|| IF( !Running(), F1_8(),LB_Warning(sms,cmc)) } MESSAGE L('Градиентные фоны главного окна задаются по умолчанию при инсталляции системы, но могут быть изменены когда угодно сисадмином') DCMENUITEM L('1.9. Прописывание путей по фактическому положению') PARENT oMenu1 ACTION {|| IF( !Running(), F1_9(),LB_Warning(sms,cmc)) } MESSAGE L('Доступно только сисадмину. Определяет фактическое месторасположение системы и приложений и прописывает пути на них в БД: PathGrAp.DBF и Appls.dbf, а также восстанавливает имена приложений в Appls.dbf на данные им при их создании') DCMENUITEM L('1.10. Экспериментальная графика Роджера ') PARENT oMenu1 ACTION {|| IF( !Running(), DC_Graph(),LB_Warning(sms,cmc))} MESSAGE L('Графика Роджера. Операции с графикой на основе манипулирования массивами. Определение характеристик пикселей') DCMENUITEM L('1.11. Локализация и инициализация (сброс) системы') PARENT oMenu1 ACTION {|| IF( !Running(), F1_11(),LB_Warning(sms,cmc)) } MESSAGE L('Доступно только сисадмину. Прописывает все пути по фактическому месторасположению системы, пересоздает общесистемные базы данных, удаляет все приложения и всех пользователей. Определяет фактическое месторасположение системы и приложений, удаляет все директории приложений с поддиректориями и всеми файлами в них, а затем прописывает все пути на них по фактическому месторасположению, т.е. пересоздает и переиндексирует БД: PathSystem.dbf, PathGrAp.dbf, Appls.dbf и Users.dbf') * DCMENUITEM L('1.12. Режим специального назначения ') PARENT oMenu1 ACTION {|| IF( !Running(), F1_12(),LB_Warning(sms,cmc)) } MESSAGE L('Комментарий: "Без комментариев"') DCSUBMENU oMenu2 PROMPT L('2. Формализация предметной области') PARENT oMenuBar MESSAGE L('Разработка классификационных и описательных шкал и градаций и формирование обучающей выборки') * DCMENUITEM SEPARATOR PARENT oMenu2 DCMENUITEM L('2.1. Классификационные шкалы и градации ') PARENT oMenu2 ACTION {|| IF( !Running(), F2_1("Close"),LB_Warning(sms,cmc)) } MESSAGE L('Ручной ввод-корректировка классификационных шкал и градаций') DCMENUITEM L('2.2. Описательные шкалы и градации ') PARENT oMenu2 ACTION {|| IF( !Running(), F2_2("Close"),LB_Warning(sms,cmc)) } MESSAGE L('Ручной ввод-корректировка описательных шкал и градаций') DCMENUITEM SEPARATOR PARENT oMenu2 DCSUBMENU oMenu2_3 PROMPT L('2.3. Ввод обучающей выборки') PARENT oMenu2 MESSAGE L(' ') DCMENUITEM L('2.3.1. Ручной ввод-корректировка обучающей выборки ') PARENT oMenu2_3 ACTION {|| IF( !Running(), F2_3_1(),LB_Warning(sms,cmc))} MESSAGE L(' ') DCMENUITEM SEPARATOR PARENT oMenu2 DCMENUITEM L('2.4. Просмотр эвентологических баз данных ') PARENT oMenu2 ACTION {|| IF( !Running(), F2_4(),LB_Warning(sms,cmc)) } MESSAGE L('Просмотр эвентологических баз данных (баз событий), в которых исходные данные закодированы с помощью классификационных и описательных шкал и градаций и представлены в форме кодов событий, между которыми существуют причинно-следственные связи') DCSUBMENU oMenu2_3_2 PROMPT L('2.3.2. Программные интерфейсы с внешними базами данных') PARENT oMenu2_3 MESSAGE L('Автоматизированная формализация предметной области: разработка классификационных и описательных шкал и градаций и кодирование с их помощью исходных данных, в результате чего они преобразуются в обучающую выборку (базу событий). По сути это нормализация исходных баз данных. При этом сами данные могут быть различных типов: текстовыми, табличными (MS Excel, dbf) и графическими (jpg, bmp)') DCMENUITEM L('2.3.2.1. Импорт данных из текстовых файлов ') PARENT oMenu2_3_2 ACTION {|| IF( !Running(), F2_3_2_1(),LB_Warning(sms,cmc)) } MESSAGE L('Универсальный программный интерфейс ввода данных из TXT, DOC и Internet (HTML) файлов неограниченного объема. Атрибуция текстов, АСК-анализ мемов') DCMENUITEM L('2.3.2.2. Универсальный программный интерфейс импорта данных в систему') PARENT oMenu2_3_2 ACTION {|| IF( !Running(), F2_3_2_2("",""),LB_Warning(sms,cmc))} MESSAGE L('Режим представляет собой УНИВЕРСАЛЬНЫЙ ПРОГРАММНЫЙ ИНТЕРФЕЙС ФОРМАЛИЗАЦИИ ПРЕДМЕТНОЙ ОБЛАСТИ И ИМПОРТА ДАННЫХ В СИСТЕМУ "ЭЙДОС-Х". Данный программный интерфейс обеспечивает автоматическое формирование классификационных и описательных шкал и градаций и обучающей выборки на основе XLS, XLSX или DBF-файла с исходными данными стандарта, описанного в Help режима. Кроме того он обеспечивает автоматический ввод распознаваемой выборки из внешней базы данных. В этом режиме может быть до 1000000 объектов обучающей выборки до 2035 шкал') DCMENUITEM L('2.3.2.3. Импорт данных из транспонированных внешних баз данных ') PARENT oMenu2_3_2 ACTION {|| IF( !Running(), F2_3_2_3(),LB_Warning(sms,cmc)) } MESSAGE L('Режим представляет собой ПРОГРАММНЫЙ ИНТЕРФЕЙС ФОРМАЛИЗАЦИИ ПРЕДМЕТНОЙ ОБЛАСТИ И ИМПОРТА ДАННЫХ В СИСТЕМУ "ЭЙДОС-Х". Данный программный интерфейс обеспечивает автоматическое формирование классификационных и описательных шкал и градаций и обучающей выборки на основе XLS, XLSX или DBF-файла с исходными данными стандарта, описанного в Help режима стандарта, представляющего собой ТРАНСПОНИРОВАННЫЙ файл стандарта режима 2.3.2.2. Кроме того он обеспечивает автоматический ввод распознаваемой выборки из внешней базы данных. В этом режиме может быть до 1000000 шкал и до 2035 объектов обучающей выборки') DCMENUITEM L('2.3.2.4. Оцифровка изображений по внешним контурам ') PARENT oMenu2_3_2 ACTION {|| IF( !Running(), F2324ok() ,LB_Warning(sms,cmc)) } MESSAGE L('Данный режим обеспечивает оцифровку изображений по внешним контурам, т.е. кодирование и ввод в систему "Эйдос" изображений и формирование файла исходных данных "Inp_data" в стандарте режима 2.3.2.2 в котором каждое изображение представлено строкой') DCMENUITEM L('2.3.2.5. Оцифровка изображений по всем пикселям и спектру ') PARENT oMenu2_3_2 ACTION {|| IF( !Running(), F2_3_2_5(),LB_Warning(sms,cmc)) } MESSAGE L('Данный режим обеспечивает оцифровку изображений по всем пикселям и спектру, т.е. кодирование и ввод в систему "Эйдос" изображений и формирование файла исходных данных "Inp_data" в стандарте режима 2.3.2.3 в котором каждое изображение представлено столбцом') DCMENUITEM L('2.3.2.6. Сценарный АСК-анализ символьных и числовых рядов ') PARENT oMenu2_3_2 ACTION {|| IF( !Running(), F2_3_2_6(),LB_Warning(sms,cmc)) } MESSAGE L('Режим обеспечивает импорт данных из DOS-TXT-рядов чисел (цифр) и слов (букв), а также генерацию рядов для расчета асимптотического информационного критерия качества шума, отражающего степень выраженности закономерностей в предметной области. Это позволяет применить сценарный метод АСК-анализа для исследования временных рядов и каузальные зависимостей будущих сценариев изменения величины от прошлых') DCMENUITEM SEPARATOR PARENT oMenu2_3_2 DCMENUITEM L('2.3.2.7. Транспонирование файлов исходных данных ') PARENT oMenu2_3_2 ACTION {|| IF( !Running(), F2_3_2_7(),LB_Warning(sms,cmc)) } MESSAGE L('Данный режим обеспечивает транспонирование базы данных Inp_data.xls и ее запись в виде файла Out_transp.xls') DCMENUITEM L('2.3.2.8. Объединение нескольких файлов исходных данных в один ') PARENT oMenu2_3_2 ACTION {|| IF( !Running(), F2_3_2_8(),LB_Warning(sms,cmc)) } MESSAGE L('Данный режим обеспечивает объединение нескольких одинаковых по структуре баз данных с именами вида: "Input####.xls", где: "####" - номер файла вида: 0001,0002,...,9999, в один файл с именем: "Add_data.xls"') DCMENUITEM L('2.3.2.9. Разбиение TXT-файла на файлы-абзацы ') PARENT oMenu2_3_2 ACTION {|| IF( !Running(), F2_3_2_9(),LB_Warning(sms,cmc)) } MESSAGE L('Данный режим обеспечивает: обнаружение в папке: ../AID_DATA/INP_DATA/ TXT-файлов, загрузку этих файлов, нахождение в них абзацев, запись этих абзацев в виде TXT-файлов с именами вида: "###### - <ИМЯ TXT-ФАЙЛА>" из сквозного номера абзаца ###### и имени исходного TXT-файла') DCMENUITEM L('2.3.2.10. CSV => DBF конвертер системы "Эйдос" ') PARENT oMenu2_3_2 ACTION {|| IF( !Running(), CsvDbfConv(),LB_Warning(sms,cmc))} MESSAGE L('CSV => DBF конвертер системы "Эйдос" преобразует файл: "c:\Aidos-X\AID_DATA\Inp_data\Inp_data.csv" в файл: "c:\Aidos-X\AID_DATA\Inp_data\Inp_data.dbf", который открывается в MS Excel') DCMENUITEM SEPARATOR PARENT oMenu2_3_2 DCMENUITEM L('2.3.2.11. Прогноз событий по астропараметрам по Н.А.Чередниченко ') PARENT oMenu2_3_2 ACTION {|| IF( !Running(), F2_3_2_11(),LB_Warning(sms,cmc)) } MESSAGE L('Создание БД Inp_data.dbf из файлов: "Input1.xls" и "Input2.xls" и создание модели для прогнозирования различных событий по астропараметрам методом Н.А.Чередниченко (г.Владивосток, Россия)') DCMENUITEM L('2.3.2.12. Прогнозирование землетрясений методом Н.А.Чередниченко ') PARENT oMenu2_3_2 ACTION {|| IF( !Running(), F2_3_2_12(),LB_Warning(sms,cmc)) } MESSAGE L('Создание БД Inp_data.dbf из файлов: "Input1.xls" и "Input2.xls" и создание модели для прогнозирования землетрясений методом Натальи Алексеевны Чередниченко (г.Владивосток, Россия)') DCMENUITEM L('2.3.2.13. Чемпионат RAIF-Challenge 2017-API-bank ') PARENT oMenu2_3_2 ACTION {|| IF( !Running(), F2_3_2_13(),LB_Warning(sms,cmc)) } MESSAGE L('Создание БД Inp_data.dbf из файлов: t1.xlsx, t2.xlsx, t3.xlsx, t4.xlsx') DCMENUITEM L('2.3.2.14. Чемпионат RAIF-Challenge 2017-API-retail ') PARENT oMenu2_3_2 ACTION {|| IF( !Running(), F2_3_2_14(),LB_Warning(sms,cmc)) } MESSAGE L('Создание БД Inp_data.dbf и файла: Inp_name.txt соответственно из файлов:jet_raif_challenge.csv и description.csv') DCMENUITEM SEPARATOR PARENT oMenu2_3_2 DCMENUITEM L('2.3.2.15. Вставка промежуточных строк в файл исходных данных Inp_data') PARENT oMenu2_3_2 ACTION {|| IF( !Running(), F2_3_2_15(),LB_Warning(sms,cmc)) } MESSAGE L('Вставка промежуточных строк в файл исходных данных с интерполяцией значений соседних строк в числовых шкалах и объединением (через разделитель) значений в текстовых щкалах') DCSUBMENU oMenu2_3_3 PROMPT L('2.3.3. Управление обучающей выборкой ') PARENT oMenu2_3 MESSAGE ' ' DCMENUITEM L('2.3.3.1. Параметрическое задание объектов для обработки ') PARENT oMenu2_3_3 ACTION {|| IF( !Running(), Razrab() ,LB_Warning(sms,cmc))} MESSAGE ' ' DCMENUITEM L('2.3.3.2. Статистическая характеристика, ручной ремонт ') PARENT oMenu2_3_3 ACTION {|| IF( !Running(), Razrab() ,LB_Warning(sms,cmc))} MESSAGE ' ' DCMENUITEM L('2.3.3.3. Автоматический ремонт обучающей выборки ') PARENT oMenu2_3_3 ACTION {|| IF( !Running(), Razrab() ,LB_Warning(sms,cmc))} MESSAGE ' ' DCMENUITEM L('2.3.3.4. Распределение объектов обучающей выборки по классам ') PARENT oMenu2_3_3 ACTION {|| IF( !Running(), F2_3_3_4(),LB_Warning(sms,cmc))} MESSAGE L('Формирование отчета о распределении объектов обучающей выборки по классам') DCMENUITEM L('2.3.3.5. Объединение объектов обуч.выборки с одинаковыми классами') PARENT oMenu2_3_3 ACTION {|| IF( !Running(), F2_3_3_5(),LB_Warning(sms,cmc))} MESSAGE L('Формирование новой обучающей выборки, в которой объединены признаки объектов с одинаковыми классами и у объектов уникальные сочетания классов') DCMENUITEM L('2.3.4. Докодирование сочетаний признаков в обучающей выборке') PARENT oMenu2_3 ACTION {|| IF( !Running(), Razrab(),LB_Warning(sms,cmc))} MESSAGE ' ' DCSUBMENU oMenu3 PROMPT L('3. Синтез, верификация и улучшение модели') PARENT oMenuBar MESSAGE L('Создание модели, повышение ее качества и оценка достоверности') * DCMENUITEM SEPARATOR PARENT oMenu3 DCMENUITEM L('3.1. Ускоренный синтез всех моделей ') PARENT oMenu3 ACTION {|| IF( !Running(), F3_1(),LB_Warning(sms,cmc))} MESSAGE L('Ускоренный синтез всех статистических и системно-когнитивных моделей: {Abs, Prc1, Prc2, Inf1, Inf2, Inf3, Inf4, Inf5, Inf6, Inf7}') DCMENUITEM L('3.2. Верификация всех моделей на GPU ') PARENT oMenu3 ACTION {|| IF( !Running(), F3_2(),LB_Warning(sms,cmc))} MESSAGE L('Верификация всех статистических и системно-когнитивных моделей: {Abs, Prc1, Prc2, Inf1, Inf2, Inf3, Inf4, Inf5, Inf6, Inf7} на графическом процессоре (GPU) с использованием параллельных вычислений') DCMENUITEM L('3.3. Синтез и верификация всех моделей на GPU ') PARENT oMenu3 ACTION {|| IF( !Running(), F3_3(),LB_Warning(sms,cmc))} MESSAGE L('Ускоренный синтез и верификация всех статистических и системно-когнитивных моделей: {Abs, Prc1, Prc2, Inf1, Inf2, Inf3, Inf4, Inf5, Inf6, Inf7} на графическом процессоре (GPU) с использованием параллельных вычислений (OpenGL)') DCMENUITEM L('3.4. Оценка достоверности 10 моделей, созданных в реж.3.5') PARENT oMenu3 ACTION {|| IF( !Running(), F3_4(),LB_Warning(sms,cmc))} MESSAGE L('Оценивается достоверность (адекватность) 10 моделей, созданных последними в режиме 3.5. Для этого в режиме 3.5 сначала осуществляется синтез заданных моделей, а затем обучающая выборка копируется в распознаваемую и в каждой заданной модели проводится распознавание с использованием двух интегральных критериев, подсчитывается количество верно идентифицированных и не идентифицированных, ошибочно идентифицированных и не идентифицированных объектов (ошибки 1-го и 2-го рода)') DCMENUITEM SEPARATOR PARENT oMenu3 DCMENUITEM L('3.5. Синтез и верификация заданных из 10 моделей ') PARENT oMenu3 ACTION {|| IF( !Running(), F3_5('CPU','SintRec','3.5','ALL'),LB_Warning(sms,cmc)) } MESSAGE L('Синтез и верификация всех статистических и системно-когнитивных моделей: {Abs, Prc1, Prc2, Inf1, Inf2, Inf3, Inf4, Inf5, Inf6, Inf7} на центральном процессоре (CPU) или на графическом процессоре (GPU)') DCMENUITEM SEPARATOR PARENT oMenu3 DCMENUITEM L('3.6. Обнаружение, удаление и типизация артефактов ') PARENT oMenu3 ACTION {|| IF( !Running(), F3_7_6() ,LB_Warning(sms,cmc)) } MESSAGE L('Объекты обучающей выборки сравниваются с теми классами, к которым они относятся, и, если уровень сходства объекта с классом оказывается ниже заданного в диалоге порога, т.е. объект является нетипичным для данного класса или артефактом, то в справочнике классов создается новый класс с тем же наименованием, что у исходного класса, но с префиксом и объект обучающей выборки перекодируется на принадлежность к нему. Для этого создается новое приложение') * DCMENUITEM L('3.7. Синтез и верификация заданной группы моделей ') PARENT oMenu3 ACTION {|| IF( !Running(), Razrab() ,LB_Warning(sms,cmc)) } MESSAGE L('В различных приложениях текущей группы приложений создаются и верифицируются модели: Abs, Prc1, Prc2, Inf1~Prc1, Inf2~Prc2, Inf3-хи-квадрат, Inf4-roi~Prc1, Inf5-roi~Prc2, Inf6-Dp~Prc1, Inf7-Dp~Prc2 с фиксированными и адаптивными интервалами со сценариями и без и для каждого класса определяется модель, в которой его идентификация осуществляется наиболее достоверно') DCSUBMENU oMenu3_7 PROMPT L('3.7. Повышение качества модели') PARENT oMenu3 MESSAGE ' ' DCMENUITEM L('3.7.1. Поиск и удаление артефактов (робастная процедура) ') PARENT oMenu3_7 ACTION {|| IF( !Running(), F3_7_1(),LB_Warning(sms,cmc))} MESSAGE L('Строится частотное распределение абсолютных частот встреч признаков в классах по матрице сопряженности Abs.dbf и пользователю предоставляется возможность удалить редко встречающиеся факты (сочетания), как случайные выбросы или артефакты. Для работы профессиональной графики нужна MS Windows 7 или выше') DCMENUITEM L('3.7.2. Значимость классификационных шкал ') PARENT oMenu3_7 ACTION {|| IF( !Running(), F3_7_2(),LB_Warning(sms,cmc))} MESSAGE L('В данном режиме классификационные шкалы ранжируются в порядке убывания значимости, т.е. средней значимости их градаций (степени детерминированности классов). Детерминированность класса - это вариабельность значений частных критериев статистических баз и баз знаний') DCMENUITEM L('3.7.3. Степень детерминированности классов (градац.класс.шкал)') PARENT oMenu3_7 ACTION {|| IF( !Running(), F3_7_3(),LB_Warning(sms,cmc))} MESSAGE L('В данном режиме все градации классификационных шкал (классы) ранжируются в порядке убывания степени детерминированности, т.е. вариабельности значений частных критериев статистических и системно-когнитивных моделей') DCMENUITEM L('3.7.4. Значимость описательных шкал ') PARENT oMenu3_7 ACTION {|| IF( !Running(), F3_7_4(),LB_Warning(sms,cmc))} MESSAGE L('В данном режиме описательные шкалы ранжируются в порядке убывания значимости, т.е. средней значимости их градаций, т.е. признаков') DCMENUITEM L('3.7.5. Значимость градаций описательных шкал и абстрагирование') PARENT oMenu3_7 ACTION {|| IF( !Running(), F3_7_5(),LB_Warning(sms,cmc))} MESSAGE L('В данном режиме все градации описательных шкал (признаки) ранжируются в порядке убывания значимости, т.е. вариабельности значений частных критериев статистических и системно-когнитивных моделей. Модели оцениваются по степени различия значимости наиболее и наименее значимых признаков. Реализована возможность абстрагирования, т.е. удаления из модели наименее значимых признаков.') DCMENUITEM L('3.7.6. Разделение классов на типичную и нетипичную части ') PARENT oMenu3_7 ACTION {|| IF( !Running(), F3_7_6(),LB_Warning(sms,cmc))} MESSAGE L('Кластеризация, путем разделения классов на типичную и нетипичную части пока реализована в упрощенной форме (по сравнению с DOS-версией системы "Эйдос"). Из файла исходных данных "Inp_data.dbf" стандарта программного интерфейса 2.3.2.2 либо удаляются объекты обучающей выборки, которые привели к ошибкам не идентификации или ложной идентификации, либо для таких объектов создаются новые классы. В данном режиме используются результаты распознавания') DCMENUITEM L('3.7.7. Генерация подсистем классов и докодир.обуч.и расп.выб. ') PARENT oMenu3_7 ACTION {|| IF( !Running(), F3_7_7(),LB_Warning(sms,cmc))} MESSAGE L('На основе сочетания классов по 2, 3, N формируются подсистемы классов, которые добавляются в качестве градаций в классификационные шкалы подсистем классов и в объекты обучающей и распознаваемой выборки') DCMENUITEM L('3.7.8. Генерация подсистем признаков и докод.обуч.и расп.выб. ') PARENT oMenu3_7 ACTION {|| IF( !Running(), F3_7_8(),LB_Warning(sms,cmc))} MESSAGE L('На основе сочетания признаков по 2, 3, N формируются подсистемы признаков, которые добавляются в качестве градаций в описательные шкалы подсистем признаков и в объекты обучающей и распознаваемой выборки') DCMENUITEM L('3.7.9. Корректировка экспертных оценок: объект => класс ') PARENT oMenu3_7 ACTION {|| IF( !Running(), F3_7_9(),LB_Warning(sms,cmc))} MESSAGE L('В данном итерационном режиме обучающая выборка корректируется на основе результатов распознавания: КОРРЕКТИРУЕТСЯ принадлежность объекта к классу с экспертной оценки на полученную с помощью модели. Затем проводится синтез моделей и распознавание. Это повторяется, пока все положительные решения не станут истинными или результат перестает улучшаться') DCMENUITEM SEPARATOR PARENT oMenu3 DCMENUITEM L('3.8. Оценка достоверности всех моделей, созданных ранее в реж.3.5') PARENT oMenu3 ACTION {|| IF( !Running(), F3_8('3.4.'),LB_Warning(sms,cmc))} MESSAGE L('Оценивается достоверность (адекватность) всех моделей различных уровней (#={1,2}) и способов нормализации (@), ранее созданных в режиме 3.5 с момента создания приложения. Для этого используются базы данных, ранее созданные режимом 3.5 при создании и верификации моделей: Dost_modCls_basic_level.dbf; Dost_modCls_#nd_level_@.dbf, Dost_modClsALL.dbf, находящиеся в папке текущего приложения') DCSUBMENU oMenu4 PROMPT L('4. Решение задач с применением модели') PARENT oMenuBar MESSAGE L('Применение модели для решения задач идентификации (распознавания), прогнозирования и поддержки принятия решений (обратная задача прогнозирования), а также для исследования моделируемой предметной области путем исследования ее модели') * DCMENUITEM SEPARATOR PARENT oMenu4 DCSUBMENU oMenu4_1 PROMPT L('4.1. Идентификация и прогнозирование ') PARENT oMenu4 MESSAGE ' ' DCMENUITEM L('4.1.1. Ручной ввод-корректировка распознаваемой выборки ') PARENT oMenu4_1 ACTION {|| IF( !Running(), F4_1_1(),LB_Warning(sms,cmc)) } MESSAGE ' ' DCMENUITEM L('4.1.2. Пакетное распознавание в текущей модели ') PARENT oMenu4_1 ACTION {|| IF( !Running(), F4_1_2(0,.T.,"4_1_2",'CPU',2,2),LB_Warning(sms,cmc))} MESSAGE L('Распознаются по очереди все объекты распознаваемой выборки в стат.модели или базе знаний, заданной текущей в режиме 3.3 или 5.6.') DCMENUITEM SEPARATOR PARENT oMenu4_1 DCSUBMENU oMenu4_1_3 PROMPT L('4.1.3. Вывод результатов распознавания') PARENT oMenu4_1 MESSAGE ' ' DCMENUITEM L('4.1.3.1. Подробно наглядно: "Объект - классы" ') PARENT oMenu4_1_3 ACTION {|| IF( !Running(), F4_1_3_1(),LB_Warning(sms,cmc))} MESSAGE L('Визуализация результатов распознавания в подробной наглядной форме в отношении: "Один объект - много классов" с двумя интегральными критериями сходства между конкретным образом распознаваемого объекта и обобщенными образами классов: "Семантический резонанс знаний" и "Сумма знаний"') DCMENUITEM L('4.1.3.2. Подробно наглядно: "Класс - объекты" ') PARENT oMenu4_1_3 ACTION {|| IF( !Running(), F4_1_3_2(),LB_Warning(sms,cmc))} MESSAGE L('Визуализация результатов распознавания в подробной наглядной форме в отношении: "Один класс - много объектов" с двумя интегральными критериями сходства между конкретным образом распознаваемого объекта и обобщенными образами классов: "Семантический резонанс знаний" и "Сумма знаний"') DCMENUITEM L('4.1.3.3. Итоги наглядно: "Объект - класс" ') PARENT oMenu4_1_3 ACTION {|| IF( !Running(), F4_1_3_3(),LB_Warning(sms,cmc))} MESSAGE L('Отображение итоговых результатов распознавания в наглядной форме: отображаются пары: "Объект-класс" у которых наибольшее сходство по двум интегральным критериям сходства: "Семантический резонанс знаний" и "Сумма знаний". Приводится информация о фактической принадлежности объекта к классу') DCMENUITEM L('4.1.3.4. Итоги наглядно: "Класс - объект" ') PARENT oMenu4_1_3 ACTION {|| IF( !Running(), F4_1_3_4(),LB_Warning(sms,cmc))} MESSAGE L('Отображение итоговых результатов распознавания в наглядной форме: отображаются пары: "Класс-объект" у которых наибольшее сходство по двум интегральным критериям сходства: "Семантический резонанс знаний" и "Сумма знаний". Приводится информация о фактической принадлежности объекта к классу') DCMENUITEM L('4.1.3.5. Подробно сжато: "Объекты - классы"') PARENT oMenu4_1_3 ACTION {|| IF( !Running(), F4_1_3_5(),LB_Warning(sms,cmc))} MESSAGE L('В подробной сжатой (числовой) форме приводится информация об уровне сходства всех объектов со всеми классами по двум интегральным критериям сходства: "Семантический резонанс знаний" и "Сумма знаний", а также о фактической принадлежности объекта к классу') DCMENUITEM SEPARATOR PARENT oMenu4_1_3 DCMENUITEM L('4.1.3.6. Обобщ.форма по достов.моделей при разных интегральных крит.') PARENT oMenu4_1_3 ACTION {|| IF( !Running(), F4_1_3_6('4.1.3.6.') ,LB_Warning(sms,cmc)) } MESSAGE L('Отображаются обобщенные результаты измерения достоверности идентификации по всем моделям и интегральным критериям из БД: Dost_mod.DBF. Отображаются частотные распределения уровней сходства истинных и ложных положительных и отрицательных решений при разных моделях и интегральных критериях') DCMENUITEM L('4.1.3.7. Обобщ.стат.анализ результатов идент. по моделям и инт.крит.') PARENT oMenu4_1_3 ACTION {|| IF( !Running(), F4_1_3_7() ,LB_Warning(sms,cmc)) } MESSAGE L('Отображаются результаты обобщенного стат.анализа достоверности идентификации по всем моделям и интегральным критериям из БД: VerModClsIT.dbf. Отображаются частотные распределения уровней сходства истинных и ложных положительных и отрицательных решений при разных моделях и интегральных критериях') DCMENUITEM L('4.1.3.8. Стат.анализ результ. идент. по классам, моделям и инт.крит.') PARENT oMenu4_1_3 ACTION {|| IF( !Running(), F4_1_3_8(7),LB_Warning(sms,cmc)) } MESSAGE L('Отображаются результаты стат.анализа достоверности идентификации по всем классам, моделям и интегральным критериям из БД: VerModCls.dbf') DCMENUITEM L('4.1.3.9. Достоверность идент.объектов при разных моделях и инт.крит.') PARENT oMenu4_1_3 ACTION {|| IF( !Running(), F4_1_3_9() ,LB_Warning(sms,cmc)) } MESSAGE L('Отображается достоверность идентификации объектов по классам (F-мера Ван Ризбергена) в разрезе по объектам при разных моделях (т.е. разных частных критериях) и при разных интегральных критериях из БД: Dost_clsF.dbf. Позволяет удалять из обучающей выборки плохо распознаваемые объекты') DCMENUITEM L('4.1.3.10.Достоверность идент.классов при разных моделях и инт.крит.') PARENT oMenu4_1_3 ACTION {|| IF( !Running(), F4_1_3_10(),LB_Warning(sms,cmc)) } MESSAGE L('Отображается достоверность идентификации объектов по классам (F-мера Ван Ризбергена) в разрезе по классам при разных моделях (т.е. разных частных критериях) и при разных интегральных критериях из БД: Dost_clsF.dbf') * DCMENUITEM L('4.1.3.11.Распределения уровн.сходства при разных моделях и инт.крит.') PARENT oMenu4_1_3 ACTION {|| IF( !Running(), F4_1_3_11old(),LB_Warning(sms,cmc))} MESSAGE L('Отображаются частотные распределения уровней сходства верно и ошибочно идентифицированных и неидентифицированных объектов при разных моделях и интегральных критериях из БД: DostRasp.dbf и DostRsp#.dbf. Расчет и графическая визуализация частотных распределений уровней сходства: 1) TP,TN,FP,FN, интегральный критерий - резонанс знаний; 2) TP,TN,FP,FN, интегральный критерий - сумма знаний; 3) (TP-FP), (TN-FN), интегральный критерий - резонанс знаний; 4) (TP-FP), (TN-FN), интегральный критерий - сумма знаний; 5) (TP-FP)/(TP+FP)*100 и (TN-FN)/(TN+FN)*100, интегральный критерий - резонанс знаний; 6) (TP-FP)/(TP+FP)*100 и (TN-FN)/(TN+FN)*100, интегральный критерий - сумма знаний') DCMENUITEM L('4.1.3.11.Объединение в одной БД строк по самым достоверным моделям ') PARENT oMenu4_1_3 ACTION {|| IF( !Running(), F4_1_3_11(.T.),LB_Warning(sms,cmc))} MESSAGE L('Объединение в одной БД "AddData.dbf" строк по наиболее достоверным моделям из Dost_modCls, формируемых в режиме 4.1.3.6. Этот режим предназначен для исследования зависимости достоверности моделей от объема обучающей выборки и других параметров моделей по F-критерию Ван Ризбергена, а также по L1- и L2-критериям проф.Е.В.Луценко') DCMENUITEM L('4.1.3.12.Вывод результатов распознавания в стиле: "Inp_data.xlsx" ') PARENT oMenu4_1_3 ACTION {|| IF( !Running(), F4_1_3_12(),LB_Warning(sms,cmc))} MESSAGE L('Вывод результатов распознавания в формате "Inp_data.xlsx" в файлах: "RecognResults_####_#_####.xls" для разных моделей: {"Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7"}, интегральных критериев: {"i","k"} и в кодах или наименованиях классов и признаков: {"Kod","Name"}') DCMENUITEM L('4.1.3.13.Частотное распределение наблюдений по самым похожим классам') PARENT oMenu4_1_3 ACTION {|| IF( !Running(), F4_1_3_13(),LB_Warning(sms,cmc))} MESSAGE L('Частотное распределения объектов распознаваемой выборки по классам формируется на основе выходной формы режима: 4.1.3.3. Итоги наглядно: "Объект - класс". При расчетах учитываются по одному классу на наблюдение: к сумматору класса, на который данное наблюдение наиболее похоже, суммируется 1') DCMENUITEM L('4.1.3.14.Распределение уровней сходства наблюдений по всем классам ') PARENT oMenu4_1_3 ACTION {|| IF( !Running(), F4_1_3_14(),LB_Warning(sms,cmc))} MESSAGE L('Распределение уровней сходства объектов распознаваемой выборки по классам формируется на основе выходной формы режима: 4.1.3.1. Подробно наглядно: "Объект - классы". При расчетах учитываются все классы, на которые данное наблюдение похоже: к сумматору каждого класса суммируется сходство данного наблюдения с этим классом') DCMENUITEM L('4.1.4. Пакетное распознавание в заданной группе моделей ') PARENT oMenu4_1 ACTION {|| IF( !Running(), Razrab(),LB_Warning(sms,cmc))} MESSAGE L('Распознаются по очереди все объекты распознаваемой выборки в стат.модели или базе знаний, заданной текущей, в всех моделях заданной группы моделей') DCMENUITEM L('4.1.5. Докодирование сочетаний признаков в распознаваемой выборке ') PARENT oMenu4_1 ACTION {|| IF( !Running(), Razrab(),LB_Warning(sms,cmc))} MESSAGE ' ' DCMENUITEM L('4.1.6. Рациональное назначение объектов на классы (задача о ранце) ') PARENT oMenu4_1 ACTION {|| IF( !Running(), F4_1_6(),LB_Warning(sms,cmc))} MESSAGE L('Управление персоналом на основе АСК-анализа и функционально-стоимостного анализа (задача о назначениях)') DCMENUITEM L('4.1.7. Интерактивная идентификация - последовательный анализ Вальда') PARENT oMenu4_1 ACTION {|| IF( !Running(), Razrab(),LB_Warning(sms,cmc))} MESSAGE ' ' DCMENUITEM L('4.1.8. Мультираспознавание (пакетное распознавание во всех моделях)') PARENT oMenu4_1 ACTION {|| IF( !Running(), Razrab(),LB_Warning(sms,cmc))} MESSAGE L('При идентификации объекта распознаваемой выборки с каждым классом он сравнивается в той модели, в которой этот класс распознается наиболее достоверно, как в системе "Эйдос-астра"') DCMENUITEM L('4.1.9. Подготовка результатов распознавания для http://kaggle.com ') PARENT oMenu4_1 ACTION {|| IF( !Running(), F4_1_9(),LB_Warning(sms,cmc))} MESSAGE L('Подготовка результатов распознавания в форме CSV-файлов в стандарте http://kaggle.com. Данный режим предполагает, что: 1) в модели 2 класса; 2) результаты распознавания во всех моделях уже получены в режиме 3.5') DCSUBMENU oMenu4_2 PROMPT L('4.2. Типология классов и принятие решений') PARENT oMenu4 MESSAGE ' ' DCMENUITEM L('4.2.1. Информационные портреты классов') PARENT oMenu4_2 ACTION {|| IF( !Running(), F4_2_1(),LB_Warning(sms,cmc))} MESSAGE L('Решение обратной задачи прогнозирования: выработка управляющих решений. Если при прогнозировании на основе значений факторов оценивается в какое будущее состояние перейдет объект управления, то при решении обратной задачи, наоборот, по заданному целевому будущему состоянию объекта управления определяется такая система значений факторов, которая в наибольшей степени обуславливает переход в это состояние') DCSUBMENU oMenu4_2_2 PROMPT L('4.2.2. Кластерный и конструктивный анализ классов') PARENT oMenu4_2 MESSAGE ' ' DCMENUITEM L('4.2.2.1. Расчет матриц сходства, кластеров и конструктов ') PARENT oMenu4_2_2 ACTION {|| IF( !Running(), F4_2_2_1(),LB_Warning(sms,cmc))} MESSAGE L('Расчет матриц сходства, кластеров и конструктов классов. Режим имеет две программных реализации: старую - на языке xBase++ и новую - на Питоне. Новая реализация работает значительно быстрее, что особенно существенно при больших размерностях моделей') DCMENUITEM L('4.2.2.2. Круговая когнитивная диаграмма классов ') PARENT oMenu4_2_2 ACTION {|| IF( !Running(), F4_2_2_2(),LB_Warning(sms,cmc))} MESSAGE L('Состояния, соответствующие классам, расположенные около одного полюса конструкта, достижимы одновременно, т.к. имеют сходную систему детерминации, а находящиеся около противоположных полюсов конструкта являются альтернативными, т.е. одновременно недостижимы') DCMENUITEM L('4.2.2.3. Когнитивная кластеризация классов ') PARENT oMenu4_2_2 ACTION {|| IF( !Running(), F4_2_2_3(),LB_Warning(sms,cmc))} MESSAGE L('Когнитивная кластеризация, путем объединения пар классов в матрице абсолютных частот и пересчет матриц условных и безусловных процентных распределений и системно-когнитивных моделей. Построение и визуализация агломеративных дендрограмм классов и графиков межкластерных расстояний в графическом виде, а также матрицы сходства классов') DCMENUITEM L('4.2.2.4. 1-2-3: Классическая кластеризация классов ') PARENT oMenu4_2_2 ACTION {|| IF( !Running(), F4_2_2_4(),LB_Warning(sms,cmc))} MESSAGE L('Режимы 1-2-3 вместе на Питоне: Классическая кластеризация классов в Питоне. Построение и визуализация агломеративных дендрограмм классов и графиков межкластерных расстояний в графическом виде, а также матрицы сходства классов в MS Excel и круговой когнитивной диаграммы классов на ее основе') * DCMENUITEM L('4.2.2.5. Дивизивная древовидная кластеризация классов ') PARENT oMenu4_2_2 ACTION {|| IF( !Running(), F3_7_6() ,LB_Warning(sms,cmc))} MESSAGE L('Кластеризация, путем разделения классов на типичную и нетипичную части пока реализована в упрощенной форме (по сравнению с DOS-версией системы "Эйдос"). Из файла исходных данных "Inp_data.dbf" стандарта программного интерфейса 2.3.2.2 либо удаляются объекты обучающей выборки, которые привели к ошибкам не идентификации или ложной идентификации, либо для таких объектов создаются новые классы. В данном режиме используются результаты распознавания') DCMENUITEM L('4.2.3. Когнитивные диаграммы классов') PARENT oMenu4_2 ACTION {|| IF( !Running(), F4_2_3(),LB_Warning(sms,cmc))} MESSAGE L('Данный режим показывает в наглядной графической форме какими признаками сходны и какими отличаются друг от друга заданные классы') DCSUBMENU oMenu4_3 PROMPT L('4.3. Типологический анализ признаков') PARENT oMenu4 MESSAGE ' ' DCMENUITEM L('4.3.1. Информационные портреты признаков') PARENT oMenu4_3 ACTION {|| IF( !Running(), F4_3_1(),LB_Warning(sms,cmc))} MESSAGE L('Семантический (смысловой) портрет признака или значения фактора, т.е. количественная характеристика силы и направления его влияния на поведение объекта управления') DCSUBMENU oMenu4_3_2 PROMPT L('4.3.2. Кластерный и конструктивный анализ признаков') PARENT oMenu4_3 MESSAGE ' ' DCMENUITEM L('4.3.2.1. Расчет матриц сходства, кластеров и конструктов ') PARENT oMenu4_3_2 ACTION {|| IF( !Running(), F4_3_2_1(),LB_Warning(sms,cmc))} MESSAGE L('Расчет матриц сходства, кластеров и конструктов признаков. Режим имеет две программных реализации: старую - на языке xBase++ и новую - на Питоне. Новая реализация работает значительно быстрее, что особенно существенно при больших размерностях моделей') DCMENUITEM L('4.3.2.2. Круговая когнитивная диаграмма признаков ') PARENT oMenu4_3_2 ACTION {|| IF( !Running(), F4_3_2_2(),LB_Warning(sms,cmc))} MESSAGE L('Признаки или градации факторов, расположенные около одного полюса конструкта, оказывают сходное влияние на объект управления, т.е. на его принадлежность к классам или его переход в состояния, соответствующие классам и могут быть заменены одни другими, а находящиеся около противоположных полюсов конструкта оказывают сильно отличающееся влияние на объект управления и не могут быть заменены одни другими') DCMENUITEM L('4.3.2.3. Когнитивная кластеризация признаков ') PARENT oMenu4_3_2 ACTION {|| IF( !Running(), F4_3_2_3(),LB_Warning(sms,cmc))} MESSAGE L('Когнитивная кластеризация, путем объединения пар признаков в матрице абсолютных частот и пересчет матриц условных и безусловных процентных распределений и системно-когнитивных моделей. Построение и визуализация агломеративных дендрограмм признаков и графиков межкластерных расстояний в графическом виде, а также матрицы сходства признаков') DCMENUITEM L('4.3.2.4. 1-2-3: Классическая кластеризация признаков ') PARENT oMenu4_3_2 ACTION {|| IF( !Running(), F4_3_2_4(),LB_Warning(sms,cmc))} MESSAGE L('Режимы 1-2-3 вместе на Питоне: Классическая кластеризация признаков в Питоне. Построение и визуализация агломеративных дендрограмм признаков и графиков межкластерных расстояний в графическом виде, а также матрицы сходства признаков в MS Excel и круговой когнитивной диаграммы признаков на ее основе') DCMENUITEM L('4.3.3. Когнитивные диаграммы признаков') PARENT oMenu4_3 ACTION {|| IF( !Running(), F4_3_3(),LB_Warning(sms,cmc))} MESSAGE L('Данный режим показывает в наглядной графической форме какими классами сходны и какими отличаются друг от друга заданные признаки') DCSUBMENU oMenu4_4 PROMPT L('4.4. Исследование предметной области путем исследования ее модели') PARENT oMenu4 MESSAGE ' ' DCMENUITEM L('4.4.1. Оценка достоверности обучающей выборки ') PARENT oMenu4_4 ACTION {|| IF( !Running(), Razrab(),LB_Warning(sms,cmc))} MESSAGE L('Выявление объектов с нарушенными корреляциями между классами и признаками. Выявление очень сходных друг с другом объектов обучающей выборки') DCMENUITEM L('4.4.2. Оценка достоверности распознаваемой выборки ') PARENT oMenu4_4 ACTION {|| IF( !Running(), Razrab(),LB_Warning(sms,cmc))} MESSAGE L('Выявление очень сходных друг с другом объектов распознаваемой выборки') DCMENUITEM L('4.4.3. Измерение адекватности 3 стат.моделей и 7 моделей знаний ') PARENT oMenu4_4 ACTION {|| IF( !Running(), Razrab(),LB_Warning(sms,cmc))} MESSAGE L('Любой заданной или всех') DCMENUITEM L('4.4.4. Измерение сходимости и устойчивости 10 моделей ') PARENT oMenu4_4 ACTION {|| IF( !Running(), Razrab(),LB_Warning(sms,cmc))} MESSAGE ' ' DCMENUITEM L('4.4.5. Зависимость достоверности моделей от объема обучающей выборки ') PARENT oMenu4_4 ACTION {|| IF( !Running(), Razrab(),LB_Warning(sms,cmc))} MESSAGE ' ' DCMENUITEM L('4.4.6. Измерение независимости классов и признаков (анализ хи-квадрат)') PARENT oMenu4_4 ACTION {|| IF( !Running(), Razrab(),LB_Warning(sms,cmc))} MESSAGE ' ' DCMENUITEM SEPARATOR PARENT oMenu4_4 DCMENUITEM L('4.4.7. Графические профили классов и признаков ') PARENT oMenu4_4 ACTION {|| IF( !Running(), Razrab(),LB_Warning(sms,cmc)) } MESSAGE ' ' DCMENUITEM L('4.4.8. Количественный SWOT-анализ классов средствами АСК-анализа ') PARENT oMenu4_4 ACTION {|| IF( !Running(), F4_4_8(),LB_Warning(sms,cmc)) } MESSAGE L('АСК-анализ обеспечивает построение SWOT-матрицы (модели) для заданного класса с указанием силы влияния способствующих и препятствующих факторов непосредственно на основе эмпирических данных и поэтому является инструментом автоматизированного количественного SWOT-анализа (прямая задача SWOT-анализа). Классы интерпретируются как целевые и нежелательные состояния фирмы, факторы делятся на внутренние, технологические, описывающие фирму, и внешние, характеризующие окружающую среду, а количество информации, содержащееся в значении фактора, рассматривается как сила и направление его влияния на переход фирмы в те или иные будущие состояния') DCMENUITEM L('4.4.9. Количественный SWOT-анализ факторов средствами АСК-анализа ') PARENT oMenu4_4 ACTION {|| IF( !Running(), F4_4_9(),LB_Warning(sms,cmc)) } MESSAGE L('АСК-анализ обеспечивает построение количественной SWOT-матрицы (модели) для заданного значения фактора с указанием степени, в которой он способствует или препятствует переходу объекта управления в различные будущие состояния, соответствующие классам (обратная задача SWOT-анализа). Эта модель строится непосредственно на основе эмпирических данных и поэтому АСК-анализ может рассматриваться как инструмент автоматизированного количественного SWOT-анализа. Факторы делятся на внутренние, технологические, описывающие саму фирму, и внешние, характеризующие окружающую среду') DCMENUITEM L('4.4.10.Нелокальные нейроны ') PARENT oMenu4_4 ACTION {|| IF( !Running(), F4_4_10(),LB_Warning(sms,cmc))} MESSAGE L('Нелокальный нейрон отражает силу и знак влияния значений факторов (рецепторов-признаков) на активацию или торможение нейрона, т.е. на принадлежность или не принадлежность объекта с этими признаками к классу, соответствующему данному нейрону') DCMENUITEM L('4.4.11.Парето-подмножества нелокальной нейронной сети ') PARENT oMenu4_4 ACTION {|| IF( !Running(), F4_4_11('NeuroNet') ,LB_Warning(sms,cmc))} MESSAGE L('В этом режиме изображается вместе сразу несколько нелокальных нейронов, которые в режиме 4.4.10 изображались по одному, т.е. Парето-подмножество нелокальной нейронной сети') DCMENUITEM L('4.4.12.Интегральные когнитивные карты ') PARENT oMenu4_4 ACTION {|| IF( !Running(), F4_4_11('IntCognMaps'),LB_Warning(sms,cmc))} MESSAGE L('Это нелокальная нейронная сеть с указанием не только связей между значениями факторов и классов (как в режиме 4.4.11), но и с корреляциями между классами (как в режиме 4.2.2), и корреляциями между значениями факторов (как в режиме 4.3.2)') DCMENUITEM L('4.5. Визуализация когнитивных функций: текущее приложение, разные модели') PARENT oMenu4 ACTION {|| IF( !Running(), F4_5(),LB_Warning(sms,cmc))} MESSAGE L('В данном режиме осуществляется визуализация и запись когнитивных функций, созданных в текущем приложении на основе различных стат.моделей и моделей знаний') DCMENUITEM L('4.6. Подготовка баз данных для визуализация когнитивных функций в Excel ') PARENT oMenu4 ACTION {|| IF( !Running(), F4_6(),LB_Warning(sms,cmc))} MESSAGE L('Данный режим готовит базы данных для визуализации в MS Excel прямых и обратных, позитивных и негативных точечных и средневзвешенных редуцированных когнитивных функций, созданных на основе различных стат.моделей и моделей знаний') DCMENUITEM L('4.7. АСК-анализ изображений по пикселям, спектрам и контурам ') PARENT oMenu4 ACTION {|| IF( !Running(), F4_8(L('4.7. АСК-анализ изображений по пикселям, спектрам и контурам')),LB_Warning(sms,cmc)) } MESSAGE L('Данный режим обеспечивает АСК-анализ изображений, как сгенерированных в учебных целях, так и внешних для системы "Эйдос-Х++", относящихся к какой-либо предметной области. АСК-анализ изображений возможен: по пикселям, спектру, по внешним контурам, по внутренним и внешним контурам (в разработке). Кроме того в данном режиме по кнопке "Формирование облака точек" возможна визуализация когнитивных функций, аналогично режимам 4.5 и 4.6. Данный режим интегрирован с Геокогнитивной подсистемой системы "Эйдос" (режим 4.8.)') DCMENUITEM L('4.8. Геокогнитивная подсистема ') PARENT oMenu4 ACTION {|| IF( !Running(), F4_8(L('4.8. Геокогнитивная подсистема')),LB_Warning(sms,cmc)) } MESSAGE L('Обеспечивает восстановление значений функций по признакам аргумента. Преобразует 2D Excel-таблицу с именем "Inp_map.xls" в файл исходных данных "Inp_data.dbf", содержащий координаты X,Y,Z точек и их признаки (модель описательной информации картографической базы данных). Визуализирует исходные данные из БД "Inp_data.dbf" или итоговые результаты распознавания из БД: "Rsp_it.dbf" в картографической форме (сетка и градиентная заливка цветом) с применением триангуляции Делоне. Обеспечивает пакетный ввод и оконтуривание изображений и формирование соответствующих файлов "Inp_data" и др. для создания и применения модели, созданной на основе этих изображений. Режим интегрирован с 4.7.') DCSUBMENU oMenu5 PROMPT L('5. Сервис') PARENT oMenuBar MESSAGE L('Конвертирование, печать и сохранение модели, пересоздание и переиндексация всех баз данных') * DCMENUITEM SEPARATOR PARENT oMenu5 * DCMENUITEM L('5.1. Конвертер приложения OLD => NEW' ) PARENT oMenu5 ACTION {|| IF( !Running(), F5_1old(), LB_Warning(sms,cmc))} MESSAGE L('Преобразование модели из стандарта БД системы Эйдос-12.5 в стандарт Эйдос-X++. Для конвертирования старого приложения надо скопировать в папку: файлы: Object.Dbf, Priz_Ob.Dbf, Priz_Per.Dbf, Priz_Per.Dbt, Obinfzag.Dbf, Obinfkpr.Dbf') DCMENUITEM L('5.1. Конвертер моделей Abs,Prc#,Inf# => CSV') PARENT oMenu5 ACTION {|| IF( !Running(), F5_1() , LB_Warning(sms,cmc))} MESSAGE L('Преобразование статистических Abs, Prc1, Prc2 и системно когнитивных моделей Inf1, Inf2, Inf3, Inf4, Inf5, Inf6, Inf7 из стандарта TXT в стандарт CSV. Особенно это может пригодиться для кластеризации в системе IBM SPSS Statistics 27.0.1 IF026. Преобразование происходит без ограничений на размерность модели (количество классов и количество признаков), т.е. для Big Data') * DCMENUITEM L('5.2. Конвертер приложения NEW => OLD' ) PARENT oMenu5 ACTION {|| IF( !Running(), F5_2()old, LB_Warning(sms,cmc))} MESSAGE L('Преобразование модели из стандарта БД системы Эйдос-X++ в стандарт Эйдос-12.5 в папку OldAppls. Все файлы из этой папки надо скопировать в текущую папку системы "Эйдос-12.5", выполнить режимы 7.2 и 2.3.5') DCMENUITEM L('5.2. Создание классов на основе кластеров' ) PARENT oMenu5 ACTION {|| IF( !Running(), F5_2() , LB_Warning(sms,cmc))} MESSAGE L('Данный режим обеспечивает создание в файле "Inp_data.csv", аналогичном "Inp_data.xls(x)" новых классификационных шкал, соответствующих уровням иерархии дерева агломеративной кластеризации классов (режим 2.3.2.1), и новых классов, соответствующих кластерам. При вводе данных из файла "Inp_data.csv" в систему "Эйдос" в API-2.3.2.2 могут быть созданы модели многослойных нейронных сетей.') DCMENUITEM L('5.3. Конв.трех БД расп.выборки в одну БД' ) PARENT oMenu5 ACTION {|| IF( !Running(), F5_3() , LB_Warning(sms,cmc))} MESSAGE L('Три базы данных распознаваемой выборки: Rso_Zag.dbf, Rso_Kcl.dbf, Rso_Kpr.dbf преобразуются в одну базу данных: Rso_all.dbf. По структуре эта база данных очень сходна с базами статистических и системно-когнитивных моделей, т.е. строки в ней соответствуют градациям описательных шкал (признакам), а колонки - объектам распознаваемой выборки, в ячейках - число встреч данного признака у данного объекта.') DCMENUITEM L('5.4. Конвер. результатов расп.для SigmaPlot') PARENT oMenu5 ACTION {|| IF( !Running(), F5_4() , LB_Warning(sms,cmc))} MESSAGE L('Конвертирует результаты распознавания, т.е. БД Rasp.dbf в параметрическую форму в стиле: "X, Y, Z", удобную для картографической визуализации в системе SigmaPlot. Это возможно, если предварительно были выполнены режимы 3.7.7 и 3.4(3.5.) и 4.1.2.') DCMENUITEM SEPARATOR PARENT oMenu5 DCMENUITEM L('5.5. Просмотр основных БД всех моделей ' ) PARENT oMenu5 ACTION {|| IF( !Running(), F5_5(.T.),LB_Warning(sms,cmc)) } MESSAGE L('Обеспечивает просмотр и экспорт в Excel основных баз данных всех статистических моделей: Abs, Prc1, Prc2 и моделей знаний: Inf1~Prc1, Inf2~Prc2, Inf3-хи-квадрат, Inf4-roi~Prc1, Inf5-roi~Prc2, Inf6-Dp~Prc1, Inf7-Dp~Prc2') DCMENUITEM SEPARATOR PARENT oMenu5 DCMENUITEM L('5.6. Выбрать модель и сделать ее текущей ' ) PARENT oMenu5 ACTION {|| IF( !Running(), F5_6(4,.T.,"MainMenu"),LB_Warning(sms,cmc))} MESSAGE L('Данная функция позволяет выбрать среди ранее рассчитанных в 3-й подсистеме статистических баз Abs, Prc1, Prc2 и моделей знаний INF#, текущую модель для решения в 4-й подсистеме задач идентификации, прогнозирования, приятия решений и исследования предметной области путем исследования ее модели') DCMENUITEM L('5.7. Переиндексация всех баз данных ' ) PARENT oMenu5 ACTION {|| IF( !Running(), F5_7() ,LB_Warning(sms,cmc)) } MESSAGE L('Заново создаются все необходимые для работы системы индексные массивы общесистемных баз данных (находящихся в папке с исполнимым модулем системы), а также баз данных текущего приложения, необходимые для работы с ним') DCMENUITEM L('5.8. Сохранение основных баз данных модели' ) PARENT oMenu5 ACTION {|| IF( !Running(), Razrab(),LB_Warning(sms,cmc)) } MESSAGE ' ' DCMENUITEM L('5.9. Восстановление модели из основных БД ' ) PARENT oMenu5 ACTION {|| IF( !Running(), Razrab(),LB_Warning(sms,cmc)) } MESSAGE ' ' DCMENUITEM L('5.10.Выгрузка исходных данных в "Inp_data"' ) PARENT oMenu5 ACTION {|| IF( !Running(), F5_10() ,LB_Warning(sms,cmc)) } MESSAGE L('Данный режим выполняет функцию, обратную универсальному программному интерфейсу с внешними базами данных 2.3.2.2(), т.е. не вводит исходные данные в систему, а наоборот, формирует на основе исходных данных файлы: Inp_data.dbf и Inp_data.txt, на основе которых в режиме 2.3.2.2() можно сформировать эту же модель') DCMENUITEM SEPARATOR PARENT oMenu5 * DCMENUITEM L('5.11. Внешнее управление системой "Эйдос"' ) PARENT oMenu5 ACTION {|| IF( !Running(), F5_11(),LB_Warning(sms,cmc)) } MESSAGE L('Данный режим обеспечивает управление системой "Эйдос" в реальном времени со стороны внешней программы путем задания ею последовательности функций системы "Эйдос" для исполнения (по сути программы, написанной на языке "Эйдос") в специальной базе данных: "ExternalControl.dbf" и программного контроля их исполнения') DCMENUITEM L('5.11. Тест по АСК-анализу и системе "Эйдос"') PARENT oMenu5 ACTION {|| IF( !Running(), F5_11(),LB_Warning(sms,cmc)) } MESSAGE L('Это экзаменационный тест по АСК-анализу и системе "Эйдос", включающий 400 вопросов, каждый с 1 верным и 3 ошибочными вариантами ответов. Тестирование занимает полную пару. По результатам тестирования тест ставит оценку 2, 3, 4 или 5. Тестируемый должен ввести свои фамилию, имя, отчество, название и № группы, название вуза. Результаты тестирования размещаются в Эйдос-облаке и их можно просматривать в таблице и на карте мира') DCMENUITEM SEPARATOR PARENT oMenu5 DCMENUITEM L('5.12. Печать структур всех БД, => xlsx,html') PARENT oMenu5 ACTION {|| IF( !Running(), F5_12(),LB_Warning(sms,cmc)) } MESSAGE L('Распечатка структур (даталогических моделей) всех баз данных текущего приложения. Преобразование всех баз данных в Excel-файлы: dbf => xlsx, html. Создание html-файлов всех графических форм и баз данных текущего приложения и их списка для оформления свидетельства Роспатента на базы данных') DCMENUITEM L('5.13. Редактирование БД лемматизации ' ) PARENT oMenu5 ACTION {|| IF( !Running(), F5_13(),LB_Warning(sms,cmc)) } MESSAGE L('Ввод-корректировка базы данных лемматизации: "Lemma.dbf"') DCMENUITEM L('5.14. On-line HELP по лабораторным работам' ) PARENT oMenu5 ACTION {|| IF( !Running(), F5_14(),LB_Warning(sms,cmc)) } MESSAGE L('On-line описания лабораторных работ (статьи и с сайта автора: http://lc.kubagro.ru/), а также пояснения по смыслу частных и интегральных критериев') DCMENUITEM L('5.15. Локальные HELP по режимам системы' ) PARENT oMenu5 ACTION {|| IF( !Running(), F5_15(),LB_Warning(sms,cmc)) } MESSAGE L('Локальные пояснения по режимам системы "Эйдос", входящие в ее исполнимый модуль') DCMENUITEM L('5.16. Минимизация инсталляции системы' ) PARENT oMenu5 ACTION {|| IF( !Running(), F5_16(),LB_Warning(sms,cmc)) } MESSAGE L('5.16. Минимизация инсталляции системы завершена успешно! Было произведено удаление из текущей инсталляции системы "Эйдос" локальных лабораторных работ, базы лемматизации, всех языковых баз. В результате минимизации rar-архив папки с системой будет уже не около 120 Мб, а примерно 40 Мб. При этом удалении ранее установленные приложения не затрагиваются. Для удаления всех приложений служит специальный режим 1.11. Все удаленное входит в полную инсталляцию, которую можно скачать с сайта автора: http://lc.kubagro.ru/aidos/_Aidos-X.htm') DCSUBMENU oMenu6 PROMPT L('6. О системе') PARENT oMenuBar MESSAGE ' ' * DCMENUITEM SEPARATOR PARENT oMenu6 DCMENUITEM L('6.1. Информация о системе, разработчике и средствах разработки') PARENT oMenu6 ACTION {|| IF( !Running(), F6_1(),LB_Warning(sms,cmc)) } MESSAGE ' ' DCMENUITEM L('6.2. Ссылки на патенты, документацию и текущую версию системы ') PARENT oMenu6 ACTION {|| IF( !Running(), F6_2(),LB_Warning(sms,cmc)) } MESSAGE L('Internet-ссылки на патенты, монографии, учебные пособия, научные статьи и самую новую (на текущий момент) версию системы "Эйдос-Х++, а также полный комплект документации на нее одним файлом"') DCMENUITEM L('6.3. Развитый алгоритм принятия решений АСК-анализа ') PARENT oMenu6 ACTION {|| IF( !Running(), F6_3(),LB_Warning(sms,cmc)) } MESSAGE L('Развитый алгоритм принятия решений в интеллектуальных системах управления на основе АСК-анализа и системы "Эйдос"') DCMENUITEM L('6.4. Порядок преобразования данных в информацию, а ее в знания') PARENT oMenu6 ACTION {|| IF( !Running(), F6_4(),LB_Warning(sms,cmc)) } MESSAGE L('В режиме раскрывается соотношение содержания понятий: "Данные", "Информация" и "Знания", а также последовательность преобразования данных в информацию, а ее в знания в системе "Эйдос-Х++" с указанием имен баз данных и ссылками на основные публикации по этим вопросам') DCMENUITEM L('6.5. Графическая заставка системы "Эйдос-12.5" ') PARENT oMenu6 ACTION {|| IF( !Running(), F6_5(),LB_Warning(sms,cmc)) } MESSAGE ' ' DCMENUITEM L('6.6. Roger Donnay, Professional Developer, Developer eXPress++') PARENT oMenu6 ACTION {|| IF( !Running(), F6_6(),LB_Warning(sms,cmc)) } MESSAGE L('Roger Donnay, профессиональный разработчик программного обеспечения, разработчик высокоэффективной инструментальной системы программирования eXPress++, широко использованной при создании системы "Эйдос-Х++". Roger Donnay, Professional Developer, Developer eXPress++') DCMENUITEM L('6.7. Логотипы мультимоделей ') PARENT oMenu6 ACTION {|| IF( !Running(), F6_7(),LB_Warning(sms,cmc)) } MESSAGE 'Это надо видеть' DCMENUITEM L('6.8. Свидетельства РосПатента РФ на систему "Эйдос" ') PARENT oMenu6 ACTION {|| IF( !Running(), F6_8(),LB_Warning(sms,cmc)) } MESSAGE L('Основные (знаковые) свидетельства РосПатента на систему "Эйдос" 1994, 2003, 2012, 2017 годов') DCMENUITEM L('6.9. География пользователей системы "Эйдос-Х++" в мире ') PARENT oMenu6 ACTION {|| IF( !Running(), F6_9(),LB_Warning(sms,cmc)) } MESSAGE L('Когда кто-либо в мире запускает систему "Эйдос-Х++" на исполнение на компьютере, подключенном к Internet, то на она программно обращается к специально созданному сайту, на котором размещен PHP-код, определяющий дату и время обращения, IP-адрес компьютера, с которого произошло это обращение, и по нему домен, страна, округ, регион, город, почтовый индекс, временной пояс и географические координаты места запуска') * DCMENUITEM L('Создание изображения в памяти и его вывод с масштабированием ') PARENT oMenu6 ACTION {|| IF( !Running(), ScalingJpg(),LB_Warning(sms,cmc)) } MESSAGE L('Отладка формирования большого изображения в памяти и его вывода на экран с масштабированием') DCMENUITEM L('7. Выход') PARENT oMenuBar ACTION {|| F7() } MESSAGE L('Завершение сеанса работы в системе "Эйдос". Перед выходом из системы осуществляется дополнение русской языковой базы текстовыми элементами интерфейса, которые встретились в текущем сеансе запуска системы "Эйдос" и которых не было в этой базе данных. Русская языковая база является основой для формирования в режиме 1.4 языковых баз по другим 43 языкам, поддерживаемых системой "Эйдос"') @ 100,100 DCSTATIC TYPE XBPSTATIC_TYPE_RAISEDBOX ; OBJECT oMessageBox ; INVISIBLE ; COLOR DC_XbpMenuConfig()[2], DC_XbpMenuConfig()[3] * @ 4,4 DCSAY L('System Aidos') ; * PARENT oMessageBox ; * FONT '10.MS Sans Serif' ; * SAYOPTION XBPSTATIC_TEXT_VCENTER + XBPSTATIC_TEXT_CENTER + XBPSTATIC_TEXT_WORDBREAK ; * COLOR DC_XbpMenuConfig()[9], DC_XbpMenuConfig()[1] @ 4,4 DCSAY L('System Aidos') ; PARENT oMessageBox ; SAYOPTION XBPSTATIC_TEXT_VCENTER + XBPSTATIC_TEXT_CENTER + XBPSTATIC_TEXT_WORDBREAK ; COLOR DC_XbpMenuConfig()[9], DC_XbpMenuConfig()[1] DCGETOPTIONS ; WINDOWHEIGHT H_MainWind ; WINDOWWIDTH W_MainWind DCREAD GUI ; TITLE L('(C) Персональная интеллектуальная онлайн среда "ЭЙДОС-X Professional" (Система "Эйдос-Хpro"),')+' ADS-'+mADStxt+L(', beta-version, rel: 23.05.2025.') ; HANDLER MenuHandler REFERENCE @oMessageBox ; OPTIONS GetOptions ; EVAL {|o|oDlg := o}; PARENT @oDlgBmp * DCREAD GUI TITLE L('Смена фона каждую секунду, минуту, час') PARENT @oDlgBmp OPTIONS GetOptions oTimer:destroy() // Закрытие фона главного меню * RECOVER // код обработки ошибки * aMess := {} * AADD(aMess, L('Возникла ошибка исполнения при попытке запуска режима главного меню системы "Эйдос". ')) // НАПРИМЕР * AADD(aMess, L('Скорее всего эта произошло потому, что не завершен предыдущий режим, также запущенный ')) * AADD(aMess, L('из главного меню. Это могло привести к нарушению среды исполнения, например попытке ')) * AADD(aMess, L('повторного открытия уже открытых и занятых баз данных. Необходимо завершить предыдущий')) * AADD(aMess, L('режим в панели задач, закрывая ранее открытые окна справа на лево в порядке, обратном ')) * AADD(aMess, L('их открытию и повторить попытку запуска режима. Возможно потребуется выйти из системы ')) * AADD(aMess, L('"Эйдос" и опять войти в нее, а затем сразу запустить нужный режим из главного меню. ')) * LB_Warning(aMess) ** EXIT * ENDSEQUENCE * ErrorBlock( bErrorMM ) // переустановить старый кодовый * ****************************************** *ENDIF // Внешнее управление ? ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы * USE PathGrAp EXCLUSIVE NEW * USE Appls EXCLUSIVE NEW * USE Users EXCLUSIVE NEW ADS_SERVER_QUIT() RETURN NIL *********************************************************************************************************** ******** 6.1. Информация о системе, разработчике и средствах разработки *********************************************************************************************************** FUNCTION F6_1() Running(.T.) aHelp := {} AADD(aHelp, L('ИНФОРМАЦИЯ О СИСТЕМЕ И РАЗРАБОТЧИКЕ:')) AADD(aHelp, L('(C) Персональная интеллектуальная онлайн среда "ЭЙДОС-X Professional" (Система "Эйдос-Хpro"),')+' ADS-'+mADStxt+L(', beta-version, rel: 23.05.2025. ')) AADD(aHelp, L('(C) д.э.н., к.т.н., профессор Луценко Евгений Вениаминович, Россия, Краснодар. ORCID: http://orcid.org/0000-0002-2742-0502, Blog: https://www.researchgate.net/profile/Eugene-Lutsenko, URL: http://lc.kubagro.ru/, ')) AADD(aHelp, L('E-mail: prof.lutsenko@gmail.com, Страницы университетов и РАЕ: http://kubsau.ru/education/chairs/comp-system/staff/3965/, https://kubsu.ru/ru/public-portfolio/39926, http://www.famous-scientists.ru/17314/, ')) AADD(aHelp, L('Skype: eugene_lutsenko. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('ТЕОРЕТИЧЕСКИЕ ОСНОВЫ СИСТЕМЫ: ')) AADD(aHelp, L('Система "Эйдос-Хpro" является программным инструментарием Автоматизированного системно-когнитивного анализа (АСК-анализ). АСК-анализ включает: теоретические основы, в частности базовую ')) AADD(aHelp, L('формализуемую когнитивную концепцию; математическую модель, основанную на системном обобщении теории информации (СТИ); методику численных расчетов (структуры баз данных и алгоритмы их обработки); ')) AADD(aHelp, L('программный инструментарий, в качестве которого в настоящее время выступает Система "Эйдос-Хpro". Принципиальным отличием системы "Эйдос-Хpro" от всех предыдущих версий системы "Эйдос" является то, ')) AADD(aHelp, L('что в ней практически сняты ограничения на объем исходных данных, т.е. она обеспечивает обработку больших данных (BigData), преобразование их в большую информации (BigInformation, а ее в большие знания ')) AADD(aHelp, L('(BigKnowledge) и решение на основе этих знаний большого количества задач в различных предметных областях. Это сделано путем применения локального Advantage Database Server (ADS). ')) AADD(aHelp, L('ФУНКЦИИ СИСТЕМЫ: ')) AADD(aHelp, L('Система "Эйдос-Хpro", разработана в универсальной постановке, не зависящей от предметной области, и ОБЕСПЕЧИВАЕТ решение следующих задач и подзадач: Задача-1. Когнитивная структуризация предметной ')) AADD(aHelp, L('области. Задача-2. Автоматизированная формализация предметной области (разработка классификационных и описательных шкал и градаций и кодирование с их помощью исходных данных, в результате чего они ')) AADD(aHelp, L('преобразуются в обучающую выборку. Задача-3. Синтез 3 статистических и 7 системно-когнитивных моделей (многопараметрическая типизация) с различными частными критериями знаний. Задача-4. Верификация ')) AADD(aHelp, L('моделей путем решения задачи идентификации обучающей выборки. Задача-5. Выбор наиболее достоверной модели по F-критерию Ван Ризбергена и его нечеткому мультиклассовому обобщению, инвариантному ')) AADD(aHelp, L('относительно объема обучающей выборки. Задача-6. Решение задачи идентификации и прогнозирования (системная идентификацию). Задача-7. Решение задачи принятия решений (Упрощенный вариант принятия ')) AADD(aHelp, L('решений как обратная задача прогнозирования, позитивный и негативный информационные портреты классов, SWOT-анализ. Развитый алгоритм принятия решений в автоматизированных интеллектуальных ')) AADD(aHelp, L('адаптивных системах управления на основе АСК-анализа и системы "Эйдос"). Задача-8. Решение задачи исследования объекта моделирования путем исследования его модели: Инвертированные SWOT-диаграммы ')) AADD(aHelp, L('значений описательных шкал (семантические потенциалы); Кластерно-конструктивный анализ классов; Кластерно-конструктивный анализ значений описательных шкал; Модель знаний системы "Эйдос" и ')) AADD(aHelp, L('нелокальные нейроны; Нелокальная нейронная сеть; 3D-интегральные когнитивные карты; 2D-интегральные когнитивные карты содержательного сравнения классов (опосредованные нечеткие правдоподобные ')) AADD(aHelp, L('рассуждения); 2D-интегральные когнитивные карты содержательного сравнения значений факторов (опосредованные нечеткие правдоподобные рассуждения); Когнитивные функции; Значимость описательных шкал ')) AADD(aHelp, L('и их градаций; Степень детерминированности классов и классификационных шкал. ')) AADD(aHelp, L('РАЗРАБОТЧИК концепции, математической модели (системной теории информации - СТИ), методики численных расчетов (структур данных и алгоритмов), программной реализации (100% кода на xBase++: ')) AADD(aHelp, L('Аляска+Экспресс++ADS), технологии и методики применения системы "Эйдос-X" (АСК-анализ) д.э.н., к.т.н., профессор Луценко Евгений Вениаминович, Alaska CID: E098865, http://Lc.lubagro.ru, ')) AADD(aHelp, L('prof.lutsenko@gmail.com. Система "Эйдос-Хpro" разработана по инициативе автора: проф. Е.В.Луценко, без заказа и финансирования со стороны каких-либо физических и юридических лиц и все права на нее ')) AADD(aHelp, L('принадлежат автору (см. Патент РФ: http://lc.kubagro.ru/aidos/2012619610.jpg, http://lc.kubagro.ru/aidos/index.htm и статью: Луценко Е.В. 30 лет системе "Эйдос" - одной из старейших отечественных универсальных ')) AADD(aHelp, L('систем искусственного интеллекта, широко применяемых и развивающихся и в настоящее время / Е.В. Луценко // Политематический сетевой электронный научный журнал Кубанского государственного аграрного ')) AADD(aHelp, L('университета (Научный журнал КубГАУ) [Электронный ресурс]. - Краснодар: КубГАУ, 2009. - №10(54). С. 48 - 77. - Шифр Информрегистра: 0420900012\0110. - Режим доступа: http://ej.kubagro.ru/2009/10/pdf/04.pdf, ')) AADD(aHelp, L('1,875 у.п.л.). ')) AADD(aHelp, L('УЧАСТИЕ В РАЗРАБОТКЕ И СОАВТОРСТВО: ')) AADD(aHelp, L('- Концепция групп приложений и алгоритмы голосования частных моделей в мультимодели разработаны проф.Е.В.Луценко совместно с Ph.D, Cand.Phys.-Math.Sci., prof. Alexander Trunev, Director, A&E Trounev IT ')) AADD(aHelp, L('Consulting, Toronto, Canada: http://chaosandcorrelation.org; ')) AADD(aHelp, L('- Дмитрий Константинович Бандык, разработчик интеллектуальных систем из Белоруссии, разработал по постановке проф.Е.В.Луценко режимы: 1.8. Создание градиентных фонов главного окна, 4.5. Визуализация ')) AADD(aHelp, L('когнитивных функций, 6.7. Визуализация логотипов мультимоделей, 3.1. Ускоренный синтез моделей на графическом процессоре (GPU), 3.2. Распознавание во всех моделях на графическом процессоре (GPU); ')) AADD(aHelp, L('- Алексей Семенович Креймер: визуализация мест запусков системы"Эйдос" на карте мира, http://kubsau.ru/education/chairs/comp-system/staff/3395/. ')) AADD(aHelp, L('- Владлен Замышляев: кластерная картографическая визуализация запусков системы "Эйдос" на карте мира http://github.com/Tapoch; ')) AADD(aHelp, L('КОНСУЛЬТАТИВНАЯ И МЕТОДИЧЕСКАЯ ПОДДЕРЖКА ПРОГРАММНОЙ РЕАЛИЗАЦИИ: ')) AADD(aHelp, L('- Roger Donnay, Professional Developer, Developer eXPress++, Boise, Idaho USA, http://donnay-software.com; ')) AADD(aHelp, L('- Boris Borzic is the CTO & President of Xb2.NET Inc. http://www.xb2.net; ')) AADD(aHelp, L('- Clifford Wiernik, CPA/CNE, Senior IT Analyst, www.aquafinance.com cwiernik@aquafinance.com, Tel: 800-234-3663 x1126, Fax: 715-848-1411, Aqua Finance, Inc, One Corporate Dr, Ste 300, Wausau WI 54401, USA; ')) AADD(aHelp, L('- dipl.ing.Slobodan Stanojevic Coba, Programi za knjigovodstvo CSYSTEMS, Office:19300 NEGOTIN Srbe Jovanovica 1/10, +38119542070 Centrala, 064 2185522 Coba, 060 0562187 Marko, http://www.cobasystems.com, ')) AADD(aHelp, L('помощь в освоении технологии локального Advantage Database Server (ADS) в интерфейсе ISAM. ')) AADD(aHelp, L('ЛИЦЕНЗИОННЫЕ СРЕДСТВА РАЗРАБОТКИ: ')) AADD(aHelp, L('- Alaska Xbase++ (R) Version 1.90.355 SL1 (международный), Сер.№106281-143290, XbToolsIII V1.90 (международный), Сер.№205281-143319, http://alaska-software.com/, eXPress++ (C) Version 1.9 Build 255, ')) AADD(aHelp, L('http://donnay-software.com. ')) AADD(aHelp, L('- Advantage Database Server: ADS DatabaseEngine V1.90 (международный), Сер.№506281-143458; ')) AADD(aHelp, L('- Xb2.NET ver 3.4.00. http://www.xb2.net; ')) AADD(aHelp, L('- Xbase ++ Проф. V2.00 (международный), Professional Edition, Сер.№ 127980. ')) AADD(aHelp, L('БЛАГОДАРНОСТИ: ')) AADD(aHelp, L('За приобретение лицензионных средств в 2012-2015 годах разработки автор благодарен зав.кафедрой компьютерных технологий и систем проф. В.И.Лойко и проректору по научной работе ФГБОУ ВО "Кубанский ')) AADD(aHelp, L('государственный аграрный университет имени И.Т.Трубилина" проф. Ю.П.Федулову. Особая благодарность лично Steffen Pirsig - Члену совета директоров, - главному архитектору, соучредителю Alaska Software Inc ')) AADD(aHelp, L('(http://www.xing.com/profile/Steffen_Pirsig) за истинно царский подарок, который он сделал в конце 2020 года: инструментальную систему: Xbase++ 2.0, Professional Edition, Сер.№ 127980. ')) mHelpMax = -999;FOR h=1 TO LEN(aHelp);mHelpMax = MAX(mHelpMax, LEN(ALLTRIM(aHelp[h])));NEXT s=1;d=0.8;@0,0 DCGROUP oGroup1 CAPTION L(' ') SIZE mHelpMax-48, LEN(aHelp)*d+1.5 FOR h=1 TO LEN(aHelp);@s,2 DCSAY aHelp[h] SIZE 0 PARENT ogroup1;s=s+d;NEXT DCREAD GUI TO lExit FIT TITLE L('6.1. О системе "ЭЙДОС-X++", авторе-разработчике, средствах разработки и поддержке.') Running(.F.) RETURN NIL ************************************************************************************************** ************************************************************************************************** *** Функции Слободана для работы c Advantage Database Server (ADS) ************************************************************************************************** *================================== * CONTENTS: ADS SERVER PROGRAMS *================================== * PROCEDURE DBESYS() * FUNCTION ADS_SERVER_START() * FUNCTION ADS_SERVER_QUIT() * FUNCTION ADS_SERVER_TIP(oSession) *************************************************************************** *PROCEDURE DBESYS() // Overload the default DBESYS for your required DBE *************************************************************************** *//----- FOXCDX: DBF-FPT-CDX * IF ! DbeLoad( "FOXDBE", .T.) // load engine for DBF files * msgbox( "Database Engine FOXDBE not loaded" , "STOP" ) * QUIT * ENDIF * IF ! DbeLoad( "CDXDBE", .T.) // load engine for DBF files * msgbox( "Database Engine CDXDBE not loaded" , "STOP" ) * QUIT * ENDIF * DbeBuild( "FOXCDX", "FOXDBE", "CDXDBE" ) // DBE=FOXCDX * *** DbeSetDefault("FOXCDX") // OFF *//----- DBFNTX: DBF-DBT-NTX *// ADS client engine and ALS Local Server engine exist *// Overload the default DBESYS for your required DBE *// system for working with DBF/NTX files on both server and client * IF ! DbeLoad( "DBFDBE") // load engine for DBF files * msgbox( "Database Engine DBFDBE not loaded" , "STOP" ) * QUIT * ENDIF * IF ! DbeLoad( "NTXDBE") // load engine for DBF files * msgbox( "Database Engine NTXDBE not loaded" , "STOP" ) * QUIT * ENDIF * DbeBuild( "DBFNTX", "DBFDBE", "NTXDBE" ) // DBE=DBFNTX * *** DbeSetDefault("DBFNTX") // OFF *//----- ADSDBE: DBF-DBT-NTX *// there must be ACE32.DLL otherwise it breaks here !!! *// mora postojati ACE32.DLL inaиe ovde pukne !!! *//----------------------------------------------------- * IF ! DbeLoad( "ADSDBE", .F.) // load engine for ADS * msgbox( "Database Engine ADSDBE not loaded" , "STOP" ) * QUIT * ENDIF *********************** * DbeSetDefault("ADSDBE") // ON *********************** *RETURN *************************************************************************** FUNCTION ADS_SERVER_START() *************************************************************************** PUBLIC oSession := NIL PUBLIC cServerTip := "" PUBLIC Server_DRIVE := "C:" // connect to the ADS server oSession := dacSession():New( "ADSDBE", Server_DRIVE ) cr:=chr(13) IF ( oSession:isConnected() ) = .T. cServerTip := ADS_SERVER_TIP(oSession) * // test message only * confirmbox(,"Connecting to server "+cServerTip +cr+; * "to location: server drajv "+Server_DRIVE +cr+; * " " +cr+; * "Advantage Database Server is ON" +cr+; * " " ,; * "SERVER: connection OK",; * XBPMB_OK,XBPMB_INFORMATION,XBPMB_SYSMODAL) ELSE // Konekcija nije uspela obavezno izdaj poruku! // Connection failed be sure to issue a message! cServerTip := ADS_SERVER_TIP(oSession) // issue a message error := var2char(oSession:getLastError()) * confirmbox(,"Connecting to server "+cServerTip +cr+; * "to location: server drajv "+Server_DRIVE +cr+; * " " +cr+; * "Advantage Database Server is OFF" +cr+; * " " +cr+; * "Server connection Error: "+error +cr+; * " " ,; * "SERVER: connection Error",; * XBPMB_OK,XBPMB_CRITICAL,XBPMB_SYSMODAL) ****** QUIT ****** ENDIF RETURN NIL *************************************************************************** FUNCTION ADS_SERVER_QUIT() *************************************************************************** // disconnect from the ADS cServerTip := ADS_SERVER_TIP(oSession) ********************** oSession:disconnect() ********************** cr:=chr(13) *confirmbox(,"Disconnecting from server "+cServerTip +cr+; * "to location: server drajv "+Server_DRIVE +cr+; * " " +cr+; * "Advantage Database Server is OFF" +cr+; * " " ,; * "SERVER: diskonnection OK",; * XBPMB_OK,XBPMB_INFORMATION,XBPMB_SYSMODAL ) RETURN NIL *************************************************************************** FUNCTION ADS_SERVER_TIP(oSession) *************************************************************************** nServerType := oSession:setProperty( ADSDBE_SERVER_TYPE ) IF nServerType == ADSDBE_LOCAL .OR. nServerType == 0 RETURN "::LOCAL SERVER" ELSE RETURN "::REMOTE SERVER" ENDIF RETURN "::STOP SERVER" *** Функции Слободана для работы c Advantage Database Server (ADS) *************************************************************************** ******************************************************************** FUNCTION BigData() // Функция для отладки работы с большими данными (DBF-файлы >>> 2 Gb) ******************************************************************************** ******************************************************************************** * FUNCTION Main() LOCAL Getlist := {}, oProgress, oDialog LOCAL aSay[30], Mess97, Mess98, Mess99 // Массив сообщений отображаемых стадий исполнения (до 30 на экране) DC_IconDefault(1000) ADS_SERVER_START() SET DECIMALS TO 15 SET DATE GERMAN SET ESCAPE On ******************************************************************** mNField = 10 // Максимум 2040 mNRecord = 10 // Максимум 1000000000000 @1,1 DCGROUP oGroup1 CAPTION 'Задайте параметры базы данных:' SIZE 40.0, 3.5 @1,2 DCSAY "Количество полей:" PARENT oGroup1 @1,20 DCSAY "" GET mNField PICTURE "##########" PARENT oGroup1 @2,2 DCSAY "Количество записей:" PARENT oGroup1 @2,20 DCSAY "" GET mNRecord PICTURE "##########" PARENT oGroup1 DCREAD GUI; TO lExit ; FIT; ADDBUTTONS; MODAL; TITLE 'Эксперименты с ADS и PGDBU' IF lExit ** Button Ok ELSE QUIT ENDIF ******************************************************************** Wsego = mNRecord // Отображение стадии исполнения. Будет написано прямо в окне Progress-bar d = 0 @0,0 DCGROUP oGroup1 CAPTION 'Стадии исполнения процесса' FONT "6.Helv" SIZE 105+d, 2.5 PARENT oTabPage1 @4,0 DCGROUP oGroup2 CAPTION 'Прогноз времени исполнения' FONT "6.Helv" SIZE 105+d, 5.0 PARENT oTabPage2 s = 1 @s++,1 DCSAY " " SAYSIZE 100 SAYOBJECT aSay[ 1] FONT "10.Helv" s++ @s++,1 DCSAY " " SAYSIZE 100 SAYOBJECT oSay97 FONT "10.HelvBold" s++ @0.2+s++,1 DCSAY " " SAYSIZE 100 SAYOBJECT oSay98 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @1.5+s ,1 DCSAY " " SAYSIZE 100 SAYOBJECT oSay99 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @s ,1 DCPROGRESS oProgress ; SIZE 95,1.5 ; PERCENT ; EVERY 1; // Кол-во обновлений изображения MAXCOUNT Wsego; COLOR GRA_CLR_CYAN // Цвет полосы @s++,97 DCPUSHBUTTON CAPTION '&Cancel' ; ACTION {||lOk:=.T.} OBJECT oButton ; SIZE 7,1.5 DCREAD GUI ; TITLE 'Создание базы данных "BigData.dbf"' ; PARENT @oDialog ; FIT ; EXIT ; MODAL oDialog:alwaysOnTop = .T. // Окно открывается на переднем плане oDialog:show() ****** Обработка ошибки ****************** bError := ErrorBlock( {|e| Break(e)} ) // установить новый кодовый блок обработки ошибок BEGIN SEQUENCE // код нормального исполнения *** код нормального исполнения aStructure := { { "NumbRecord" , "N", 19, 0} } FOR j=1 TO mNField FieldName = "F"+ALLTRIM(STR(j,19)) AADD(aStructure, { FieldName , "N", 19, 7 }) NEXT DbCreate( "BigData.dbf", aStructure ) RECOVER // код обработки ошибки aMess := {} AADD(aMess, "Возникла ошибка при попытке создания БД с числом полей: "+ALLTRIM(STR(mNField))) LB_Warning(aMess, 'Эксперименты с "BigData.dbf"') MsgBox('') ADS_SERVER_QUIT() QUIT ENDSEQUENCE ErrorBlock( bError ) // переустановить старый кодовый ****************************************** // Начало отсчета времени для прогнозирования длительности исполнения Time_progress = 0 // Прошло секунд с начала процесса // Процесс может идти больше суток, поэтому для определения // во всех случаях вычисляется время, прошедшее с начала года T_Mess1 = "Начало:"+" "+TIME() // Начало Sec_1 = (DOY(DATE())-1)*86400+SECONDS() PUBLIC T1 := (DOY(DATE())-1)*86400+SECONDS() // Время предыдущей индикации процесса исполнения PUBLIC T2 := (DOY(DATE())-1)*86400+SECONDS()+1 // Текущее время (1-й раз оно заметно больше T1 чтобы было отображение) PUBLIC T1tp := T1 PUBLIC T2tp := T2 ********************************************************************************* ****** Обработка ошибки ****************** bError := ErrorBlock( {|e| Break(e)} ) // установить новый кодовый блок обработки ошибок BEGIN SEQUENCE // код нормального исполнения *** код нормального исполнения aSay[ 1]:SetCaption('Идет процесс создания базы данных: "BigData.dbf"') USE BigData EXCLUSIVE NEW FOR r=1 TO mNRecord APPEND BLANK REPLACE NumbRecord WITH r lOk = Time_Progress (++Time_Progress, mNRecord, oProgress, lOk ) NEXT RECOVER // код обработки ошибки CLOSE ALL aMess := {} AADD(aMess, "Возникла ошибка при попытке добавления в БД записи N=й: "+ALLTRIM(STR(r))) LB_Warning(aMess, 'Эксперименты с "BigData.dbf"') MsgBox('') * ADS_SERVER_QUIT() * QUIT ENDSEQUENCE ErrorBlock( bError ) // переустановить старый кодовый ****************************************** ADS_CopyFile('BigData.dbf', 'BigDdds.dbf', .T., .F.) ***** Удаление старых версий файла START_AIDOS запуска и обновления системы Эйдос, если они есть <<<===####################### CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * aDir := Directory("*START_AIDOS-X*.exe") mNStartAidos = ADIR("*START_AIDOS-X*.exe") PRIVATE aFileName[mNStartAidos], aFileSize[mNStartAidos], aFileDate[mNStartAidos], aFileTime[mNStartAidos] ADIR("*START_AIDOS-X*.exe", aFileName, aFileSize, aFileDate, aFileTime) * LB_Warning(aFileName, 'Эксперименты с "BigData.dbf"') aStructure := { { 'File_Num ', "C", 8, 0 }, ; { 'File_Name', "C", 40, 0 }, ; // ___START_AIDOS-X_2021_10_26.exe { 'File_Size', "N", 10, 0 }, ; { 'File_Date', "D", 8, 0 }, ; { 'File_Time', "C", 8, 0 }, ; { 'Delete ', "C", 1, 0 } } * DbCreate( "StartAidos.dbf", aStructure, "DBFNTX" ) // ALL NB !!! DbCreate( "StartAidos", aStructure ) // ALL NB !!! * USE ("StartAidos.dbf") NEW SHARED ALIAS "START_AIDOS" USE StartAidos EXCLUSIVE NEW IF LEN(aFileName) > 0 * FOR j := 1 TO Len(aDir) * APPEND BLANK * REPLACE File_Num WITH ALLTRIM(STR(j)) * REPLACE File_Name WITH aDir[j,F_NAME] * REPLACE File_Size WITH aDir[j,F_SIZE] * REPLACE File_Date WITH DTOS(aDir[j,F_WRITE_DATE]) * REPLACE File_Time WITH aDir[j,F_WRITE_TIME] * REPLACE Delete WITH 'Y' * NEXT FOR j := 1 TO Len(aFileName) APPEND BLANK REPLACE File_Num WITH ALLTRIM(STR(j)) REPLACE File_Name WITH aFileName[j] REPLACE File_Size WITH aFileSize[j] REPLACE File_Date WITH aFileDate[j] REPLACE File_Time WITH aFileTime[j] REPLACE Delete WITH 'Y' NEXT INDEX ON DTOS(File_Date)+File_Time TO StartAidos DBGOBOTTOM() REPLACE Delete WITH 'N' mFileName = ALLTRIM(File_Name) MsgBox(mFileName) DBGOTOP() DO WHILE .NOT. EOF() IF Delete = 'Y' ERASE(File_Name) ENDIF DBSKIP(1) ENDDO CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций IF mFileName <> "___START_AIDOS-X.exe" ADS_CopyFile(mFileName, '___START_AIDOS-X.exe', .F., .T.) // Скопировать новый файл запуска со стандартным именем и удалить новый файл ENDIF ENDIF ****************************************** * РАБОТА С БАЗАМИ ДАННЫХ ****************************************** CLOSE ALL oSay97:SetCaption(oSay97:caption) oButton:SetCaption('&Ok') // Деструктурирование окна отображения графического Progress-bar oButton:activate := {||PostAppEvent(xbeP_Close,,,oDialog)} //<<<<<< Add This DC_AppEvent( @lOk ) * PostAppEvent(xbeP_Activate,,,DC_GetObject(GetList,'DCGUI_BUTTON_OK')) // Роджер oDialog:Destroy() aMess := {} AADD(aMess, 'База данных: "BigData.dbf" успешно создана') LB_Warning(aMess, 'Эксперименты с "BigData.dbf"') ADS_SERVER_QUIT() RETURN NIL ***************************************************************************************************** FUNCTION ADS_CopyFile(mFileName1, mFileName2, mDialod, mDelete) // Копирование файла при ADSDBE ON ****** Обработка ошибки ****************** bError := ErrorBlock( {|e| Break(e)} ) // установить новый кодовый блок обработки ошибок BEGIN SEQUENCE // код нормального исполнения *** код нормального исполнения IF mDialod oScr := DC_WaitOn('Копирование файла: '+ALLTRIM(mFileName1)+' ===>>> '+ALLTRIM(mFileName2)+'. Немного подождите!!!',,,,,,,,,,,.F.) ENDIF CLOSE ALL DbeSetDefault("DBFNTX") // ADS OFF COPY FILE (mFileName1) TO (mFileName2) // <<<===########################## kill IF mDelete ERASE(mFileName1) ENDIF DbeSetDefault("ADSDBE") // ADS ON IF mDialod DC_Impl(oScr) ENDIF * IF mDialod * aMess := {} * AADD(aMess, L('Копирование файла:')+' '+ALLTRIM(mFileName1)+' ===>>> '+ALLTRIM(mFileName2)+' '+L('завершено нормально !!!')) * AADD(aMess, '') * LB_Warning(aMess, L('(C) Система "Эйдос-Хpro"')) * ENDIF mFlagError = .F. RECOVER // код обработки ошибки IF mDialod DC_Impl(oScr) aMess := {} AADD(aMess, L('При копировании файла:')+' '+ALLTRIM(mFileName1)+' ===>>> '+ALLTRIM(mFileName2)) AADD(aMess, L('возникла ошибка. С причинами этой ошибки надо разбираться отдельно.')) LB_Warning(aMess, L('(C) Система "Эйдос-Хpro"')) ENDIF mFlagError = .T. * EXIT ENDSEQUENCE ErrorBlock( bError ) // переустановить старый кодовый блок ****************************************** RETURN(mFlagError) ****************************************************************************************** ******** Функция, которая запускает команду, заданную в виде текстового параметра ****************************************************************************************** Function StartFunctTXT(cText) Local bBlock := "{|| "+cText +" )}" Local uResult bBlock := &(bBlock) // <<<===####### Error uResult := eval(bBlock) return uResult ****************************************************************************************** Function StartFunctPar(cFunction,cPara1,cPara2) Local bBlock := "{|cPara1,cPara2| " + cFunction+"(cPara1,cPara2) }" Local bFunction if IsFunction(cFunction) bBlock := &(bBlock) eval(bBlock,cPara1,cPara2) else msgbox("Function not available") endif return nil ****************************************************************************************** *** Regan Cawkwell *Below is a function we use a lot to execute / open a specific webpage in a users internet browser. As an example, you can use it like the below: *ShellOpenFile("http://www.google.com/") *Maybe that would work with the URL that you posted instead of runshell? //--------------------------------------------------------------------- *#include "dll.ch" *#define SW_HIDE 0 *#define SW_NORMAL 1 *#define SW_SHOWMINIMIZED 2 *#define SW_SHOWMAXIMIZED 3 *#define SW_MAXIMIZE 3 *#define SW_SHOWNOACTIVATE 4 *#define SW_SHOW 5 *#define SW_MINIMIZE 6 *#define SW_SHOWMINNOACTIVE 7 *#define SW_SHOWNA 8 *#define SW_RESTORE 9 *#define SW_SHOWDEFAULT 10 *#define SE_ERR_FNF 2 *#define SE_ERR_PNF 3 *#define SE_ERR_ACCESSDENIED 5 *#define SE_ERR_OOM 8 *#define SE_ERR_DLLNOTFOUND 32 *#define SE_ERR_SHARE 6 *#define SE_ERR_ASSOCINCOMPLETE 27 *#define SE_ERR_DDETIMEOUT 28 *#define SE_ERR_DDEFAIL 29 *#define SE_ERR_DDEBUSY 30 *#define SE_ERR_NOASSOC 31 *#define ERROR_BAD_FORMAT 11 PROCEDURE DC_SpawnURL( cFile ) LOCAL nReturn, cMsg nReturn:=DllCall( "SHELL32.DLL",DLL_STDCALL,"ShellExecuteA",AppDesktop():GetHWND(),"open",cFile,NIL,CurDir(),SW_NORMAL) If nReturn <= 32 cMsg:="Error trying to launch "+cFile+";;" do case Case nReturn == SE_ERR_FNF cMsg += "File not found" Case nReturn == SE_ERR_PNF cMsg += "Path not found" Case nReturn == SE_ERR_ACCESSDENIED cMsg += "Access denied" Case nReturn == SE_ERR_OOM cMsg += "Out of memory" Case nReturn == SE_ERR_DLLNOTFOUND cMsg += "DLL not found" Case nReturn == SE_ERR_SHARE cMsg += "A sharing violation occurred" Case nReturn == SE_ERR_ASSOCINCOMPLETE cMsg += "Incomplete or invalid file association" Case nReturn == SE_ERR_DDETIMEOUT cMsg += "DDE Time out" Case nReturn == SE_ERR_DDEFAIL cMsg += "DDE transaction failed" Case nReturn == SE_ERR_DDEBUSY cMsg += "DDE busy" Case nReturn == SE_ERR_NOASSOC cMsg += "No association for file extension" Case nReturn == ERROR_BAD_FORMAT cMsg += "Invalid EXE file or error in EXE image" Otherwise cMsg += "Unknown Error Code ("+ntrim(nReturn)+")" EndCase dc_alert(cMsg) EndIf RETURN //--------------------------------------------------------------------- ****************************************************************************************** ******** Скачивание всех статей проф.Е.В.Луценко из Научного журнала КубГАУ ****************************************************************************************** FUNCTION DownloadArticles() LOCAL cFile, oHC LOCAL Getlist := {}, oProgress, oDialog, lCancelled := .F., lStatus := .T. LOCAL aSay[30], Mess97, Mess98, Mess99 // Массив сообщений отображаемых стадий исполнения (до 30 на экране) * DC_IconDefault(1000) * RunShell("","__aidos-x.exe",.T.) SET DECIMALS TO 15 SET DATE GERMAN SET ESCAPE On SET COLLATION TO SYSTEM // Русификация *SET COLLATION TO ASCII // Русификация ****************************************************************************************************************************** IF InternetGetConnectedState( @n, 0 ) == 0 LB_Warning('Система не может скачать публикации, т.к. нет соединения с Internet!', 'C° Пакетное скачивание публикаций') RETURN NIL ENDIF PUBLIC Disk_name := DISKNAME() PUBLIC Cur_dir := CURDIR() PUBLIC Disk_dir := Disk_name+":\"+Cur_dir // Путь на папку с системой mDataSource = 1 * @0,0 DCGROUP oGroup1 CAPTION 'Укажите источник данных с гиперссылками на публикации:' SIZE 63, 9.7 * @1.0, 2 DCRADIO mDataSource VALUE 1 PROMPT 'Страница в Internet' PARENT oGroup1 * @2.0, 2 DCRADIO mDataSource VALUE 2 PROMPT 'Текстовый файл' PARENT oGroup1 * mIntAddr = "http://lc.kubagro.ru/aidos/_Aidos-X.htm " mIntAddr = "http://ej.kubagro.ru/t2.asp?aut=11&keepThis=true&TB_iframe=true&width=750" * @4, 2 DCGROUP oGroup2 CAPTION 'Задайте адрес страницы в Internet:' SIZE 59, 3.7 PARENT oGroup1 HIDE {|| .NOT.mDataSource=1} * @1, 2 DCGET mIntAddr PICTURE 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX' PARENT oGroup2 * @2.5, 2 DCSAY 'На странице должны быть абсолютные гиперссылки на публикации' PARENT oGroup2 * mFileName = "ListArticles.txt " * @4, 2 DCGROUP oGroup3 CAPTION 'Задайте имя текстового файла:' SIZE 59, 4.7 PARENT oGroup1 HIDE {|| .NOT.mDataSource=2} * @1, 2 DCGET mFileName PICTURE 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX' PARENT oGroup3 * @2.5, 2 DCSAY 'В текстовом файле должны быть абсолютные гиперссылки на публикации' PARENT oGroup3 * @3.5, 2 DCSAY 'Текстовый файл должен быть стандарта DOS TXT' PARENT oGroup3 * DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE * DCREAD GUI ; * TO lExit ; * FIT ; * OPTIONS GetOptions ; * ADDBUTTONS; * MODAL ; * TITLE 'C° Пакетное скачивание публикаций' * ***************************************************************** * IF lExit * ** Button Ok * ELSE * RETURN NIL * ENDIF * ***************************************************************** mIntAddr = STRTRAN(mIntAddr, ' ','') mFileName = STRTRAN(mFileName,' ','') DO CASE CASE mDataSource = 1 mIntAddr = ALLTRIM(mIntAddr) cFile = '' cFile := LoadFromURL(mIntAddr) // Считывает страницу сайта в текстовую переменную. Но с некоторыми сайтами не получается StrFile(cFile, 'ListArticles.txt') IF AT('404 - File or directory not found',cFile) > 0 aMess := {} AADD(aMess, 'Заданного Internet-адреса не существует:') AADD(aMess, mIntAddr) LB_Warning(aMess, 'C° Пакетное скачивание публикаций') RETURN NIL ENDIF CASE mDataSource = 2 mFileName = ALLTRIM(mFileName) IF .NOT. FILE(mFileName) aMess := {} AADD(aMess, 'В папке с программой: "'+Disk_dir+'"') AADD(aMess, 'должен быть DOS-TXT файл: "'+mFileName+'"') AADD(aMess, 'со списком публикаций и абсолютными гиперссылками на них') LB_Warning(aMess, 'C° Пакетное скачивание публикаций') RETURN NIL ENDIF cFile = FileStr(mFileName) StrFile(cFile, 'ListArticles.txt') ENDCASE PRIVATE aPar[2] AFILL(aPar, .T.) @ 1.3, 6 DCSAY 'Скачивать PDF-файлы статей' FONT "9.Helv" @ 2.3, 6 DCSAY 'Скачивать DOC-файлы статей в ZIP' FONT "9.Helv" @ 1,2 DCCHECKBOX aPar[1] @ 2,2 DCCHECKBOX aPar[2] DCREAD GUI ; TO lExit ; FIT ; MODAL ; ADDBUTTONS; TITLE 'Какие статьи скачивать?'+'°°°°°°°' ******************************************************************** IF lExit ** Button Ok ELSE CLOSE ALL RETURN NIL ENDIF ******************************************************************** IF aPar[1]=.F. .AND. aPar[2]=.F. LB_Warning('Задайте скачивание файлов какого-нибудь типа', 'C° Пакетное скачивание публикаций') CLOSE ALL RETURN NIL ENDIF ****************************************************************************************************************************** * oScr := DC_WaitOn('Формирование базы данных гиперссылок на pdf-файлы',,,,,,,,,,,.F.) aStructure := { { 'Num ' , "N", 15, 0 }, ; { 'HLinkPDF' , "C",250, 0 }, ; { 'HLinkZIP' , "C",250, 0 }, ; { 'DwnLoadPDF', "C", 5, 0 }, ; { 'DwnLoadZIP', "C", 5, 0 } } DbCreate( "HyperLinks.dbf", aStructure, "DBFNTX" ) // ALL NB !!! USE HyperLinks EXCLUSIVE NEW SELECT HyperLinks aHyperLinks := {} // В БД запоминать только уникальные значения гиперссылок (исключить повторы) mNum = 0 mPos1 = AT('http://', SUBSTR(cFile, 1)) DO WHILE AT('http://', SUBSTR(cFile, mPos1)) * AT('.pdf', SUBSTR(cFile, mPos1)) > 0 mPos2 = mPos1+AT('.pdf', SUBSTR(cFile, mPos1))+3 * http:///2004/05/pdf/14.pdf * http:///2004/05/zip/14.zip mPdfHyperLink = STRTRAN(SUBSTR(cFile, mPos1, mPos2-mPos1),' ','') mZipHyperLink = STRTRAN(STRTRAN(mPdfHyperLink, 'pdf', 'zip'),' ','') ** Проверка корректности гиперссылок *************** IF LEN(mPdfHyperLink) > 255 mPdfHyperLink = SUBSTR(mPdfHyperLink,1,255) ENDIF mPosPdf = AT('.pdf', mPdfHyperLink) IF LEN(mZipHyperLink) > 255 mZipHyperLink = SUBSTR(mZipHyperLink,1,255) ENDIF mPosZip = AT('.zip', mZipHyperLink) IF mPosPdf + mPosZip > 0 IF ASCAN(aHyperLinks, mPdfHyperLink) = 0 // В БД запоминать только уникальные значения гиперссылок (исключить повторы) AADD (aHyperLinks, mPdfHyperLink) APPEND BLANK REPLACE Num WITH ++mNum IF mPosPdf > 0 REPLACE HLinkPDF WITH mPdfHyperLink ENDIF IF mPosZip > 0 REPLACE HLinkZIP WITH mZipHyperLink ENDIF ENDIF ENDIF * MsgBox(ALLTRIM(STR(mPos1))+' '+ALLTRIM(STR(mPos2))+' '+SUBSTR(cFile, mPos1, mPos2-mPos1)) mPos1 = mPos2+AT('http://', SUBSTR(cFile, mPos2))-1 ENDDO * DC_Impl(oScr) *** Скачивание pdf и zip файлов по найденным гиперссылкам ************************** USE HyperLinks EXCLUSIVE NEW SELECT HyperLinks ** Выход с сообщением, если в БД HyperLinks нет гиперссылок IF RECCOUNT() = 0 LB_Warning('Нет гиперссылок на файлы публикаций '+IF(mDataSource=1,'на странице: "'+mIntAddr+'"','в файле: "'+mFileName+'"'), 'C° Пакетное скачивание публикаций') RETURN NIL ENDIF mNFiles = RECCOUNT() mLen = LEN(ALLTRIM(STR(mNFiles))) Wsego = mNFiles // Начало отсчета времени для прогнозирования длительности исполнения Time_progress = 0 // Прошло секунд с начала процесса // Процесс может идти больше суток, поэтому для определения // во всех случаях вычисляется время, прошедшее с начала года T_Mess1 = "Начало:"+" "+TIME() // Начало Sec_1 = (DOY(DATE())-1)*86400+SECONDS() PUBLIC T1 := (DOY(DATE())-1)*86400+SECONDS() // Время предыдущей индикации процесса исполнения PUBLIC T2 := (DOY(DATE())-1)*86400+SECONDS()+1 // Текущее время (1-й раз оно заметно больше T1 чтобы было отображение) PUBLIC T1tp := T1 PUBLIC T2tp := T2 ********************************************************************************* **** Формирование базы данных гиперссылок на pdf-файлы ************************** // Отображение стадии исполнения. Будет написано прямо в окне Progress-bar @ 0,0 DCGROUP oGroup1 CAPTION 'Стадии исполнения процесса' FONT "6.Helv" SIZE 105, 3.5 PARENT oTabPage1 @ 5,0 DCGROUP oGroup2 CAPTION 'Прогноз времени исполнения' FONT "6.Helv" SIZE 105, 5.0 PARENT oTabPage2 s = 1 @s++,1 DCSAY " " SAYSIZE 100 SAYOBJECT aSay[ 1] FONT "10.Helv" @s++,1 DCSAY " " SAYSIZE 100 SAYOBJECT aSay[ 2] FONT "10.Helv" s++ @s++,1 DCSAY " " SAYSIZE 100 SAYOBJECT oSay97 FONT "10.HelvBold" s++ @0.2+s++,1 DCSAY " " SAYSIZE 100 SAYOBJECT oSay98 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @1.5+s ,1 DCSAY " " SAYSIZE 100 SAYOBJECT oSay99 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @s , 1 DCPROGRESS oProgress SIZE 95,1.5 PERCENT ; EVERY 1 ; // Кол-во обновлений изображения (в функции самой регулируеся обновление изображений через 0,1 секунды) MAXCOUNT Wsego ; COLOR GRA_CLR_CYAN // Цвет полосы @s++,97 DCPUSHBUTTON CAPTION '&Cancel' ; ACTION {||lOk:=.T.} OBJECT oButton ; SIZE 7,1.5 DCREAD GUI ; TITLE 'C° Пакетное скачивание публикаций в папку: "'+STRTRAN(Disk_dir,'\','/')+'/AID_DATA/Articles"'; PARENT @oDialog ; FIT ; EXIT ; MODAL oDialog:show() ****************************************************************************************************************************** * aSay[ 1]:SetCaption('1/2. Поиск гиперссылок на файлы публикаций '+IF(mDataSource=1,'на странице: "'+mIntAddr+'"','в файле: "'+mFileName+'"')) aSay[ 1]:SetCaption('1/2. Поиск гиперссылок на публикации '+IF(mDataSource=1,'на странице: "http://ej.kubagro.ru/a/viewaut.asp?id=11"','в файле: "'+mFileName+'"')+'. Найдено: '+ALLTRIM(STR(mNFiles))) aSay[ 2]:SetCaption('2/2. Скачивание'+' '+IF(aPar[1],'PDF','')+IF(aPar[1] .AND. aPar[2],' и ',' ')+IF(aPar[2],'ZIP','')+' '+'файлов статей в папку:'+' '+STRTRAN(Disk_dir,'\','/')+'/AID_DATA/Articles') IF FILEDATE(Disk_dir+'/AID_DATA/Articles',16) = CTOD("//") DIRMAKE( Disk_dir+'/AID_DATA/Articles') ENDIF mNum = 0 DBGOTOP() DO WHILE .NOT. EOF() DC_CompleteEvents();IF lCancelled;EXIT;ENDIF // Выход из цикла загрузки по нажатию клавиши Cancel * oScr := DC_WaitOn('Скачивание pdf-файла: "'+STRTRAN(STR(Num,mLen),' ','0')+'.pdf" / '+ALLTRIM(STR(mNFiles)),,,,,,,,,,,.F.) IF aPar[1] cFile = '' cFile := LoadFromURL(HLinkPDF) // Считывает страницу сайта в текстовую переменную. Но с некоторыми сайтами не получается IF AT('Error 404',cFile) = 0 StrFile(cFile, Disk_dir+'/AID_DATA/Articles'+'/'+STRTRAN(STR(Num,mLen),' ','0')+'.pdf') REPLACE DwnLoadPDF WITH 'Ok' ELSE REPLACE DwnLoadPDF WITH 'Error' ENDIF ENDIF IF aPar[2] cFile = '' cFile := LoadFromURL(HLinkZIP) // Считывает страницу сайта в текстовую переменную. Но с некоторыми сайтами не получается IF AT('Error 404',cFile) = 0 StrFile(cFile, Disk_dir+'/AID_DATA/Articles'+'/'+STRTRAN(STR(Num,mLen),' ','0')+'.zip') REPLACE DwnLoadZIP WITH 'Ok' ELSE REPLACE DwnLoadZIP WITH 'Error' ENDIF ENDIF * DC_Impl(oScr) aSay[ 2]:SetCaption('2/2. Скачивание'+' '+IF(aPar[1],'PDF','')+IF(aPar[1] .AND. aPar[2],' и ',' ')+IF(aPar[2],'ZIP','')+' '+'файлов статей в папку:'+' '+STRTRAN(Disk_dir,'\','/')+'/AID_DATA/Articles: '+ALLTRIM(STR(++mNum))+'/'+ALLTRIM(STR(mNFiles))) lOk = Time_Progress (++Time_Progress, mNFiles, oProgress, lOk ) DBSKIP(1) ENDDO CLOSE ALL * aSay[ 2]:SetCaption('2/2. Скачивание'+' '+IF(aPar[1],'PDF','')+IF(aPar[1] .AND. aPar[2],' и ',' ')+IF(aPar[2],'ZIP','')+' '+'файлов статей в папку:'+' '+STRTRAN(Disk_dir,'\','/')+'/AID_DATA/Articles') DO CASE CASE aPar[1] =.T. .AND. aPar[2] = .F. // PDF N_Files = ADIR(Disk_dir+'/AID_DATA/Articles/*.pdf') PRIVATE aFileName[N_Files], aFileSize[N_Files], aFileDate[N_Files], aFileTime[N_Files] ADIR(Disk_dir+'/AID_DATA/Articles/*.pdf', aFileName, aFileSize, aFileDate, aFileTime) CASE aPar[1] =.F. .AND. aPar[2] = .T. // ZIP N_Files = ADIR(Disk_dir+'/AID_DATA/Articles/*.zip') PRIVATE aFileName[N_Files], aFileSize[N_Files], aFileDate[N_Files], aFileTime[N_Files] ADIR(Disk_dir+'/AID_DATA/Articles/*.zip', aFileName, aFileSize, aFileDate, aFileTime) CASE aPar[1] =.T. .AND. aPar[2] = .T. // PDF & ZIP N_Files = ADIR(Disk_dir+'/AID_DATA/Articles/*.*') PRIVATE aFileName[N_Files], aFileSize[N_Files], aFileDate[N_Files], aFileTime[N_Files] ADIR(Disk_dir+'/AID_DATA/Articles/*.*', aFileName, aFileSize, aFileDate, aFileTime) ENDCASE mSizeSum = 0 FOR j=1 TO N_Files mSizeSum = mSizeSum + aFileSize[j] NEXT aMess := {} AADD(aMess, L('Все статьи проф.Е.В.Луценко, опубликованные в Научном журнале КубГАУ, скачаны успешно !!!')) AADD(aMess, ALLTRIM(STR(mNum))+' '+L('статей общим объемом:')+' '+ALLTRIM(STR(mSizeSum/(1024^3),7,3))+' '+L('Гб находятся в папке:'+' '+' "'+STRTRAN(Disk_dir,'\','/')+'/AID_DATA/Articles"')) LB_Warning(aMess, L('C° Пакетное скачивание публикаций')) * oSay97:SetCaption(L('Все')+' '+ALLTRIM(STR(++mNum))+' '+L('файлов статей скачаны успешно, всего:')+' '+ALLTRIM(STR(mSizeSum/(1024^3),7,3))+' '+L('Гб !!!')) oSay97:SetCaption(oSay97:caption) oButton:SetCaption('&Ok') // Деструктурирование окна отображения графического Progress-bar oButton:activate := {||PostAppEvent(xbeP_Close,,,oDialog)} //<<<<<< Add This DC_AppEvent( @lOk ) * PostAppEvent(xbeP_Activate,,,DC_GetObject(GetList,'DCGUI_BUTTON_OK')) // Роджер oDialog:Destroy() RETURN NIL ****************************************************************************************** FUNCTION Xb2NetKey() PUBLIC Ftp_User := '***' PUBLIC Ftp_Passw := '***' Return NIL ****************************************************************************************** ******** http://online-audio-convert.com/ru/ogg-to-wav/ Function PlayASound(cWaveFile) cWaveFile := alltrim(cWaveFile) DllCall("WINMM.DLL",32,"PlaySoundA",cWaveFile,0,0x00020000+0x0001) RETURN (NIL) ****************************************************************************************** ******************************************************************************** ******** 1.1. Авторизация сисадмина, администратора приложения или пользователя ******************************************************************************** FUNCTION F1_1() LOCAL GetList := {}, aPres, oBrowse, oToolBar, aColors, bColor, GetOptions, m11txt Running(.T.) ** Выбор сообщения на титульной видеограмме (сейчас 1-го из 4) IF .NOT. FILE("_11.txt") m11txt=1;StrFile(STR(m11txt), '_11.txt') ELSE m11txt = VAL(ALLTRIM(FileStr('_11.txt'))) ENDIF aMess = InstallFonts() // Установка шрифтов, независимых от Windows M_Login = "1 " M_Passw = "1 " ***********XXXXXXXXXXXXXXX @0.0,0 DCGROUP oGroup1 CAPTION L('Задайте имя и пароль:' ) SIZE 80.0, 3.5 @4.0,0 DCGROUP oGroup2 CAPTION L('Особенности работы в системе:') SIZE 80.0, 5.0 @1,2 DCSAY L("Login :") PARENT oGroup1 @2,2 DCSAY L("Password:") PARENT oGroup1 @1,13 DCGET M_Login PASSWORD PARENT oGroup1 PICTURE "XXXXXXXXXXXXXXX" @2,13 DCGET M_Passw PASSWORD PARENT oGroup1 PICTURE "XXXXXXXXXXXXXXX" **** Если файл существует изображения и его контрольная сумма совпадает, то он отображается cFile = Disk_dir+"\_Aidos_gr55.jpg" IF FILE(cFile) IF FILECHECK(cFile) = 1847316 d=45 IF mADStxt = 'OFF' @1.5,d DCSAY L("Advantage Database Server (ADS) - OFF") PARENT oGroup1 FONT '9.Arial Bold' COLOR(aColor[11]) SAYSIZE 0 @8,240 DCSTATIC TYPE XBPSTATIC_TYPE_BITMAP CAPTION cFile SIZE 59,59 PIXEL PARENT oGroup1 ENDIF IF mADStxt = 'ON' @1.5,d DCSAY L("Advantage Database Server (ADS) - ON") PARENT oGroup1 FONT '9.Arial Bold' COLOR(aColor[190]) SAYSIZE 0 @8,240 DCSTATIC TYPE XBPSTATIC_TYPE_BITMAP CAPTION cFile SIZE 59,59 PIXEL PARENT oGroup1 ENDIF ELSE Mess = L('Графический файл: "#" поврежден и не может быть отображен!') Mess = STRTRAN(Mess, "#", cFile) * Mess = STRTRAN(Mess, "#", ALLTRIM(STR(FILECHECK(cFile),19))) // Отображение контрольной суммы файла LB_Warning(Mess) ENDIF ENDIF s = 1 d = 0.8 @s,2 DCSAY L("1.") PARENT oGroup2;@s, 4 DCSAY L('Если система в данной папке запускается впервые, то будет произведена ЛОКАЛИЗАЦИЯ системы, ') PARENT oGroup2;s=s+d @s, 4 DCSAY L('т.е. будут удалены все приложения и пользователи и заново прописаны пути на все базы данных ') PARENT oGroup2;s=s+d @s, 4 DCSAY L('по фактическому расположению системы. ') PARENT oGroup2;s=s+d*1.5 @s,2 DCSAY L("2.") PARENT oGroup2;@s, 4 DCSAY L('Новое окно главного меню можно открывать только после закрытия всех предыдущих. ') PARENT oGroup2;s=s+d*1.5 s = 1 d = 0.8 h = 20.7 DO CASE CASE m11txt = 1 @9.5,0 DCGROUP oGroup3 CAPTION L('Главное, что делает система:') SIZE 80.0, h @s,2 DCSAY L("1.") PARENT oGroup3;@s, 4 DCSAY L('Альберт Эйнштейн писал, что научные законы это лишь высказывания о повторениях в наблюдаемых ') PARENT oGroup3;s=s+d @s, 4 DCSAY L('явлениях. Конечно наверное он имел в виду не сами законы природы, а лишь формулировки этих ') PARENT oGroup3;s=s+d*1.5 @s, 4 DCSAY L('законов. В системе "Эйдос" эти наблюдения повторений называются событиями или фактами. ') PARENT oGroup3;s=s+d*1.5 @s,2 DCSAY L("2.") PARENT oGroup3;@s, 4 DCSAY L('Например, фактом является наблюдение определенного значения какого-либо свойства у объектов ') PARENT oGroup3;s=s+d @s, 4 DCSAY L('некоторой обобщенной категории (класса), или наблюдение определенного значения фактора при ') PARENT oGroup3;s=s+d @s, 4 DCSAY L('переходе объекта в будущее состояние, соответствующее к классу. ') PARENT oGroup3;s=s+d*1.5 @s,2 DCSAY L("3.") PARENT oGroup3;@s, 4 DCSAY L('Система "Эйдос" выявляет эмпирические закономерности в фактах и тем самым преобразует исход- ') PARENT oGroup3;s=s+d @s, 4 DCSAY L('ные данные в информацию, а ее в знания и решает на основе этих знаний задачи идентификации, ') PARENT oGroup3;s=s+d @s, 4 DCSAY L('прогнозирования, принятия решений и исследования моделируемой предметной области путем ') PARENT oGroup3;s=s+d @s, 4 DCSAY L('исследования ее модели. ') PARENT oGroup3;s=s+d*1.5 @s,2 DCSAY L("4.") PARENT oGroup3;@s, 4 DCSAY L('Кроме того система "Эйдос" выводит информацию об обнаруженных закономерностях в большом ') PARENT oGroup3;s=s+d @s, 4 DCSAY L('количестве разнообразных и оригинальных текстовых, табличных и графических выходных форм. ') PARENT oGroup3;s=s+d*1.5 @s, 4 DCSAY L('Работы автора системы "Эйдос" проф.Е.В.Луценко & C° по АСК-анализу и системе "Эйдос": ') PARENT oGroup3;s=s+d*1.5 CASE m11txt = 2 @9.5,0 DCGROUP oGroup3 CAPTION L('Главное, что делает система:') SIZE 80.0, h @s, 4 DCSAY L('Персональная интеллектуальная онлайн среда "ЭЙДОС-X Professional" (Система "Эйдос-Хpro"): ') PARENT oGroup3;s=s+d*1.5 @s,2 DCSAY L("1.") PARENT oGroup3;@s, 4 DCSAY L('ПРЕДНАЗНАЧЕНА для обучения и научных исследований в области искусственного интеллекта ') PARENT oGroup3;s=s+d @s, 4 DCSAY L('с применением автоматизированного системно-когнитивного анализа (АСК-анализ) и его програм- ') PARENT oGroup3;s=s+d @s, 4 DCSAY L('много инструментария - интеллектуальной системы "Эйдос-Хpro". ') PARENT oGroup3;s=s+d*1.5 @s,2 DCSAY L("2.") PARENT oGroup3;@s, 4 DCSAY L('ОБЕСПЕЧИВАЕТ преобразование больших данных (Big Data), в большую информацию (Big Information),') PARENT oGroup3;s=s+d @s, 4 DCSAY L('а ее в большие знания (Big Knowledge) с использованием ADS (Advantage Database Server) и реше-') PARENT oGroup3;s=s+d @s, 4 DCSAY L('ние на основе этих знаний задач обобщения, абстрагирования, идентификации (классификации, рас-') PARENT oGroup3;s=s+d @s, 4 DCSAY L('познавания, диагностики, прогнозирования), поддержки принятия решений и исследования модели- ') PARENT oGroup3;s=s+d @s, 4 DCSAY L('руемой предметной области путем исследования ее модели. ') PARENT oGroup3;s=s+d*1.5 @s,2 DCSAY L("3.") PARENT oGroup3;@s, 4 DCSAY L('ПОЗВОЛЯЕТ пользователям и разработчикам интеллектуальных облачных Эйдос-приложений во ') PARENT oGroup3;s=s+d @s, 4 DCSAY L('всем мире обмениваться опытом решения различных задач учебного и научного характера с приме- ') PARENT oGroup3;s=s+d @s, 4 DCSAY L('нением технологий искусственного интеллекта на платформе "Эйдос-Хpro". ') PARENT oGroup3;s=s+d*1.5 @s, 4 DCSAY L('Работы автора системы "Эйдос" проф.Е.В.Луценко & C° по АСК-анализу и системе "Эйдос": ') PARENT oGroup3;s=s+d*1.5 CASE m11txt = 3 @9.5,0 DCGROUP oGroup3 CAPTION L('Объявление о получении магистерского образования по искусственному интеллекту в КубГУ:') SIZE 80.0, h @s,2 DCSAY L("1.") PARENT oGroup3;@s, 4 DCSAY L('В связи с высокой востребованностью на рынке труда специалистов в области цифровой экономики ') PARENT oGroup3;s=s+d @s, 4 DCSAY L('Кубанскому государственному университету оказано доверие и увеличено число бюджетных мест в ') PARENT oGroup3;s=s+d @s, 4 DCSAY L('магистратуру по приоритетным IT направлениям до 75. Приглашаем получить высококвалифициро- ') PARENT oGroup3;s=s+d @s, 4 DCSAY L('ванную подготовку по актуальным IT специальностям. ') PARENT oGroup3;s=s+d*2.0 @s, 4 DCSAY L('СПИСОК направлений подготовки магистратуры (очная и заочная формы обучения): ') PARENT oGroup3;s=s+d*2.0 @s,2 DCSAY L("2.") PARENT oGroup3;@s, 4 DCSAY L('09.04.02 Информационные системы и технологии (Искусственный интеллект и машинное обучение); ') PARENT oGroup3;s=s+d @s, 4 DCSAY L('09.04.02 Информационные системы и технологии (Искусственный интеллект и машинное обучение); ') PARENT oGroup3;s=s+d @s, 4 DCSAY L('01.04.02 Прикладная математика и информатика (Матем.и инф.обеспечение эконом.деятельности); ') PARENT oGroup3;s=s+d @s, 4 DCSAY L('01.04.02 Прикладная математика и информатика (Матем.модел.в естествознании и технологиях); ') PARENT oGroup3;s=s+d @s, 4 DCSAY L('01.04.02 Прикладная математика и информатика (Технологии програм.и разр.инф.-коммун.систем); ') PARENT oGroup3;s=s+d @s, 4 DCSAY L('02.04.02 Фунд.информатика и информ.технологии (Интеллектуальные системы и технологии). ') PARENT oGroup3;s=s+d*2.0 @s,2 DCSAY L("3.") PARENT oGroup3;@s, 4 DCSAY L('КОНТАКТЫ: +79189800003, savanna-05@mail.ru, докт.техн.наук Анна Владимировна Коваленко ') PARENT oGroup3;s=s+d*2.0 CASE m11txt = 4 @9.5,0 DCGROUP oGroup3 CAPTION 'Announcement of own fonts of the Eidos system:' SIZE 80.0, h IF LEN(aMess) > 0 FOR j=1 TO LEN(aMess) @s, 13 DCSAY L(aMess[j]) PARENT oGroup3;s=s+d NEXT ENDIF CASE m11txt = 5 @9.5,0 DCGROUP oGroup3 CAPTION L('Приглашение к размещению интеллектуальных облачных Эйдос-приложений:') SIZE 80.0, h; s=s+d @s, 2 DCSAY L('Уважаемые пользователи системы "Эйдос" во всем мире: http://lc.kubagro.ru/map5.php! ') PARENT oGroup3;s=s+d*2 @s, 2 DCSAY L('Приглашаю размещать свои интеллектуальные облачные Эйдос-приложения. Это делается в диспетчере ') PARENT oGroup3;s=s+d @s, 2 DCSAY L('приложений (режим 1.3). Для разработки приложения рекомендуется ознакомиться с инструкцией для ') PARENT oGroup3;s=s+d @s, 2 DCSAY L('учащихся по адресу: http://lc.kubagro.ru/aidos/How_to_make_your_own_cloud_Eidos-application.pdf') PARENT oGroup3;s=s+d*2 @s, 2 DCSAY L('Прошу вас отнестись ОТВЕТСТВЕННО к качеству разработки приложения и его описанию и размещать ') PARENT oGroup3;s=s+d @s, 2 DCSAY L('только разработанные вами лично приложения, описанные в соответствии со стандартом IMRAD. Это ') PARENT oGroup3;s=s+d @s, 2 DCSAY L('общепринятый в мире стандарт изложения научных результатов, принятый в наукометрических базах ') PARENT oGroup3;s=s+d @s, 2 DCSAY L('Scopus и Web of science (WoS). Описание, т.е.его текст и все выходные формы и скриншоты, должно') PARENT oGroup3;s=s+d @s, 2 DCSAY L('ПОЛНОСТЬЮ соответствовать модели, полученной в системе "Эйдос" на приведенных исходных данных ') PARENT oGroup3;s=s+d @s, 2 DCSAY L('при выполнении всех пунктов этого описания. Примеры подобных описаний интеллекутальных облачных') PARENT oGroup3;s=s+d @s, 2 DCSAY L('Эйдос-приложений приведены в ряде работ автора и разработчика системы "Эйдос" проф.Е.В.Луценко,') PARENT oGroup3;s=s+d @s, 2 DCSAY L('например по ссылке: https://www.researchgate.net/publication/362211691. ') PARENT oGroup3;s=s+d*2 CASE m11txt = 6 @9.5,0 DCGROUP oGroup3 CAPTION L('Пояснение о некорректном запуске системы "Эйдос"') SIZE 80.0, h @s, 2 DCSAY L('Студенты и некоторые другие пользователи иногда запускают систему "Эйдос" некорректно: ') PARENT oGroup3;s=s+d @s, 2 DCSAY L('- в папке загрузки или на рабочем столе; ') PARENT oGroup3;s=s+d @s, 2 DCSAY L('- в архиве инсталляции системы "Эйдос", который скачали с сайта разработчика; ') PARENT oGroup3;s=s+d @s, 2 DCSAY L('- в папке, в пути на которую встречаются пробелы и кириллица. ') PARENT oGroup3;s=s+d @s, 2 DCSAY L('Кроме того иногда систему запускают в одной и той же папке несколько раз, чего делать нельзя ') PARENT oGroup3;s=s+d @s, 2 DCSAY L('(ее можно запускать несколько раз одновременно на одном компьютере, но в разных папках). ') PARENT oGroup3;s=s+d @s, 2 DCSAY L('Некорректный запуск системы "Эйдос" вызывает ошибку исполнения. Поэтому приходится проверять ') PARENT oGroup3;s=s+d @s, 2 DCSAY L('корректность запуска системы "Эйдос". Однако эта проверка занимает довольно много времени. ') PARENT oGroup3;s=s+d @s, 2 DCSAY L('Поэтому она оставлена только в модуле запуска системы: "___START_AIDOS-X.exe", а в исполнимом') PARENT oGroup3;s=s+d @s, 2 DCSAY L('модуле самой системы "__AIDOS-X.exe" она включается/отключается в зависимости от содержания ') PARENT oGroup3;s=s+d @s, 2 DCSAY L('текстового файла: "Checking_the_correctness_of_the_module_launch__AIDOS-X.txt": "ON"/"OFF". ') PARENT oGroup3;s=s+d @s, 2 DCSAY L('Отметим, что модуль запуска системы: "___START_AIDOS-X.exe" кроме проверки корректности ') PARENT oGroup3;s=s+d @s, 2 DCSAY L('запуска системы еще проверяет целостность исполнимого молуля системы "__AIDOS-X.exe" и ') PARENT oGroup3;s=s+d @s, 2 DCSAY L('наличие обновлений на сайте автора и разработчика системы проф.Е.В.Луценко. Если обновления ') PARENT oGroup3;s=s+d @s, 2 DCSAY L('есть, то они скачиваются, разархивируются и устанавливаются автоматически. ') PARENT oGroup3;s=s+d*2 CASE m11txt = 7 @9.5,0 DCGROUP oGroup3 CAPTION L('Предложения об услугах с помощью АСК-анализа и системы "Эйдос"') SIZE 80.0, h @s, 2 DCSAY L('Проф.Е.В.Луценко - автор и разработчик Автоматизированного системно-когнитивного анализа') PARENT oGroup3;s=s+d @s, 2 DCSAY L('(АСК-анализ) и его программного инструментария - интеллектуальной системы "Эйдос" может:') PARENT oGroup3;s=s+d @s, 2 DCSAY L('выдать СЕРТИФИКАТ (в электронной форме) об успешном освоении знаний, умений и навыков, ') PARENT oGroup3;s=s+d @s, 2 DCSAY L('необходимых для разработки собственного интеллектуального облачного Эйдос-приложения и ') PARENT oGroup3;s=s+d @s, 2 DCSAY L('его размещении в Эйдос-облаке, http://researchgate.net/ и в РИНЦ: https://elibrary.ru/. ') PARENT oGroup3;s=s+d*1.3 @s, 2 DCSAY L('Возможны также: ') PARENT oGroup3;s=s+d @s, 2 DCSAY L('-авторское сопровождение и консультации по разработке Эйдос-приложений в самых различных') PARENT oGroup3;s=s+d @s, 2 DCSAY L('предметных областях и даже просто разработка и описание Эйдос-приложений; ') PARENT oGroup3;s=s+d @s, 2 DCSAY L('- заказная доработка системы "Эйдос" с учетом пожеланий заказчика. ') PARENT oGroup3;s=s+d*1.3 @s, 2 DCSAY L('Большой объем научной и учебно-методической информации находится по ссылкам в режиме 6.2') PARENT oGroup3;s=s+d @s, 2 DCSAY L('системы "Эйдос". Инструкция по разработке интеллектуальных облачных Эйдос-приложений, ') PARENT oGroup3;s=s+d @s, 2 DCSAY L('включающая информацию об источниках данных для машинного обучения (ML) и шаблоны ') PARENT oGroup3;s=s+d @s, 2 DCSAY L('описания Эйдос-приложений, а также видео-занятия проф.Е.В.Луценко, находится по ссылке: ') PARENT oGroup3;s=s+d @s, 2 DCSAY L('http://lc.kubagro.ru/aidos/How_to_make_your_own_cloud_Eidos-application.pdf ') PARENT oGroup3;s=s+d @s, 2 DCSAY L('e-mail: prof.lutsenko@gmail.com ') PARENT oGroup3;s=s+d ENDCASE m11txt = IF(m11txt < 7,m11txt+1,1) StrFile(STR(m11txt), '_11.txt') *mCh = 1+INT(RANDOM()%100) *MsgBox(STR(mCh)) *IF mCh < 60 ProfessorAdvises() *ENDIF l = s a = 41 b = 37 *@l,2 DCPUSHBUTTON CAPTION L('Системное обобщение математики') SIZE b, 1.5 ACTION {||ShellOpenFile( 'http://lc.kubagro.ru/aidos/Work_on_emergence.htm' , .T., .T. )} PARENT oGroup3;l=l+d*2 *@l,2 DCPUSHBUTTON CAPTION L('АСК-анализ текстов ') SIZE b, 1.5 ACTION {||ShellOpenFile( 'http://lc.kubagro.ru/aidos/Works_on_ASK-analysis_of_texts.htm' , .T., .T. )} PARENT oGroup3;l=l+d*2 *@l,2 DCPUSHBUTTON CAPTION L('АСК-анализ как метод познания ') SIZE b, 1.5 ACTION {||ShellOpenFile( 'http://lc.kubagro.ru/aidos/Works_on_identification_presentation_and_use_of_knowledge.htm', .T., .T. )} PARENT oGroup3;l=l+d*2 *@l,2 DCPUSHBUTTON CAPTION L('Кратко об АСК-анализе ') SIZE b, 1.5 ACTION {||ShellOpenFile( 'https://www.researchgate.net/publication/356084911', .T., .T. )} PARENT oGroup3;l=l+d*2 @l,2 DCPUSHBUTTON CAPTION L('Кратко об АСК-анализе ') SIZE b, 1.5 ACTION {||LC_RunUrl( 'https://www.researchgate.net/publication/356084911' )} PARENT oGroup3;l=l+d*2 l = s *@l,a DCPUSHBUTTON CAPTION L('АСК-анализ изображений ') SIZE b, 1.5 ACTION {||ShellOpenFile( 'http://lc.kubagro.ru/aidos/Works_on_ASK-analysis_of_images.htm', .T., .T. )} PARENT oGroup3;l=l+d*2 *@l,a DCPUSHBUTTON CAPTION L('Когнитивные функции ') SIZE b, 1.5 ACTION {||ShellOpenFile( 'http://lc.kubagro.ru/aidos/Works_on_cognitive_functions.htm' , .T., .T. )} PARENT oGroup3;l=l+d*2 *@l,a DCPUSHBUTTON CAPTION L('Когнитивная наукометрия ') SIZE b, 1.5 ACTION {||ShellOpenFile( 'http://lc.kubagro.ru/aidos/Works_on_scientometrics.htm' , .T., .T. )} PARENT oGroup3;l=l+d*2 @l,a DCPUSHBUTTON CAPTION L('Подборки публикаций по АСК-анализу') SIZE b, 1.5 ACTION {||ShellOpenFile( 'http://lc.kubagro.ru/aidos/_Aidos-X.htm' , .T., .T. )} PARENT oGroup3;l=l+d*2 *@l,2 DCPUSHBUTTON CAPTION L('АСК-анализ влияния космической среды на процессы на Земле ') SIZE 76, 1.5 ACTION {||ShellOpenFile( 'http://lc.kubagro.ru/aidos/Work_on_the_study_of_the_influence_of_the_space_environment_on_various_processes_on_Earth.htm', .T., .T. )} PARENT oGroup3;l=l+d*2 @l,2 DCPUSHBUTTON CAPTION L('Скачать все публикации проф.Е.В.Луценко из Научного журнала КубГАУ (> 2.3 Гб)') SIZE 76, 1.5 ACTION {||DownloadArticles()} PARENT oGroup3;l=l+d*2 @l,2 DCPUSHBUTTON CAPTION L('СЕРТИФИКАТ об освоении системы "Эйдос" от проф.Е.В.Луценко. ПОДДЕРЖКА') SIZE 76, 1.5 ACTION {||Help11()} PARENT oGroup3;l=l+d*2 @l,2 DCPUSHBUTTON CAPTION L('ПРЕДЛОЖЕНИЕ об использовании АСК-анализа и системы "Эйдос" от проф.Е.В.Луценко') SIZE 76, 1.5 ACTION {||Help11n()} FONT '9.Arial Bold' PARENT oGroup3;l=l+d*2 *DCREAD GUI TO lExit FIT TITLE L('6.1. О системе "ЭЙДОС-X++", авторе-разработчике, средствах разработки и поддержке.') *DCREAD GUI; * TO lExit ; * FIT; * ADDBUTTONS; * MODAL; * TITLE L('(c) Авторизация в системе ЭЙДОС-X++') DCREAD GUI; TO lExit ; FIT; ADDBUTTONS; TITLE L('(c) Авторизация в системе ЭЙДОС-X++') ******************************************************************** IF lExit ** Button Ok ELSE * ADS_SERVER_QUIT() QUIT ENDIF ******************************************************************** M_Login = SUBSTR(ALLTRIM(M_Login)+" ",1,10) M_Passw = SUBSTR(ALLTRIM(M_Passw)+" ",1,10) *Mess = M_Login+" "+M_Passw *LB_Warning(Mess, L("Login & Password" ) IF FILE("Users.dbf") // БД администраторов приложений и паролей доступа к ним: Users.dbf GenNtxUsers() ELSE GenDbfUsers() ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Users INDEX Use_LPAA, Use_LPus EXCLUSIVE NEW PUBLIC Flag_SysAdmin := .F., M_KodSysAdmin := 0 PUBLIC Flag_AdmAppl := .F., M_KodAdmAppls := 0 PUBLIC Flag_User := .F., M_KodAdmAppls := 0 // Для авторизации сисадмина надо ввести login=1, password=1 IF M_Login = "1" .AND. M_Passw = "1" // Сисадмин, все права. Flag_SysAdmin = .T. M_KodAdmAppls = Kod_AdmApp aMess := {} AADD(aMess, L('Приветствую тебя, о СИСАДМИН! Слушаюсь и повинуюсь!!!')) AADD(aMess, '') AADD(aMess, L('Эта версия системы "Эйдос" откомпилирована на языках Питон и Аляска-2.0 ')) AADD(aMess, L('и предназначена для всех версий MS Windows: 7, 8, а также Windows-10. Файл')) AADD(aMess, L('запуска системы "Эйдос": ___START_AIDOS-X.exe тоже работает под Windows-10')) AADD(aMess, L('и рекомендуется его запускать, т.к. он проверяет обновления системы Эйдос')) AADD(aMess, L('и скачивает их, если они есть. Можно также скачать их самим в режиме 6.2. ')) * LB_Warning(aMess, L("Авторизация сисадмина в системе ЭЙДОС-X++" )) Running(.F.) RETURN(M_KodAdmAppls) ENDIF // Для авторизации администратора приложения надо ввести login и password, заданные при его регистрации SET ORDER TO 1;T=DBSEEK(M_Login+M_Passw) IF T Flag_AdmAppl = .T. M_KodAdmAppls = Kod_AdmApp Mess = L("Авторизация администратора приложения: [#] прошла успешно!!!") Mess = STRTRAN(Mess, "#",UPPER(ALLTRIM(Name_AdmAp))) LB_Warning(Mess, L("Авторизация администратора приложения в системе ЭЙДОС-X++" )) Running(.F.) RETURN(M_KodAdmAppls) ENDIF // Для авторизации пользователя надо ввести password, заданный администратором приложения для пользователей SET ORDER TO 2;T=DBSEEK(UPPER(ALLTRIM(M_Login))+M_Passw) // login="USER" +Password пользователей приложения IF T Flag_User = .T. M_KodAdmAppls = Kod_AdmApp Mess = L("Авторизация пользователя приложения: [#] прошла успешно!!!") Mess = STRTRAN(Mess, "#",UPPER(ALLTRIM(Name_AdmAp))) LB_Warning(Mess, L("Авторизация пользователя в системе ЭЙДОС-X++" )) Running(.F.) RETURN(M_KodAdmAppls) ENDIF Mess = L('Неверное сочетание: Login - Password !!!') LB_Warning( L(Mess), L('1.1. Авторизация в системе ЭЙДОС-X++' )) ***** Проверка контрольной суммы exe-модуля системы Эйдос, и, если она не совпадает, то выдача сообщения ***** Это вставить в _START_AIDOS.exe, т.к. проверка контрольной суммы может быть только у закрытого файла cFile = "_aidos-x.exe" IF FILE(cFile) IF .NOT. FILE('_CheckSum.txt') // Если файла с контрольной суммой нет, то создать его StrFile(ALLTRIM(STR(FILECHECK(cFile))), '_CheckSum.txt') ELSE // Если файл с контрольной суммой есть, то проверить его совпадение и выдать сообщение, если он отличается mCheckSum = VAL(FileStr('_CheckSum.txt')) IF FILECHECK(cFile) <> mCheckSum aMess := {} AADD(aMess, L('EXE-модуль системы "Эйдос" был несанкционированно изменен,' )) AADD(aMess, L('Поэтому работоспособность системы "Эйдос" не гарантируется!')) LB_Warning(aMess,L('(С) "Эйдос-Х++"')) ENDIF ENDIF ENDIF * ***** Перенести в _START_AIDOS.exe, т.к. контрольная сумма правильно считается только для закрытого файла ******** * cFile = "_aidos-x.exe" * IF FILE(cFile) * IF .NOT. FILE('_CheckSum.txt') // Если файла с контрольной суммой нет, то создать его * StrFile(ALLTRIM(STR(FILECHECK(cFile))), '_CheckSum.txt') * ELSE // Если файл с контрольной суммой есть, то проверить его совпадение и выдать сообщение, если он отличается * mCheckSum = VAL(FileStr('_CheckSum.txt')) * IF FILECHECK(cFile) <> mCheckSum * Mess = 'CheckSum='+ALLTRIM(STR(mCheckSum))+'. '+L('EXE-модуль системы "Эйдос" поврежден и его работоспособность не гарантируется!' * LB_Warning(Mess) * ENDIF * ENDIF * ENDIF * ******************************************************************************************************** Running(.F.) RETURN(M_KodAdmAppls) *********************************************************************************************************** ******** Просьба о помощи *********************************************************************************************************** FUNCTION Help11() * Я могу решать задачи, которые вам интересны (если вы предоставите исходные данные). Если получится что-то разумное * - вы можете публиковать результаты (со мной) в изданиях, входящих в Скопус и WoS. Мы можем размещать описания и * исходные данные задач в Эйдос-облаке (в общем доступе). Я могу выдавать сертификаты об освоении вами или вашими * учениками знаний, умений и навыков автоматизированного системо-когнитивного анализа и системы Эйдос. Я могу * разрабатывать заказные расширения системы Эйдос. Вы можете разрабатывать новые версии системы Эйдос на перспективных * языках программирования. Я могу предоставить всю необходимую для этого информацию. Вы можете платить мне за это. * Вы можете предложить еще что-то. DCSETFONT TO '10.Helv' s=0 @ s++,1 DCSAY L('Проф.Е.В.Луценко - автор и разработчик Автоматизированного системно-когнитивного анализа') SAYSIZE 0 @ s++,1 DCSAY L('(АСК-анализ) и его программного инструментария - интеллектуальной системы "Эйдос" может:') SAYSIZE 0 @ s++,1 DCSAY L('выдать СЕРТИФИКАТ (в электронной форме) об успешном освоении знаний, умений и навыков, ') SAYSIZE 0 @ s++,1 DCSAY L('необходимых для разработки собственного интеллектуального облачного Эйдос-приложения и ') SAYSIZE 0 @ s++,1 DCSAY L('его размещении в Эйдос-облаке, http://researchgate.net/ и в РИНЦ: https://elibrary.ru/. ') SAYSIZE 0 @ s++,1 DCSAY L('') SAYSIZE 0 @ s++,1 DCSAY L('Реестр зарегистрированных в Виртуальном центре системно-когнитивных исследований "Эйдос"') SAYSIZE 0 @ s++,1 DCSAY L('сертификатов об освоении Автоматизированного системно-когнитивного анализа (АСК-анализ) ') SAYSIZE 0 @ s++,1 DCSAY L('и его программного инструментария - интеллектуальной системы "Эйдос" находится по ссылке:') SAYSIZE 0 @ s++,1 DCPUSHBUTTON CAPTION L('Посмотреть реестр зарегистрированных сертификатов об освоении системы "Эйдос":') SIZE 93, 1.1 ACTION {||LC_RunUrl("http://lc.kubagro.ru/Eidos/Certificate.php")} @ s++,1 DCSAY L('') SAYSIZE 0 @ s++,1 DCSAY L('Возможны также авторское сопровождение и консультации по разработке Эйдос-приложений в ') SAYSIZE 0 @ s++,1 DCSAY L('в различных предметных областях и заказная доработка системы "Эйдос" с учетом пожеланий ') SAYSIZE 0 @ s++,1 DCSAY L('заказчика. Большой объем научной и учебно-методической информации находится по ссылкам ') SAYSIZE 0 @ s++,1 DCSAY L('в режиме 6.2 системы "Эйдос". Краткая инструкция по разработке интеллектуальных облачных') SAYSIZE 0 @ s++,1 DCSAY L('Эйдос-приложений, включающая информацию об источниках данных для машинного обучения (ML),') SAYSIZE 0 @ s++,1 DCSAY L('шаблоны описания Эйдос-приложений и видео-занятия проф.Е.В.Луценко, находится по ссылке:') SAYSIZE 0 @ s++,1 DCPUSHBUTTON CAPTION L('Инструкция по разработке собственного интеллектуального облачного Эйдос-приложения') SIZE 93, 1.1 ACTION {||LC_RunUrl("http://lc.kubagro.ru/aidos/How_to_make_your_own_cloud_Eidos-application.pdf")} @ s++,1 DCSAY L('') SAYSIZE 0 DCSETFONT TO '10.Helv Bold' @ s++,1 DCSAY L('Если вам захотелось поблагодарить автора, то это можно сделать просто перечислив') SAYSIZE 0 @ s++,1 DCSAY L('подарок на карту Сбербанка РФ (в рублях), привязанную к телефону автора: ') SAYSIZE 0 @ s++,1 DCSAY L('+7 905 408 5424. Просьба в поле: "назначение платежа" писать только: "ПОДАРОК". ') SAYSIZE 0 @ s++,1 DCSAY L('Звонить можно ТОЛЬКО в рабочие дни в рабочее время по Московскому времени (МСК).') SAYSIZE 0 @ s++,1 DCSAY L('e-mail: prof.lutsenko@gmail.com ') SAYSIZE 0 DCREAD GUI FIT TITLE L('Предложения профессора Е.В.Луценко') RETURN nil *********************************** *********************************************************************************************************** ******** Предложение по применению АСК-анализа и системы Эйдос *********************************************************************************************************** FUNCTION Help11n() DCSETFONT TO '10.Helv' s=0 @ s++, 0 DCSAY L('Уважаемые коллеги! ') SAYSIZE 0;s=s+0.5 @ s++, 0 DCSAY L('Все слышали о революции в области искусственного интеллекта, происходящей в наше время на наших глазах. ') SAYSIZE 0;s=s+0.2 @ s++, 0 DCPUSHBUTTON CAPTION L('Об этом можно почитать в монографии о современной революции в искусственном интеллекте') SIZE 106, 1.1 ACTION {||LC_RunUrl("https://www.researchgate.net/publication/378138050")};s=s+0.3 @ s++, 0 DCSAY L('Эта революция уже привела к тому, что есть все основания рассматривать системы искусственного интеллекта ') SAYSIZE 0;s=s+0.2 @ s++, 0 DCSAY L('как системы автоматизации процесса научного познания, которые можно с успехом применить как инструменты ') SAYSIZE 0;s=s+0.2 @ s , 0 DCSAY L('научных исследований практически во всех областях и направлениях науки: ') SAYSIZE 0;s=s-0.1 @ s++, 74 DCPUSHBUTTON CAPTION L('Статья о применении ИИ в науке') SIZE 32, 1.1 ACTION {||LC_RunUrl("http://ej.kubagro.ru/2024/01/pdf/09.pdf")} ;s=s+0.3 @ s++, 0 DCSAY L('В этой связи предлагаю вам применить автоматизированный системно-когнитивный анализ (АСК-анализ) и его ') SAYSIZE 0;s=s+0.2 @ s++, 0 DCSAY L('программный инструментарий - интеллектуальную систему "Эйдос" для обработки данных вашего исследования ') SAYSIZE 0;s=s+0.2 @ s++, 0 DCSAY L('исследования и подготовки научного отчета о вашем исследовании примерно такого уровня: ') SAYSIZE 0;s=s+0.2 @ s , 0 DCPUSHBUTTON CAPTION L('Скачать отчет о НИР-1') SIZE 32, 1.1 ACTION {||LC_RunUrl("http://lc.kubagro.ru/Source_data_applications/Applications-000335/readme.docx")} @ s , 37 DCPUSHBUTTON CAPTION L('Скачать отчет о НИР-2') SIZE 32, 1.1 ACTION {||LC_RunUrl("http://lc.kubagro.ru/Source_data_applications/Applications-000391/readme.docx")} @ s++, 74 DCPUSHBUTTON CAPTION L('Скачать отчет о НИР-3') SIZE 32, 1.1 ACTION {||LC_RunUrl("http://lc.kubagro.ru/Source_data_applications/Applications-000393/readme.docx")};s=s+0.3 @ s++, 0 DCSAY L('Проф.Е.В.Луценко может оказать вам в этом адресную авторскую помощь на основе договора. ') SAYSIZE 0;s=s+0.2 @ s , 0 DCSAY L('Об АСК-анализе и системе "Эйдос" подробнее можно узнать по ссылке: ') SAYSIZE 0;s=s-0.1 @ s++, 74 DCPUSHBUTTON CAPTION L('Посмотреть MVP-проект') SIZE 32, 1.1 ACTION {||LC_RunUrl("http://lc.kubagro.ru/aidos/MVP-projects.htm")} ;s=s+0.5 @ s++, 0 DCSAY L('С уважением и пожеланиями Успехов! ') SAYSIZE 0;s=s+0.5 @ s++, 0 DCSAY L('Автор и разработчик АСК-анализа и системы "Эйдос" проф.Е.В.Луценко, e-mail: prof.lutsenko@gmail.com ') SAYSIZE 0 DCREAD GUI FIT TITLE L('Предложение профессора Е.В.Луценко') RETURN nil *********************************** FUNCTION ProfessorAdvises() *RETURN nil ****************************************** ****** Обработка ошибки ****************** bError := ErrorBlock( {|e| Break(e)} ) // установить новый кодовый блок обработки ошибок BEGIN SEQUENCE // код нормального исполнения *** код нормального исполнения ***************** *** *** ********************************************************************************************************************* // Скачивание советов профессора из "Заработало" с сайт: http://lc.kubagro.ru/Sounds/*.wav ********************************************************************************************************************* n=0 IF .NOT. InternetGetConnectedState( @n, 0 ) == 0 * cFile := LoadFromURL('http://lc.kubagro.ru/index_aidos.php') // Считывает страницу сайта в текстовую переменную ********************************************************************************************************** Xb2NetKey() cFtpServer:="94.25.18.114" // Это везде одинаково <<<===############ oFtp := FTPClient():new( cFtpServer, Ftp_User, Ftp_Passw ) // Соединение с моим сайтом и авторизация IF oFtp:connect() // Есть соединение с моим сайтом и авторизация? ********************************************************************************************************** **** Узнать, работает ли на компьютере доступ к FTP-серверу ******* **** Взять из ___START_AIDOS-X mFTP = 'ON' * StrFile(mFTP, '_FTP.txt') * mFTP = FileStr('_FTP.txt') IF mFTP = 'ON' **** Узнать, есть ли на хостинге обновления, и, если есть, включить говорилку ******* PRIVATE aName[1], aSize[1], aDate[1] mCountSys = ADIR('__aidos-x.exe', aName, aSize, aDate ) mDateSys = aDate[1] // Дата текущего исполнимого модуля системы "Эйдос" oFtp:curDir("public_html") aFileUpd := oFtp:Directory("Downloads.exe") mDateUpd = aFileUpd[1,F_WRITE_DATE] IF mDateSys < mDateUpd // Исполнимый файл системы в текущей папке старее файла обновлений **** Сделать текущей папку: ftp://94.25.18.114/public_html/Sounds/ * aDirSite := oFtp:Directory("*.*","D") //<<<===############### * DC_DebugQout( aDirSite ) //<<<===############### * MsgBox('2. Исходная директория: '+oFtp:curDir()) * oFtp:curDir("public_html") oFtp:curDir("Sounds") * MsgBox('2. Должна быть директория: "\public_html\Sounds", а фактически: '+oFtp:curDir()) * IF oFtp:curDir("public_html\Sounds") * LB_Warning(L('Не удалось сделать текущей директорию: "Sounds"'), L('(C) Система "Эйдос-Х++"' )) * RETURN NIL * ENDIF aWaveFile := oFtp:Directory("*.WAV") * LB_Warning(aWaveFile[1,F_NAME]) * DC_DebugQout( aWaveFile[1,F_NAME] ) // Отладка Имя Размер Дата Время * wtf oFtp:Directory("*.WAV") // VALUE: {{"Downloads.exe", 10242016, 20201202, "07:57:00", "N", 0, , "00:00:00", , "00:00:00"}} * DC_MsgBox(10,10,aWaveFile[1,F_NAME]) * MsgBox('Имя файла: '+aWaveFile[1,F_NAME]+', размер: '+STR(aWaveFile[1,F_SIZE])+' байт, дата создания: '+DTOC(aWaveFile[1,F_WRITE_DATE])+', время создания: '+aWaveFile[1,F_WRITE_TIME]) * mSizeUpd = aFileUpd[1,F_SIZE] / (1024^2) // Мб * mDateUpd = aFileUpd[1,F_WRITE_DATE] * mTimeUpd = aFileUpd[1,F_WRITE_TIME] *** Скачать случайный звуковой файл для вопроизведения ******* cWaveFile = 1+INT(RANDOM()%LEN(aWaveFile)) * MsgBox(aWaveFile[cWaveFile,F_NAME]) IF oFtp:GetFile(aWaveFile[cWaveFile,F_NAME]) // <<<===################# Сделать обработку ошибки * LB_Warning(L('Скачивание файла: "')+aWaveFile[1,F_NAME]+L('" с FTP-сервера завершено успешно'), L('(C) Система "Эйдос-Х++"' )) ELSE ENDIF PlayASound(aWaveFile[cWaveFile,F_NAME]) ERASE(aWaveFile[cWaveFile,F_NAME]) ENDIF ENDIF ELSE LB_Warning(L('Нет соединения с FTP-сервером'), L('(C) Система "Эйдос-Х++"')) ENDIF ENDIF RECOVER // код обработки ошибки * aMess := {} * AADD(aMess, L('При распознавании была попытка превышения максимального допустимого объема БД 2 Гб.')) // НАПРИМЕР * AADD(aMess, L('Необходимо уменьшить количество классов или/и объектов распознаваемой выборки !!! ')) * AADD(aMess, L('Можно также исключить из результатов распознавания наименее достоверные (режим 3.5)')) * LB_Warning(aMess) ** EXIT ENDSEQUENCE ErrorBlock( bError ) // переустановить старый кодовый ****************************************** ****************************************** RETURN NIL******************** #include "adsdbe.ch" // ADSDBE = ADS SERVER ENGINE ******************** #include "inkey.ch" #include "dcdir.ch" #include "appevent.ch" #include "xbp.ch" #include "dll.ch" #include "dccursor.ch" #Include "thread.ch" #include "class.ch" #include "dmlb.ch" #include "fileio.ch" #include "dctree.ch" *#include "SystemMetrics.ch" *#include "axcdxcmx.ch" // Графика ActiveX #include "collat.ch" #include "common.ch" #include "dbedit.ch" #include "Dbfdbe.ch" #include "dcapp.ch" #include "dcbitmap.ch" #include "dccargo.ch" #include "dcdialog.ch" #include "dcdir.ch" #include "dcfiles.ch" #include "dcgra.ch" #include "dcgraph.ch" // графика #include "BdColors.Ch" // графика #include "dccolors.ch" // графика #include "dcprint.ch" // графика #include "Dcicon.ch" #include "dcmsg.ch" #include "dcpick.ch" #include "deldbe.ch" #include "directry.ch" #include "dmlb.ch" #include "express.ch" #include "fileio.ch" #include "font.ch" #include "gra.ch" #include "inkey.ch" #include "memvar.ch" #include "natmsg.ch" #include "prompt.ch" #include '_dcdbfil.ch' #include "set.ch" #include "std.ch" #include "xbp.ch" #include '_dcappe.ch' #include 'dcscope.ch' #include '_dcstru.ch' #include 'dcfields.ch' #include 'dccolor.ch' *#include "Fileio.ch" // Max_DB *#include "rmchart.ch" // Графика ActiveX #include "dcads.ch" #pragma Library( "ASINet10.lib" ) // 2.0 // Для альтернативного и неальтернативного выбора в просмотре таблиц *#define BMP_CHECKED "check1.bmp" *#define BMP_UNCHECKED "check2.bmp" *#define BMP_RACHECKED "radio1.bmp" *#define BMP_RAUNCHECKED "radio2.bmp" *#include "test.ch" #define BMP_CHECKED 10002 #define BMP_UNCHECKED 10003 #define BMP_RACHECKED 10004 #define BMP_RAUNCHECKED 10005 #pragma library( "ascom10.lib" ) #pragma library( "dclip1.lib" ) #pragma library( "dclip2.lib" ) #pragma library( "dclipx.lib" ) #pragma library( "xbtbase1.lib" ) #pragma library( "xbtbase2.lib" ) #pragma library( "xppui2.lib" ) #pragma library( "XPPRT0.LIB" ) #Pragma Library("Taskbar.lib") #xtranslate NTrim() => LTrim(Str()) #define USE_HTTPCLIENT // comment out to try Method2 //#include "Imgview.ch" /* * We use user defined events */ #define xbeDS_DirChanged xbeP_User + 100 #define xbeFS_FileMarked xbeP_User + 101 #define xbeFS_FileSelected xbeP_User + 102 #define DCAREAMSG_1 'Invalid Expression in Index Key:' /* * This directive calculates a centered position */ #xtrans CenterPos( , ) => ; { Int( (\[1] - \[1]) / 2 ) ; , Int( (\[2] - \[2]) / 2 ) } #define DC_RDDMSG_1 'Invalid RDD selection - '+cSuperRdd #define DC_RDDMSG_2 'DBE Name Description' #define DC_RDDMSG_3 'Select a Database Driver' *#define ADSDBE_MEMOFILE_EXT (DBE_USER+1) // RO *#define ADSDBE_INDEX_EXT (DBE_USER+2) // RW *#define ADSDBE_TBL_MODE (DBE_USER+3) // RW *#define ADSDBE_LOCK_MODE (DBE_USER+4) // RW *#define ADSDBE_RIGHTS_MODE (DBE_USER+5) // RW *#define ADSDBE_MEMOBLOCKSIZE (DBE_USER+6) // RW *#define ADSDBE_PASSWORD (DBE_USER+7) // RW // Return types of ADSDBE_TBL_MODE *#define ADSDBE_NTX 1 *#define ADSDBE_CDX 2 *#define ADSDBE_ADT 3 // Для опредедения разрешения монитора от Джимми #define DESKTOPVERTRES 117 #define DESKTOPHORZRES 118 // Excel Orientation #DEFINE xlLandscape 2 #DEFINE xlPortrait 1 #DEFINE xlWorkbookNormal -4143 #DEFINE xlCellTypeLastCell 11 #DEFINE SRCCOPY 0xCC0020 // Для быстрой графики Роджера #define KEYEVENTF_KEYUP 0x02 #define VK_MENU 0x12 #define VK_SNAPSHOT 0x2C #DEFINE VK_LBUTTON 0x01 #DEFINE VK_RBUTTON 0x02 * Для CSV=>DBF конвертера *#include "ot4xb.ch" // => ot4xb.dll => www.xbwin.com #ifndef CRLF #define CRLF chr(13)+chr(10) #endif * Klasse zum sequentiellen Einlesen groбer Dateien *#IF .t. // zum Einbinden in eigenes Projekt, .f. setzen ! MEMVAR dCBROWSE, dCEDIT, dCCOLOR STATIC snHdll // Для быстрой графики Роджера ********************************************************************************* **************************************************************************************** ******** 1.4. Выбор режима использования системы: монопольный или многопользовательский **************************************************************************************** *FUNCTION F1_4old() *Running(.T.) *IF .NOT. Flag_SysAdmin * LB_Warning(L("Эта функция доступна только сисадмину")) *ELSE * RegimSys := 1 // EXCLUSIVE-1, EXCLUSIVE-2 * @0,0 DCSAY L("Задайте режим ипользования системы: EXCLUSIVE-1, EXCLUSIVE-2") GET RegimSys PICTURE "#" COLOR "n/gb+" * DCREAD GUI FIT ADDBUTTONS TITLE L("1.4. Выбор режима: монопольный или сетевой") * DO CASE * CASE RegimSys = 1 * LB_Warning(L("Система будет работать в монопольном режиме")) * CASE RegimSys = 2 * LB_Warning(L("Система будет работать в сетевом режиме")) * OTHERWISE * RegimSys := 1 // EXCLUSIVE-1, EXCLUSIVE-2 * LB_Warning(L("Система будет работать в монопольном режиме")) * ENDCASE *ENDIF *Running(.F.) *RETURN NIL **************************************************************************************** ******** 1.5. Задание путей на папки с БД групп приложений (в БД Appls.dbf) **************************************************************************************** FUNCTION F1_5() LOCAL GetList := {}, aPres, oBrowse, oToolBar, aColors, bColor, GetOptions Running(.T.) IF .NOT. Flag_SysAdmin LB_Warning(L("Эта функция доступна только сисадмину!")) Running(.F.) RETURN NIL ENDIF // На конкретный заспук системы активной является одна текущая группа, заданная "по умолчанию" // Разные группы могут быть на различных носителях, локальных, сетвеых и даже в Internet IF FILE("PathGrAp.dbf") // БД путей на группы приложений. ** Переиндексировать БД PathGrAp.dbf, ** если не хватает хотя бы одного какого-нибудь индексного массива IF FILE("Path_kod.ntx").AND.; FILE("PathDefa.ntx").AND.; FILE("PathName.ntx").AND.; FILE("PathCrea.ntx") ELSE GenNtxPaths() ENDIF ELSE GenDbfPaths() ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций *USE PathGrAp INDEX Path_kod, PathDefa, PathName, PathCrea EXCLUSIVE NEW * 1 2 3 4 USE PathGrAp EXCLUSIVE NEW aColors := { {GRA_CLR_WHITE,GRA_CLR_DARKRED },; {GRA_CLR_WHITE,GRA_CLR_DARKBLUE },; {GRA_CLR_BLACK,GRA_CLR_DARKGREEN} } aPres := ; { { XBP_PP_COL_HA_FGCLR, GRA_CLR_WHITE },; // Header FG Color { XBP_PP_COL_HA_BGCLR, GRA_CLR_DARKGRAY },; // Header BG Color { XBP_PP_COL_FA_FGCLR, GRA_CLR_YELLOW },; // Footer FG Color { XBP_PP_COL_FA_BGCLR, GRA_CLR_DARKGRAY },; // Footer BG Color { XBP_PP_COL_DA_ROWSEPARATOR, XBPCOL_SEP_DOTTED },; // Row Sep { XBP_PP_COL_DA_COLSEPARATOR, XBPCOL_SEP_DOTTED },; // Col Sep { XBP_PP_COL_HA_ALIGNMENT, XBPALIGN_LEFT },; // Header alignment { XBP_PP_COL_DA_ROWHEIGHT, 20 },; // Row Height { XBP_PP_COL_DA_CELLHEIGHT, 20 } } // Cell Height /* ----- Create ToolBar ----- */ @ 27.5, 1 DCTOOLBAR oToolBar SIZE 130, 1.5 K=1.15 DCADDBUTTON CAPTION L('Помощь') ; SIZE K+LEN(L("Помощь")) ; ACTION {||Help15(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Помощь по режиму 1.2') DCADDBUTTON CAPTION L('Поиск') ; SIZE K+LEN(L("Поиск")) ; ACTION {||Search1_5(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Поиск по режиму 1.2') DCADDBUTTON CAPTION L('Сортировка') ; SIZE K+LEN(L("Сортировка")) ; ACTION {||Sort1_2(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Сортировка по режиму 1.2') DCADDBUTTON CAPTION L('В начало БД') ; SIZE K+LEN(L("В начало БД")) ; ACTION {||dbGoTop(), DC_GetRefresh(GetList)} ; WHEN {||!DC_TestBof()} ; PARENT oToolBar ; TOOLTIP L('Перейти на 1-ю запись') DCADDBUTTON CAPTION L('В конец БД') ; SIZE K+LEN(L("В конец БД")) ; ACTION {||dbGoBottom(), DC_GetRefresh(GetList)} ; WHEN {||!DC_TestEof()} ; PARENT oToolBar ; TOOLTIP L('Перейти на последнюю запись') DCADDBUTTON CAPTION L('Предыдущая') ; SIZE K+LEN(L("Предыдущая")) ; ACTION {||dbSkip(-1), DC_GetRefresh(GetList)} ; WHEN {||!DC_TestBof()} ; PARENT oToolBar ; TOOLTIP L('Перейти на предыдущую запись') DCADDBUTTON CAPTION L('Следующая') ; SIZE K+LEN(L("Следующая")) ; ACTION {||dbSkip(1), DC_GetRefresh(GetList)} ; WHEN {||!DC_TestEof()} ; PARENT oToolBar ; TOOLTIP L('Перейти на следующую запись') DCADDBUTTON CAPTION L('Добавить') ; SIZE K+LEN(L("Добавить")) ; ACTION {||Add_rec1_5(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; FONT '9.Arial Bold' ; TOOLTIP L('Добавить запись') DCADDBUTTON CAPTION L('Вставить') ; SIZE K+LEN(L("Вставить")) ; ACTION {||Ins_rec1_2(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Вставить пустую запись') DCADDBUTTON CAPTION L('Скопировать') ; SIZE K+LEN(L("Скопировать")) ; ACTION {||Copy_rec1_5(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Скопировать текущую запись') DCADDBUTTON CAPTION L('Удалить') ; SIZE K+LEN(L("Удалить")) ; ACTION {||Del_rec1_5(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Удалить запись') DCADDBUTTON CAPTION L('Очистить БД') ; SIZE K+LEN(L("Очистить БД")) ; ACTION {||Zap_db1_5(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Очистить БД') /* ----- Create browse ----- */ @ 1, 0 DCBROWSE oBrowse ALIAS 'PathGrAp' SIZE 131,26 ; EDIT xbeBRW_ItemSelected MODE DCGUI_BROWSE_EDITDOWN ; PRESENTATION aPres ; IF Flag_SysAdmin DCBROWSECOL FIELD PathGrAp->Kod_GrApps HEADER L("Код" ) PARENT oBrowse WIDTH 5 PROTECT {|| .T. } DCBROWSECOL FIELD PathGrAp->By_default HEADER L("По умолчанию" ) PARENT oBrowse WIDTH 1 DCBROWSECOL FIELD PathGrAp->NameGrApps HEADER L("Название группы приложений" ) PARENT oBrowse WIDTH 25 DCBROWSECOL FIELD PathGrAp->PathGrApps HEADER L("Путь на БД группы приложений") PARENT oBrowse WIDTH 30 DCBROWSECOL FIELD PathGrAp->Date HEADER L("Дата" ) PARENT oBrowse WIDTH 5 PROTECT {|| .T. } DCBROWSECOL FIELD PathGrAp->Time HEADER L("Время" ) PARENT oBrowse WIDTH 5 PROTECT {|| .T. } ENDIF DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; OPTIONS GetOptions ; MODAL ; TITLE L('1.5. Задание путей на папки с БД групп приложений') ; FIT ; CLEAREVENTS DBGOTOP() DO WHILE .NOT. EOF() IF LEN(ALLTRIM(By_default)) > 0 REPLACE By_default WITH "W" M_ApplsPath = UPPER(ALLTRIM(PathGrApps)) * MsgBox(M_ApplsPath) EXIT ENDIF DBSKIP(1) ENDDO ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW Running(.F.) RETURN(M_ApplsPath) **************************************************************************************** ****** Функции обработки кнопок 1.5 **************************************************************************************** ************************************************************************************************** FUNCTION Help15() aHelp := {} AADD(aHelp, L('Помощь по режиму: "1.5. ЗАДАНИЕ ПУТЕЙ НА ПАПКИ С БД ГРУПП ПРИЛОЖЕНИЙ". ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Папки с различными группами приложений могут быть на локальном компьютере, в локальной сети ')) AADD(aHelp, L('или в Internet. Пути на них задаются сисадмином при инсталляции системы и могут быть изменены ')) AADD(aHelp, L('им когда угодно. Все ранее созданные пути сохраняются в базе данных: PathGrAp.dbf. Один из этих путей,')) AADD(aHelp, L('а именно первый из отмеченный специальных символов, считается текущим и используется при СОЗДАНИИ ')) AADD(aHelp, L('приложений в диспетчере приложений 1.3, а в последующем при запуске приложений на исполнение пути ')) AADD(aHelp, L('берутся уже из БД диспетчера приложений ')) mHelpMax = -999;FOR h=1 TO LEN(aHelp);mHelpMax = MAX(mHelpMax, LEN(ALLTRIM(aHelp[h])));NEXT s=1;d=0.9;@0,0 DCGROUP oGroup1 CAPTION L(' ') SIZE mHelpMax-18, LEN(aHelp)*d+1.5 FOR h=1 TO LEN(aHelp);@s,2 DCSAY aHelp[h] SIZE 0 PARENT ogroup1;s=s+d;NEXT DCREAD GUI TO lExit FIT MODAL TITLE L('Помощь по режиму: 1.5. (C) Система "ЭЙДОС-X++"') RETURN NIL ************************************************************************************************** ******** Поиск по столбцу в"Наименование" режиме 2.1 FUNCTION Search1_5() * xdemo.exe ReTURN nil ******** Сортировка по заданному столбцу в режиме 1.2. (xdemo.exe FUNCTION XDemo_4 ( oDialog, lMDI, lGui )) FUNCTION Sort1_5() LOCAL nChoice := 1, oAppWindow, oCrt, oParent DC_Gui(.t.) SetColor('W+/N') CLS SetColor('N/W,W+/B') @ 5,20 CLEAR TO 19,60 @ 5,20 TO 19,60 *USE Users INDEX Use_kod, Use_name, Use_LPAA, Use_LPus, Use_dreg EXCLUSIVE NEW * 1 2 3 4 5 @ 7,25 PROMPT L('Код администратора приложения') @ 9,25 PROMPT L('Имя администратора приложения') @11,25 PROMPT L('Дата регистрации ') @13,25 PROMPT L('Exit ') MENU TO nChoice DO CASE CASE nChoice = 1 SET ORDER TO 1 CASE nChoice = 2 SET ORDER TO 2 CASE nChoice = 3 SET ORDER TO 5 CASE nChoice = 6 .OR. nChoice = 0 ENDCASE IF Valtype(oCrt) = 'O' .AND. oCrt:status()>0 oCrt:Destroy() SetAppWindow( oAppWindow ) ENDIF RETURN nil ******** Удалить текущую запись в БД, ******** а остальные сдвинуть вверх и перенумеровать FUNCTION Del_rec1_5() SET ORDER TO M_Recno = RECNO() DELETE;PACK *** Перенумеровать записи, начиная с удаленной DBGOTO(M_Recno) DO WHILE .NOT. EOF() FIELDPUT(1, RECNO()) DBSKIP(1) ENDDO DBGOTO(M_Recno) RETURN NIL ******** Вставить пустую запись в БД на месте текущей, ******** а остальные сдвинуть вниз и перенумеровать FUNCTION Ins_rec1_5() SET ORDER TO M_Recno = RECNO() APPEND BLANK A_RecNew := {} // Пустая запись FOR j=1 TO FCOUNT() AADD(A_RecNew, FIELDGET(j)) NEXT *** Переписать предпоследнюю запись на последнюю и т.д. до текущей FOR r=RECCOUNT()-1 TO M_Recno STEP -1 DBGOTO(r) A_Rec := {} FOR j=1 TO FCOUNT() AADD(A_Rec, FIELDGET(j)) NEXT DBGOTO(r+1) FOR j=1 TO FCOUNT() FIELDPUT(j, A_Rec[j]) NEXT NEXT *** Стереть текущую запись DBGOTO(M_Recno) FOR j=1 TO FCOUNT() FIELDPUT(j, A_RecNew[j]) NEXT *** Перенумеровать записи, начиная со вставленной DBGOTO(M_Recno) DO WHILE .NOT. EOF() FIELDPUT(1, RECNO()) DBSKIP(1) ENDDO DBGOTO(M_Recno) RETURN NIL ******** Скопировать (сдублировать) текущую запись в БД на месте текущей, ******** а остальные сдвинуть вниз и перенумеровать FUNCTION Copy_rec1_5() SET ORDER TO M_Recno = RECNO() A_RecNew := {} // Текущая запись FOR j=1 TO FCOUNT() AADD(A_RecNew, FIELDGET(j)) NEXT APPEND BLANK *** Переписать предпоследнюю запись на последнюю и т.д. до текущей FOR r=RECCOUNT()-1 TO M_Recno STEP -1 DBGOTO(r) A_Rec := {} FOR j=1 TO FCOUNT() AADD(A_Rec, FIELDGET(j)) NEXT DBGOTO(r+1) FOR j=1 TO FCOUNT() FIELDPUT(j, A_Rec[j]) NEXT NEXT *** Скопировать текущую запись DBGOTO(M_Recno) FOR j=1 TO FCOUNT() FIELDPUT(j, A_RecNew[j]) NEXT REPLACE Date WITH DTOC(DATE()) REPLACE Time WITH TIME() *** Перенумеровать записи, начиная со вставленной DBGOTO(M_Recno) DO WHILE .NOT. EOF() FIELDPUT(1, RECNO()) DBSKIP(1) ENDDO DBGOTO(M_Recno) RETURN NIL ******** Добавить пустую запись в конец БД FUNCTION Add_rec1_5() SET ORDER TO APPEND BLANK REPLACE Kod_GrApps WITH RECNO() REPLACE By_default WITH "W" REPLACE NameGrApps WITH "Новая группа приложений" REPLACE PathGrApps WITH UPPER(ALLTRIM(M_ApplsPath)) REPLACE Date WITH DTOC(DATE()) REPLACE Time WITH TIME() RETURN NIL ******** Очистить БД FUNCTION Zap_db1_5() SET ORDER TO ZAP APPEND BLANK REPLACE Kod_GrApps WITH 1 REPLACE By_default WITH "W" REPLACE NameGrApps WITH "Базовая группа приложений (по умолчанию)" REPLACE PathGrApps WITH UPPER(ALLTRIM(M_ApplsPath)) REPLACE Date WITH DTOC(DATE()) REPLACE Time WITH TIME() RETURN NIL **************************************************************************************** ******** 1.2. Регистрация и удаление регистрации ******** администратора приложения и его пользователей **************************************************************************************** FUNCTION F1_2() LOCAL GetList := {}, aPres, oBrowse, oToolBar, aColors, bColor, GetOptions Running(.T.) IF Flag_SysAdmin .OR. Flag_AdmAppl ELSE LB_Warning(L("Эта функция доступна только Сисадмину и Администраторам приложений")) Running(.F.) RETURN NIL ENDIF IF ApplChange("1.2()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF IF FILE("Users.dbf") // БД администраторов приложений и паролей доступа к ним: Users.dbf ** Переиндексировать БД Users.dbf, GenNtxUsers() ELSE GenDbfUsers() ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Users INDEX Use_kod, Use_name, Use_LPAA, Use_LPus, Use_dreg EXCLUSIVE NEW * 1 2 3 4 5 aColors := { {GRA_CLR_WHITE,GRA_CLR_DARKRED },; {GRA_CLR_WHITE,GRA_CLR_DARKBLUE },; {GRA_CLR_BLACK,GRA_CLR_DARKGREEN} } aPres := ; { { XBP_PP_COL_HA_FGCLR, GRA_CLR_WHITE },; // Header FG Color { XBP_PP_COL_HA_BGCLR, GRA_CLR_DARKGRAY },; // Header BG Color { XBP_PP_COL_FA_FGCLR, GRA_CLR_YELLOW },; // Footer FG Color { XBP_PP_COL_FA_BGCLR, GRA_CLR_DARKGRAY },; // Footer BG Color { XBP_PP_COL_DA_ROWSEPARATOR, XBPCOL_SEP_DOTTED },; // Row Sep { XBP_PP_COL_DA_COLSEPARATOR, XBPCOL_SEP_DOTTED },; // Col Sep { XBP_PP_COL_HA_ALIGNMENT, XBPALIGN_LEFT },; // Header alignment { XBP_PP_COL_DA_ROWHEIGHT, 20 },; // Row Height { XBP_PP_COL_DA_CELLHEIGHT, 20 } } // Cell Height /* ----- Create ToolBar ----- */ @ 27.5, 1 DCTOOLBAR oToolBar SIZE 130, 1.5 K=1.15 DCADDBUTTON CAPTION L('Помощь') ; SIZE K+LEN(L("Помощь")) ; ACTION {||Help12(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Помощь по режиму 1.2') DCADDBUTTON CAPTION L('Поиск') ; SIZE K+LEN(L("Поиск")) ; ACTION {||Search1_2(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Поиск по режиму 1.2') DCADDBUTTON CAPTION L('Сортировка') ; SIZE K+LEN(L("Сортировка")) ; ACTION {||Sort1_2(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Сортировка по режиму 1.2') DCADDBUTTON CAPTION L('В начало БД') ; SIZE K+LEN(L("В начало БД")) ; ACTION {||dbGoTop(), DC_GetRefresh(GetList)} ; WHEN {||!DC_TestBof()} ; PARENT oToolBar ; TOOLTIP L('Перейти на 1-ю запись') DCADDBUTTON CAPTION L('В конец БД') ; SIZE K+LEN(L("В конец БД")) ; ACTION {||dbGoBottom(), DC_GetRefresh(GetList)} ; WHEN {||!DC_TestEof()} ; PARENT oToolBar ; TOOLTIP L('Перейти на последнюю запись') DCADDBUTTON CAPTION L('Предыдущая') ; SIZE K+LEN(L("Предыдущая")) ; ACTION {||dbSkip(-1), DC_GetRefresh(GetList)} ; WHEN {||!DC_TestBof()} ; PARENT oToolBar ; TOOLTIP L('Перейти на предыдущую запись') DCADDBUTTON CAPTION L('Следующая') ; SIZE K+LEN(L("Следующая")) ; ACTION {||dbSkip(1), DC_GetRefresh(GetList)} ; WHEN {||!DC_TestEof()} ; PARENT oToolBar ; TOOLTIP L('Перейти на следующую запись') DCADDBUTTON CAPTION L('Добавить') ; SIZE K+LEN(L("Добавить")) ; ACTION {||Add_rec1_2(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Добавить запись') DCADDBUTTON CAPTION L('Вставить') ; SIZE K+LEN(L("Вставить")) ; ACTION {||Ins_rec1_2(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Вставить пустую запись') DCADDBUTTON CAPTION L('Скопировать') ; SIZE K+LEN(L("Скопировать")) ; ACTION {||Copy_rec1_2(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Скопировать текущую запись') IF Flag_SysAdmin DCADDBUTTON CAPTION L('Удалить') ; SIZE K+LEN(L("Удалить")) ; ACTION {||Del_rec1_2(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Удалить запись') DCADDBUTTON CAPTION L('Очистить БД') ; SIZE K+LEN(L("Очистить БД")) ; ACTION {||Zap_db1_2(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Очистить базу данных') ENDIF /* ----- Create browse ----- */ @ 1, 0 DCBROWSE oBrowse ALIAS 'Users' SIZE 131,26 ; EDIT xbeBRW_ItemSelected MODE DCGUI_BROWSE_EDITDOWN ; PRESENTATION aPres ; * DCBROWSECOL DATA {||Decrypt(USERS->Passw_AdmA)} HEADER L('Password') WIDTH 10 // Шифрованный пароль (Роджер) DCBROWSECOL FIELD Users->KOD_AdmApp HEADER L("Код адм.приложения" ) PARENT oBrowse PROTECT {|| .T. } // Отображаемое некорректируемое поле DCBROWSECOL FIELD Users->NAME_AdmAp HEADER L("Ф.И.О.адм.приложения" ) PARENT oBrowse // Отображаемое корректируемое поле * DCBROWSECOL DATA {||REPL('*',LEN(ALLTRIM(Users->Login_AdmA)))} HEADER L("Login адм.приложения" ) PARENT oBrowse // Неотображаемое корректируемое поле (Роджер) * DCBROWSECOL DATA {||REPL('*',LEN(ALLTRIM(Users->Passw_AdmA)))} HEADER L("Пароль адм.приложения") PARENT oBrowse // Неотображаемое корректируемое поле (Роджер) *DCBROWSECOL DATA {||REPL('*',LEN(ALLTRIM(Users->Passw_User)))} HEADER L("Пароль пользователя" ) PARENT oBrowse // Неотображаемое корректируемое поле (Роджер) DCBROWSECOL FIELD Users->Login_AdmA HEADER L("Login адм.приложения" ) PARENT oBrowse // Неотображаемое корректируемое поле (Роджер) DCBROWSECOL FIELD Users->Passw_AdmA HEADER L("Пароль адм.приложения") PARENT oBrowse // Неотображаемое корректируемое поле (Роджер) DCBROWSECOL FIELD Users->Passw_User HEADER L("Пароль пользователя" ) PARENT oBrowse // Неотображаемое корректируемое поле (Роджер) DCBROWSECOL FIELD Users->ColorSchem HEADER L("Цветовая схема меню" ) PARENT oBrowse // Отображаемое корректируемое поле DCBROWSECOL FIELD Users->Date HEADER L("Дата регистрации" ) PARENT oBrowse PROTECT {|| .T. } // Отображаемое некорректируемое поле DCBROWSECOL FIELD Users->Time HEADER L("Время регистрации" ) PARENT oBrowse PROTECT {|| .T. } // Отображаемое некорректируемое поле DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; OPTIONS GetOptions ; MODAL ; TITLE L('1.2. Регистрация и удаление регистрации администраторов приложений') ; FIT ; CLEAREVENTS ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ************************************************************************************************** FUNCTION Help12() aHelp := {} AADD(aHelp, L('Помощь по режиму: "1.2. РЕГИСТРАЦИЯ И УДАЛЕНИЕ РЕГИСТРАЦИИ АДМИНИСТРАТОРОВ ПРИЛОЖЕНИЙ". ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Администратор приложения имеет все права на создание и удаление приложения и на реализацию в ')) AADD(aHelp, L('созданном им приложении всех возможностей системы: ')) AADD(aHelp, L('- формализация предметной области; ')) AADD(aHelp, L('- синтез (многопараметрическая типизация) и верификация модели; ')) AADD(aHelp, L('- решение задач системной идентификации, прогнозирования и поддержки принятия решений; ')) AADD(aHelp, L('- исследование предметной области путем исследования ее модели. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Администратор приложений в данном режиме может: ')) AADD(aHelp, L('- задать и скорректировать данные СВОЕЙ учетной записи; ')) AADD(aHelp, L('- удалить свою учетную запись; ')) AADD(aHelp, L('- задать пароль пользователей СВОИХ приложений. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('После регистрации в данном режиме для реализации полномочий администратора приложения ему ')) AADD(aHelp, L('необходимо авторизоваться в режиме 1.1 и выбрать приложение для работы в диспетчере приложений')) AADD(aHelp, L('(режим 1.3.). ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Пользователь имеет все права администратора приложения, кроме создания и удаления приложения, ')) AADD(aHelp, L('а также корректировки любой информации в режиме 1.2, в частности создания и удаления записей ')) AADD(aHelp, L('регистрации администраторов приложений, задания и изменения паролей доступа для пользователей.')) AADD(aHelp, L(' ')) AADD(aHelp, L('Пользователи для получения доступа к приложению должны авторизоваться в режиме 1.1, задав ')) AADD(aHelp, L('Login: "User" и пароль, предоставленный администратором приложения, а затем выбрать приложение')) AADD(aHelp, L('для работы в диспетчере приложений (режим 1.3.) ')) mHelpMax = -999;FOR h=1 TO LEN(aHelp);mHelpMax = MAX(mHelpMax, LEN(ALLTRIM(aHelp[h])));NEXT s=1;d=0.9;@0,0 DCGROUP oGroup1 CAPTION L(' ') SIZE mHelpMax-7, LEN(aHelp)*d+1.5 FOR h=1 TO LEN(aHelp);@s,2 DCSAY aHelp[h] SIZE 0 PARENT ogroup1;s=s+d;NEXT DCREAD GUI TO lExit FIT MODAL TITLE L('Помощь по режиму: 1.2. (C) Система "ЭЙДОС-X++"') RETURN NIL ************************************************************************************************** ******** Поиск по столбцу в"Наименование" режиме 2.1 FUNCTION Search1_2() * xdemo.exe ReTURN nil ******** Сортировка по заданному столбцу в режиме 1.2. (xdemo.exe FUNCTION XDemo_4 ( oDialog, lMDI, lGui )) FUNCTION Sort1_2() LOCAL nChoice := 1, oAppWindow, oCrt, oParent DC_Gui(.t.) SetColor('W+/N') CLS SetColor('N/W,W+/B') @ 5,20 CLEAR TO 19,60 @ 5,20 TO 19,60 *USE Users INDEX Use_kod, Use_name, Use_LPAA, Use_LPus, Use_dreg EXCLUSIVE NEW * 1 2 3 4 5 @ 7,25 PROMPT L('Код администратора приложения') @ 9,25 PROMPT L('Имя администратора приложения') @11,25 PROMPT L('Дата регистрации ') @13,25 PROMPT L('Exit ') MENU TO nChoice DO CASE CASE nChoice = 1 SET ORDER TO 1 CASE nChoice = 2 SET ORDER TO 2 CASE nChoice = 3 SET ORDER TO 5 CASE nChoice = 6 .OR. nChoice = 0 ENDCASE IF Valtype(oCrt) = 'O' .AND. oCrt:status()>0 oCrt:Destroy() SetAppWindow( oAppWindow ) ENDIF RETURN nil ******** Удалить текущую запись в БД, ******** а остальные сдвинуть вверх и перенумеровать FUNCTION Del_rec1_2() SET ORDER TO M_Recno = RECNO() DELETE;PACK *** Перенумеровать записи, начиная с удаленной DBGOTO(M_Recno) DO WHILE .NOT. EOF() FIELDPUT(1, RECNO()) DBSKIP(1) ENDDO DBGOTO(M_Recno) RETURN NIL ******** Вставить пустую запись в БД на месте текущей, ******** а остальные сдвинуть вниз и перенумеровать FUNCTION Ins_rec1_2() SET ORDER TO M_Recno = RECNO() APPEND BLANK A_RecNew := {} // Пустая запись FOR j=1 TO FCOUNT() AADD(A_RecNew, FIELDGET(j)) NEXT *** Переписать предпоследнюю запись на последнюю и т.д. до текущей FOR r=RECCOUNT()-1 TO M_Recno STEP -1 DBGOTO(r) A_Rec := {} FOR j=1 TO FCOUNT() AADD(A_Rec, FIELDGET(j)) NEXT DBGOTO(r+1) FOR j=1 TO FCOUNT() FIELDPUT(j, A_Rec[j]) NEXT NEXT *** Стереть текущую запись DBGOTO(M_Recno) FOR j=1 TO FCOUNT() FIELDPUT(j, A_RecNew[j]) NEXT *** Перенумеровать записи, начиная со вставленной DBGOTO(M_Recno) DO WHILE .NOT. EOF() FIELDPUT(1, RECNO()) DBSKIP(1) ENDDO DBGOTO(M_Recno) RETURN NIL ******** Скопировать (сдублировать) текущую запись в БД на месте текущей, ******** а остальные сдвинуть вниз и перенумеровать FUNCTION Copy_rec1_2() SET ORDER TO M_Recno = RECNO() A_RecNew := {} // Текущая запись FOR j=1 TO FCOUNT() AADD(A_RecNew, FIELDGET(j)) NEXT APPEND BLANK *** Переписать предпоследнюю запись на последнюю и т.д. до текущей FOR r=RECCOUNT()-1 TO M_Recno STEP -1 DBGOTO(r) A_Rec := {} FOR j=1 TO FCOUNT() AADD(A_Rec, FIELDGET(j)) NEXT DBGOTO(r+1) FOR j=1 TO FCOUNT() FIELDPUT(j, A_Rec[j]) NEXT NEXT *** Скопировать текущую запись DBGOTO(M_Recno) FOR j=1 TO FCOUNT() FIELDPUT(j, A_RecNew[j]) NEXT REPLACE Date WITH DTOC(DATE()) REPLACE Time WITH TIME() *** Перенумеровать записи, начиная со вставленной DBGOTO(M_Recno) DO WHILE .NOT. EOF() FIELDPUT(1, RECNO()) DBSKIP(1) ENDDO DBGOTO(M_Recno) RETURN NIL ******** Добавить пустую запись в конец БД FUNCTION Add_rec1_2() SET ORDER TO APPEND BLANK REPLACE Kod_AdmApp WITH RECNO() REPLACE Login_AdmA WITH "" REPLACE Passw_AdmA WITH "" REPLACE Passw_User WITH "" REPLACE Date WITH DTOC(DATE()) REPLACE Time WITH TIME() REPLACE ColorSchem WITH "000 000 000 255 255 204" * 12345678901234567890123 * 1 5 9 12 17 21 RETURN NIL ******** Очистить БД Users.dbf и сформировать начальные записи FUNCTION Zap_db1_2() SET ORDER TO ZAP APPEND BLANK REPLACE Kod_AdmApp WITH 1 REPLACE Name_AdmAp WITH "Системый администратор" REPLACE Login_AdmA WITH "1" REPLACE Passw_AdmA WITH "1" REPLACE Passw_User WITH "1" REPLACE Date WITH DTOC(DATE()) REPLACE Time WITH TIME() REPLACE ColorSchem WITH "000 000 000 025 255 204" * 12345678901234567890123 * 1 5 9 13 17 21 APPEND BLANK REPLACE Kod_AdmApp WITH 2 REPLACE Name_AdmAp WITH "Администратор учебных приложений" REPLACE Login_AdmA WITH "2" REPLACE Passw_AdmA WITH "2" REPLACE Passw_User WITH "2" REPLACE Date WITH DTOC(DATE()) REPLACE Time WITH TIME() REPLACE ColorSchem WITH "000 000 000 255 255 204" * 12345678901234567890123 * 1 5 9 13 17 21 APPEND BLANK REPLACE Kod_AdmApp WITH 3 REPLACE Name_AdmAp WITH "Администратор научных приложений" REPLACE Login_AdmA WITH "3" REPLACE Passw_AdmA WITH "3" REPLACE Passw_User WITH "3" REPLACE Date WITH DTOC(DATE()) REPLACE Time WITH TIME() REPLACE ColorSchem WITH "000 000 000 155 255 204" * 12345678901234567890123 * 1 5 9 13 17 21 RETURN NIL ******** Display a warning message ******** Может выдавать сообщения элементами массива и без ctitle: *message := {} *AADD(message,'1-е сообщение') *AADD(message,'2-е сообщение') *AADD(message,'3-е сообщение') *LB_Warning( message ) FUNCTION LB_Warning( message, ctitle ) LOCAL aMsg := {} DEFAULT cTitle TO '' IF valtype(message) # 'A' aadd(aMsg,message) ELSE aMsg := message ENDIF IF LEN(ALLTRIM(cTitle)) > 0 DC_MsgBox( ,,aMsg,cTitle) ELSE DC_MsgBox( ,,aMsg,'(C) Универсальная когнитивная аналитическая система "Эйдос-Х++"') ENDIF RETURN NIL *------------------------------------------------------------------------------ ******** Display a message of up to 60 characters in a window (usually ******** at the beginning of some lengthy, time-consuming process) FUNCTION LB_Inform(message) STATIC cDialog IF message == NIL DC_Impl(cDialog) cDialog := NIL ELSE cDialog := DC_WaitOn(message,,,,,,,,,,,.F.) ENDIF RETURN NIL * --------------- FUNCTION LogHandler( nEvent, mp1, mp2, oXbp, oDlg, GetList ) LOCAL oMenu, cMessage, cCaption, nPointer, cType := '', ; cProcName, cProcLine IF oXbp == nil RETURN DCGUI_NONE ENDIF IF oXbp:isDerivedFrom('XbpMenuBar') IF nEvent == xbeP_ItemSelected oMenu := oXbp:getItem(mp1)[1] IF Valtype(oMenu) == 'O' nPointer := oMenu:getListPointer cCaption := GetList[nPointer,cGETLIST_CAPTION] cMessage := GetList[nPointer,cGETLIST_MESSAGE] IF Valtype(cMessage) = 'A' cMessage := cMessage[1] ENDIF ELSE IF mp1 > 0 .AND. mp1 <= Len(oXbp:cargo[6]) cMessage := oXbp:cargo[5,mp1] cCaption := oXbp:cargo[8,mp1] ENDIF ENDIF cType := 'Menu Item' ENDIF ELSEIF oXbp:isDerivedFrom('DC_XbaseParts') IF nEvent == xbeP_Activate nPointer := oXbp:getListPointer cCaption := GetList[nPointer,cGETLIST_CAPTION] cMessage := GetList[nPointer,cGETLIST_MESSAGE] cType := 'Button' IF Valtype(cCaption) == 'B' cCaption := Eval(cCaption) ENDIF IF Empty(cCaption) cCaption := oXbp:caption ENDIF ENDIF ENDIF IF !Empty(cType) IF Valtype(cMessage) == 'A' cMessage := cMessage[1] ENDIF LogEvent( cType, cCaption, cMessage ) ENDIF RETURN DCGUI_NONE * --------------- FUNCTION LogEvent( cType, cCaption, cMessage ) LOCAL nHandle DEFAULT cCaption := '', ; cMessage := '' nHandle := FOpen( 'EVENTS.LOG', FO_WRITE ) IF nHandle <= 0 nHandle := FCreate( 'EVENTS.LOG' ) ENDIF FSeek( nHandle, 0, FS_END ) FWrite( nHandle, Dtos(Date()) + ' ' + Time() + ' : ' + ; cType + ' : ' + cCaption + ' : ' + cMessage + Chr(13) + Chr(10) ) FClose(nHandle) RETURN nil * --------------- FUNCTION MenuHandler( nEvent, mp1, mp2, oXbp, oDlg, GetList, oMessageBox ) LOCAL oMenu, aPos, cMessage, nPointer STATIC cMenuMessage := '' IF oXbp#nil .AND. oXbp:isDerivedFrom('XbpMenuBar') IF nEvent == xbeP_ItemMarked oMenu := oXbp:getItem(mp1)[1] IF Valtype(oMenu) == 'O' IF !oMessageBox:isVisible() oMessageBox:show() ENDIF nPointer := oMenu:getListPointer cMessage := GetList[nPointer,cGETLIST_MESSAGE] ELSE IF mp1 > 0 .AND. mp1 <= Len(oXbp:cargo[6]) cMessage := oXbp:cargo[5,mp1] ENDIF ENDIF IF Empty(cMessage) cMessage := Chr(255) ELSE cMessage := cMessage[1] ENDIF IF cMenuMessage # cMessage cMessage := Strtran(cMessage,';',Chr(13)) oMessageBox:ChildList()[1]:setCaption(cMessage) cMenuMessage := cMessage ENDIF IF Valtype(oMenu) == 'O' .AND. !Empty(cMessage) oMessageBox:setSize({oMenu:currentSize()[1],130}) oMessageBox:childList()[1]:setPos({4,4}) oMessageBox:childList()[1]:setSize({oMessageBox:currentSize()[1]-8,oMessageBox:currentSize()[2]-20}) aPos := oMenu:currentPos() oMessageBox:setPos({aPos[1],aPos[2]-130}) oMessageBox:toFront() ENDIF ELSEIF nEvent == xbeMENB_EndMenu .OR. nEvent == xbeP_ActivateItem oMessageBox:hide() ENDIF ENDIF RETURN DCGUI_NONE ******** Расчет координат главного окна *FUNCTION CenterPos( aSize, aRefSize ) *RETURN { Int( (aRefSize[1] - aSize[1]) / 2 ) ; * , Int( (aRefSize[2] - aSize[2]) / 2 ) + 14 } // Информационное сообщение *LB_Warning(Mess) *LB_Inform("Ура! Получилось!") // Сообщение об ошибке *LB_Warning(L("Нет папки! Создайте!", "Сообщение об ошибке" ) ******** Заглушка FUNCTION Razrab() LB_Warning(L("Данная функция в процессе разработки"), L("Информационное сообщение" )) RETURN NIL ******************************************************************************* ******** Выбор цветовой схемы главного меню (использован пример из demo3) ******************************************************************************* FUNCTION F1_6() LOCAL i, aCoords, aLocals[76], GetOptions, GetList Running(.T.) IF Flag_SysAdmin .OR. Flag_AdmAppl ELSE LB_Warning(L("Эта функция доступна только Сисадмину и Администраторам приложений")) Running(.F.) RETURN NIL ENDIF PUBLIC Cf1:=000,Cf2:=000,Cf3:=000, Cb1:=025,Cb2:=255,Cb3:=255 // Загрузить цветовую схему меню, заданную авторизованным пользователем CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Users INDEX Use_kod EXCLUSIVE NEW SET ORDER TO 1;T=DBSEEK(STR(M_KodAdmAppls,8)) IF T * 000 000 000 025 255 204 * 12345678901234567890123 * 1 5 9 13 17 21 Cf1 = VAL(SUBSTR(ColorSchem, 1,3)) Cf2 = VAL(SUBSTR(ColorSchem, 5,3)) Cf3 = VAL(SUBSTR(ColorSchem, 9,3)) Cb1 = VAL(SUBSTR(ColorSchem,13,3)) Cb2 = VAL(SUBSTR(ColorSchem,17,3)) Cb3 = VAL(SUBSTR(ColorSchem,21,3)) ENDIF GetList := {} nRed = Cb1 nGreen = Cb2 nBlue = Cb3 @ 2.5, 20 DCSPINBUTTON nRed PARENT oTabPage1 SIZE 7 LIMITS 0,255 ; OBJECT oRedSpin ; CALLBACK {|a,b,o|o:GetData(),oRedBar:SetData(),RGB(aLocals)} @ 0, -10 DCSAY L('Red') SAYSIZE 5 PARENT oTabPage1 RELATIVE oRedSpin @ 0, 10 DCSCROLLBAR DATA nRed SIZE 40,1 PARENT oTabPage1 ; RELATIVE oRedSpin ; TYPE XBPSCROLL_HORIZONTAL RANGE 0,255 OBJECT oRedBar ; SCROLL { |a,x,o| nRed := a[1], ; oRedSpin:SetData(), ; o:SetData(), RGB(aLocals) } @ 2, 0 DCSPINBUTTON nGreen PARENT oTabPage1 SIZE 7 LIMITS 0,255 ; OBJECT oGreenSpin RELATIVE oRedSpin ; CALLBACK {|a,b,o|o:GetData(),oGreenBar:SetData(),RGB(aLocals)} @ 0, -10 DCSAY L('Green') SAYSIZE 5 PARENT oTabPage1 RELATIVE oGreenSpin @ 0, 10 DCSCROLLBAR DATA nGreen SIZE 40,1 PARENT oTabPage1 ; TYPE XBPSCROLL_HORIZONTAL RANGE 0,255 OBJECT oGreenBar ; RELATIVE oGreenSpin ; SCROLL { |a,x,o| nGreen := a[1], ; oGreenSpin:SetData(), ; o:SetData(), RGB(aLocals) } @ 2, 0 DCSPINBUTTON nBlue PARENT oTabPage1 SIZE 7 LIMITS 0,255 ; OBJECT oBlueSpin RELATIVE oGreenSpin ; CALLBACK {|a,b,o|o:GetData(),oBlueBar:SetData(),RGB(aLocals)} @ 0, -10 DCSAY L('Blue') SAYSIZE 5 PARENT oTabPage1 RELATIVE oBlueSpin @ 0, 10 DCSCROLLBAR DATA nBlue SIZE 40,1 PARENT oTabPage1 ; RELATIVE oBlueSpin ; TYPE XBPSCROLL_HORIZONTAL RANGE 0,255 OBJECT oBlueBar ; SCROLL { |a,x,o| nBlue := a[1], ; oBlueSpin:SetData(), ; o:SetData(), RGB(aLocals) } @ 5, 0 DCSTATIC TYPE XBPSTATIC_TYPE_RAISEDBOX SIZE 45,4 ; OBJECT oColorBox PARENT oTabPage1 RELATIVE oBlueSpin ; EVAL { |o| o:paint := {||RGB(aLocals)} } /* ---- Tool Bar ---- */ @ .1,.2 DCTOOLBAR oToolBar SIZE 9,1 BUTTONSIZE 9,1 DCADDBUTTON CAPTION L('Exit') PARENT oToolBar ; ACTION {||DC_ReadGuiEvent(DCGUI_EXIT_OK,GetList)} DCREAD GUI ; TITLE L('1.6. Выбор цветовой схемы главного меню') ; OPTIONS GetOptions ; FIT ** Присвоить фону цвет, заданный в диалоге ******* ** MsgBox(STR(nRed)+STR(nGreen)+STR(nBlue)) Cb1 = nRed Cb2 = nGreen Cb3 = nBlue fColor := GraMakeRGBColor({ Cf1, Cf2, Cf3 }) // Цветовые параметры текста меню bColor := GraMakeRGBColor({ Cb1, Cb2, Cb3 }) // Цветовые параметры фона меню ApplColSch() ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ******** Принять цветовую схему главного меню FUNCTION ApplColSch() * 000 000 000 025 255 204 * 12345678901234567890123 * 1 5 9 13 17 21 Mess = STRTRAN(STR(Cf1,3)," ","0")+" "+; STRTRAN(STR(Cf2,3)," ","0")+" "+; STRTRAN(STR(Cf3,3)," ","0")+" "+; STRTRAN(STR(Cb1,3)," ","0")+" "+; STRTRAN(STR(Cb2,3)," ","0")+" "+; STRTRAN(STR(Cb3,3)," ","0") CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Users INDEX Use_kod EXCLUSIVE NEW SET ORDER TO 1;T=DBSEEK(STR(M_KodAdmAppls,8)) IF T REPLACE ColorSchem WITH Mess ENDIF *Mess = "Fr_Red=" +STRTRAN(STR(Cf1,3)," ","0")+" "+; * "Fr_Green="+STRTRAN(STR(Cf2,3)," ","0")+" "+; * "Fr_Blue=" +STRTRAN(STR(Cf3,3)," ","0")+" "+; * "Bg_Red=" +STRTRAN(STR(Cb1,3)," ","0")+" "+; * "Bg_Green="+STRTRAN(STR(Cb2,3)," ","0")+" "+; * "Bg_Blue=" +STRTRAN(STR(Cb3,3)," ","0") aMess := {} AADD(aMess, L("Выбрана следующая цветовая схема главного меню:")) AADD(aMess, " Red=" +STRTRAN(STR(Cb1,3)," ","0")+"; "+; " Green="+STRTRAN(STR(Cb2,3)," ","0")+"; "+; " Blue=" +STRTRAN(STR(Cb3,3)," ","0")) AADD(aMess, L(" Данная цветовая схема вступит в силу")) AADD(aMess, L(" после перезагрузки системы Эйдос-Х++")) LB_Warning(aMess, L("Цветовая схема фона главного меню") ) Flad_ExitColSch = .F. RETURN NIL ******** Выйти на просмотр следующей цветовой схемы главного меню FUNCTION NextColSch() Mess = "Cf1="+STRTRAN(STR(Cf1,3)," ","0")+" "+; "Cf2="+STRTRAN(STR(Cf2,3)," ","0")+" "+; "Cf3="+STRTRAN(STR(Cf3,3)," ","0")+" "+; "Cb1="+STRTRAN(STR(Cb1,3)," ","0")+" "+; "Cb2="+STRTRAN(STR(Cb2,3)," ","0")+" "+; "Cb3="+STRTRAN(STR(Cb3,3)," ","0") LB_Warning(Mess, L("Текущая цветовая схема") ) Flad_ExitColSch = .T. RETURN NIL ******** Выйти из режима просмотра и выбора цветовых схем главного меню FUNCTION ExitColSch() LB_Warning(L("Для выхода нажмите [X]"), L("Выход") ) Flad_ExitColSch = .F. RETURN NIL ****************************************************************** STATIC PROCEDURE RGB( aLocals ) LOCAL aAttr := Array(GRA_AA_COUNT) // area attributes LOCAL nMax, aOldAttr, aOldRGB oPS := oColorBox:LockPS() nMax := 255 // oPS:maxColorIndex() // max colors // Set new RGB color and draw box aAttr[ GRA_AA_COLOR ] := nMax aOldAttr := oPS:setAttrArea( aAttr ) aOldRGB := oPS:setColorIndex( nMax, {nRed,nGreen,nBlue} ) GraBox( oPS, {0,0}, {400,400}, GRA_FILL ) oPS:setAttrArea( aOldAttr ) oPS:setColorIndex( nMax, aOldRGB ) oColorBox:unlockPS( oPS ) RETURN ****************************************************************** * Create std dialog window hidden ****************************************************************** FUNCTION GuiStdDialog( cTitle ) LOCAL oDlg LOCAL aSize := {600,400} LOCAL aPos := CenterPos( aSize, AppDesktop():currentSize() ) DEFAULT cTitle TO "Standard Dialog Window" oDlg := XbpDialog():new( ,, aPos, aSize,, .F. ) oDlg:icon := 1 oDlg:taskList := .T. oDlg:title := cTitle oDlg:drawingArea:ClipChildren := .T. oDlg:create() oDlg:drawingArea:setFontCompoundName( FONT_DEFPROP_SMALL ) RETURN oDlg *FUNCTION CenterPos( aSize, aRefSize ) *RETURN { Int( (aRefSize[1] - aSize[1]) / 2 ) ; * , Int( (aRefSize[2] - aSize[2]) / 2 ) } ****************************************************************** * Get filename with filedialog ****************************************************************** FUNCTION GetFilename() LOCAL oDlg := XbpFiledialog():New(), cFile oDlg:Title := "Please select DBF file" oDlg:Create() cFile := oDlg:Open( "..\..\DATA\*.DBF" ) RETURN cFile ****************************************************************** * Data code block for fields ****************************************************************** FUNCTION EditBlock( cFieldName ) LOCAL bBlock, cBlock IF FieldPos( cFieldName ) <> 0 IF ! "->" $ cFieldName cFieldName := "FIELD->"+cFieldName ENDIF cBlock := "{|x| IIf(x==NIL,"+cFieldName+",WriteField('"+cFieldName+"',x) ) }" bBlock := &cBlock ENDIF RETURN bBlock ****************************************************************** * Write value to field when record lock can be obtained ****************************************************************** FUNCTION WriteField( cField, xValue ) IF RLock() &cField := xValue DbUnlock() ENDIF RETURN xValue ******** GUI-DBEDIT от Роджера ***************** * This sample demonstrates a browse of a database with a toolbar at the top * containing pushbuttons for navigation of the browse. * BROWSE(DATABASE) *FUNCTION XSample_7() *RETURN NIL **************************************************************************************** ******** 2.1. Классификационные шкалы и градации **************************************************************************************** FUNCTION F2_1() LOCAL GetList := {}, aPres, oBrowse, oToolBar, aColors, bColor, GetOptions Running(.T.) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF ApplChange("2.1()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF IF FILE("_CurrInf.arx") // Файл с информацией о том, какая модель задана текущей M_CurrInf = DC_ARestore("_CurrInf.arx") ELSE DC_ASave(M_CurrInf, "_CurrInf.arx") ENDIF Flag_Classes = .T. Flag_ClassSc = .T. Flag_GrClSc = .T. IF .NOT. FILE("Class_Sc.dbf") // БД класс.шкал: Class_Sc.dbf Flag_ClassSc = .F. GenDbfClSc(.F.) ENDIF IF .NOT. FILE("Gr_ClSc.dbf") // БД градаций класс.шкал: Gr_ClSc.dbf Flag_GrClSc = .F. GenDbfGrClSc(.F.) ENDIF IF .NOT. FILE("Classes.dbf") // БД градаций класс.шкал + градаций класс.шкал: Classes.dbf Flag_Classes = .F. GenDbfClass(.F.) ENDIF aStructure := { { "Rang" , "N", 8, 0 }, ; { "Kod_min" , "N", 8, 0 }, ; { "Kod_max" , "N", 8, 0 } } DbCreate( 'aKodCls', aStructure ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Class_Sc EXCLUSIVE NEW;N_ClSc = RECCOUNT() USE Gr_ClSc EXCLUSIVE NEW;N_GrClSc = RECCOUNT() USE aKodCls EXCLUSIVE NEW;ZAP IF N_ClSc * N_GrClSc = 0 .AND. N_Cls > 0 Flag_Classes = .T. Flag_ClassSc = .F. Flag_GrClSc = .F. ENDIF // Нет БД Class_Sc и Gr_ClSc: однооконный интерфейс, в котором задать и сформировать класс.шкалы и градации IF Flag_Classes = .T. .AND.; Flag_ClassSc = .F. .AND.; Flag_GrClSc = .F. aMess := {} AADD(aMess, L('В текущем приложении нет баз данных классификационных шкал и градаций: "Class_Sc", "Gr_ClSc"!')) AADD(aMess, L('Необходимо вручную задать КОДЫ классиф.шкал и нажать кнопку: "Создать класс.шкалы и градации"')) LB_Warning(aMess) F2_1win1() ENDIF // Все нормально, двухоконный интерфейс, аналогичный 2.2() ***************************** IF Flag_Classes = .T. .AND.; Flag_ClassSc = .T. .AND.; Flag_GrClSc = .T. F2_1win2() ENDIF // Все нормально, двухоконный интерфейс, аналогичный 2.2() ***************************** IF Flag_Classes = .F. .AND.; Flag_ClassSc = .F. .AND.; Flag_GrClSc = .F. F2_1win2() ENDIF ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) ReTURN nil **************************************************************************************** **************************************************************************************** ******** 2.1. Классификационные шкалы и градации, 1 окно **************************************************************************************** FUNCTION F2_1win1() LOCAL GetList := {}, aPres, oBrowse, oToolBar, aColors, bColor, GetOptions aColors := { {GRA_CLR_WHITE,GRA_CLR_DARKRED },; {GRA_CLR_WHITE,GRA_CLR_DARKBLUE },; {GRA_CLR_BLACK,GRA_CLR_DARKGREEN} } aPres := ; { { XBP_PP_COL_HA_FGCLR, GRA_CLR_WHITE },; // Header FG Color { XBP_PP_COL_HA_BGCLR, GRA_CLR_DARKGRAY },; // Header BG Color { XBP_PP_COL_FA_FGCLR, GRA_CLR_YELLOW },; // Footer FG Color { XBP_PP_COL_FA_BGCLR, GRA_CLR_DARKGRAY },; // Footer BG Color { XBP_PP_COL_DA_ROWSEPARATOR, XBPCOL_SEP_DOTTED },; // Row Sep { XBP_PP_COL_DA_COLSEPARATOR, XBPCOL_SEP_DOTTED },; // Col Sep { XBP_PP_COL_HA_ALIGNMENT, XBPALIGN_LEFT },; // Header alignment { XBP_PP_COL_DA_ROWHEIGHT, 20 },; // Row Height { XBP_PP_COL_DA_CELLHEIGHT, 20 } } // Cell Height KodOne2_1() /* ----- Create ToolBar ----- */ @ 27.5, 1 DCTOOLBAR oToolBar SIZE 130, 1.5 DCADDBUTTON CAPTION L('Помощь') ; SIZE 5+LEN(L("Помощь")) ; ACTION {||Help21win1(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Помощь по режиму 2.1') DCADDBUTTON CAPTION L('Присвоить коды по возрастанию') ; SIZE 5+LEN(L("Присвоить коды по возрастанию")) ; ACTION {||Kod_progr2_1(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Присвоить всем класс.шкалам коды в порядке возрастания') DCADDBUTTON CAPTION L('Присвоить всем шкалам код 1') ; SIZE 5+LEN(L("Присвоить всем шкалам код 1")) ; ACTION {||KodOne2_1(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Присвоить всем класс.шкалам код 1') @ DCGUI_ROW, DCGUI_COL + 30 DCPUSHBUTTON CAPTION L('Создать класс.шкалы и градации') ; SIZE 2+LEN(L("Создать класс.шкалы и градации")), 1.5 ; ACTION {||CreateClScGr(.T.), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Создать класс.шкалы и градации') /* ----- Create browse ----- */ @ 1, 0 DCBROWSE oBrowse ALIAS 'Classes' SIZE 131,26 ; HEADLINES 4 ; // Кол-во строк в заголовке (перенос строки - ";") EDIT xbeBRW_ItemSelected MODE DCGUI_BROWSE_EDITDOWN ; PRESENTATION aPres ; DCBROWSECOL FIELD Classes->Kod_cls HEADER L('Код' ) PARENT oBrowse WIDTH 5 FOOTER '1' PROTECT {|| .T. } DCBROWSECOL FIELD Classes->Name_cls HEADER L('Наименование класса' ) PARENT oBrowse WIDTH 67 FOOTER '2' DCBROWSECOL FIELD Classes->Rang HEADER L('Код;классифи-;кационной;шкалы') PARENT oBrowse WIDTH 7 FOOTER '3' DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; OPTIONS GetOptions ; MODAL ; TITLE L('2.1. Классификационные шкалы и градации. Текущая модель: "')+UPPER(Ar_Model[M_CurrInf])+'"'; FIT ; CLEAREVENTS GenDbfClass(.F.) // Пересоздать БД Classes.dbf ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) ReTURN nil **************************************************************************************** ******** Присвоить всем класс.шкалам коды в порядке возрастания FUNCTION Kod_progr2_1() SELECT Classes DBGOTOP() DO WHILE .NOT. EOF() REPLACE Rang WITH RECNO() DBSKIP(1) ENDDO DBGOTOP() ReTURN nil ******** Присвоить всем класс.шкалам код 1 FUNCTION KodOne2_1() SELECT Classes DBGOTOP() DO WHILE .NOT. EOF() REPLACE Rang WITH 1 DBSKIP(1) ENDDO DBGOTOP() ReTURN nil ********* Помощь по режиму 2.1 *FUNCTION Help21win1() *LOCAL GetList[0], cText *TEXT INTO cText WRAP "\n" TRIMMED * РЕЖИМ: "2.1. КЛАССИФИКАЦИОННЫЕ ШКАЛЫ И ГРАДАЦИИ" предназначен * для ручного ввода и корректировки кодов классификационных шкал, * а затем автоматического формирования с их использованием баз * данных классификационных шкал и градаций классификационных шкал. * Корректировки обучающей и распознаваемой выборки не требуется. *ENDTEXT *@ 0,0 DCSTATIC TYPE XBPSTATIC_TYPE_TEXT SIZE 0 ; * CAPTION cText FORMATTED ; * FONT '10.Lucida Console' ; * COLOR GRA_CLR_BLACK, GRA_CLR_WHITE * DCREAD GUI FIT TITLE L('Помощь по режиму 2.1') *ReTURN nil ************************************************************************************************** FUNCTION Help21win1() aHelp := {} AADD(aHelp, L('РЕЖИМ: "2.1. КЛАССИФИКАЦИОННЫЕ ШКАЛЫ И ГРАДАЦИИ" предназначен ')) AADD(aHelp, L('для ручного ввода и корректировки кодов классификационных шкал, ')) AADD(aHelp, L('а затем автоматического формирования с их использованием баз ')) AADD(aHelp, L('данных классификационных шкал и градаций классификационных шкал.')) AADD(aHelp, L('Корректировки обучающей и распознаваемой выборки не требуется. ')) mHelpMax = -999;FOR h=1 TO LEN(aHelp);mHelpMax = MAX(mHelpMax, LEN(ALLTRIM(aHelp[h])));NEXT s=1;d=0.9;@0,0 DCGROUP oGroup1 CAPTION L(' ') SIZE mHelpMax-0, LEN(aHelp)*d+1.5 FOR h=1 TO LEN(aHelp);@s,2 DCSAY aHelp[h] SIZE 0 PARENT ogroup1;s=s+d;NEXT DCREAD GUI TO lExit FIT MODAL TITLE L('Помощь по режиму: 2.1. (C) Система "ЭЙДОС-X++"') RETURN NIL ************************************************************************************************** ******** Создать классификационные шкалы и градации на основе информации в Classes.dbf FUNCTION CreateClScGr(Dialog) // .T. - с диалогом, .F. - без диалога SELECT Class_Sc;ZAP SELECT Gr_ClSc ;ZAP SELECT Classes INDEX ON STR(Rang,19) TO Cls_rang UNIQUE COUNT TO N_Rang ******* Проверка на пропуски в нумерации класс.шкал SET ORDER TO DBGOBOTTOM();mRangMax = Rang PRIVATE aRang[mRangMax] AFILL(aRang, 0) DBGOTOP() DO WHILE .NOT. EOF() IF VALTYPE(Rang) = "N" aRang[Rang] = aRang[Rang] + 1 ENDIF DBSKIP(1) ENDDO ASORT(aRang) IF aRang[1] = 0 aMess := {} AADD(aMess, L('В нумерации классификационных шкал есть пропуски !!')) AADD(aMess, L('Коды шкал должны возрастать на 1, а не на 2 или др.')) LB_Warning(aMess) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Class_Sc EXCLUSIVE NEW;N_ClSc = RECCOUNT() USE Gr_ClSc EXCLUSIVE NEW;N_GrClSc = RECCOUNT() USE aKodCls EXCLUSIVE NEW RETURN NIL ENDIF DBGOTOP() IF Rang = 0 LB_Warning(L('Перед вызовом данной функции необходимо ввести коды классификационных шкал !')) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Class_Sc EXCLUSIVE NEW;N_ClSc = RECCOUNT() USE Gr_ClSc EXCLUSIVE NEW;N_GrClSc = RECCOUNT() USE aKodCls EXCLUSIVE NEW RETURN NIL ENDIF ***** Определение начальной и конечной записей для каждой классификационной шкалы PRIVATE aKodClsMin[N_Rang] // Начальная запись классификационной шкалы (код класса и номер записи в БД Classes) PRIVATE aKodClsMax[N_Rang] // Конечная запись классификационной шкалы (код класса и номер записи в БД Classes) INDEX ON STR(Rang,19) TO Cls_rang DBGOTOP() mRang = Rang mNameCls = Name_cls IF mRang <> 1 aMess := {} AADD(aMess, L('Минимальный код классификационной шкалы должен' )) AADD(aMess, L('быть равен 1 и коды шкал должны возрастать на 1!')) LB_Warning(aMess) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Class_Sc EXCLUSIVE NEW;N_ClSc = RECCOUNT() USE Gr_ClSc EXCLUSIVE NEW;N_GrClSc = RECCOUNT() USE aKodCls EXCLUSIVE NEW RETURN NIL ENDIF aKodClsMin[mRang] = Kod_cls aKodClsMax[mRang] = Kod_cls DBGOTOP() DO WHILE .NOT. EOF() IF mRang = Rang aKodClsMax[mRang] = Kod_cls ELSE mRang = Rang aKodClsMin[mRang] = Kod_cls aKodClsMax[mRang] = Kod_cls ENDIF DBSKIP(1) ENDDO SELECT aKodCls FOR j=1 TO LEN(aKodClsMin) APPEND BLANK REPLACE Rang WITH j REPLACE Kod_min WITH aKodClsMin[j] REPLACE Kod_max WITH aKodClsMax[j] NEXT *** Цикл по классификационным шкалам *********************** FOR mRang = 1 TO N_Rang ****** Формирование наименования классификационной шкалы SELECT Classes IF aKodClsMax[mRang] > aKodClsMin[mRang] Pos = 9999999999 FOR r = aKodClsMin[mRang] TO aKodClsMax[mRang]-1 DBGOTO(r );mNameCls1 = ALLTRIM(Name_cls) DBGOTO(r+1);mNameCls2 = ALLTRIM(Name_cls) Pos = MIN(Pos, POSDIFF(mNameCls1, mNameCls2)) mNameCls = ALLTRIM(SUBSTR(mNameCls1, 1, Pos-1)) NEXT ELSE DBGOTO(aKodClsMin[mRang]) mNameCls = ALLTRIM(Name_cls) Pos = 1 ENDIF // Убрать В КОНЦЕ наименования " - ", если это там есть IF SUBSTR(mNameCls, LEN(mNameCls), 1) = "-" mNameCls = ALLTRIM(SUBSTR(mNameCls, 1, LEN(mNameCls)-1)) ENDIF SELECT Class_Sc APPEND BLANK REPLACE Kod_ClSc WITH mRang REPLACE Name_ClSc WITH mNameCls REPLACE N_GrClSc WITH aKodClsMax[mRang] - aKodClsMin[mRang] + 1 REPLACE KodGr_min WITH aKodClsMin[mRang] REPLACE KodGr_max WITH aKodClsMax[mRang] FOR r = aKodClsMin[mRang] TO aKodClsMax[mRang] SELECT Classes DBGOTO(r) mNameCls = Name_cls SELECT Gr_ClSc APPEND BLANK REPLACE Kod_ClSc WITH mRang REPLACE Kod_GrCS WITH r REPLACE Name_GrCS WITH SUBSTR(mNameCls, Pos, LEN(mNameCls)-Pos+1) NEXT NEXT // Сделать БД Classes по новой структуре *********************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций COPY FILE ("Classes.dbf") TO ("Cls_tmp.dbf") GenDbfClass(.F.) USE Classes EXCLUSIVE NEW USE Cls_tmp EXCLUSIVE NEW USE Class_Sc EXCLUSIVE NEW USE Gr_ClSc EXCLUSIVE NEW SELECT Cls_tmp DBGOTOP() DO WHILE .NOT. EOF() mKodCls = Kod_cls mNameCls = Name_cls mIntInf = Int_Inf mSumII = Sum_II mSiiPerc = SII_Perc mRang = Rang mAbs = Abs mPercFiz = Perc_fiz mDate = Date mTime = Time SELECT Gr_ClSc DBGOTO(mKodCls) mKodClSc = Kod_ClSc SELECT Class_Sc DBGOTO(mKodClSc) mNameClSc = ALLTRIM(Name_ClSc) SELECT Classes APPEND BLANK REPLACE Kod_cls WITH mKodCls REPLACE Name_cls WITH mNameCls REPLACE Kod_ClSc WITH mKodClSc REPLACE N_ChrClSc WITH LEN(mNameClSc) REPLACE Int_Inf WITH mIntInf REPLACE Sum_II WITH mSumII REPLACE SII_Perc WITH mSiiPerc REPLACE Rang WITH mRang REPLACE Abs WITH mAbs REPLACE Perc_fiz WITH mPercFiz REPLACE Date WITH mDate REPLACE Time WITH mTime SELECT Cls_tmp DBSKIP(1) ENDDO ***** Доформировать оставшиеся поля БД Class_Sc и Gr_ClSc (информативность и значимость) ############### IF Dialog LB_Warning(L('Формирование БД класс.шкал и градаций класс.шкал: "Class_Sc", "Gr_ClSc" завершено успешно!')) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Class_Sc EXCLUSIVE NEW;N_ClSc = RECCOUNT() USE Gr_ClSc EXCLUSIVE NEW;N_GrClSc = RECCOUNT() USE aKodCls EXCLUSIVE NEW ENDIF RETURN NIL FUNCTION Set_MainWindow( oDialog ) STATIC soDialog IF Valtype(oDialog) == 'O' soDialog := oDialog ENDIF RETURN soDialog ************************************************************************************************** FUNCTION Help21() aHelp := {} AADD(aHelp, L('Режим: "2.1. КЛАССИФИКАЦИОННЫЕ ШКАЛЫ И ГРАДАЦИИ" предназначен ')) AADD(aHelp, L('для ручного ввода и корректировки справочника классов, которые')) AADD(aHelp, L('представляют собой градации классификационных шкал. После ')) AADD(aHelp, L('корректировки справочника классов обязательно необходимо: ')) AADD(aHelp, L('- скорректировать обучающую выборку; ')) AADD(aHelp, L('- провести пересинтез модели. ')) mHelpMax = -999;FOR h=1 TO LEN(aHelp);mHelpMax = MAX(mHelpMax, LEN(ALLTRIM(aHelp[h])));NEXT s=1;d=0.9;@0,0 DCGROUP oGroup1 CAPTION L(' ') SIZE mHelpMax-0, LEN(aHelp)*d+1.5 FOR h=1 TO LEN(aHelp);@s,2 DCSAY aHelp[h] SIZE 0 PARENT ogroup1;s=s+d;NEXT DCREAD GUI TO lExit FIT MODAL TITLE L('Помощь по режиму: 2.1. (C) Система "ЭЙДОС-X++"') RETURN NIL ************************************************************************************************** ******** Поиск по столбцу в "Наименование" режиме 2.1 FUNCTION Search2_1() ReTURN nil ******** Сортировка по заданному столбцу в режиме 2.1. (xdemo.exe FUNCTION XDemo_4 ( oDialog, lMDI, lGui )) FUNCTION Sort2_1() LOCAL nChoice := 1, oAppWindow, oCrt, oParent DC_Gui(.t.) SetColor('W+/N') CLS SetColor('N/W,W+/B') @ 5,20 CLEAR TO 19,60 @ 5,20 TO 19,60 @ 7,25 PROMPT L('Код ') @ 9,25 PROMPT L('Наименование ') @11,25 PROMPT L('Редукция класса ') @13,25 PROMPT L('N объектов (абс.)') @15,25 PROMPT L('N объектов (%) ') @17,25 PROMPT L('Exit ') MENU TO nChoice *USE Classes INDEX Obj_kod, Obj_name, Obj_ini, Obj_abs EXCLUSIVE NEW DO CASE CASE nChoice = 1 SET ORDER TO 1 CASE nChoice = 2 SET ORDER TO 2 CASE nChoice = 3 SET ORDER TO 3 CASE nChoice = 4 SET ORDER TO 4 CASE nChoice = 5 SET ORDER TO 4 CASE nChoice = 6 .OR. nChoice = 0 ENDCASE IF Valtype(oCrt) = 'O' .AND. oCrt:status()>0 oCrt:Destroy() SetAppWindow( oAppWindow ) ENDIF RETURN nil ******** This example shows how to use the RGB Color Picker (xdemo.exe) FUNCTION XSample_136(Cf1,Cf2,Cf3,Cb1,Cb2,Cb3) LOCAL GetList := {}, GetOptions, oSay, bColor PUBLIC aRGBColor aRGBColor := { {0,0,0}, {0,0,0} } aRGBColor[1,1] = Cf1 aRGBColor[1,2] = Cf2 aRGBColor[1,3] = Cf3 aRGBColor[2,1] = Cb1 aRGBColor[2,2] = Cb2 aRGBColor[2,3] = Cb3 SET WRAP ON @ 0,0 DCSAY L('Red Foreground' ) GET aRGBColor[1,1] RANGE 0,255 @ 1,0 DCSAY L('Green Foreground') GET aRGBColor[1,2] RANGE 0,255 @ 2,0 DCSAY L('Blue Foreground' ) GET aRGBColor[1,3] RANGE 0,255 @ 4,0 DCSAY L('Red Background' ) GET aRGBColor[2,1] RANGE 0,255 @ 5,0 DCSAY L('Green Background') GET aRGBColor[2,2] RANGE 0,255 @ 6,0 DCSAY L('Blue Background' ) GET aRGBColor[2,3] RANGE 0,255 M_Caption = L('Выбрать цветовую схему меню') @ 8,0 DCPUSHBUTTON CAPTION M_Caption SIZE LEN(M_Caption),1.2 ; ACTION {|a|a := DC_PopColor(aRGBColor,0,.t.), ; aRGBColor[1,1] := a[1,1], ; aRGBColor[1,2] := a[1,2], ; aRGBColor[1,3] := a[1,3], ; aRGBColor[2,1] := a[2,1], ; aRGBColor[2,2] := a[2,2], ; aRGBColor[2,3] := a[2,3], ; Eval(bColor,nil,nil,oSay), ; DC_GetRefresh(GetList) } bColor := {|a,b,o|o:setColorFG(GraMakeRGBColor(aRGBColor[1])), ; o:setColorBG(GraMakeRGBColor(aRGBColor[2]))} @11,0 DCSAY L('Compound Color') SAYSIZE 0 FONT '14.Arial Bold' ; OBJECT oSay ; EVAL {|o|Eval(bColor,nil,nil,o)} DCGETOPTIONS SAYRIGHT SAYWIDTH 120 DCREAD GUI FIT ADDBUTTONS MODAL TITLE L('1.6. Выбор цветовой схемы меню') ; OPTIONS GetOptions EVAL {|o|SetAppWindow(o)} RETURN nil *** END OF EXAMPLE *** ******** Удалить текущую запись в БД, ******** а остальные сдвинуть вверх и перенумеровать FUNCTION Del_rec() SET ORDER TO M_Recno = RECNO() DELETE;PACK *** Перенумеровать записи, начиная с удаленной DBGOTO(M_Recno) DO WHILE .NOT. EOF() FIELDPUT(1, RECNO()) DBSKIP(1) ENDDO DBGOTO(M_Recno) DC_GetRefresh(GetList) RETURN NIL ******** Вставить пустую запись в БД на месте текущей, ******** а остальные сдвинуть вниз и перенумеровать FUNCTION Ins_rec() SET ORDER TO M_Recno = RECNO() APPEND BLANK A_RecNew := {} // Пустая запись FOR j=1 TO FCOUNT() AADD(A_RecNew, FIELDGET(j)) NEXT *** Переписать предпоследнюю запись на последнюю и т.д. до текущей FOR r=RECCOUNT()-1 TO M_Recno STEP -1 DBGOTO(r) A_Rec := {} FOR j=1 TO FCOUNT() AADD(A_Rec, FIELDGET(j)) NEXT DBGOTO(r+1) FOR j=1 TO FCOUNT() FIELDPUT(j, A_Rec[j]) NEXT NEXT *** Стереть текущую запись DBGOTO(M_Recno) FOR j=1 TO FCOUNT() FIELDPUT(j, A_RecNew[j]) NEXT *** Перенумеровать записи, начиная со вставленной DBGOTO(M_Recno) DO WHILE .NOT. EOF() FIELDPUT(1, RECNO()) DBSKIP(1) ENDDO DBGOTO(M_Recno) DC_GetRefresh(GetList) RETURN NIL ******** Скопировать (сдублировать) текущую запись в БД на месте текущей, ******** а остальные сдвинуть вниз и перенумеровать FUNCTION Copy_rec() SET ORDER TO M_Recno = RECNO() A_RecNew := {} // Текущая запись FOR j=1 TO FCOUNT() AADD(A_RecNew, FIELDGET(j)) NEXT APPEND BLANK *** Переписать предпоследнюю запись на последнюю и т.д. до текущей FOR r=RECCOUNT()-1 TO M_Recno STEP -1 DBGOTO(r) A_Rec := {} FOR j=1 TO FCOUNT() AADD(A_Rec, FIELDGET(j)) NEXT DBGOTO(r+1) FOR j=1 TO FCOUNT() FIELDPUT(j, A_Rec[j]) NEXT NEXT *** Скопировать текущую запись DBGOTO(M_Recno) FOR j=1 TO FCOUNT() FIELDPUT(j, A_RecNew[j]) NEXT *** Перенумеровать записи, начиная со вставленной DBGOTO(M_Recno) DO WHILE .NOT. EOF() FIELDPUT(1, RECNO()) DBSKIP(1) ENDDO DBGOTO(M_Recno) DC_GetRefresh(GetList) RETURN NIL ******** Добавить пустую запись в конец БД FUNCTION Add_rec() SET ORDER TO APPEND BLANK FIELDPUT(1, RECNO()) DC_GetRefresh(GetList) RETURN NIL ******** Очистить БД FUNCTION Zap_db() SET ORDER TO ZAP DC_GetRefresh(GetList) RETURN NIL ******** Выход и редактора БД FUNCTION Exit_dbe() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций RETURN NIL ******** Сообщение: текущая/всего БД FUNCTION Mess_dbe() Mess_dbe = ALLTRIM(STR(RECNO(),19))+"/"+ALLTRIM(STR(RECCOUNT(),19)) RETURN(Mess_dbe) ******************************************************************************************** ******** Выбор режима оцифровки изображений: ******** - по всем пикселям; ******** - по внешним контурам; ******** - по внешним и внутренним контурам. ******************************************************************************************** #include "inkey.ch" #include "dcdir.ch" #include "appevent.ch" #include "xbp.ch" #include "dll.ch" #include "dccursor.ch" #Include "thread.ch" #include "class.ch" #include "dmlb.ch" #include "fileio.ch" #include "dctree.ch" *#include "SystemMetrics.ch" *#include "axcdxcmx.ch" // Графика ActiveX #include "collat.ch" #include "common.ch" #include "dbedit.ch" #include "Dbfdbe.ch" #include "dcapp.ch" #include "dcbitmap.ch" #include "dccargo.ch" #include "dcdialog.ch" #include "dcdir.ch" #include "dcfiles.ch" #include "dcgra.ch" #include "dcgraph.ch" // графика #include "BdColors.Ch" // графика #include "dccolors.ch" // графика #include "dcprint.ch" // графика #include "Dcicon.ch" #include "dcmsg.ch" #include "dcpick.ch" #include "deldbe.ch" #include "directry.ch" #include "dmlb.ch" #include "express.ch" #include "fileio.ch" #include "font.ch" #include "gra.ch" #include "inkey.ch" #include "memvar.ch" #include "natmsg.ch" #include "prompt.ch" #include '_dcdbfil.ch' #include "set.ch" #include "std.ch" #include "xbp.ch" #include '_dcappe.ch' #include 'dcscope.ch' #include '_dcstru.ch' #include 'dcfields.ch' #include 'dccolor.ch' *#include "Fileio.ch" // Max_DB *#include "rmchart.ch" // Графика ActiveX #include "dcads.ch" #pragma Library( "ASINet10.lib" ) // 2.0 // Для альтернативного и неальтернативного выбора в просмотре таблиц *#define BMP_CHECKED "check1.bmp" *#define BMP_UNCHECKED "check2.bmp" *#define BMP_RACHECKED "radio1.bmp" *#define BMP_RAUNCHECKED "radio2.bmp" *#include "test.ch" #define BMP_CHECKED 10002 #define BMP_UNCHECKED 10003 #define BMP_RACHECKED 10004 #define BMP_RAUNCHECKED 10005 #pragma library( "ascom10.lib" ) #pragma library( "dclip1.lib" ) #pragma library( "dclip2.lib" ) #pragma library( "dclipx.lib" ) #pragma library( "xbtbase1.lib" ) #pragma library( "xbtbase2.lib" ) #pragma library( "xppui2.lib" ) #pragma library( "XPPRT0.LIB" ) #Pragma Library("Taskbar.lib") #xtranslate NTrim() => LTrim(Str()) #define USE_HTTPCLIENT // comment out to try Method2 //#include "Imgview.ch" /* * We use user defined events */ #define xbeDS_DirChanged xbeP_User + 100 #define xbeFS_FileMarked xbeP_User + 101 #define xbeFS_FileSelected xbeP_User + 102 #define DCAREAMSG_1 'Invalid Expression in Index Key:' /* * This directive calculates a centered position */ #xtrans CenterPos( , ) => ; { Int( (\[1] - \[1]) / 2 ) ; , Int( (\[2] - \[2]) / 2 ) } #define DC_RDDMSG_1 'Invalid RDD selection - '+cSuperRdd #define DC_RDDMSG_2 'DBE Name Description' #define DC_RDDMSG_3 'Select a Database Driver' *#define ADSDBE_MEMOFILE_EXT (DBE_USER+1) // RO *#define ADSDBE_INDEX_EXT (DBE_USER+2) // RW *#define ADSDBE_TBL_MODE (DBE_USER+3) // RW *#define ADSDBE_LOCK_MODE (DBE_USER+4) // RW *#define ADSDBE_RIGHTS_MODE (DBE_USER+5) // RW *#define ADSDBE_MEMOBLOCKSIZE (DBE_USER+6) // RW *#define ADSDBE_PASSWORD (DBE_USER+7) // RW // Return types of ADSDBE_TBL_MODE *#define ADSDBE_NTX 1 *#define ADSDBE_CDX 2 *#define ADSDBE_ADT 3 // Для опредедения разрешения монитора от Джимми #define DESKTOPVERTRES 117 #define DESKTOPHORZRES 118 // Excel Orientation #DEFINE xlLandscape 2 #DEFINE xlPortrait 1 #DEFINE xlWorkbookNormal -4143 #DEFINE xlCellTypeLastCell 11 #DEFINE SRCCOPY 0xCC0020 // Для быстрой графики Роджера #define KEYEVENTF_KEYUP 0x02 #define VK_MENU 0x12 #define VK_SNAPSHOT 0x2C #DEFINE VK_LBUTTON 0x01 #DEFINE VK_RBUTTON 0x02 * Для CSV=>DBF конвертера *#include "ot4xb.ch" // => ot4xb.dll => www.xbwin.com #ifndef CRLF #define CRLF chr(13)+chr(10) #endif * Klasse zum sequentiellen Einlesen groбer Dateien *#IF .t. // zum Einbinden in eigenes Projekt, .f. setzen ! STATIC snHdll *************************************************************************************************** FUNCTION F4_7() LOCAL GetList[0] Running(.T.) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF *IF ApplChange("4.7()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения *ENDIF *IF ApplChange("") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения * Running(.F.) * RETURN NIL *ENDIF ******* Узнать разрешение экрана и не показывать изображений большой размерности **************** nWidth := AppDeskTop():currentSize()[1] // current screen size width in pixels nHeight := AppDeskTop():currentSize()[2] // current screen size height in pixels * nWidth = 1366 // <<<===########################## * nHeight = 768 IF .NOT. FILE('Delone_1280_604.jpg') aMess := {} AADD(aMess, L('В текущей папке системы: ')+Disk_dir+L(' должен быть файл: "Delone_1280_604.jpg"!!! ')) AADD(aMess, L('Этот файл можно создать в любом графическом редакторе. Он должен быть пустым и иметь разрешение 1280 х 604 пикселей')) LB_Warning( aMess,L('4.8. АСК-анализ изображений в системе "Эйдос"' )) Running(.F.) RETURN nil ENDIF IF .NOT. FILE('Delone_1280_604.bmp') aMess := {} AADD(aMess, L('В текущей папке системы: ')+Disk_dir+L(' должен быть файл: "Delone_1280_604.bmp"!!! ')) AADD(aMess, L('Этот файл можно создать в любом графическом редакторе. Он должен быть пустым и иметь разрешение 1280 х 604 пикселей')) LB_Warning( aMess,L('4.8. АСК-анализ изображений в системе "Эйдос"' )) Running(.F.) RETURN nil ENDIF IF .NOT. FILE('Delone_1800_850.jpg') aMess := {} AADD(aMess, L('В текущей папке системы: ')+Disk_dir+L(' должен быть файл: "Delone_1800_850.jpg"!!! ')) AADD(aMess, L('Этот файл можно создать в любом графическом редакторе. Он должен быть пустым и иметь разрешение 1800 х 850 пикселей')) LB_Warning( aMess,L('4.8. АСК-анализ изображений в системе "Эйдос"' )) Running(.F.) RETURN nil ENDIF IF .NOT. FILE('Delone_1800_850.bmp') aMess := {} AADD(aMess, L('В текущей папке системы: ')+Disk_dir+L(' должен быть файл: "Delone_1800_850.bmp"!!! ')) AADD(aMess, L('Этот файл можно создать в любом графическом редакторе. Он должен быть пустым и иметь разрешение 1800 х 850 пикселей')) LB_Warning( aMess,L('4.8. АСК-анализ изображений в системе "Эйдос"' )) Running(.F.) RETURN nil ENDIF IF nWidth < 1800 PUBLIC X_MaxW := 1280, Y_MaxW := 604 // Размер графического окна для самого графика в пикселях. Переход к большому экрану: kx=SQRT(2), ky=SQRT(2) * 1366 768 COPY FILE 'Delone_1280_604.jpg' TO 'Delone.jpg' COPY FILE 'Delone_1280_604.bmp' TO 'Delone.bmp' ELSE PUBLIC X_MaxW := 1800, Y_MaxW := 850 // Размер графического окна для самого графика в пикселях. Переход к малому экрану: kx=1/SQRT(2), ky=1/SQRT(2) * 1920 1080 COPY FILE 'Delone_1800_850.jpg' TO 'Delone.jpg' COPY FILE 'Delone_1800_850.bmp' TO 'Delone.bmp' ENDIF ************************************************************************************************* IF .NOT. FILE('_DigitImage.txt') StrFile(ALLTRIM(STR(1)), '_DigitImage.txt') // Запись текстового файла _DigitImage.txt ENDIF mDigitImage = VAL(FileStr('_DigitImage.txt')) // Загрузка текстового файла _DigitImage.txt @ 0, 0 DCGROUP oGroup1 CAPTION L('Как проводить оцифровку изображений:') SIZE 60.0, 5.5 @ 1, 2 DCRADIO mDigitImage VALUE 1 PROMPT L('по всем пикселям' ) PARENT oGroup1 @ 2, 2 DCRADIO mDigitImage VALUE 2 PROMPT L('по внешним контурам' ) PARENT oGroup1 @ 3, 2 DCRADIO mDigitImage VALUE 3 PROMPT L('по внешним и внутренним контурам') PARENT oGroup1 @ 4, 2 DCRADIO mDigitImage VALUE 4 PROMPT L('геокогнитивная подсистема ') PARENT oGroup1 @1.5,36 DCPUSHBUTTON CAPTION L("Пояснение") SIZE 20, 2.0 ACTION {||HelpASCAimages()} PARENT oGroup1 DCREAD GUI; TO lExit ; FIT; ADDBUTTONS; MODAL; TITLE L("Оцифровка изображений") ******************************************************************** IF lExit ** Button Ok ELSE mDigitImage = 999 ENDIF ******************************************************************** ERASE('_DigitImage.txt') StrFile(ALLTRIM(STR(mDigitImage)), '_DigitImage.txt') // Запись текстового файла _DigitImage.txt * mDigitImage = VAL(FileStr('_DigitImage.txt')) // Загрузка текстового файла _DigitImage.txt IF mDigitImage = 1 // Пиксели GenGraSimbPix() ENDIF IF mDigitImage = 2 // Внешние контуры GenGraSimbOk() ENDIF IF mDigitImage = 3 // Внутренние и внешние контуры Razrab() ENDIF IF mDigitImage = 4 // геокогнитивная подсистема F4_8(L('4.7. АСК-анализ изображений по пикселям, спектрам и контурам')) // Если F4_8() запускается не из главного меню, а из F4_7(), то может работать на любом экране ENDIF ** Восстановить состояние среды на момент входа в главное меню ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) ReTURN(mDigitImage) *********************************************************************************************************** ******** Геокогнитивная система. Преобразует 2D Excel-таблицу с именем "Inp_map.xls" в файл "Inp_data.xls", ******** содержащий координаты X,Y,Z точек и их признаки (модель описательной информации картографической ******** базы данных). Визуализирует 2D Excel-таблицу или итоговые результаты распознавания (данные из БД: ******** "Rsp_it.dbf") в картографической форме с применением триангуляции Делоне *********************************************************************************************************** FUNCTION F4_8(mTitle) PUBLIC GetList[0], GetOptions, oSay, hDC1, hDC2, oStatic, oStatic1, aPixel, oBitmap Running(.T.) *DC_IconDefault(1000) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF ******* Узнать разрешение экрана и не показывать изображений большой размерности **************** nWidth := AppDeskTop():currentSize()[1] // current screen size width in pixels nHeight := AppDeskTop():currentSize()[2] // current screen size height in pixels * nWidth = 1366 // <<<===########################## * nHeight = 768 * F4_8('L('4.7. АСК-анализ изображений по пикселям, спектрам и контурам')') // Если F4_8() запускается не из главного меню, а из F4_7(), то может работать на любом экране IF mTitle = L('4.8. Геокогнитивная подсистема') // 4.8. Геокогнитивная подсистема работает только на экранах с разрешением 1920 x 1080 и более IF nWidth < 1800 aMess := {} AADD(aMess, L("Для правильного отображения графической формы")) AADD(aMess, L("необходимо разрешение экрана 1800 pix по горизонтали,")) AADD(aMess, L("а фактически установлено: ")+ALLTRIM(STR(nWidth))+" pix") LB_Warning(aMess ) Running(.F.) ReTURN NIL ENDIF IF nHeight < 850 aMess := {} AADD(aMess, L("Для правильного отображения графической формы")) AADD(aMess, L("необходимо разрешение экрана 850 pix по вертикали,")) AADD(aMess, L("а фактически установлено: ")+ALLTRIM(STR(nHeight))+" pix") LB_Warning(aMess ) Running(.F.) ReTURN NIL ENDIF ENDIF IF .NOT. FILE('Delone_1280_604.jpg') aMess := {} AADD(aMess, L('В текущей папке системы: ')+Disk_dir+L(' должен быть файл: "Delone_1280_604.jpg"!!! ')) AADD(aMess, L('Этот файл можно создать в любом графическом редакторе. Он должен быть пустым и иметь разрешение 1280 х 604 пикселей')) LB_Warning( aMess,L('4.8. АСК-анализ изображений в системе "Эйдос"' )) Running(.F.) RETURN nil ENDIF IF .NOT. FILE('Delone_1280_604.bmp') aMess := {} AADD(aMess, L('В текущей папке системы: ')+Disk_dir+L(' должен быть файл: "Delone_1280_604.bmp"!!! ')) AADD(aMess, L('Этот файл можно создать в любом графическом редакторе. Он должен быть пустым и иметь разрешение 1280 х 604 пикселей')) LB_Warning( aMess,L('4.8. АСК-анализ изображений в системе "Эйдос"' )) Running(.F.) RETURN nil ENDIF IF .NOT. FILE('Delone_1800_850.jpg') aMess := {} AADD(aMess, L('В текущей папке системы: ')+Disk_dir+L(' должен быть файл: "Delone_1800_850.jpg"!!! ')) AADD(aMess, L('Этот файл можно создать в любом графическом редакторе. Он должен быть пустым и иметь разрешение 1800 х 850 пикселей')) LB_Warning( aMess,L('4.8. АСК-анализ изображений в системе "Эйдос"' )) Running(.F.) RETURN nil ENDIF IF .NOT. FILE('Delone_1800_850.bmp') aMess := {} AADD(aMess, L('В текущей папке системы: ')+Disk_dir+L(' должен быть файл: "Delone_1800_850.bmp"!!! ')) AADD(aMess, L('Этот файл можно создать в любом графическом редакторе. Он должен быть пустым и иметь разрешение 1800 х 850 пикселей')) LB_Warning( aMess,L('4.8. АСК-анализ изображений в системе "Эйдос"' )) Running(.F.) RETURN nil ENDIF IF .NOT. FILE('Delone.jpg') COPY FILE 'Delone_1800_850.jpg' TO 'Delone.jpg' ENDIF IF .NOT. FILE('Delone.bmp') COPY FILE 'Delone_1800_850.bmp' TO 'Delone.bmp' ENDIF IF nWidth < 1800 PUBLIC X_MaxW := 1280, Y_MaxW := 604 // Размер графического окна для самого графика в пикселях. Переход к большому экрану: kx=SQRT(2), ky=SQRT(2) * 1366 768 * COPY FILE 'Delone_1280_604.jpg' TO 'Delone.jpg' * COPY FILE 'Delone_1280_604.bmp' TO 'Delone.bmp' ELSE PUBLIC X_MaxW := 1800, Y_MaxW := 850 // Размер графического окна для самого графика в пикселях. Переход к малому экрану: kx=1/SQRT(2), ky=1/SQRT(2) * 1920 1080 * COPY FILE 'Delone_1800_850.jpg' TO 'Delone.jpg' * COPY FILE 'Delone_1800_850.bmp' TO 'Delone.bmp' ENDIF ************************************************************************************************* *********** Формирование массива точек *** mCount = 100000 *PUBLIC aX[100000], aY[100000], aZ[100000] // Координаты X,Y,Z точек облака PUBLIC TrianglesP1[100000], TrianglesP2[100000], TrianglesP3[100000] // Массивы номеров точек вершин треугольников PUBLIC RibsP1[100000], RibsP2[100000], RibsSide[100000] // Массивы номеров точек концов ребер PUBLIC TrianglesCount:=0, RibsCount:=0, PointsCount:=0 // Кол-во треугольников, ребер, точек PUBLIC mFlagCircle:=.F., mFlagRibs:=.T., mFlagsquare:=.T. // Флаги - рисовать ли окружности, рисовать ли ребра в градиентной цветовой заливке, квадратное ли поле рисования PUBLIC aTriangleID:={}, mTriangleID, aRibID:={}, mRibID // Массив ID созданных треугольников (ID - рассортированный массив номеров точек вершин) и ребер PUBLIC nXSize := X_MaxW // Размер изображения в пикселях PUBLIC nYSize := Y_MaxW StrFile(STR(nXSize,9)+' '+STR(nYSize,9), '_XYSize.txt') // Запись текстового файла с параметрами nXSize, nYSize *nXSize = VAL(SUBSTR(FileStr('_XYSize.txt'), 1,9)) // Загрузка параметра nXSize из текстового файла *nYSize = VAL(SUBSTR(FileStr('_XYSize.txt'),11,9)) // Загрузка параметра nYSize из текстового файла *AFILL(aX,0) *AFILL(aY,0) *AFILL(aZ,0) AFILL(RibsP1,0) AFILL(RibsP2,0) AFILL(RibsSide,0) AFILL(TrianglesP1,0) AFILL(TrianglesP2,0) AFILL(TrianglesP3,0) ******* Имя графического файла для рисования *********************************************** PRIVATE aSize := {X_MaxW, Y_MaxW} PRIVATE nColor := BD_LIGHTGREY PUBLIC oBitmap := XbpBitmap() :new() :create() // create Bitmap PUBLIC oPS := XbpPresSpace():new() // NO :Create() here oPS:create( oBitmap, { aSize[1],aSize[2] } ) // here :Create() oBitmap:presSpace( oPS ) // assing to Bitmap:presSpace oBitmap:make( aSize[1],aSize[2] ) // make empty Bitmap ********** Создать файлы Delone.bmp и Delone.jpg нужного размера с учетом размера экрана *** mFileName = 'Delone.bmp' GraSetColor( oPS, nColor, nColor ) // Background Color GraBox( oPS, {0,0}, {aSize[1],aSize[2]}, 1 ) // fill Background oBitmap:saveFile('Delone.jpg',XBPBMP_FORMAT_JPG) oBitmap:saveFile('Delone.bmp') ******************************************************************************************** *H = 20 // Высота кнопки в pix H = 1.5 // Высота кнопки W = 8 // Ширина кнопки D = 2 // Расстояние между кнопками @ 0,0 DCSTATIC TYPE XBPSTATIC_TYPE_BITMAP CAPTION mFileName OBJECT oStatic1 ; PREEVAL {|o|o:autoSize := .t.} EVAL {|o|hDC1 := GetWindowDC(o:getHWnd()), o:motion := {|a,b,o|ShowColorTr( hDC1, a, oSay, o )},; aPixel := Array(o:caption:xSize,o:caption:ySize), o:paint := {|a,b,o|Gratest(o)}} * nWidth = 1366 // <<<===############################## IF nWidth < 1800 *** Группа-2 ****************************** mk1 =L('Помощь' );d1=+3 mk2 =L('Очистка' );d2=+2 mk3 =L('Облако точек' );d3=-1 mk4 =L('Трианг.("Сетка")' );d4=-2 mk5 =L('Трианг.("Град.цвет")' );d5=-3 mk6 =L('Изобр.символов' );d6=-0 mk7 =L('Цвет.зонирование' );d7=-1 *** Группа-3 ****************************** mk8 =L('По пикселям' );d8=+1 mk9 =L('По контурам' );d9=+1 *** Группа-4 ****************************** mk10=L('Помощь' );d10=+2 mk11=L('Подг.данных' );d11=-0 mk12=L('Спектры объектов' );d12=-0 mk13=L('Спектры классов' );d13=-0 ELSE *** Группа-2 ****************************** mk1 =L('Помощь' );d1=+3 mk2 =L('Очистка' );d2=+2 mk3 =L('Формирование облака точек' );d3=-1 mk4 =L('Триангуляция ("Сетка")' );d4=-2 mk5 =L('Триангуляция ("Градиентный цвет")');d5=-4 mk6 =L('Генерация изображений символов' );d6=-3 mk7 =L('Цветовое зонирование' );d7=-1 *** Группа-3 ****************************** mk8 =L('По пикселям' );d8=+1 mk9 =L('По контурам' );d9=+1 *** Группа-4 ****************************** mk10=L('Помощь' );d10=+2 mk11=L('Подготовка данных' );d11=-0 mk12=L('Изображения и спектры объектов' );d12=-2 mk13=L('Изображения и спектры классов' );d13=-3 ENDIF gr2 = LEN(mk1+mk2+mk3+mk4+mk5+mk6+Mk7)+d1+d2+d3+d4+d5+d6+d7 gr3 = LEN(mk8+mk9)+d8+d9 gr4 = LEN(mk10+mk11+mk12+mk13)+d10+d11+d12+d13 @ 1,0 DCGROUP oGroup1 CAPTION L(' ') SIZE gr2+gr3+gr4+16.5, 5.0 @ 0.5,1 DCGROUP oGroup2 CAPTION L('4.8. Геокогнитивная подсистема системы "Эйдос":') SIZE gr2+4.5, 4.0 PARENT oGroup1 // Все эти функции требуют экрана не менее 1920 Х 1080 @ 1.5,1 DCPUSHBUTTON CAPTION mk1 SIZE LEN(mk1)+d1 , H ACTION {||Help48(), DC_GetRefresh(GetList)} PARENT oGroup2 @ DCGUI_ROW, DCGUI_COL + D DCPUSHBUTTON CAPTION mk2 SIZE LEN(mk2)+d2 , H ACTION {||ClearImageTr()} PARENT oGroup2 @ DCGUI_ROW, DCGUI_COL + D DCPUSHBUTTON CAPTION mk3 SIZE LEN(mk3)+d3 , H ACTION {||GetPoints(oBitmap, oPS)} PARENT oGroup2 @ DCGUI_ROW, DCGUI_COL + D DCPUSHBUTTON CAPTION mk4 SIZE LEN(mk4)+d4 , H ACTION {||Triangulation(.T.)} PARENT oGroup2 @ DCGUI_ROW, DCGUI_COL + D DCPUSHBUTTON CAPTION mk5 SIZE LEN(mk5)+d5 , H ACTION {||Shading(.T.)} PARENT oGroup2 @ DCGUI_ROW, DCGUI_COL + D DCPUSHBUTTON CAPTION mk6 SIZE LEN(mk6)+d6 , H ACTION {||ParGenSimb('Ok')} PARENT oGroup2 @ DCGUI_ROW, DCGUI_COL + D DCPUSHBUTTON CAPTION mk7 SIZE LEN(mk7)+d7 , H ACTION {||ColorZone(hDC1,aPixel)} PARENT oGroup2 @ 0.5,gr2+7 DCGROUP oGroup3 CAPTION L('4.7. АСК-анализ изображений:') SIZE gr3+gr4+7.8,4.0 PARENT oGroup1 @ 1.5,1 DCPUSHBUTTON CAPTION mk8 SIZE LEN(mk8)+d8 , H ACTION {||F4_7()} PARENT oGroup3 // Функции F4_7() работает на экранах менее 1920 Х 1080, но вызывается из отдельного режима главного меню 4.7. @ DCGUI_ROW, DCGUI_COL + D DCPUSHBUTTON CAPTION mk9 SIZE LEN(mk9)+d9 , H ACTION {||Contouring(hDC1,aPixel)} PARENT oGroup3 @ 0.5,gr3+3 DCGROUP oGroup4 CAPTION L('По спектрам:') SIZE gr4+2.9, 3.0 PARENT oGroup3 @ 1.0,1 DCPUSHBUTTON CAPTION mk10 SIZE LEN(mk10)+d10, H ACTION {||Help47(), DC_GetRefresh(GetList)} PARENT oGroup4 @ DCGUI_ROW, DCGUI_COL + D DCPUSHBUTTON CAPTION mk11 SIZE LEN(mk11)+d11, H ACTION {||F2_3_2_5()} PARENT oGroup4 @ DCGUI_ROW, DCGUI_COL + D DCPUSHBUTTON CAPTION mk12 SIZE LEN(mk12)+d12, H ACTION {||SpectrView2325()} PARENT oGroup4 /// <<<===#################### @ DCGUI_ROW, DCGUI_COL + D DCPUSHBUTTON CAPTION mk13 SIZE LEN(mk13)+d13, H ACTION {||SpectrViewCls()} PARENT oGroup4 /// <<<===#################### ******* Отладочные режимы ********************* *@DCGUI_ROW, DCGUI_COL + D DCPUSHBUTTON CAPTION L('Информационные портреты' ) SIZE 200, H ACTION {||InfPortSimbKon()} *@DCGUI_ROW, DCGUI_COL + D DCPUSHBUTTON CAPTION L('Создание приложения (2.3.2.2)' ) SIZE 210, H ACTION {||F2_3_2_2("","")} *@DCGUI_ROW, DCGUI_COL + D DCPUSHBUTTON CAPTION L('Синтез геокогнитивной модели (3.4)') SIZE 220, H ACTION {||F3_4(.T., 0, 0, 0, .T.,"")} *@DCGUI_ROW, DCGUI_COL + D DCPUSHBUTTON CAPTION L('Распознавание объектов (4.1.2)' ) SIZE 210, H ACTION {||F4_1_2(4,.T.,"4_8",'CPU')} *@DCGUI_ROW, DCGUI_COL + D DCPUSHBUTTON CAPTION L('Поиск 1-го ребра' ) SIZE 150, H ACTION {||FindFirstRib(.T.)} *@DCGUI_ROW, DCGUI_COL + D DCPUSHBUTTON CAPTION L('Тест станд.графики' ) SIZE 160, H ACTION {||Gratest(oStatic1)} *DCGETOPTIONS PIXEL DCREAD GUI FIT TITLE mTitle OPTIONS GetOptions ; EVAL {||GraTest(oStatic1)} SETAPPWINDOW oStatic1:unlockPS() * SetAppFocus(oStatic) * nEvent := 0 * DO WHILE nEvent <> xbeP_Close * nEvent := AppEvent( @mp1, @mp2, @oXbp) * DO CASE * CASE nEvent == xbeP_Keyboard .AND. mp1 == xbeK_ESC * EXIT * OTHERWISE * oXbp:HandleEvent( nEvent, mp1, mp2 ) * ENDCASE * ENDDO CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций Running(.F.) RETURN NIL ************************************************************************************************** ***************************************************************** ******** Визуализация изображений и их спектров из "Inp_spectr" ***************************************************************** FUNCTION SpectrView2325() LOCAL GetList[0], GetOptions, oSay, oDialog, oProgress, oScrn PUBLIC oBitmap, hDC1, oPS ******* Узнать разрешение экрана и не показывать изображений большой размерности **************** nWidth := AppDeskTop():currentSize()[1] // current screen size width in pixels nHeight := AppDeskTop():currentSize()[2] // current screen size height in pixels * nWidth = 1366 // <<<===########################## * nHeight = 768 IF nWidth < 1800 PUBLIC X_MaxW := 1280, Y_MaxW := 604 // Размер графического окна для самого графика в пикселях. Переход к большому экрану: kx=SQRT(2), ky=SQRT(2) * 1366 768 * COPY FILE 'Delone_1280_604.jpg' TO 'Delone.jpg' * COPY FILE 'Delone_1280_604.bmp' TO 'Delone.bmp' ELSE PUBLIC X_MaxW := 1800, Y_MaxW := 850 // Размер графического окна для самого графика в пикселях. Переход к малому экрану: kx=1/SQRT(2), ky=1/SQRT(2) * 1920 1080 * COPY FILE 'Delone_1800_850.jpg' TO 'Delone.jpg' * COPY FILE 'Delone_1800_850.bmp' TO 'Delone.bmp' ENDIF ************************************************************************************************* DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы ***** Если нет базы данных Inp_spectr.dbf, то выдать сообщение и прекратить выполнение режима IF .NOT.FILE('Inp_spectr.dbf') aMess := {} AADD(aMess, L('В текущей папке системы: ')+Disk_dir+L(' должен быть файл: "Inp_spectr.dbf"!!! ')) AADD(aMess, L('Чтобы создать этот файл необходимо выполнить подряд режимы подготовки данных для спектрального анализа!')) LB_Warning( aMess,L('4.8. АСК-анализ изображений в системе "Эйдос"' )) RETURN nil ENDIF IF .NOT.FILE('SpectralRanges.dbf') aMess := {} AADD(aMess, L('В текущей папке системы: ')+Disk_dir+L(' должен быть файл: "SpectralRanges.dbf"!!!')) AADD(aMess, L('Чтобы создать этот файл необходимо выполнить подряд режимы подготовки данных для спектрального анализа!')) LB_Warning( aMess,L('4.8. АСК-анализ изображений в системе "Эйдос"' )) RETURN nil ENDIF ** Загрузить и использовать массив полных имен файлов изображений * DC_ASave(aFileName, "_FileName.arx") aFileName := DC_ARestore("_FileName.arx") ***** Вытащить из БД размеры изображения по X и по Y и использовать и при расчете координат изображения слева ####### CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Inp_spectr EXCLUSIVE NEW USE SpectralRanges EXCLUSIVE NEW ****** Сформировать массивы цветов цветовых диапазонов SELECT SpectralRanges aSpectrIntervR := {} // Массив ЦВЕТОВ цветовых интервалов (градаций цвета) aSpectrIntervG := {} // Массив ЦВЕТОВ цветовых интервалов (градаций цвета) aSpectrIntervB := {} // Массив ЦВЕТОВ цветовых интервалов (градаций цвета) DBGOTOP() DO WHILE .NOT. EOF() AADD(aSpectrIntervR, fRed ) // Яркость R-луча цветового диапазона AADD(aSpectrIntervG, fGreen ) // Яркость G-луча цветового диапазона AADD(aSpectrIntervB, fBlue ) // Яркость B-луча цветового диапазона DBSKIP(1) ENDDO SELECT Inp_spectr mFlagView = .T. FOR mObj=3 TO FCOUNT() ******** ############################################################################################################ ******** Визуализация исходного изображения в стиле: "Витраж" ******************************************************* ******** ############################################################################################################ * IF nWidth < 1800 * PUBLIC X_MaxW := 1280, Y_MaxW := 604 // Размер графического окна для самого графика в пикселях. Переход к большому экрану: kx=SQRT(2), ky=SQRT(2) * 1366 768 * ELSE * PUBLIC X_MaxW := 1800, Y_MaxW := 850 // Размер графического окна для самого графика в пикселях. Переход к малому экрану: kx=1/SQRT(2), ky=1/SQRT(2) * 1920 1080 * ENDIF * DBGOTO(1);mNameObj=ALLTRIM(FIELDGET(mObj)) * 1234567890123 44-31=13 * C:\AIDOS-X\AID_DATA\Inp_data\.\Весна-001.jpg * 12345678901234567890123456789012345678901234 * 10 20 30 40 44 * mPos = 31 mNObj = ALLTRIM(aFileName[mObj-2]) mPos = RAT('\',mNObj) mNameObj = ConvToOemCP(SUBSTR(mNObj,mPos+1,LEN(mNObj)-mPos)) IF nWidth < 1800 DBGOTO(2);mXSizePix = VAL(FIELDGET(mObj))/SQRT(2) DBGOTO(3);mYSizePix = VAL(FIELDGET(mObj))/SQRT(2) mXSizeSpc = 800/SQRT(2) mYSizeSpc = 600/SQRT(2) ELSE DBGOTO(2);mXSizePix = VAL(FIELDGET(mObj)) DBGOTO(3);mYSizePix = VAL(FIELDGET(mObj)) mXSizeSpc = 800 mYSizeSpc = 600 ENDIF IF mFlagView IF nWidth < 1800 IF mXSizePix > 800/SQRT(2) .OR. mYSizePix > 600/SQRT(2) aMess := {} AADD(aMess, L('Для правильного вывода изображения его размер должен быть не более, чем 800 на 600 пикселей,')) AADD(aMess, L('а фактически у изображения: "')+mNameObj+L('" размеры: ')+ALLTRIM(STR(INT(mXSizePix)))+L(' на ')+ALLTRIM(STR(INT(mYSizePix)))+' pix') AADD(aMess, L('Желательно изменить размер изображений, чтобы они соответствовали этому требованию!')) LB_Warning(aMess ) mFlagView = .F. ENDIF ELSE IF mXSizePix > 800 .OR. mYSizePix > 600 aMess := {} AADD(aMess, L('Для правильного вывода изображения его размер должен быть не более, чем 800 на 600 пикселей,')) AADD(aMess, L('а фактически у изображения: "')+mNameObj+L('" размеры: ')+ALLTRIM(STR(INT(mXSizePix)))+L(' на ')+ALLTRIM(STR(INT(mYSizePix)))+' pix') AADD(aMess, L('Желательно изменить размер изображений, чтобы они соответствовали этому требованию!')) LB_Warning(aMess ) mFlagView = .F. ENDIF ENDIF ENDIF X0pix = ROUND( ( X_MaxW - ( mXSizePix+mXSizeSpc ) ) / 3 + 0.5 * mXSizePix, 0) X0spc = ROUND( ( X_MaxW - ( mXSizeSpc+mXSizeSpc ) ) / 3 * 2 + 1.5 * mXSizeSpc, 0) Y0all = ROUND( Y_MaxW / 2 , 0) ClearImageTr() // Стереть весь экран **** Написать заголовок диаграммы *** IF nWidth < 1800 oFont := XbpFont():new():create('16.Arial Bold') d1=30;d2=55 ELSE oFont := XbpFont():new():create('18.Arial Bold') d1=30;d2=65 ENDIF GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты mTitle = L('ИСХОДНОЕ ИЗОБРАЖЕНИЕ:')+' '+ALLTRIM(STR(mObj-2))+'/'+ALLTRIM(STR(FCOUNT()-2))+'-"'+mNameObj+'" '+L('И ЕГО СПЕКТР') // <<<===################## GraStringAt( oPS, { X_MaxW/2, Y_MaxW-d1 }, mTitle) IF LEN(ALLTRIM(M_NameAppl)) > 0 IF LEN(ALLTRIM(M_NameAppl)) < 70 GraStringAt( oPS, { X_MaxW/2+25, Y_MaxW-d2 }, "Приложение: "+'"'+ALLTRIM(M_NameAppl)+'"' ) ELSE GraStringAt( oPS, { X_MaxW/2+25, Y_MaxW-d2 }, '"'+ALLTRIM(M_NameAppl)+'"' ) ENDIF ENDIF aSpectrIntervV := {} // Массив значенний в % цветовых интервалов (градаций цвета) *********** Рамка вокруг изображения *** aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT // Тонкая сплошная линия aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты IF nWidth < 1800 d1=24 ELSE d1=0 ENDIF GraSetColor( oPS, BD_INDIGO, BD_INDIGO ) GraBox( oPS, { X0pix-mXSizePix/2-3, Y0all+mYSizePix/2-d1+3}, { X0pix+mXSizePix/2+3, Y0all-mYSizePix/2-d1-3 }, GRA_OUTLINE ) *********** Фон окна для изображения *** GraSetColor( oPS, BD_ICEGREY, BD_ICEGREY ) GraBox( oPS, { X0pix-mXSizePix/2-1, Y0all+mYSizePix/2-d1+1}, { X0pix+mXSizePix/2+1, Y0all-mYSizePix/2-d1-1 }, GRA_FILL ) mSpIntVmax = -9999999 DBGOTOP() DO WHILE .NOT. EOF() mScName = ALLTRIM(SCALENAME) ** Извлечь из БД Inp_spectr.dbf и цвет fColor и координаты X,Y пикселя * mScName = 'Pixel(23,11)' * 12345 IF SUBSTR(mScName,1,5) = 'Pixel' fColor = VAL(ALLTRIM(FIELDGET(mObj))) * IF fColor > 0 mPos1x = 7 mPos2x = AT(',', mScName)-1 mPos1y = AT(',', mScName)+1 mPos2y = AT(')', mScName)-1 IF nWidth < 1800 mX = VAL(SUBSTR(mScName, mPos1x, mPos2x-mPos1x+1))/SQRT(2) mY = VAL(SUBSTR(mScName, mPos1y, mPos2y-mPos1y+1))/SQRT(2) ELSE mX = VAL(SUBSTR(mScName, mPos1x, mPos2x-mPos1x+1)) mY = VAL(SUBSTR(mScName, mPos1y, mPos2y-mPos1y+1)) ENDIF IF mX <= mXSizePix .AND. mY <= mYSizePix IF nWidth < 1800 mXpix = X0pix - mXSizePix/2 + VAL(SUBSTR(mScName, mPos1x, mPos2x-mPos1x+1))/SQRT(2) mYpix = Y0all - mYSizePix/2 + VAL(SUBSTR(mScName, mPos1y, mPos2y-mPos1y+1))/SQRT(2)+d1 // <<<===######################### ELSE mXpix = X0pix - mXSizePix/2 + VAL(SUBSTR(mScName, mPos1x, mPos2x-mPos1x+1)) mYpix = Y0all - mYSizePix/2 + VAL(SUBSTR(mScName, mPos1y, mPos2y-mPos1y+1)) ENDIF SetPixel(hDC1,mXpix,mYpix,fColor) // <<<===######################### ENDIF * ENDIF ENDIF ** Вытащить из БД данные для отображения спектра * SpectrInterv: 999/999-{123,123,123} * 123456789012 R G B IF SUBSTR(mScName,1,12) = 'SPECTRINTERV' mPosR1 = AT('{', mScName)+1 mPosR2 = mPosR1+2 mPosG1 = mPosR2+2 mPosG2 = mPosG1+2 mPosB1 = mPosG2+2 mPosB2 = mPosB1+2 mRed = VAL(SUBSTR(mScName, mPosR1, mPosR2-mPosR1+1)) mGreen = VAL(SUBSTR(mScName, mPosG1, mPosG2-mPosG1+1)) mBlue = VAL(SUBSTR(mScName, mPosB1, mPosB2-mPosB1+1)) * MsgBox(mScName+' '+STR(mRed)+','+STR(mGreen)+','+STR(mBlue)) mColorV = VAL(ALLTRIM(FIELDGET(mObj))) AADD(aSpectrIntervV, mColorV) // Доля в изображении пикселей с цветом, попадающим в этот дипазон mSpIntVmax = MAX(mSpIntVmax, mColorV) ENDIF DBSKIP(1) ENDDO SET FILTER TO SUBSTR(ALLTRIM(ScaleName),1,12) = 'SPECTRINTERV' COUNT TO mNGrad SET FILTER TO ***** Расчет позиций центров исходного изображения и спектра PRIVATE X0 := 0 PRIVATE Y0 := 0 // Начало координат по осям X и Y с учетом места для легенды IF nWidth < 1800 PRIVATE W_Wind := (X_MaxW - X0)/SQRT(2) // Ширина окна для самого графика) PRIVATE H_Wind := (Y_MaxW - Y0)/SQRT(2) // Высота окна для самого графика ELSE PRIVATE W_Wind := X_MaxW - X0 // Ширина окна для самого графика PRIVATE H_Wind := Y_MaxW - Y0 // Высота окна для самого графика ENDIF PRIVATE Kx := mXSizeSpc / mNGrad // Коэффициент масштабирования по оси X: преобразует аргумент функции в номер пикселя по оси X PRIVATE Ky := mYSizeSpc / mSpIntVmax // Коэффициент масштабирования по оси Y: преобразует значение функции в номер пикселя по оси Y ****** Визуализация спектра ************************ *********** Рамка вокруг изображения *** aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT // Тонкая сплошная линия aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты IF nWidth < 1800 oFont := XbpFont():new():create('12.Arial') d1=24 ELSE oFont := XbpFont():new():create('14.Arial') d1=0 ENDIF GraSetColor( oPS, BD_INDIGO, BD_INDIGO ) GraBox( oPS, { X0spc-mXSizeSpc/2-3, Y0all+mYSizeSpc/2-d1+3}, { X0spc+mXSizeSpc/2+3, Y0all-mYSizeSpc/2-d1-3 }, GRA_OUTLINE ) *********** Фон окна для изображения *** GraSetColor( oPS, BD_ICEGREY, BD_ICEGREY ) GraBox( oPS, { X0spc-mXSizeSpc/2-1, Y0all+mYSizeSpc/2-d1+1}, { X0spc+mXSizeSpc/2+1, Y0all-mYSizeSpc/2-d1-1 }, GRA_FILL ) ****** Надпись в верхнем левом углу окна спектра (макс.%) GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты *** Может быть сделать штук 5 интервалов по Y и сеточку пунктиром? aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DOT // Пунктир aAttr [ GRA_AL_COLOR ] := GRA_CLR_PALEGRAY // Серого цвета aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=0 TO mSpIntVmax STEP mSpIntVmax/5 GraStringAt( oPS, { X0spc-mXSizeSpc/2-30, Y0all-mYSizeSpc/2-d1+j * Ky }, ALLTRIM(STR(j,3))+'%' ) GraLine(oPS, { X0spc-mXSizeSpc/2 , Y0all - j * Ky + mYSizeSpc/2-d1 }, {X0spc+mXSizeSpc/2, Y0all - j * Ky + mYSizeSpc/2-d1} ) // Нарисовать пунктирную линию уровня Y NEXT j=0 GraStringAt( oPS, { X0spc-mXSizeSpc/2-30, Y0all-mYSizeSpc/2-d1+j * Ky }, ALLTRIM(STR(j,3))+'%' ) GraLine(oPS, { X0spc-mXSizeSpc/2 , Y0all - j * Ky + mYSizeSpc/2-d1 }, {X0spc+mXSizeSpc/2, Y0all - j * Ky + mYSizeSpc/2-d1} ) // Нарисовать пунктирную линию уровня Y j=mSpIntVmax GraStringAt( oPS, { X0spc-mXSizeSpc/2-30, Y0all-mYSizeSpc/2-d1+j * Ky }, ALLTRIM(STR(j,3))+'%' ) Column = 0 ma := 127.5 mb := 127.5 mc := 127.5 mU := 0 mV := 120 mW := 240 Delta = 360 / mNGrad IF nWidth < 1800 d1=24 ELSE d1=0 ENDIF FOR c=1 TO mNGrad ***** Закрасить фон прямоугольника цветом интервала *************** ++Column X1 := X0spc + (Column-1) * Kx - mXSizeSpc/2 Y1 := Y0all + mYSizeSpc/2+d1 X2 := X0spc + Column * Kx - mXSizeSpc/2 Y2 := Y0all - aSpectrIntervV[c] * Ky + mYSizeSpc/2+d1 fColor := GraMakeRGBColor({ aSpectrIntervR[c], aSpectrIntervG[c], aSpectrIntervB[c]}) FOR y = Y2 TO Y1 FOR x = X1 TO X2 SetPixel(hDC1, x, y, AutomationTranslateColor(fColor,.f.) ) NEXT NEXT NEXT ****** Нарисовать ось X на нулевом уровне *** // <<<===############################################# * GraBox( oPS, { X0spc-mXSizeSpc/2-3, Y0all+mYSizeSpc/2-d1+3}, { X0spc+mXSizeSpc/2+3, Y0all-mYSizeSpc/2-d1-3 }, GRA_OUTLINE ) // Рамка изображения спектра X1 = X0spc-mXSizeSpc/2-2 X2 = X0spc+mXSizeSpc/2+2 nColor = AutomationTranslateColor(GraMakeRGBColor({1,1,1}),.f.) FOR x = X1 TO X2 SetPixel(hDC1, x, Y1, nColor ) NEXT // Нарисовать сплошную линию спектром ниже гистограммы для выравнивания столбиков по нижнему краю aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := GRA_CLR_PALEGRAY // Серого цвета aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты * GraLine(oPS, { X0spc-mXSizeSpc/2 , Y0all-mYSizeSpc/2-d1+1 }, {X0spc+mXSizeSpc/2 , Y0all-mYSizeSpc/2-d1+1} ) ********* Отобразить узкую полоску спектра под реальным спектром Delta = 360 / mNGrad Column = 0 n = 360 FOR j=1 TO mNGrad R := INT( ma * (1 + COS( ( n + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( n + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( n + mW ) * GradRad ) ) ) * MsgBox(STR(R)+STR(G)+STR(B)) fColor := GraMakeRGBColor({ R, G, B }) ***** Закрасить фон прямоугольника *************** GraSetColor( oPS, fColor, fColor ) ++Column * GraBox( oPS, { X0spc-mXSizeSpc/2-3, Y0all+mYSizeSpc/2+3}, { X0spc+mXSizeSpc/2+3, Y0all-mYSizeSpc/2-3 }, GRA_OUTLINE ) // Граница изображения спектра X1 := X0spc + (Column-1) * Kx - mXSizeSpc/2 Y1 := Y0all - mYSizeSpc/2-d1- 7 X2 := X0spc + Column * Kx - mXSizeSpc/2 Y2 := Y0all - mYSizeSpc/2-d1-17 GraBox( oPS, { X1, Y1 }, { X2, Y2 }, GRA_FILL) GraBox( oPS, { X1, Y0all-mYSizeSpc/2-d1+0 }, { X2, Y0all-mYSizeSpc/2-d1+1 }, GRA_FILL) * GraLine(oPS, { X0spc-mXSizeSpc/2 , Y0all-mYSizeSpc/2-d1+1 }, {X0spc+mXSizeSpc/2 , Y0all-mYSizeSpc/2-d1+1} ) n=n-Delta NEXT IF nWidth < 1800 oFont := XbpFont():new():create('12.Arial') d1=24 ELSE oFont := XbpFont():new():create('14.Arial') d1=0 ENDIF GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraStringAt( oPS, { X0pix, Y0all+mYSizePix/2-d1+17 }, 'Исходное изображение: "'+mNameObj+'"' ) // Надпись на исходном изображении GraStringAt( oPS, { X0spc, Y0all+mYSizeSpc/2-d1+17 }, 'Доля различных цветов в изображении: "'+mNameObj+'" в (%)' ) // Надпись на изображении спектра GraStringAt( oPS, { X0spc, Y2-d1-10 }, 'Ч а с т о т а ц в е т а' ) // Надпись на координатной оси X ********* Запись изображения символа в папку с именем: "InpSpectrPix" в виде графического файла DIRCHANGE(Disk_dir+"\Aid_data\") // Перейти в папку с исполнимым модулем системы IF FILEDATE("InpSpectrPix",16) = CTOD("//") DIRMAKE ("InpSpectrPix") * Mess = L('В папке:')+' '+Disk_dir+'\Aid_data\'+' '+L('не было директории "InpSpectrCls" для обобщенных спектров классов и она была создана!') Mess = L('В папке:')+' '+Disk_dir+'\Aid_data\'+' '+L('не было директории "InpSpectrPix" для изображений и их спектров и она была создана!') LB_Warning(Mess, mTitle ) ENDIF DIRCHANGE(Disk_dir+"\Aid_data\InpSpectrPix") // Перейти в папку "InpSpectrPix" // Убрать из имени класса недопустимые символы (может быть еще добавить) mFN = SUBSTR(mNameObj,1,AT('.',mNameObj)-1) mFN = STRTRAN(mFN, '/', ' из ') mFN = STRTRAN(mFN, '?', '_') mFN = STRTRAN(mFN, '>', '_') mFN = STRTRAN(mFN, '<', '_') mFN = STRTRAN(mFN, '"', '_') mFN = STRTRAN(mFN, ':', '_') mFN = STRTRAN(mFN, '\', '_') mFN = STRTRAN(mFN, '|', '_') mFN = STRTRAN(mFN, '*', '_') cFileName = Disk_dir+"\Aid_data\InpSpectrPix\"+ConvToAnsiCP(mFN)+".bmp" // Чтобы в именах файлов можно было использовать русские символы * MsgBox(cFileName) ERASE(cFileName) DC_Scrn2ImageFile( oStatic1, cFileName ) DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы MILLISEC(2000) // Задержка после визуализации спектра, чтобы можно было хоть немного его рассмотреть и чтобы он был виден через teamViewer NEXT aMess := {} AADD(aMess, L('Вывод')+' '+ALLTRIM(STR(FCOUNT()-2))+' '+L('изображений и их спектров завершен!')) AADD(aMess, L('Все изображения записаны в папку:')+' '+Disk_dir+'\Aid_data\InpSpectrPix\') LB_Warning(aMess) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ************************************************************************** ******** Визуализация изображений и их спектров классов из Abs, Prc#, Inf# ************************************************************************** FUNCTION SpectrViewCls() LOCAL GetList[0], GetOptions, oSay, oDialog, oProgress, oScrn PUBLIC oBitmap, hDC1, oPS ****** Узнать разрешение экрана и не показывать изображений большой размерности **************** nWidth := AppDeskTop():currentSize()[1] // current screen size width in pixels nHeight := AppDeskTop():currentSize()[2] // current screen size height in pixels * nWidth = 1366 // <<<===########################## * nHeight = 768 IF nWidth < 1800 PUBLIC X_MaxW := 1280, Y_MaxW := 604 // Размер графического окна для самого графика в пикселях. Переход к большому экрану: kx=SQRT(2), ky=SQRT(2) * 1366 768 ELSE PUBLIC X_MaxW := 1800, Y_MaxW := 850 // Размер графического окна для самого графика в пикселях. Переход к малому экрану: kx=1/SQRT(2), ky=1/SQRT(2) * 1920 1080 ENDIF PRIVATE W_Wind := X_MaxW // Ширина окна для самого графика PRIVATE H_Wind := Y_MaxW // Высота окна для самого графика ************************************************************************************************ ******************* Узнать путь на текущее приложение и его наименование ********************** DIRCHANGE(Disk_dir) // Перейти в папку с системой CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Appls EXCLUSIVE NEW SELECT Appls DBGOTOP() DO WHILE .NOT. EOF() IF LEN(ALLTRIM(By_default)) > 0 REPLACE By_default WITH "W" M_PathAppl = ALLTRIM(Path_Appl) // Путь на текущее приложение M_NameAppl = ALLTRIM(Name_Appl) EXIT ENDIF DBSKIP(1) ENDDO DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы ** Имя графического файла для рисования DO CASE CASE FILE('Delone.bmp') mFileName = 'Delone.bmp' CASE FILE('Delone.jpg') mFileName = 'Delone.jpg' OTHERWISE LB_Warning(L('В текущей папке системы')+Disk_dir+L(' должен быть файл: "Delone.bmp" или "Delone.jpg"'),L('4.8. АСК-анализ изображений в системе "Эйдос"' )) RETURN nil ENDCASE ****** Задание текущей модели M_CurrInf = 4 @ 0,0 DCGROUP oGroup1 CAPTION L('Задайте модель для визуализации спектров классов') SIZE 90,13.5 @ 1,1 DCSAY L('Статистические модели:' ) PARENT oGroup1 @ 2,3 DCRADIO M_CurrInf VALUE 1 PROMPT L('1. ABS - частный критерий: количество встреч сочетаний: "класс-признак" у объектов обуч.выборки') PARENT oGroup1 @ 3,3 DCRADIO M_CurrInf VALUE 2 PROMPT L('2. PRC1 - частный критерий: усл. вероятность i-го признака среди признаков объектов j-го класса ') PARENT oGroup1 @ 4,3 DCRADIO M_CurrInf VALUE 3 PROMPT L('3. PRC2 - частный критерий: условная вероятность i-го признака у объектов j-го класса ') PARENT oGroup1 @ 5.2,1 DCSAY L('Системно-когнитивные модели:' ) PARENT oGroup1 @ 6,3 DCRADIO M_CurrInf VALUE 4 PROMPT L('4. INF1 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC1 ') PARENT oGroup1 @ 7,3 DCRADIO M_CurrInf VALUE 5 PROMPT L('5. INF2 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC2 ') PARENT oGroup1 @ 8,3 DCRADIO M_CurrInf VALUE 6 PROMPT L('6. INF3 - частный критерий: Xи-квадрат, разности между фактическими и ожидаемыми абс.частотами ') PARENT oGroup1 @ 9,3 DCRADIO M_CurrInf VALUE 7 PROMPT L('7. INF4 - частный критерий: ROI (Return On Investment); вероятности из PRC1 ') PARENT oGroup1 @10,3 DCRADIO M_CurrInf VALUE 8 PROMPT L('8. INF5 - частный критерий: ROI (Return On Investment); вероятности из PRC2 ') PARENT oGroup1 @11,3 DCRADIO M_CurrInf VALUE 9 PROMPT L('9. INF6 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC1 ') PARENT oGroup1 @12,3 DCRADIO M_CurrInf VALUE 10 PROMPT L('10.INF7 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC2 ') PARENT oGroup1 DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; OPTIONS GetOptions ; ADDBUTTONS; MODAL ; TITLE L('4.8. Выбор модели для визуализации спектров классов') ******************************************************************** IF lExit ** Button Ok ELSE ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ******************************************************************** Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } M_Inf = UPPER(Ar_Model[M_CurrInf]) DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы ***** Если нет базы данных Inp_spectr.dbf, то выдать сообщение и прекратить выполнение режима IF .NOT.FILE('Inp_spectr.dbf') aMess := {} AADD(aMess, L('В текущей папке системы: ')+Disk_dir+L('\ должен быть файл: "Inp_spectr.dbf"!!! ')) AADD(aMess, L('Чтобы создать этот файл необходимо выполнить подряд режимы подготовки данных для спектрального анализа!')) LB_Warning( aMess,L('4.8. АСК-анализ изображений в системе "Эйдос"' )) RETURN nil ENDIF IF .NOT.FILE('SpectralRanges.dbf') aMess := {} AADD(aMess, L('В текущей папке системы: ')+Disk_dir+L('\ должен быть файл: "SpectralRanges.dbf"!!!')) AADD(aMess, L('Чтобы создать этот файл необходимо выполнить подряд режимы подготовки данных для спектрального анализа!')) LB_Warning( aMess,L('4.8. АСК-анализ изображений в системе "Эйдос"' )) RETURN nil ENDIF ***** Проверка наличия основных БД всех моделей. Ar_Model := {"Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } Flag = .F. DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения FOR z=1 TO LEN(Ar_Model) IF .NOT. FILE(Ar_Model[z]+'.txt') Mess = L('Модель: "#" отсутствует. Необходимо провести расчет моделей в режиме 3.5 !!!') Mess = STRTRAN(Mess, '#', Ar_Model[z]) LB_Warning( Mess, L('5.5. Просмотр основных БД всех моделей' )) Flag = .T. EXIT ENDIF NEXT IF Flag // Если какой-нибудь БД нет, то режим не запускать ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ***** Копировать txt => dbf mLenNameMax = CreateStructAll() // Создание файлов структур баз данных всех моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() // Количество классов (градаций классификационных шкал) USE Attributes EXCLUSIVE NEW;N_Gos = RECCOUNT() // Количество признаков (градаций описательных шкал) USE Gr_OpSc EXCLUSIVE NEW;N_Gos = RECCOUNT() // Количество признаков (градаций описательных шкал) USE Opis_Sc EXCLUSIVE NEW PRIVATE aInfTime[LEN(Ar_Model)] // Время создания основных баз данных моделей: Abs, Prc#, Inf# FOR z=1 TO LEN(Ar_Model) aInfTime[z] = FileTime(Ar_Model[z]+'.txt') NEXT DC_ASave(aInfTime, "_InfTime.arx") // Сформировать и записать массив времен создания основных баз данных моделей, если его не было *aInfTime = DC_ARestore("_InfTime.arx") ***** Копирование основных БД всех моделей из txt в dbf формат с числом полей до 2035 IF N_Cls > 2035 LB_Warning(L("Будут показаны только первые 2035 колонок"), L('5.5. Просмотр основных БД всех моделей' )) ENDIF * ########################################################################### // Открытие текстовых баз данных ******************************************** *** Создание баз данных в dbf-формате с найденной максимальной длиной наименования шкалы + строки и столбцы, как в Inf# GenDbfAbsOld(mLenNameMax) GenDbfPrcOld(mLenNameMax) GenDbfInfOld(mLenNameMax) *DC_ASave(aInfStruct, "_InfStruct.arx") // Когда БД создается - записывать структуру, когда открывается - считывать aInfStruct = DC_ARestore("_InfStruct.arx") *DC_ASave(aStrEmpty, "_aStrEmpty.arx") // Записывать только после расчета Abs.txt, а при расчете остальных БД только считывать *DC_ASave(aColEmpty, "_aColEmpty.arx") aStrEmpty = DC_ARestore("_aStrEmpty.arx") aColEmpty = DC_ARestore("_aColEmpty.arx") ************************************************* ***** Формирование пустой записи N_Col = N_Cls+6 // Число полей CrLf = CHR(13)+CHR(10) // Конец строки (записи) Lc_buf = "" FOR j=1 TO N_Col * S = IF(j=2*INT(j/2),"#","X") // Для отладки S = " " // Для работы Lc_buf = Lc_buf + REPLICATE(S, aInfStruct[j,3]) NEXT Lc_buf = Lc_buf + CrLf PUBLIC Len_LcBuf := LEN(Lc_buf) ****** Создаем стат.базы и базы знаний (7 по частным критериям знаний) Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } PUBLIC nHandle[LEN(Ar_Model)] FOR z=1 TO LEN(Ar_Model) nHandle[z] := FOpen( Ar_Model[z]+".txt", FO_READWRITE ) // Открыть все текстовые базы данных ######################################## NEXT **** Рассчет массива начальных позиций полей в строке PUBLIC aPos[N_Col] aPos[1] = 1 FOR j=2 TO N_Col aPos[j] = aPos[j-1] + aInfStruct[j-1,3] NEXT * ########################################################################### ***** Открытие основных БД.dbf всех моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() // Количество классов (градаций классификационных шкал) FOR z=1 TO LEN(Ar_Model) M_Inf = Ar_Model[z] USE (M_Inf) EXCLUSIVE NEW NEXT ***************************** nMax = N_Gos + 4 + ( N_Gos + 3 ) * 9 Mess = L('Копирование основных баз данных моделей: Abs, Prc#, Inf#: txt => dbf') @ 4,5 DCPROGRESS oProgr SIZE 80,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 DCREAD GUI TITLE Mess PARENT @oDial FIT EXIT oDial:show() nTime = 0 DC_GetProgress(oProgr,0,nMax) ***************************** *** Копирование БД.txt => БД.dbf ************** (но не более 2035 полей классов) mNCls = IF(N_Cls<=2035,N_Cls,2035) FOR z=1 TO LEN(Ar_Model) M_Inf = Ar_Model[z] SELECT(M_Inf) FOR i=1 TO N_Gos * IF aStrEmpty[i] DBGOTO(i) Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], i, 1 ));FIELDPUT(1, Fv) Fv = LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], i, 2 ) ;FIELDPUT(2, Fv) FOR j=1 TO mNCls * IF aColEmpty[j] Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], i, 2+j ));FIELDPUT(2+j, Fv) * ENDIF NEXT FOR j=1 TO 3 Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], i, mNCls+2+j ));FIELDPUT(mNCls+2+j, Fv) NEXT * ENDIF DC_GetProgress(oProgr, ++nTime, nMax) NEXT FOR i=1 TO 4 DBGOTO(N_Gos+i) Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], N_Gos+i, 1 ));FIELDPUT(1, Fv) Fv = LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], N_Gos+i, 2 ) ;FIELDPUT(2, Fv) FOR j=1 TO mNCls * IF aColEmpty[j] Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], N_Gos+i, 2+j ));FIELDPUT(2+j, Fv) * ENDIF NEXT FOR j=1 TO 3 Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], N_Gos+i, mNCls+2+j ));FIELDPUT(mNCls+2+j, Fv) NEXT DC_GetProgress(oProgr, ++nTime, nMax) NEXT NEXT DC_GetProgress(oProgr,nMax,nMax) oDial:Destroy() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций FOR z=1 TO LEN(nHandle) FClose( nHandle[z] ) // Закрытие txt баз данных ###################################### NEXT ***** Открытие основных БД.dbf всех моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW N_Cls = RECCOUNT() // Количество классов (градаций классификационных шкал) SELECT Classes aNameCls := {} DBGOTOP() DO WHILE .NOT. EOF() AADD(aNameCls , DelZeroNameGr(Name_cls)) DBSKIP(1) ENDDO Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } FOR z=1 TO LEN(Ar_Model) M_Inf = Ar_Model[z] USE (M_Inf) EXCLUSIVE NEW NEXT aIntInfCls := {} // Массив для того, чтобы узнавать, сформирован ли класс или нет SELECT Abs DBGOBOTTOM() FOR j=1 TO FCOUNT() AADD(aIntInfCls, FIELDGET(j)) NEXT ********************************************************************************************** ***** Вытащить из БД размеры изображения по X и по Y и использовать и при расчете координат изображения слева ####### * DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения DIRCHANGE(Disk_dir) // Перейти в папку с системой USE Inp_spectr EXCLUSIVE NEW USE SpectralRanges EXCLUSIVE NEW ****** Сформировать массивы цветов цветовых диапазонов *** SELECT SpectralRanges aSpectrIntervR := {} // Массив ЦВЕТОВ цветовых интервалов (градаций цвета) aSpectrIntervG := {} // Массив ЦВЕТОВ цветовых интервалов (градаций цвета) aSpectrIntervB := {} // Массив ЦВЕТОВ цветовых интервалов (градаций цвета) DBGOTOP() DO WHILE .NOT. EOF() AADD(aSpectrIntervR, fRed ) // Яркость R-луча цветового диапазона AADD(aSpectrIntervG, fGreen ) // Яркость G-луча цветового диапазона AADD(aSpectrIntervB, fBlue ) // Яркость B-луча цветового диапазона DBSKIP(1) ENDDO mFlagView = .T. DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения * DIRCHANGE(Disk_dir) // Перейти в папку с системой M_Inf = Ar_Model[M_CurrInf] SELECT (M_Inf) FOR mObj=3 TO FCOUNT()-3 // Начало цикла по классам IF aIntInfCls[mObj] > 0 // Класс сформирован * PUBLIC X_MaxW := 1800, Y_MaxW := 850 // Размер графического окна для самого графика в пикселях IF nWidth < 1800 mXSizePix = 700/SQRT(2) mYSizePix = ROUND(mXSizePix / 1.33, 0)/SQRT(2) mXSizeSpc = 700/SQRT(2) mYSizeSpc = ROUND(mXSizeSpc / 1.33, 0)/SQRT(2) ELSE mXSizePix = 700 mYSizePix = ROUND(mXSizePix / 1.33, 0) mXSizeSpc = 700 mYSizeSpc = ROUND(mXSizeSpc / 1.33, 0) ENDIF X0pix = ROUND( ( X_MaxW - ( mXSizePix+mXSizeSpc ) ) / 3 + 0.5 * mXSizePix , 0) X0spc = ROUND( ( X_MaxW - ( mXSizeSpc+mXSizeSpc ) ) / 3 * 2 + 1.5 * mXSizeSpc + 40, 0) Y0all = ROUND( Y_MaxW / 2 , 0) ClearImageTr() // Стереть весь экран **** Написать заголовок диаграммы *** IF nWidth < 1800 oFont := XbpFont():new():create('16.Arial Bold') a=30;b=65 d1=24;d2=0 ELSE oFont := XbpFont():new():create('18.Arial Bold') a=30;b=65 d1=0;d2=0 ENDIF GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты mTitle = 'ОБОБЩЕННЫЕ СПЕКТРЫ КЛАССА: "'+aNameCls[mObj-2]+'" В МОДЕЛЯХ: "PRC1" И "'+ALLTRIM(UPPER(M_Inf))+'"' GraStringAt( oPS, { X_MaxW/2, Y_MaxW-a }, mTitle) IF LEN(ALLTRIM(M_NameAppl)) < 70 GraStringAt( oPS, { W_Wind/2+d2, Y_MaxW - b }, "Приложение: "+'"'+ALLTRIM(M_NameAppl)+'."' ) ELSE GraStringAt( oPS, { W_Wind/2+d2, Y_MaxW - b }, '"'+ALLTRIM(M_NameAppl)+'"' ) ENDIF ****************************************************************************************** ******************* Рисование ЛЕВОГО окна со спектром в модели PRC1 ********************** ****************************************************************************************** aSpectrIntervV := {} // Массив отображаемых значенний цветовых интервалов (градаций цвета) aSpectrIntervA := {} // Массив средних значенний цветовых интервалов (градаций цвета) mSpIntVmax = -9999999 mSpIntVmin = +9999999 DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения * DIRCHANGE(Disk_dir) // Перейти в папку с системой M_Inf = Ar_Model[2] // Модель PRC1 SELECT (M_Inf) DBGOTOP() DO WHILE .NOT. EOF() mScName = ALLTRIM(NAME) ** Вытащить из БД данные для отображения спектра * SpectrInterv: 999/999-{123,123,123} * 123456789012 R G B IF SUBSTR(mScName,1,12) = 'SPECTRINTERV' mPosR1 = AT('{', mScName)+1 mPosR2 = mPosR1+2 mPosG1 = mPosR2+2 mPosG2 = mPosG1+2 mPosB1 = mPosG2+2 mPosB2 = mPosB1+2 mRed = VAL(SUBSTR(mScName, mPosR1, mPosR2-mPosR1+1)) mGreen = VAL(SUBSTR(mScName, mPosG1, mPosG2-mPosG1+1)) mBlue = VAL(SUBSTR(mScName, mPosB1, mPosB2-mPosB1+1)) * MsgBox(mScName+' '+STR(mRed)+','+STR(mGreen)+','+STR(mBlue)) mColorV = FIELDGET(mObj) // Вытаскивать из БД заданной модели <=######################### mSrednV = Sredn AADD(aSpectrIntervV, mColorV) // Количество информации в цветовом диапазоне о данном классе AADD(aSpectrIntervA, mSrednV) // Среднее количество информации в цветовом диапазоне о данном классе mSpIntVmax = MAX(mSpIntVmax, mColorV) mSpIntVmin = MIN(mSpIntVmin, mColorV) mSpIntVmax = MAX(mSpIntVmax, mSrednV) mSpIntVmin = MIN(mSpIntVmin, mSrednV) ENDIF DBSKIP(1) ENDDO SET FILTER TO SUBSTR(ALLTRIM(Name),1,12) = 'SPECTRINTERV' COUNT TO mNGrad SET FILTER TO ***** Расчет позиций центров исходного изображения и спектра *** PRIVATE X0 := 0 PRIVATE Y0 := 0 // Начало координат по осям X и Y с учетом места для легенды PRIVATE W_Wind := X_MaxW - X0 // Ширина окна для самого графика PRIVATE H_Wind := Y_MaxW - Y0 // Высота окна для самого графика PRIVATE Kx := mXSizeSpc / mNGrad // Коэффициент масштабирования по оси X: преобразует аргумент функции в номер пикселя по оси X PRIVATE Ky := mYSizeSpc / (mSpIntVmax-mSpIntVmin) // Коэффициент масштабирования по оси Y: преобразует значение функции в номер пикселя по оси Y *********** Рамка вокруг изображения *** aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT // Тонкая сплошная линия aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты GraSetColor( oPS, BD_INDIGO, BD_INDIGO ) GraBox( oPS, { X0pix-mXSizePix/2-3, Y0all+mYSizePix/2+3}, { X0pix+mXSizePix/2+3, Y0all-mYSizePix/2-3 }, GRA_OUTLINE ) *********** Фон окна для изображения *** GraSetColor( oPS, BD_ICEGREY, BD_ICEGREY ) GraBox( oPS, { X0pix-mXSizePix/2-1, Y0all+mYSizePix/2+1}, { X0pix+mXSizePix/2+1, Y0all-mYSizeSpc/2-1 }, GRA_FILL ) ****** Надписи по оси Y *** IF nWidth < 1800 oFont := XbpFont():new():create('12.Arial') d1=24 ELSE oFont := XbpFont():new():create('14.Arial') d1=0 ENDIF GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты *** Может быть сделать штук 5 интервалов по Y и сеточку пунктиром? *** aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DOT // Пунктир aAttr [ GRA_AL_COLOR ] := GRA_CLR_PALEGRAY // Серого цвета aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты Y0A := Y0all + mYSizePix/2 - IF(mSpIntVmin>0, 0, ABS(mSpIntVmin) * Ky ) // Позиция оси X на оси Y D = 45 mStep = (mSpIntVmax-mSpIntVmin)/5 FOR j=mSpIntVmin TO mSpIntVmax STEP (mSpIntVmax-mSpIntVmin)/5 Y2 := Y0all - mYSizePix/2 + j * Ky + IF(mSpIntVmin>0, 0, ABS(mSpIntVmin) * Ky ) GraStringAt( oPS, { X0pix-mXSizePix/2-D, Y2 }, ALLTRIM(STR(j,15,2))+' %' ) GraLine( oPS, { X0pix-mXSizePix/2 , Y2 }, {X0pix+mXSizePix/2, Y2 } ) // <<<===########## Нарисовать пунктирную линию уровня Y NEXT j=mSpIntVmin Y2 := Y0all - mYSizePix/2 + j * Ky + IF(mSpIntVmin>0, 0, ABS(mSpIntVmin) * Ky ) GraStringAt( oPS, { X0pix-mXSizePix/2-D, Y2 }, ALLTRIM(STR(j,15,2))+' %' ) j=mSpIntVmax Y2 := Y0all - mYSizePix/2 + j * Ky + IF(mSpIntVmin>0, 0, ABS(mSpIntVmin) * Ky ) GraStringAt( oPS, { X0pix-mXSizePix/2-D, Y2 }, ALLTRIM(STR(j,15,2))+' %' ) ****** Нарисовать ось X на нулевом уровне *** X1 := X0pix - mXSizePix/2 X2 := X0pix + mXSizePix/2 nColor = AutomationTranslateColor(GraMakeRGBColor({1,1,1}),.f.) FOR x = X1 TO X2 SetPixel(hDC1, x, Y0A, nColor ) NEXT Column = 0 ma := 127.5 mb := 127.5 mc := 127.5 mU := 0 mV := 120 mW := 240 Delta = 360 / mNGrad * Y0A := Y0all + mYSizePix/2 - IF(mSpIntVmin>0, 0, ABS(mSpIntVmin) * Ky ) // Позиция оси X на оси Y FOR c=1 TO mNGrad ***** Закрасить фон прямоугольника цветом интервала *************** ++Column X1 := X0pix + (Column-1) * Kx - mXSizePix/2 Y1 := Y0A X2 := X0pix + Column * Kx - mXSizePix/2 Y2 := Y0A - aSpectrIntervV[c] * Ky fColor := GraMakeRGBColor({ aSpectrIntervR[c], aSpectrIntervG[c], aSpectrIntervB[c]}) IF Y2 < Y1 FOR y = Y2 TO Y1 FOR x = X1 TO X2 SetPixel(hDC1, x, y, AutomationTranslateColor(fColor,.f.) ) NEXT NEXT ENDIF IF Y1 < Y2 FOR y = Y1 TO Y2 FOR x = X1 TO X2 SetPixel(hDC1, x, y, AutomationTranslateColor(fColor,.f.) ) NEXT NEXT ENDIF NEXT ****** Рисование линии средних значений цветовых диапазонов по всем классам *** aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DOT aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты графической линии nColor = AutomationTranslateColor(GraMakeRGBColor({1,1,1}),.f.) Column = 0.5 FOR c=2 TO mNGrad ++Column X1 := X0pix + (Column-1) * Kx - mXSizePix/2 Y1 := Y0all + aSpectrIntervA[c-1] * Ky - mYSizePix/2 X2 := X0pix + Column * Kx - mXSizePix/2 Y2 := Y0all + aSpectrIntervA[c] * Ky - mYSizePix/2 GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) *********** Маркеры ******************************** * IF nWidth < 1800 * Y1 := Y0all - aSpectrIntervA[c-1] * Ky + mYSizePix/2 - d1 * Y2 := Y0all - aSpectrIntervA[c] * Ky + mYSizePix/2 - d1 * ELSE Y1 := Y0all - aSpectrIntervA[c-1] * Ky + mYSizePix/2 Y2 := Y0all - aSpectrIntervA[c] * Ky + mYSizePix/2 * ENDIF SetPixel(hDC1, X1-1, Y1-1, nColor);SetPixel(hDC1, X1+0, Y1-1, nColor);SetPixel(hDC1, X1+1, Y1-1, nColor) SetPixel(hDC1, X1-1, Y1+0, nColor);SetPixel(hDC1, X1+0, Y1+0, nColor);SetPixel(hDC1, X1+1, Y1+0, nColor) SetPixel(hDC1, X1-1, Y1+1, nColor);SetPixel(hDC1, X1+0, Y1+1, nColor);SetPixel(hDC1, X1+1, Y1+1, nColor) SetPixel(hDC1, X2-1, Y2-1, nColor);SetPixel(hDC1, X2+0, Y2-1, nColor);SetPixel(hDC1, X2+1, Y2-1, nColor) SetPixel(hDC1, X2-1, Y2+0, nColor);SetPixel(hDC1, X2+0, Y2+0, nColor);SetPixel(hDC1, X2+1, Y2+0, nColor) SetPixel(hDC1, X2-1, Y2+1, nColor);SetPixel(hDC1, X2+0, Y2+1, nColor);SetPixel(hDC1, X2+1, Y2+1, nColor) NEXT ****** Нарисовать ось X черным цветом на нулевом уровне *** X1 := X0pix - mXSizePix/2 X2 := X0pix + mXSizePix/2 nColor = AutomationTranslateColor(GraMakeRGBColor({1,1,1}),.f.) FOR x = X1 TO X2 SetPixel(hDC1, x, Y0A - 1, nColor ) NEXT // Нарисовать сплошную линию ниже гистограммы для выравнивания столбиков по нижнему краю aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := GRA_CLR_PALEGRAY // Серого цвета aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты GraLine(oPS, { X0pix-mXSizePix/2 , Y0all-mYSizePix/2-1 }, {X0pix+mXSizePix/2 , Y0all-mYSizePix/2-1} ) ********* Отобразить узкую полоску спектра под реальным спектром *** Delta = 360 / mNGrad Column = 0 n = 360 FOR j=1 TO mNGrad R := INT( ma * (1 + COS( ( n + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( n + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( n + mW ) * GradRad ) ) ) * MsgBox(STR(R)+STR(G)+STR(B)) fColor := GraMakeRGBColor({ R, G, B }) ***** Закрасить фон прямоугольника *************** GraSetColor( oPS, fColor, fColor ) ++Column * GraBox( oPS, { X0spc-mXSizeSpc/2-3, Y0all+mYSizeSpc/2+3}, { X0spc+mXSizeSpc/2+3, Y0all-mYSizeSpc/2-3 }, GRA_OUTLINE ) // Граница изображения спектра X1 := X0pix + (Column-1) * Kx - mXSizePix/2 Y1 := Y0all - mYSizePix/2- 7 X2 := X0pix + Column * Kx - mXSizePix/2 Y2 := Y0all - mYSizePix/2-17 GraBox( oPS, { X1, Y1 }, { X2, Y2 }, GRA_FILL) n=n-Delta NEXT IF nWidth < 1800 oFont := XbpFont():new():create('12.Arial') ELSE oFont := XbpFont():new():create('14.Arial') ENDIF GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraStringAt( oPS, { X0pix, Y0all+mYSizePix/2+17 }, 'Обобщенный спектр класса: "'+aNameCls[mObj-2]+'" в модели: "'+ALLTRIM(UPPER(M_Inf))+'"' ) // Надпись на изображении спектра GraStringAt( oPS, { X0pix, Y2-10 }, 'Ч а с т о т а ц в е т а' ) // Надпись на координатной оси X ****************************************************************************************** ******************* Конец рисования левого окна со спектром в заданной модели PRC1 ******* ****************************************************************************************** ****************************************************************************************** ******************* Рисование ПРАВОГО окна со спектром в заданной модели INF ************* ****************************************************************************************** aSpectrIntervV := {} // Массив отображаемых значенний цветовых интервалов (градаций цвета) mSpIntVmax = -9999999 mSpIntVmin = +9999999 DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения * DIRCHANGE(Disk_dir) // Перейти в папку с системой M_Inf = Ar_Model[M_CurrInf] SELECT (M_Inf) DBGOTOP() DO WHILE .NOT. EOF() mScName = ALLTRIM(NAME) ** Вытащить из БД данные для отображения спектра * SpectrInterv: 999/999-{123,123,123} * 123456789012 R G B IF SUBSTR(mScName,1,12) = 'SPECTRINTERV' mPosR1 = AT('{', mScName)+1 mPosR2 = mPosR1+2 mPosG1 = mPosR2+2 mPosG2 = mPosG1+2 mPosB1 = mPosG2+2 mPosB2 = mPosB1+2 mRed = VAL(SUBSTR(mScName, mPosR1, mPosR2-mPosR1+1)) mGreen = VAL(SUBSTR(mScName, mPosG1, mPosG2-mPosG1+1)) mBlue = VAL(SUBSTR(mScName, mPosB1, mPosB2-mPosB1+1)) * MsgBox(mScName+' '+STR(mRed)+','+STR(mGreen)+','+STR(mBlue)) mColorV = FIELDGET(mObj) // Вытаскивать из БД заданной модели <=######################### AADD(aSpectrIntervV, mColorV) // Количество информации в цветовом диапазоне о данном классе mSpIntVmax = MAX(mSpIntVmax, mColorV) mSpIntVmin = MIN(mSpIntVmin, mColorV) ENDIF DBSKIP(1) ENDDO SET FILTER TO SUBSTR(ALLTRIM(Name),1,12) = 'SPECTRINTERV' COUNT TO mNGrad SET FILTER TO ***** Расчет позиций центров исходного изображения и спектра PRIVATE X0 := 0 PRIVATE Y0 := 0 // Начало координат по осям X и Y с учетом места для легенды PRIVATE W_Wind := X_MaxW - X0 // Ширина окна для самого графика PRIVATE H_Wind := Y_MaxW - Y0 // Высота окна для самого графика PRIVATE Kx := mXSizeSpc / mNGrad // Коэффициент масштабирования по оси X: преобразует аргумент функции в номер пикселя по оси X PRIVATE Ky := mYSizeSpc / (mSpIntVmax-mSpIntVmin) // Коэффициент масштабирования по оси Y: преобразует значение функции в номер пикселя по оси Y mDiapazon = mSpIntVmax-mSpIntVmin ****** Визуализация спектра ************************ *********** Рамка вокруг изображения *** aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT // Тонкая сплошная линия aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты GraSetColor( oPS, BD_INDIGO, BD_INDIGO ) GraBox( oPS, { X0spc-mXSizeSpc/2-3, Y0all+mYSizeSpc/2+3}, { X0spc+mXSizeSpc/2+3, Y0all-mYSizeSpc/2-3 }, GRA_OUTLINE ) *********** Фон окна для изображения *** GraSetColor( oPS, BD_ICEGREY, BD_ICEGREY ) GraBox( oPS, { X0spc-mXSizeSpc/2-1, Y0all+mYSizeSpc/2+1}, { X0spc+mXSizeSpc/2+1, Y0all-mYSizeSpc/2-1 }, GRA_FILL ) ****** Надписи по оси Y *** IF nWidth < 1800 oFont := XbpFont():new():create('12.Arial') ELSE oFont := XbpFont():new():create('14.Arial') ENDIF GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты *** Может быть сделать штук 5 интервалов по Y и сеточку пунктиром? aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DOT // Пунктир aAttr [ GRA_AL_COLOR ] := GRA_CLR_PALEGRAY // Серого цвета aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты Y0A := Y0all + mYSizeSpc/2 - IF(mSpIntVmin>0, 0, ABS(mSpIntVmin) * Ky ) // Позиция оси X на оси Y D = 50 mStep = (mSpIntVmax-mSpIntVmin)/5 FOR j=mSpIntVmin TO mSpIntVmax STEP (mSpIntVmax-mSpIntVmin)/5 Y2 := Y0all - mYSizeSpc/2 + j * Ky + IF(mSpIntVmin>0, 0, ABS(mSpIntVmin) * Ky ) GraStringAt( oPS, { X0spc-mXSizeSpc/2-D, Y2 }, ALLTRIM(STR(j,15,3))+IF(M_CurrInf=4,' бит','') ) GraLine( oPS, { X0spc-mXSizeSpc/2 , Y2 }, {X0spc+mXSizeSpc/2, Y2 } ) // Нарисовать пунктирную линию уровня Y NEXT j=mSpIntVmin Y2 := Y0all - mYSizeSpc/2 + j * Ky + IF(mSpIntVmin>0, 0, ABS(mSpIntVmin) * Ky ) GraStringAt( oPS, { X0spc-mXSizeSpc/2-D, Y2 }, ALLTRIM(STR(j,15,3))+IF(M_CurrInf=4,' бит','') ) j=mSpIntVmax Y2 := Y0all - mYSizeSpc/2 + j * Ky + IF(mSpIntVmin>0, 0, ABS(mSpIntVmin) * Ky ) GraStringAt( oPS, { X0spc-mXSizeSpc/2-D, Y2 }, ALLTRIM(STR(j,15,3))+IF(M_CurrInf=4,' бит','') ) ****** Нарисовать ось X на нулевом уровне X1 := X0spc - mXSizeSpc/2 X2 := X0spc + mXSizeSpc/2 nColor = AutomationTranslateColor(GraMakeRGBColor({1,1,1}),.f.) FOR x = X1 TO X2 SetPixel(hDC1, x, Y0A, nColor ) NEXT Column = 0 ma := 127.5 mb := 127.5 mc := 127.5 mU := 0 mV := 120 mW := 240 Delta = 360 / mNGrad * Y0A := Y0all + mYSizeSpc/2 - IF(mSpIntVmin>0, 0, ABS(mSpIntVmin) * Ky ) // Позиция оси X на оси Y FOR c=1 TO mNGrad ***** Закрасить фон прямоугольника цветом интервала *************** ++Column X1 := X0spc + (Column-1) * Kx - mXSizeSpc/2 Y1 := Y0A X2 := X0spc + Column * Kx - mXSizeSpc/2 Y2 := Y0A - aSpectrIntervV[c] * Ky fColor := GraMakeRGBColor({ aSpectrIntervR[c], aSpectrIntervG[c], aSpectrIntervB[c]}) IF Y2 < Y1 FOR y = Y2 TO Y1 FOR x = X1 TO X2 SetPixel(hDC1, x, y, AutomationTranslateColor(fColor,.f.) ) NEXT NEXT ENDIF IF Y1 < Y2 FOR y = Y1 TO Y2 FOR x = X1 TO X2 SetPixel(hDC1, x, y, AutomationTranslateColor(fColor,.f.) ) NEXT NEXT ENDIF NEXT ****** Нарисовать ось X черным цветом на нулевом уровне *** X1 := X0spc - mXSizeSpc/2 X2 := X0spc + mXSizeSpc/2 nColor = AutomationTranslateColor(GraMakeRGBColor({1,1,1}),.f.) FOR x = X1 TO X2 SetPixel(hDC1, x, Y0A, nColor ) NEXT // Нарисовать сплошную линию ниже гистограммы для выравнивания столбиков по нижнему краю aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := GRA_CLR_PALEGRAY // Серого цвета aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты GraLine(oPS, { X0spc-mXSizeSpc/2 , Y0all-mYSizeSpc/2-1 }, {X0spc+mXSizeSpc/2 , Y0all-mYSizeSpc/2-1} ) ********* Отобразить узкую полоску спектра под реальным спектром *** Delta = 360 / mNGrad Column = 0 n = 360 FOR j=1 TO mNGrad R := INT( ma * (1 + COS( ( n + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( n + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( n + mW ) * GradRad ) ) ) * MsgBox(STR(R)+STR(G)+STR(B)) fColor := GraMakeRGBColor({ R, G, B }) ***** Закрасить фон прямоугольника *************** GraSetColor( oPS, fColor, fColor ) ++Column * GraBox( oPS, { X0spc-mXSizeSpc/2-3, Y0all+mYSizeSpc/2+3}, { X0spc+mXSizeSpc/2+3, Y0all-mYSizeSpc/2-3 }, GRA_OUTLINE ) // Граница изображения спектра X1 := X0spc + (Column-1) * Kx - mXSizeSpc/2 Y1 := Y0all - mYSizeSpc/2- 7 X2 := X0spc + Column * Kx - mXSizeSpc/2 Y2 := Y0all - mYSizeSpc/2-17 GraBox( oPS, { X1, Y1 }, { X2, Y2 }, GRA_FILL) n=n-Delta NEXT IF nWidth < 1800 oFont := XbpFont():new():create('12.Arial') ELSE oFont := XbpFont():new():create('14.Arial') ENDIF GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraStringAt( oPS, { X0spc, Y0all+mYSizeSpc/2+17 }, 'Обобщенный спектр класса: "'+aNameCls[mObj-2]+'" в модели: "'+ALLTRIM(UPPER(M_Inf))+'"' ) // Надпись на изображении спектра GraStringAt( oPS, { X0spc, Y2-10 }, 'Ч а с т о т а ц в е т а' ) // Надпись на координатной оси X ******* Частные критерии, которыми и отличаются друг от друга модели PRIVATE aModName[10] aModName := {'1. ABS - частный критерий: количество встреч сочетаний: "класс-признак" у объектов обуч.выборки',; '2. PRC1 - частный критерий: условная вероятность i-го признака среди признаков объектов j-го класса',; '3. PRC2 - частный критерий: условная вероятность i-го признака у объектов j-го класса ',; '4. INF1 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC1 ',; '5. INF2 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC2 ',; '6. INF3 - частный критерий: Xи-квадрат, разности между фактическими и ожидаемыми абс.частотами ',; '7. INF4 - частный критерий: ROI (Return On Investment); вероятности из PRC1 ',; '8. INF5 - частный критерий: ROI (Return On Investment); вероятности из PRC2 ',; '9. INF6 - частный критерий: разность условной и безуслувной вероятностей; вероятности из PRC1 ',; '10.INF7 - частный критерий: разность условной и безуслувной вероятностей; вероятности из PRC2 ' } *********** Рамка вокруг изображения *** aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT // Тонкая сплошная линия aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты S = 60 D = 25 Dpix = 45 Dspc = 50 IF nWidth < 1800 oFont := XbpFont():new():create('8.Arial') mCentr = 613 ELSE oFont := XbpFont():new():create('12.Arial') mCentr = 884 ENDIF *********** Фон окна для изображения *** GraSetColor( oPS, BD_ICEGREY, BD_ICEGREY ) GraBox( oPS, { X0pix-mXSizePix/2-2*Dpix+5, Y0all-mYSizePix/2-S-3}, { X0spc+mXSizeSpc/2+Dpix+10, Y0all-mYSizeSpc/2-S-13-3*D }, GRA_FILL ) *********** Рамка вокруг изображения *** GraSetColor( oPS, BD_INDIGO, BD_INDIGO ) GraBox( oPS, { X0pix-mXSizePix/2-2*Dpix+5, Y0all-mYSizePix/2-S-3}, { X0spc+mXSizeSpc/2+Dpix+10, Y0all-mYSizeSpc/2-S-13-3*D }, GRA_OUTLINE ) GraBox( oPS, { mCentr, Y0all-mYSizePix/2-S-3}, { mCentr, Y0all-mYSizeSpc/2-S-13-3*D }, GRA_OUTLINE ) *********** Поясняющие надписи в нижнем окне GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraStringAt( oPS, { X0pix - mXSizePix/2-2*Dpix+12, Y2-S-0*D }, 'Гистограмма отражает условную вероятность встречи каждого цвета в изображениях данного класса.' ) GraStringAt( oPS, { X0pix - mXSizePix/2-2*Dpix+12, Y2-S-1*D }, 'Пунктирная линия отражает безусловную (среднюю) вероятность встречи цвета по всей выборке изображений.' ) GraStringAt( oPS, { X0pix - mXSizePix/2-2*Dpix+12, Y2-S-2*D }, ALLTRIM(aModName[2]) ) GraStringAt( oPS, { X0spc - mXSizeSpc/2-Dspc-55, Y2-S-0*D }, 'Гистограмма отражает степень характерности/нехарактерности каждого цвета для изображений данного класса, т.е.' ) GraStringAt( oPS, { X0spc - mXSizeSpc/2-Dspc-55, Y2-S-1*D }, 'степень отличия его доли в изображении от среднего по выборке, а знак зависит от того, больше она или меньше.' ) GraStringAt( oPS, { X0spc - mXSizeSpc/2-Dspc-55, Y2-S-2*D }, ALLTRIM(aModName[M_CurrInf]) ) ********* Запись изображения символа в папку с именем: "InpSpectrPix" в виде графического файла DIRCHANGE(Disk_dir+"\Aid_data\") // Перейти в папку с исполнимым модулем системы IF FILEDATE("InpSpectrCls",16) = CTOD("//") DIRMAKE ("InpSpectrCls") Mess = L('В папке:')+' '+Disk_dir+'\Aid_data\'+' '+L('не было директории "InpSpectrCls" для обобщенных спектров классов и она была создана!') LB_Warning(Mess, mTitle ) ENDIF DIRCHANGE(Disk_dir+"\Aid_data\InpSpectrCls") // Перейти в папку "InpSpectrCls" // Убрать из имени класса недопустимые символы (может быть еще добавить) mFN = aNameCls[mObj-2]+'-'+ALLTRIM(UPPER(M_Inf)) mFN = STRTRAN(mFN, '/', ' из ') mFN = STRTRAN(mFN, '?', '_') mFN = STRTRAN(mFN, '>', '_') mFN = STRTRAN(mFN, '<', '_') mFN = STRTRAN(mFN, '"', '_') mFN = STRTRAN(mFN, ':', '_') mFN = STRTRAN(mFN, '\', '_') mFN = STRTRAN(mFN, '|', '_') mFN = STRTRAN(mFN, '*', '_') cFileName = Disk_dir+"\Aid_data\InpSpectrCls\"+ConvToAnsiCP(mFN)+".bmp" // Чтобы в именах файлов можно было использовать русские символы * MsgBox(cFileName) ERASE(cFileName) DC_Scrn2ImageFile( oStatic1, cFileName ) DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы MILLISEC(2000) // Задержка после визуализации спектра, чтобы можно было хоть немного его рассмотреть и чтобы он был виден через teamViewer ****************************************************************************************** ******************* Конец рисования правого окна со спектром в заданной модели INF ******* ****************************************************************************************** ENDIF NEXT aMess := {} AADD(aMess, L('Вывод')+' '+ALLTRIM(STR(FCOUNT()-5))+' '+L('обобщенных спектров классов завершен!')) AADD(aMess, L('Все изображения записаны в папку: ')+Disk_dir+'\Aid_data\InpSpectrCls\') LB_Warning(aMess) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ******************************************************************************************************************* ******** Занести в БД описательных и классификационных шкал информацию о начальной и конечной градации каждой шкалы ******************************************************************************************************************* FUNCTION DiapGradSc() ****** Занести в БД описательных шкал информацию о начальной и конечной градации каждой шкалы SELECT Gr_OpSc DBGOTOP() mKodOpSc = Kod_OpSc mKodGrOpSc = Kod_GrOS SELECT Opis_Sc DBGOTO(mKodOpSc) REPLACE KodGr_Min WITH mKodGrOpSc SELECT Gr_OpSc DBGOTOP() DO WHILE .NOT. EOF() IF mKodOpSc = Kod_OpSc mKodGrOpSc = Kod_GrOS ELSE SELECT Opis_Sc DBGOTO(mKodOpSc) REPLACE KodGr_Max WITH mKodGrOpSc SELECT Gr_OpSc mKodOpSc = Kod_OpSc mKodGrOpSc = Kod_GrOS SELECT Opis_Sc DBGOTO(mKodOpSc) REPLACE KodGr_Min WITH mKodGrOpSc ENDIF SELECT Gr_OpSc DBSKIP(1) ENDDO SELECT Opis_Sc DBGOTO(mKodOpSc) REPLACE KodGr_Max WITH mKodGrOpSc ****** Занести в БД классификационных шкал информацию о начальной и конечной градации каждой шкалы SELECT Gr_ClSc DBGOTOP() mKodClSc = Kod_ClSc mKodGrClSc = Kod_GrCS SELECT Class_Sc DBGOTO(mKodClSc) REPLACE KodGr_Min WITH mKodGrClSc SELECT Gr_ClSc DBGOTOP() DO WHILE .NOT. EOF() IF mKodClSc = Kod_ClSc mKodGrClSc = Kod_GrCS ELSE SELECT Class_Sc DBGOTO(mKodClSc) REPLACE KodGr_Max WITH mKodGrClSc SELECT Gr_ClSc mKodClSc = Kod_ClSc mKodGrClSc = Kod_GrCS SELECT Class_Sc DBGOTO(mKodClSc) REPLACE KodGr_Min WITH mKodGrClSc ENDIF SELECT Gr_ClSc DBSKIP(1) ENDDO SELECT Class_Sc DBGOTO(mKodClSc) REPLACE KodGr_Max WITH mKodGrClSc RETURN NIL ******************************************************************************************************************* ******** Заготовка для простого отображения стадии исполнения (без стадий) FUNCTION LC_Progress() LOCAL Getlist := {}, oProgress, oDialog Mess = L('2.2. Копирование описательной шкалы со всеми градациями') @ 4,5 DCPROGRESS oProgress SIZE 70,1.1 MAXCOUNT RecCount() COLOR GRA_CLR_BLUE PERCENT EVERY 100 DCREAD GUI TITLE Mess PARENT @oDialog FIT EXIT oDialog:show() nMax = RECCOUNT() nTime = 0 DC_GetProgress(oProgress,0,nMax) FOR r=1 TO nMax DC_GetProgress(oProgress, ++nTime, nMax) NEXT DC_GetProgress(oProgress,nMax,nMax) oDialog:Destroy() RETURN NIL * Xdemo3 ********************************************************************************************************** *********************************************************************************************************** ********** РЕЖИМЫ КЛАСТЕРНО-КОНСТРУКТИВНОГО АНАЛИЗА ПО КЛАССАМ ******************************************** *********************************************************************************************************** ************************************************************************************** ******** 4.2.2.1. Расчет матриц сходства, кластеров и конструктов классов ******** Сначала сделать вариант с DBF не более 2035 классов ************************************************************************************** FUNCTION F4_2_2_1(Vie) LOCAL oDial, nTime, oProgr LOCAL Getlist := {}, oProgress, oDialog, lOk := .t., oButton, nEvent, mp1, mp2, oXbp // XSample_14_Ok.prg Roger *LOCAL aSay[30], Mess97, Mess98, Mess99 // Массив сообщений отображаемых стадий исполнения (до 30 на экране) Running(.T.) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN(.T.) ENDIF IF ApplChange("4.2.2.1()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF dbeSetDefault('DBFNTX') ** Ели файл параметров калстеризации существует, то просто загрузить его, ** иначе сформировать. В любом случае предоставить возможность корректировки параметров диалоге CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() IF FILE("_aClustParCls.arx") aClustParCls = DC_ARestore("_aClustParCls.arx") * DC_ASave(aClustParCls, "_aClustParCls.arx") ELSE ******* Загрузить массив с информацией о созданых моделях, ******* выбрать из него модели, для которых можно расчитать матрицу сходства классов ******* задать их в диалоге IF FILE("_VerifInf.arx") // Файл с информацией о том, какие модели были верифицированы ранее aVerifInf = DC_ARestore("_VerifInf.arx") ELSE LB_Warning(L("Необходимо предварительно провести рассчет моделей в 3-й подсистеме!")) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF *** Проводить кластеризацию во всех просчитанных моделях PRIVATE aClustParCls[12] // Массив параметров кластеризации FOR j=1 TO LEN(aVerifInf) aClustParCls[j] = aVerifInf[j] NEXT aClustParCls[11] = 1 // Начальный класс диапазона кластеризации (mCls1) aClustParCls[12] = N_Cls // Конечный класс диапазона кластеризации (mCls2) ENDIF * ********************************************************************************************************************** * // Диалог задания моделей расчета матриц сходства классов * @ 0,0 DCGROUP oGroup1 CAPTION L('Задайте модели, для которых проводить кластерно-конструктивный анализ:') SIZE 82,13.5 * @14,0 DCGROUP oGroup2 CAPTION L('' ) SIZE 82,2.5 * @ 1,1 DCSAY L('Статистические базы:') PARENT oGroup1 * @ 2,3 DCCHECKBOX aClustParCls[ 1] PROMPT L('1. ABS - частный критерий: количество встреч сочетаний: "класс-признак" у объектов обуч.выборки') PARENT oGroup1 * @ 3,3 DCCHECKBOX aClustParCls[ 2] PROMPT L('2. PRC1 - частный критерий: усл. вероятность i-го признака среди признаков объектов j-го класса ') PARENT oGroup1 * @ 4,3 DCCHECKBOX aClustParCls[ 3] PROMPT L('3. PRC2 - частный критерий: условная вероятность i-го признака у объектов j-го класса ') PARENT oGroup1 * @ 5.2,1 DCSAY L('Системно-когнитивные модели (Базы знаний):' ) PARENT oGroup1 * @ 6,3 DCCHECKBOX aClustParCls[ 4] PROMPT L('4. INF1 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC1 ') PARENT oGroup1 * @ 7,3 DCCHECKBOX aClustParCls[ 5] PROMPT L('5. INF2 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC2 ') PARENT oGroup1 * @ 8,3 DCCHECKBOX aClustParCls[ 6] PROMPT L('6. INF3 - частный критерий: Xи-квадрат, разности между фактическими и ожидаемыми абс.частотами ') PARENT oGroup1 * @ 9,3 DCCHECKBOX aClustParCls[ 7] PROMPT L('7. INF4 - частный критерий: ROI (Return On Investment); вероятности из PRC1 ') PARENT oGroup1 * @10,3 DCCHECKBOX aClustParCls[ 8] PROMPT L('8. INF5 - частный критерий: ROI (Return On Investment); вероятности из PRC2 ') PARENT oGroup1 * @11,3 DCCHECKBOX aClustParCls[ 9] PROMPT L('9. INF6 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC1 ') PARENT oGroup1 * @12,3 DCCHECKBOX aClustParCls[10] PROMPT L('10.INF7 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC2 ') PARENT oGroup1 * @ 1, 2.2 DCSAY L("Задайте диапазон кодов классов (подматрицу) для анализа:") PARENT oGroup2 * @ 1, 50 DCSAY L(" ") GET aClustParCls[11] PARENT oGroup2 PICTURE "###########" * @ 1, 65 DCSAY L(" ") GET aClustParCls[12] PARENT oGroup2 PICTURE "###########" * @1,58 DCPUSHBUTTON ; * CAPTION L('Пояснение по режиму') ; * SIZE LEN(L('Пояснение по режиму'))+3, 0.9 ; * ACTION {||Help422()} * DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE * DCREAD GUI ; * TO lExit ; * FIT ; * OPTIONS GetOptions ; * ADDBUTTONS; * MODAL ; * TITLE L('4.2.2.1. Расчет матриц сходства, кластеров и конструктов классов') * IF lExit * ** Button Ok * ELSE * ************************************************************** * ***** БД, открытые перед запуском главного меню * ***** Восстанавливать их после выхода из функций главного меню * ************************************************************** * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы * USE PathGrAp EXCLUSIVE NEW * USE Appls EXCLUSIVE NEW * USE Users EXCLUSIVE NEW * ************************************************************** * Running(.F.) * RETURN(.F.) * ENDIF * ********************************************************************************************************************** ** Проверить корректность заданных параметров FlagErr = .F. IF aClustParCls[11] < aClustParCls[12] ELSE LB_Warning(L('Неверно задан диапазон кодов классов для анализа: Kod1 должен быть меньше Kod2 !'), L('4.2.2.1. Расчет матриц сходства, кластеров и конструктов классов')) FlagErr = .T. ENDIF IF aClustParCls[11] < 1 aClustParCls[11] = 1 ENDIF IF aClustParCls[12] > N_Cls aClustParCls[12] = N_Cls ENDIF **** Если для расчета матриц сходства заданы модели, которые не были рассчитаны, то выдать об этом сообщение и выйти Flag = .T. PRIVATE Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } Mess = L("Необходимо предварительно провести рассчет моделей:")+' ' FOR j=1 TO LEN(aVerifInf) IF aClustParCls[j] = .T. Mess = Mess + IF(Flag," ",", ") + Ar_Model[j] Flag = .F. ENDIF NEXT IF Flag LB_Warning(Mess + ' ' + L("в 3-й подсистеме!"), L('4.2.2.1. Расчет матриц сходства, кластеров и конструктов классов')) FlagErr = .T. ENDIF IF FlagErr ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN(.F.) ENDIF ********* Записать массив с информацией со ВСЕМИ параметрами кластеризации, заданными для рассчета * aClustParCls = DC_ARestore("_aClustParCls.arx") DC_ASave(aClustParCls, "_aClustParCls.arx") ********************************************************************************************************************** nRadio = 1 @ 0, 0 DCGROUP oGroup1 CAPTION L('Задайте режим:') SIZE 45.0, 5.0 @ 1, 2 DCRADIO nRadio VALUE 1 PROMPT L('1. Новый вариант (Питон)' ) PARENT oGroup1 @ 2, 2 DCRADIO nRadio VALUE 2 PROMPT L('2. Старый вариант (xBase++)' ) PARENT oGroup1 @ 3, 2 DCRADIO nRadio VALUE 3 PROMPT L('3. Пояснение по режиму' ) PARENT oGroup1 DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; ADDBUTTONS; OPTIONS GetOptions ; MODAL ; TITLE L('4.2.2.1. Расчет матриц сходства классов') IF lExit ** Button Ok ELSE ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF *********************************************************************** DO CASE CASE nRadio=1 IF FILE('_4221Python.txt') ERASE('_4221Python.txt') ENDIF LC_RunShell("__AIDOS-PY.exe", 717400306, "_4221py") // Мой вариант на Питоне в системе __AIDOS-PY.exe DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения StrFile('', '_4221Python.txt') // Признак, что режим _4221 на Питоне завершился нормально ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL CASE nRadio=2 IF FILE('_4221xBase.txt') ERASE('_4221xBase.txt') ENDIF CASE nRadio=3 Help422() ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDCASE ***** Копирование txt => dbf баз данных заданных моделей ********************** mLenNameMax = CreateStructAll() // Создание файлов структур баз данных всех моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() // Количество классов (градаций классификационных шкал) USE Attributes EXCLUSIVE NEW;N_Atr = RECCOUNT() // Количество признаков (градаций описательных шкал) ***** Копирование основных БД всех моделей из txt в dbf формат с числом полей до 2035 IF N_Cls > 2035 LB_Warning(L("Будут показаны только первые 2035 колонок"), L('4.2.2.1. Расчет матриц сходства, кластеров и конструктов классов' )) ENDIF * ########################################################################### // Открытие текстовых баз данных ******************************************** *** Создание баз данных в dbf-формате с найденной максимальной длиной наименования шкалы + строки и столбцы, как в Inf# GenDbfAbsOld(mLenNameMax) GenDbfPrcOld(mLenNameMax) GenDbfInfOld(mLenNameMax) PRIVATE Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } IF .NOT. FILE("_InfStruct.arx") aMess := {} AADD(aMess, L("Необходимо предварительно провести рассчет моделей:")) AADD(aMess, L('"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7"')) AADD(aMess, L("в 3-й подсистеме, например в режиме 3.5 !")) LB_Warning(aMess, L('4.2.2.1. Расчет матриц сходства, кластеров и конструктов классов')) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN(.F.) ELSE * DC_ASave(aInfStruct, "_InfStruct.arx") // Когда БД создается - записывать структуру, когда открывается - считывать aInfStruct = DC_ARestore("_InfStruct.arx") ENDIF *DC_ASave(aStrEmpty, "_aStrEmpty.arx") // Записывать только после расчета Abs.txt, а при расчете остальных БД только считывать *DC_ASave(aColEmpty, "_aColEmpty.arx") aStrEmpty = DC_ARestore("_aStrEmpty.arx") aColEmpty = DC_ARestore("_aColEmpty.arx") ************************************************* * *****************************################################################ // Начало отсчета времени для прогнозирования длительности исполнения Time_progress = 0 // Прошло секунд с начала процесса // Процесс может идти больше суток, поэтому для определения // во всех случаях вычисляется время, прошедшее с начала года T_Mess1 = "Начало:"+" "+TIME() // Начало Sec_1 = (DOY(DATE())-1)*86400+SECONDS() PUBLIC T1 := (DOY(DATE())-1)*86400+SECONDS() // Время предыдущей индикации процесса исполнения PUBLIC T2 := (DOY(DATE())-1)*86400+SECONDS()+1 // Текущее время (1-й раз оно заметно больше T1 чтобы было отображение) PUBLIC T1tp := T1 PUBLIC T2tp := T2 mNModels = 0 // Количество моделей FOR z=1 TO LEN(Ar_Model) IF aClustParCls[z] mNModels++ ENDIF NEXT Wsego = 0 Wsego = Wsego + mNModels*N_Atr // 1. Копирование БД.txt => БД.dbf. <<<===########################### Wsego = Wsego + mNModels*(N_Cls+(aClustParCls[12]-aClustParCls[11]+1)^2) // 2. РАСЧЕТ МАТРИЦ СХОДСТВА КЛАССОВ. <<<===########################### Wsego = Wsego + mNModels*((aClustParCls[12]-aClustParCls[11]+1)^2) // 3. РАСЧЕТ КЛАСТЕРОВ И КОНСТРУКТОВ КЛАССОВ. <<<===########################### Wsego = Wsego + mNModels*(N_Cls^2) // 4. Физическая сортировка и дорасчет БД кластеров и конструктов классов во всех моделях <<<===########################### * *****************************################################################ // Отображение стадии исполнения. Будет написано прямо в окне Progress-bar d = 0 @0,0 DCGROUP oGroup1 CAPTION 'Стадии исполнения процесса' FONT "6.Helv" SIZE 105+d, 5.5 PARENT oTabPage1 @7,0 DCGROUP oGroup2 CAPTION 'Прогноз времени исполнения' FONT "6.Helv" SIZE 105+d, 5.0 PARENT oTabPage2 s = 1 @s++,1 DCSAY " " SAYSIZE 100 SAYOBJECT aSay[ 1] FONT "10.Helv" PARENT oGroup1 @s++,1 DCSAY " " SAYSIZE 100 SAYOBJECT aSay[ 2] FONT "10.Helv" PARENT oGroup1 @s++,1 DCSAY " " SAYSIZE 100 SAYOBJECT aSay[ 3] FONT "10.Helv" PARENT oGroup1 @s++,1 DCSAY " " SAYSIZE 100 SAYOBJECT aSay[ 4] FONT "10.Helv" PARENT oGroup1 s++ @s++,1 DCSAY " " SAYSIZE 100 SAYOBJECT oSay97 FONT "10.HelvBold" s++ @0.2+s++,1 DCSAY " " SAYSIZE 100 SAYOBJECT oSay98 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @1.5+s ,1 DCSAY " " SAYSIZE 100 SAYOBJECT oSay99 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @s ,1 DCPROGRESS oProgress ; SIZE 95,1.5 ; PERCENT ; EVERY 1; // Кол-во обновлений изображения MAXCOUNT Wsego; COLOR GRA_CLR_CYAN // Цвет полосы @s++,97 DCPUSHBUTTON CAPTION '&Cancel' ; ACTION {||lOk:=.T.} OBJECT oButton ; SIZE 7,1.5 DCREAD GUI ; TITLE L('4.2.2.1. Расчет матриц сходства, кластеров и конструктов классов') ; PARENT @oDialog ; FIT ; EXIT ; MODAL oDialog:alwaysOnTop = .T. // Окно открывается на переднем плане oDialog:show() * *****************************################################################ ***** Формирование пустой записи N_Col = N_Cls+6 // Число полей CrLf = CHR(13)+CHR(10) // Конец строки (записи) Lc_buf = "" FOR j=1 TO N_Col * S = IF(j=2*INT(j/2),"#","X") // Для отладки S = " " // Для работы Lc_buf = Lc_buf + REPLICATE(S, aInfStruct[j,3]) NEXT Lc_buf = Lc_buf + CrLf PUBLIC Len_LcBuf := LEN(Lc_buf) ****** Создаем стат.базы и базы знаний (7 по частным критериям знаний) Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } PUBLIC nHandle[LEN(Ar_Model)] FOR z=1 TO LEN(Ar_Model) IF aClustParCls[z] nHandle[z] := FOpen( Ar_Model[z]+".txt", FO_READWRITE ) // Открыть заданные текстовые базы данных ######################################## ENDIF NEXT **** Рассчет массива начальных позиций полей в строке PUBLIC aPos[N_Col] aPos[1] = 1 FOR j=2 TO N_Col aPos[j] = aPos[j-1] + aInfStruct[j-1,3] NEXT *****************************################################################ ***** Открытие основных БД.dbf всех моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() // Количество классов (градаций классификационных шкал) N_Model = 0 FOR z=1 TO LEN(Ar_Model) IF aClustParCls[z] ++N_Model M_Inf = Ar_Model[z] USE (M_Inf) EXCLUSIVE NEW ENDIF NEXT *** Копирование БД.txt => БД.dbf ************** (но не более 2035 полей классов) mNCls = IF(N_Cls<=2035,N_Cls,2035) // Даже с ADS не обрабатывается больше 2035 классов FOR z=1 TO LEN(Ar_Model) // 1. Копирование БД.txt => БД.dbf. Wsego = Wsego + mNModels*N_Atr <<<===########################### IF aClustParCls[z] M_Inf = Ar_Model[z] aSay[ 1]:SetCaption(L('1. Копирование БД.txt => БД.dbf в модели: ')+ALLTRIM(STR(z))+'/10-'+M_Inf) SELECT(M_Inf) FOR i=1 TO N_Atr * IF aStrEmpty[i] DBGOTO(i) Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], i, 1 ));FIELDPUT(1, Fv) Fv = LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], i, 2 ) ;FIELDPUT(2, Fv) FOR j=1 TO mNCls * IF aColEmpty[j] Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], i, 2+j ));FIELDPUT(2+j, Fv) * ENDIF NEXT FOR j=1 TO 3 Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], i, mNCls+2+j ));FIELDPUT(mNCls+2+j, Fv) NEXT * ENDIF lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) NEXT FOR i=1 TO 4 DBGOTO(N_Atr+i) Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], N_Atr+i, 1 ));FIELDPUT(1, Fv) Fv = LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], N_Atr+i, 2 ) ;FIELDPUT(2, Fv) FOR j=1 TO mNCls * IF aColEmpty[j] Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], N_Atr+i, 2+j ));FIELDPUT(2+j, Fv) * ENDIF NEXT FOR j=1 TO 3 Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], N_Atr+i, mNCls+2+j ));FIELDPUT(mNCls+2+j, Fv) NEXT NEXT ENDIF NEXT ***** Закрытие основных БД.txt всех заданных моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций FOR z=1 TO LEN(nHandle) IF aClustParCls[z] FClose( nHandle[z] ) // Закрытие txt баз данных ENDIF NEXT * ########################################################################### *************************************** *** РАСЧЕТ МАТРИЦ СХОДСТВА КЛАССОВ *** *************************************** ***** Создание матриц сходства классов для заданных моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() // Количество классов (градаций классификационных шкал) mLenNameMax = -9999 SELECT Classes DBGOTOP() DO WHILE .NOT. EOF() mLenNameMax = MAX(mLenNameMax, LEN(ALLTRIM(Name_cls))) DBSKIP(1) ENDDO ********** Структура создаваемой базы *********** aStructure := { { "Kod_cls" , "N", 15, 0},; // 1 { "Kod_ClSc", "N", 15, 0},; // 2 { "Name_cls", "C",mLenNameMax, 0} } // 3 FOR j=1 TO N_Cls FieldName = "N"+ALLTRIM(STR(j,15)) AADD(aStructure, { FieldName, "N", 19, 7 }) NEXT FOR z=1 TO LEN(Ar_Model) IF aClustParCls[z] cFileName = "SxodCls"+Ar_Model[z] DbCreate( cFileName, aStructure ) ENDIF NEXT ***** Открытие основных БД.dbf всех заданных моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() // Количество классов (градаций классификационных шкал) Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } FOR m=1 TO LEN(Ar_Model) // 2. РАСЧЕТ МАТРИЦ СХОДСТВА КЛАССОВ. Wsego = Wsego + mNModels*(((N_Cls+(aClustParCls[12]-aClustParCls[11]+1)^2)/2)+N_Cls/2 ) <<<===########################### IF aClustParCls[m] M_Inf = Ar_Model[m] aSay[ 2]:SetCaption(L('2. Расчет матрицы сходства классов в модели:')+' '+ALLTRIM(STR(m))+'/10-'+M_Inf) M_SxodCls = "SxodCls"+Ar_Model[m] USE (M_SxodCls) EXCLUSIVE NEW USE (M_Inf) EXCLUSIVE NEW ****** Присвоение записям матрицы сходства кодов и наименований классов SELECT Classes DBGOTOP() DO WHILE .NOT. EOF() M_KodCls = Kod_cls M_KodClSc = Kod_ClSc M_NameCls = Name_cls SELECT (M_SxodCls) APPEND BLANK REPLACE Kod_cls WITH M_KodCls REPLACE Kod_ClSc WITH M_KodClSc REPLACE Name_cls WITH M_NameCls FOR j=1 TO N_Cls FIELDPUT(3+j,0) NEXT lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) SELECT Classes DBSKIP(1) ENDDO **** Расчет матрицы сходства (M_SxodCls) **** Похоже как в пакетном распознавании PRIVATE aCls1[N_Atr], aCls2[N_Atr] Max = -9999999 Min = 9999999 SELECT (M_Inf) FOR mCls1 = aClustParCls[11] TO aClustParCls[12] // Цикл по классам подматрицы Inf.dbf заданного диапазона классов ####### SELECT (M_Inf) **************** Формирование массива 1-го класса FlagCls1 = .F. AFILL(aCls1,0) SumCls1 = 0 // Сумма FOR i=1 TO N_Atr GO i;aCls1[i] = FIELDGET(2+mCls1) SumCls1 = SumCls1 + aCls1[i] IF aCls1[i] <> 0 FlagCls1 = .T. // Флаг наличия данных ENDIF NEXT IF FlagCls1 // Если есть данные по 1-му классу ***** Расчет среднего и дисперсии массива 1-го класса SrCls1 = SumCls1/N_Atr // Среднее массива 1-го класса DiCls1 = 0 // Дисперсия массива 1-го класса FOR i=1 TO N_Atr DiCls1 = DiCls1 + ( aCls1[i] - SrCls1 ) ^ 2 NEXT DiCls1 = SQRT( DiCls1 / (N_Atr - 1)) // Дорасчет дисперсии массива 1-го класса ENDIF FOR mCls2 = aClustParCls[11] TO aClustParCls[12] // Цикл по классам подматрицы Inf.dbf заданного диапазона классов ####### IF FlagCls1 .AND. mCls2 >= mCls1 SELECT (M_Inf) **************** Формирование массива 2-го класса FlagCls2 = .F. AFILL(aCls2,0) SumCls2 = 0 // Сумма FOR i=1 TO N_Atr GO i;aCls2[i] = FIELDGET(2+mCls2) SumCls2 = SumCls2 + aCls2[i] IF aCls2[i] <> 0 FlagCls2 = .T. // Флаг наличия данных ENDIF NEXT IF FlagCls2 // Если есть данные по классу2-му ***** Расчет среднего и дисперсии массива 2-го класса SrCls2 = SumCls2/N_Atr // Среднее массива 1-го класса DiCls2 = 0 // Дисперсия массива 1-го класса FOR i=1 TO N_Atr DiCls2 = DiCls2 + ( aCls2[i] - SrCls2 ) ^ 2 NEXT DiCls2 = SQRT( DiCls2 / (N_Atr - 1)) // Дорасчет дисперсии массива 1-го класса ******** Расчет нормированной к 100% корреляции массивов ******** локатора источника и информативностей признаков объекта Korr = 0 FOR i=1 TO N_Atr Korr = Korr + (aCls1[i] - SrCls1) * (aCls2[i] - SrCls2) NEXT Korr = Korr / ( (N_Atr-1) * DiCls1 * DiCls2 ) * 100 *** Вообще-то 1 вычитать не надо, в Help Excel приведена формула без вычитания 1, *** НО в Excel-2003 СЧИТАЕТСЯ ОНА ТАК, КАК БУДТО 1 ВСЕ ЖЕ ВЫЧИТАЕТСЯ (См.: "Кореляция" и "Ковариация") *** В Excel-2007 и выше все считается правильно, а в Excel-2003 просто неверно и формула корреляции приведена неправильная Max = MAX(Max,Korr) Min = MIN(Min,Korr) SELECT (M_SxodCls) GO mCls1;FIELDPUT(3+mCls2,Korr) GO mCls2;FIELDPUT(3+mCls1,Korr) ENDIF ENDIF lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) NEXT NEXT ENDIF NEXT ********************************************** *** РАСЧЕТ КЛАСТЕРОВ И КОНСТРУКТОВ КЛАССОВ *** ********************************************** ***** Создание баз кластеров и конструктов классов для разных моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() // Количество классов (градаций классификационных шкал) mLenNameMax = -9999 SELECT Classes DBGOTOP() DO WHILE .NOT. EOF() mLenNameMax = MAX(mLenNameMax, LEN(ALLTRIM(Name_cls))) DBSKIP(1) ENDDO ********** Структура создаваемой базы *********** aStructure := { { "Model" , "C", 4, 0},; // 1 { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } { "Num_Klast", "N", 15, 0},; // 2 { "Num_pp" , "N", 15, 0},; // 3 { "Kod_cls" , "N", 15, 0},; // 4 { "Name_cls" , "C",mLenNameMax, 0},; // 5 { "Sxodstvo" , "N", 19, 7},; // 6 { "Fltr_wind", "C", 1, 0},; // 7 { "Kod_ClSc" , "N", 15, 0} } // 8 FOR z=1 TO LEN(Ar_Model) IF aClustParCls[z] cFileName = "KlastCls"+Ar_Model[z] DbCreate( cFileName, aStructure ) ENDIF NEXT DbCreate( 'KonstCls.dbf' , aStructure ) DbCreate( 'KonstClsAll.dbf', aStructure ) DbCreate( 'KonstClsTmp.dbf', aStructure ) *********************** К Л А С Т Е Р И З А Ц И Я **************************** ***** Открытие основных БД.dbf всех заданных моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() // Количество классов (градаций классификационных шкал) USE KonstClsAll EXCLUSIVE NEW // Одна общая БД для всех конструктов всех моделей USE KonstClsTmp EXCLUSIVE NEW // Одна общая БД для всех конструктов всех моделей FOR m=1 TO LEN(Ar_Model) // Цикл по заданным моделям IF aClustParCls[m] M_KlastCls = "KlastCls"+Ar_Model[m] USE (M_KlastCls) EXCLUSIVE NEW ENDIF NEXT SELECT Classes aClsKod = {} // Массив кодов всех классов DBGOTOP() DO WHILE .NOT. EOF() AADD(aClsKod, ALLTRIM(STR(Kod_cls))) DBSKIP(1) ENDDO **** Создать БД KonstClsAll, общую для всех кластеров и конструктов всех моделей Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } FOR m=1 TO LEN(Ar_Model) // 3. РАСЧЕТ КЛАСТЕРОВ И КОНСТРУКТОВ КЛАССОВ. Wsego = Wsego + mNModels*((aClustParCls[12]-aClustParCls[11]+1)^2) <<<===########################### IF aClustParCls[m] M_Inf = Ar_Model[m] aSay[ 3]:SetCaption(L('3. Расчет кластеров и конструктов классов в модели:')+' '+ALLTRIM(STR(m))+'/10-'+M_Inf) M_SxodCls = "SxodCls"+Ar_Model[m] USE (M_SxodCls) EXCLUSIVE NEW mNumKlast = 0 // Номер кластера FOR mCls1 = aClustParCls[11] TO aClustParCls[12] // Цикл по классам заданного диапазона mNumKlast++ FOR mCls2 = aClustParCls[11] TO aClustParCls[12] // Цикл по классам заданного диапазона SELECT (M_SxodCls) DBGOTO(mCls2) mSxodstvo = FIELDGET(3+mCls1) * IF ABS(mSxodstvo) >= aClustParCls[13] // Исключить середину конструкта (это делать уже при просмотре и отображении: "Вписать в окно") mKodcls = Kod_cls mKodclSc = Kod_ClSc mNameCls = Name_cls SELECT KonstClsAll APPEND BLANK REPLACE Model WITH Ar_Model[m] // Модель REPLACE Num_Klast WITH mNumKlast // Номер кластера REPLACE Kod_cls WITH mKodcls // Код класса REPLACE Kod_ClSc WITH mKodClSc // Код классификационной шкалы REPLACE Name_cls WITH mNameCls // Наименование класса REPLACE Sxodstvo WITH mSxodstvo // Сходство класса * ENDIF lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) NEXT NEXT ENDIF NEXT ****** Физическая сортировка и дорасчет БД кластеров и конструктов ***************###################### aSay[ 4]:SetCaption(L('4. Физическая сортировка и дорасчет БД кластеров и конструктов классов в заданных моделях')) SELECT KonstClsAll INDEX ON Model+STR(Num_Klast,15)+STR(99999.9999999-Sxodstvo,19,7) TO KonstClsAll DBGOTOP() mNumKlast = Num_klast mNumPP = 0 DO WHILE .NOT. EOF() // 4. Физическая сортировка и дорасчет БД кластеров и конструктов во всех моделях. Wsego = Wsego + mNModels*(N_Cls^2) <<<===########################### ** Нумерация записи IF mNumKlast = Num_klast REPLACE Num_pp WITH ++mNumPP ELSE mNumKlast = Num_klast mNumPP = 0 REPLACE Num_pp WITH ++mNumPP ENDIF ** Копирование записи в рассортированную БД KonstClsTmp Ar := {} FOR j=1 TO FCOUNT() AADD(Ar, FIELDGET(j)) NEXT SELECT KonstClsTmp APPEND BLANK FOR j=1 TO LEN(Ar) FIELDPUT(j, Ar[j]) NEXT ** Копирование записи в рассортированную БД (M_KlastCls) M_KlastCls = "KlastCls"+ALLTRIM(Model) IF FILE(M_KlastCls+'.dbf') // <<<===################# Если для расчета заданы не все модели, то некторые файлы могут быть не созданы SELECT (M_KlastCls) APPEND BLANK FOR j=1 TO LEN(Ar) FIELDPUT(j, Ar[j]) NEXT ENDIF lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) SELECT KonstClsAll DBSKIP(1) ENDDO ***** Копирование БД KonstClsTmp => KonstClsAll (Может быть использовать ADS_CopyFile()?) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций ERASE("KonstClsAll.dbf") COPY FILE ("KonstClsTmp.dbf") TO ("KonstClsAll.dbf") ERASE("KonstClsTmp.dbf") FOR m=1 TO LEN(Ar_Model) // 3. РАСЧЕТ КЛАСТЕРОВ И КОНСТРУКТОВ КЛАССОВ. Wsego = Wsego + mNModels*((aClustParCls[12]-aClustParCls[11]+1)^2) <<<===########################### IF aClustParCls[m] Name_SS = "SxodCls"+Ar_Model[m]+".dbf" Name_DD = "SxodCls"+Ar_Model[m]+".xls" * LB_Warning(L("Источник: "+Name_SS+", приемник: "+Name_DD) COPY FILE (Name_SS) TO (Name_DD) ENDIF NEXT StrFile('', '_4221xBase.txt') // Признак, что режим _4221 на xBase++ завершился нормально oSay97:SetCaption(L("РАСЧЕТ МАТРИЦ СХОДСТВА, КЛАСТЕРОВ И КОНСТРУКТОВ КЛАССОВ ЗАВЕРШЕН УСПЕШНО !!!")) oSay97:SetCaption(oSay97:Caption) oButton:activate := {||PostAppEvent(xbeP_Close,,,oDialog)} //<<<<<< Add This oButton:SetCaption('&Ok') // Деструктурирование окна отображения графического Progress-bar DC_AppEvent( @lOk ) oDialog:Destroy() aMess := {} AADD(aMess, L('Расчет матриц сходства классов успешно завершен!')) AADD(aMess, L(' ')) AADD(aMess, L('Матрицы сходства классов содержатся в папке текущего приложения:')+' '+M_PathAppl+' '+L('в следующих таблицах MS Excel,')) AADD(aMess, L('созданных на основе статистических и СК-моделей: "SxodClsAbs.xlsx", "SxodClsPrc1.xlsx", "SxodClsPrc2.xlsx", "SxodClsInf1.xlsx", ')) AADD(aMess, L('"SxodClsInf2.xlsx", "SxodClsInf3.xlsx", "SxodClsInf4.xlsx", "SxodClsInf5.xlsx", "SxodClsInf6.xlsx", "SxodClsInf7.xlsx".')) AADD(aMess, L(' ')) AADD(aMess, L('Эти таблицы создаются в режиме 5.12. Они уже подготовлены для включения их в отчеты, но рекомендуется еще немного их отформатировать.')) AADD(aMess, L(' ')) AADD(aMess, L('Наименования колонок в матрице сходства классов являются наименованиями классов, которые есть в каждой строке. Поэтому можно взять ')) AADD(aMess, L('их из строк и вставить с транспонированием в строку наименований колонок, придав им вертикальную ориентацию и выровняв их по центру. ')) AADD(aMess, L('Сходство дано в процентах, поэтому можно задать формат ячеек без десятичных знаков и отображать отрицательные значения красным цветом.')) AADD(aMess, L('Ширину колонок есть смысл минимизировать по реальным значениям данных, а также сделать сетку в таблице.')) LB_Warning(aMess, L("Сообщение об успешном завершении операции" )) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL *********************************************************************************************************************** ******** 4.2.2.2. Результаты кластерно-конструктивного анализа классов ################ *********************************************************************************************************************** FUNCTION F4_2_2_2() LOCAL GetList := {}, aPres, oBrowse, oToolBar, aColors, bColor, GetOptions Running(.T.) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF ApplChange("4.2.2.2()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF *********************************************************** ***** Проверка на наличие необходимых БД всех моделей ***** *********************************************************** IF .NOT. FILE("Classes.dbf") // БД градаций класс.шкал: Classes.dbf LB_Warning(L("Необходимо создать базу данных классов !!!")) Running(.F.) RETURN NIL ENDIF ******* Загрузить массив aClustParCls с информацией о созданных маьтрицах сходства классов ******* и проверить, созданы ли базы данных сходства классов, ******* выдать сообщение и выйти, если нет **** Проверка, существуют ли файлы матриц сходства для моделей, заданных для проведения кластерно-конструктивного анализа * nRadio = 1 * @ 0, 0 DCGROUP oGroup1 CAPTION L('Задайте режим:') SIZE 45.0, 5.0 * @ 1, 2 DCRADIO nRadio VALUE 1 PROMPT L('1. Новый вариант (Питон)' ) PARENT oGroup1 * @ 2, 2 DCRADIO nRadio VALUE 2 PROMPT L('2. Старый вариант (xBase++)' ) PARENT oGroup1 * @ 3, 2 DCRADIO nRadio VALUE 3 PROMPT L('3. Пояснение по режиму' ) PARENT oGroup1 IF FILE('_4221xBase.txt') .OR. FILE('_4221Python.txt') ELSE LB_Warning(L("Предварительно необходимо выполнить режим 4.2.2.1 !!!"),L('4.2.2.2. Результаты кластерно-конструктивного анализа классов')) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF IF FILE("_aClustParCls.arx") aClustParCls = DC_ARestore("_aClustParCls.arx") * DC_ASave(aClustParCls, "_aClustParCls.arx") ELSE LB_Warning(L("Предварительно необходимо выполнить расчеты в режиме 4.2.2.1 !!!"),L('4.2.2.2. Результаты кластерно-конструктивного анализа классов')) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF PRIVATE Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } Mess = L("Предварительно необходимо выполнить расчет матриц сходства классов в моделях:")+' ' Flag = .F. FOR j=1 TO LEN(Ar_Model) IF aClustParCls[j] mName = "KlastCls"+Ar_Model[j]+'.DBF' IF .NOT. FILE(mName) Mess = Mess + IF(Flag, ", ","") + Ar_Model[j] Flag = .T. * EXIT ENDIF ENDIF NEXT IF Flag LB_Warning(Mess+' '+L(' в режиме 4.2.2.1 !!!'),L('4.2.2.2. Результаты кластерно-конструктивного анализа классов')) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF **** Проверка, существуют ли БД с результатами кластерно-конструктивного анализа PRIVATE Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } Mess = L("Необходимо предварительно провести кластерно-конструктивный анализ в моделях:")+' ' Flag = .F. FOR j=1 TO LEN(Ar_Model) IF aClustParCls[j] mName = "SxodCls"+Ar_Model[j]+'.DBF' IF .NOT. FILE(mName) Mess = Mess + IF(Flag, ", ","") + Ar_Model[j] Flag = .T. * EXIT ENDIF ENDIF NEXT IF Flag LB_Warning(Mess+' '+L(' в режиме 4.2.2.1 !!!'),L('4.2.2.2. Результаты кластерно-конструктивного анализа классов')) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ***** Подготовить БД для визуализации конструктов KonstCls.dbf IF FILE("_WindOn4222.arx") aWindOn4222 = DC_ARestore("_WindOn4222.arx") mNCls = aWindOn4222[1] // Число отображаемых классов mMinSx = aWindOn4222[2] // MIN модуль уровня сходства отображаемых классов mVar = aWindOn4222[3] // mVar=1: Классы с MAX и MIN уровнями сходства, mVar=2: Классы с MAX по модулю уровнем сходства mXSize = aWindOn4222[4] // Разрешение по X mYSize = aWindOn4222[5] // Разрешение по Y ELSE mNCls = 12 mMinSx = 0 mVar = 1 mXSize = 1800 // Разрешение по X mYSize = 900 // Разрешение по Y PRIVATE aWindOn4222[5] aWindOn4222[1] = mNCls // Число отображаемых классов aWindOn4222[2] = mMinSx // MIN модуль уровня сходства отображаемых классов aWindOn4222[3] = mVar // mVar=1: Классы с MAX и MIN уровнями сходства, mVar=2: Классы с MAX по модулю уровнем сходства aWindOn4222[4] = mXSize // Разрешение по X aWindOn4222[5] = mYSize // Разрешение по Y ENDIF * aWindOn4222 = DC_ARestore("_WindOn4222.arx") DC_ASave(aWindOn4222, "_WindOn4222.arx") ***** Открытие необходимых для работы БД CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW USE KonstCls EXCLUSIVE NEW mNumMod = 0 FOR m=1 TO LEN(Ar_Model) // Цикл по заданным моделям IF aClustParCls[m] mNumMod = IF(mNumMod=0, m, mNumMod) M_SxodCls = "SxodCls"+Ar_Model[m] USE (M_SxodCls) EXCLUSIVE NEW M_KlastCls = "KlastCls"+Ar_Model[m] USE (M_KlastCls) EXCLUSIVE NEW ENDIF NEXT ****** Отобразить 1-й конструкт SELECT Classes SET FILTER TO DBGOTOP() M_KodCls = Kod_cls M_NameCls = Name_cls MessIPC := L('Конструкт класса: ')+ALLTRIM(STR(M_KodCls, 15))+' "'+DelZeroNameGr(M_NameCls)+L('" в модели: ')+ALLTRIM(STR(mNumMod, 15))+' "'+UPPER(Ar_Model[mNumMod]+'"') @ 0,0 DCSAY {|| MessIPC } OBJECT oSay1 SAYSIZE 133 FONT "9.HelvBold" // Наименование конструкта KonstCls(mNumMod) // <<<===########################### Возникает ошибка, если посчитана только одна матрица сходства /* ----- Create ToolBar ----- */ @ 28.5, 0 DCTOOLBAR oToolBar SIZE 133, 1.5 DCADDBUTTON CAPTION L('Помощь') ; SIZE LEN(L("Помощь"))+2 ; ACTION {||Help422(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Помощь по режиму 4.2.2.3') DCADDBUTTON CAPTION Ar_Model[1] ; SIZE LEN(Ar_Model[1])+2 ; ACTION {||KonstCls(1), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Генерация конструкта текущего класса в модели: ')+Ar_Model[1] DCADDBUTTON CAPTION Ar_Model[2] ; SIZE LEN(Ar_Model[2])+1 ; ACTION {||KonstCls(2), DC_GetRefresh(GetList)}; PARENT oToolBar ; TOOLTIP L('Генерация конструкта текущего класса в модели: ')+Ar_Model[2] DCADDBUTTON CAPTION Ar_Model[3] ; SIZE LEN(Ar_Model[3])+1 ; ACTION {||KonstCls(3), DC_GetRefresh(GetList)}; PARENT oToolBar ; TOOLTIP L('Генерация конструкта текущего класса в модели: ')+Ar_Model[3] DCADDBUTTON CAPTION Ar_Model[4] ; SIZE LEN(Ar_Model[4])+1 ; ACTION {||KonstCls(4), DC_GetRefresh(GetList)}; PARENT oToolBar ; TOOLTIP L('Генерация конструкта текущего класса в модели: ')+Ar_Model[4] DCADDBUTTON CAPTION Ar_Model[5] ; SIZE LEN(Ar_Model[5])+1 ; ACTION {||KonstCls(5), DC_GetRefresh(GetList)}; PARENT oToolBar ; TOOLTIP L('Генерация конструкта текущего класса в модели: ')+Ar_Model[5] DCADDBUTTON CAPTION Ar_Model[6] ; SIZE LEN(Ar_Model[6])+1 ; ACTION {||KonstCls(6), DC_GetRefresh(GetList)}; PARENT oToolBar ; TOOLTIP L('Генерация конструкта текущего класса в модели: ')+Ar_Model[6] DCADDBUTTON CAPTION Ar_Model[7] ; SIZE LEN(Ar_Model[7])+1 ; ACTION {||KonstCls(7), DC_GetRefresh(GetList)}; PARENT oToolBar ; TOOLTIP L('Генерация конструкта текущего класса в модели: ')+Ar_Model[7] DCADDBUTTON CAPTION Ar_Model[8] ; SIZE LEN(Ar_Model[8])+1 ; ACTION {||KonstCls(8), DC_GetRefresh(GetList)}; PARENT oToolBar ; TOOLTIP L('Генерация конструкта текущего класса в модели: ')+Ar_Model[8] DCADDBUTTON CAPTION Ar_Model[9] ; SIZE LEN(Ar_Model[9])+1 ; ACTION {||KonstCls(9), DC_GetRefresh(GetList)}; PARENT oToolBar ; TOOLTIP L('Генерация конструкта текущего класса в модели: ')+Ar_Model[9] DCADDBUTTON CAPTION Ar_Model[10] ; SIZE LEN(Ar_Model[10])+1 ; ACTION {||KonstCls(10), DC_GetRefresh(GetList)}; PARENT oToolBar ; TOOLTIP L('Генерация конструкта текущего класса в модели: ')+Ar_Model[10] DCADDBUTTON CAPTION L('График') FONT '9.Arial Bold' ; SIZE LEN(L("График"))+3 ; ACTION {||SemNetCls("AUTO"), DC_GetRefresh(GetList)} ; PARENT oToolBar COLOR aColor[189] ; TOOLTIP L('Вывод 2d семантической сети классов') DCADDBUTTON CAPTION L('ВКЛ.фильтр по кл.шкале') ; SIZE LEN(L("ВКЛ.фильтр по кл.шкале"))-2 ; ACTION {||FltrOn4222(KonstCls->Kod_ClSc), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Включить фильтр по фактору') DCADDBUTTON CAPTION L('ВЫКЛ.фильтр по кл.шкале') ; SIZE LEN(L("ВЫКЛ.фильтр по кл.шкале"))-2 ; ACTION {||FltrOff4222(KonstCls->Kod_ClSc), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Выключить фильтр по кл.шкале') DCADDBUTTON CAPTION L('Параметры') FONT '9.Arial Bold'; SIZE LEN(L("Параметры"))+3 ; ACTION {||WindOn4222(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Параметры диаграммы') DCADDBUTTON CAPTION L('Показать ВСЕ') ; SIZE LEN(L("Показать ВСЕ")) ; ACTION {||WindOff4222(), DC_GetRefresh(GetList)}; PARENT oToolBar ; TOOLTIP L('Показать все записи конструкта в окне') @ 0,0 DCSAY {|| MessIPC } OBJECT oSay1 SAYSIZE 133 FONT "9.HelvBold" // Наименование инф.портрета /* ----- Create browse Classes ----- */ @ 1, 0 DCBROWSE oBrowse ALIAS 'Classes' SIZE 48.8,27 ; PRESENTATION LC_BrowPres() // Только просмотр БД DCBROWSECOL FIELD Classes->Kod_cls HEADER L("Код" ) PARENT oBrowse WIDTH 5 DCBROWSECOL FIELD Classes->Name_cls HEADER L("Наименование класса") PARENT oBrowse WIDTH 23 DCBROWSECOL FIELD Classes->Int_inf HEADER L("Редукция класса" ) PARENT oBrowse WIDTH 3 DCBROWSECOL FIELD Classes->Abs HEADER L("N объектов (абс.)" ) PARENT oBrowse WIDTH 3 DCBROWSECOL FIELD Classes->Perc_fiz HEADER L("N объектов (%)" ) PARENT oBrowse WIDTH 3 /* ----- Create browse (M_KlastCls) ----- */ PRIVATE bColorBlockZn:={|| iif(KonstCls->Sxodstvo>0,{GRA_CLR_RED,nil},iif(KonstCls->Sxodstvo=0,{GRA_CLR_BLACK,nil},{GRA_CLR_BLUE,nil})) } // Клиффорд @ 1,51 DCBROWSE oBrowIpc ALIAS 'KonstCls' SIZE 82,27 ; PRESENTATION LC_BrowPres() // Только просмотр БД DCSETPARENT oBrowIpc DCBROWSECOL FIELD KonstCls->Num_pp HEADER L('№' ) WIDTH 5 DCBROWSECOL FIELD KonstCls->Kod_cls HEADER L('Код класса' ) WIDTH 5 DCBROWSECOL FIELD KonstCls->Name_cls HEADER L('Наименование класса') WIDTH 31 DCBROWSECOL DATA {|x|x:=KonstCls->Sxodstvo,IIF(Empty(x),'',Str(x,8,3))} HEADER L("Сходство") FONT "9.Courier" COLOR bColorBlockZn DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; OPTIONS GetOptions ; MODAL ; TITLE L('4.2.2.2. Результаты кластерно-конструктивного анализа классов') ; // Надпись на окне графика FIT ; CLEAREVENTS ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) ReTURN nil *********************************************************************************************************************** **************************************************************** ******** Вписать конструкт класса в окно, задать разрешение окна **************************************************************** FUNCTION WindOn4222() IF FILE("_WindOn4222.arx") aWindOn4222 = DC_ARestore("_WindOn4222.arx") mNCls = aWindOn4222[1] // Число отображаемых классов mMinSx = aWindOn4222[2] // MIN модуль уровня сходства отображаемых классов mVar = aWindOn4222[3] // mVar=1: Классы с MAX и MIN уровнями сходства, mVar=2: Классы с MAX по модулю уровнем сходства mXSize = aWindOn4222[4] // Разрешение по X mYSize = aWindOn4222[5] // Разрешение по Y ELSE mNCls = 12 mMinSx = 0 mVar = 1 mXSize = 1800 // Разрешение по X mYSize = 900 // Разрешение по Y PRIVATE aWindOn4222[5] aWindOn4222[1] = mNCls // Число отображаемых классов aWindOn4222[2] = mMinSx // MIN модуль уровня сходства отображаемых классов aWindOn4222[3] = mVar // mVar=1: Классы с MAX и MIN уровнями сходства, mVar=2: Классы с MAX по модулю уровнем сходства aWindOn4222[4] = mXSize // Разрешение по X aWindOn4222[5] = mYSize // Разрешение по Y ENDIF * aWindOn4222 = DC_ARestore("_WindOn4222.arx") DC_ASave(aWindOn4222, "_WindOn4222.arx") @ 1, 1 DCGROUP oGroup1 CAPTION L('Задание параметров отображения классов:') SIZE 60.0, 11.0 @ 1, 2 DCSAY L("Задайте число отображаемых классов:") PARENT oGroup1 @ 1,50 DCGET mNCls PICTURE "####" PARENT oGroup1 @ 2, 2 DCSAY L("Задайте MIN модуль уровня сходства отображаемых классов:") PARENT oGroup1 @ 2,50 DCGET mMinSx PICTURE "####" PARENT oGroup1 @ 3, 2 DCGROUP oGroup2 CAPTION L('Задайте способ выбора классов для отображения:') SIZE 56.0, 3.5 PARENT oGroup1 @ 1, 2 DCRADIO mVar VALUE 1 PROMPT L('Классы с MAX и MIN уровнями сходства') PARENT oGroup2 @ 2, 2 DCRADIO mVar VALUE 2 PROMPT L('Классы с MAX по модулю уровнем сходства') PARENT oGroup2 @ 7, 2 DCGROUP oGroup3 CAPTION L('Задайте размер изображения в пикселях (не более 4K):') SIZE 56.0, 3.5 PARENT oGroup1 @ 1, 2 DCSAY L("Размер по X:") PARENT oGroup3;@ 1,15 DCGET mXSize PICTURE "####" PARENT oGroup3 @ 2, 2 DCSAY L("Размер по Y:") PARENT oGroup3;@ 2,15 DCGET mYSize PICTURE "####" PARENT oGroup3 DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; ADDBUTTONS; OPTIONS GetOptions ; MODAL ; TITLE L('4.2.2.2. Задание классов для отображения') ******************************************************************** IF lExit ** Button Ok ELSE RETURN NIL ENDIF ******************************************************************** *** Записать заданные параметры в виде файла, чтобы можно было загрузить их и отобразить в диаграмме mXSize = IF(mXSize< 100,1800,mXSize ) mXSize = IF(mXSize>4096,4096,mXSize ) mYSize = IF(mYSize< 100, 900,mYSize ) mYSize = IF(mYSize>4096,4096,mYSize ) aWindOn4222[1] = mNCls // Число отображаемых классов aWindOn4222[2] = mMinSx // MIN модуль уровня сходства отображаемых классов aWindOn4222[3] = mVar // mVar=1: Классы с MAX и MIN уровнями сходства, mVar=2: Классы с MAX по модулю уровнем сходства aWindOn4222[4] = mXSize // Разрешение по X aWindOn4222[5] = mYSize // Разрешение по Y * aWindOn4222 = DC_ARestore("_WindOn4222.arx") DC_ASave(aWindOn4222, "_WindOn4222.arx") SELECT KonstCls N_Rec = RECCOUNT() * mNCls = N_Rec - N_Del // 23 - число строк, которое помещается в окне N_Del = N_Rec - mNCls * IF N_Del <= 0 * LB_Warning(L('Заданы условия, при которых не будет отображено ни одного класса !'),L('4.2.2.2. Результаты кластерно-конструктивного анализа классов')) // Удалять ничего не надо. Выйти * ReTURN NIL * ENDIF // Ничего не показывать SET ORDER TO SET FILTER TO DBGOTOP() DO WHILE .NOT. EOF() REPLACE Fltr_wind WITH " " DBSKIP(1) ENDDO IF mVar = 1 // Классы с MAX и MIN уровнями сходства // Показывать mNCls наиболее значимых записей SELECT KonstCls FOR j=1 TO ROUND(mNCls/2,0) DBGOTO(j) REPLACE Fltr_wind WITH "#" NEXT FOR j=1 TO ROUND(mNCls/2,0)+IF(mNCls=2*INT(mNCls/2), 0, -1) // Поправка на нечетность числа классов DBGOTO(N_Rec-j+1) REPLACE Fltr_wind WITH "#" NEXT ENDIF IF mVar = 2 // Классы с MAX по модулю уровнем сходства // Не показывать N_Del наименее значимых записей, так, чтобы заполнить окно SELECT KonstCls INDEX ON STR(99999999.9999999-ABS(Sxodstvo), 19, 7) TO Temp N = 0 DBGOTOP() DO WHILE .NOT. EOF() .AND. (N+1) <= mNCls REPLACE Fltr_wind WITH "#" ++N DBSKIP(1) ENDDO ENDIF IF mMinSx > 0 // MIN модуль уровня сходства отображаемых классов // Не показывать наименее значимые записи SELECT KonstCls SET ORDER TO DBGOTOP() DO WHILE .NOT. EOF() IF ABS(Sxodstvo) < mMinSx // <===#################### REPLACE Fltr_wind WITH " " ENDIF DBSKIP(1) ENDDO ENDIF SET ORDER TO SET FILTER TO Fltr_wind = "#" DBGOTOP() ReTURN NIL ********************************************************************************************************************* ********************************************************************************************************************* ******** Формирование БД для отображения заданного конструкта FUNCTION KonstCls(mNumMod) DC_ASave(mNumMod, "_NumMod.arx") * mNumMod = DC_ARestore("_NumMod.arx") SELECT Classes M_Recno = RECNO() M_KodCls = Kod_cls M_NameCls = Name_cls PUBLIC MessIPC := L('Конструкт класса: ')+ALLTRIM(STR(M_KodCls, 15))+' "'+DelZeroNameGr(M_NameCls)+L('" в модели: ')+ALLTRIM(STR(mNumMod, 15))+' "'+UPPER(Ar_Model[mNumMod]+'"') *LB_Warning(MessIPC) DC_GetRefresh(oSay1) // Наименование информационного портрета ***** Подготовить БД для визуализации конструктов KonstCls.dbf M_SxodCls = "SxodCls" +Ar_Model[mNumMod] M_KlastCls = "KlastCls"+Ar_Model[mNumMod] IF .NOT. FILE(M_SxodCls+'.dbf') LB_Warning(L("Предварительно в режиме 4.2.2.1 нужно посчитать матрицу сходства в модели:")+' '+Ar_Model[mNumMod]) Running(.F.) RETURN NIL ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE KonstCls EXCLUSIVE NEW;ZAP USE (M_SxodCls) EXCLUSIVE NEW // Для рисования 2d семантической сети классов USE (M_KlastCls) EXCLUSIVE NEW SELECT (M_KlastCls) SET ORDER TO SET FILTER TO Num_Klast = M_KodCls COUNT TO N_Rec DBGOTOP();DBGOBOTTOM();DBGOTOP() ***************************** nMax = N_Rec + LEN(Ar_Model) Mess = L('Подготовка БД для визуализации конструкта текущего класса') @ 4,5 DCPROGRESS oProgr SIZE 80,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 DCREAD GUI TITLE Mess PARENT @oDial FIT EXIT oDial:show() nTime = 0 DC_GetProgress(oProgr,0,nMax) ***************************** DO WHILE .NOT. EOF() Ar := {} FOR j=1 TO FCOUNT() AADD(Ar, FIELDGET(j)) NEXT SELECT KonstCls APPEND BLANK FOR j=1 TO LEN(Ar) FIELDPUT(j, Ar[j]) NEXT DC_GetProgress(oProgr, ++nTime, nMax) SELECT (M_KlastCls) DBSKIP(1) ENDDO ***** Открытие необходимых для работы БД CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW USE KonstCls EXCLUSIVE NEW FOR m=1 TO LEN(Ar_Model) // Цикл по заданным моделям IF aClustParCls[m] M_KlastCls = "KlastCls"+Ar_Model[m] USE (M_KlastCls) EXCLUSIVE NEW ENDIF DC_GetProgress(oProgr, ++nTime, nMax) NEXT *MsgBox('STOP') DC_GetProgress(oProgr,nMax,nMax) oDial:Destroy() SELECT KonstCls DBGOTOP() SELECT Classes *SET FILTER TO Abs+Int_inf > 0 // Из-за этого не показывает DBGOTO(M_Recno) ReTURN NIL ************************************************************************************************** ******** Помощь для режимов 4.2.2.1 - 4.2.2.4 ************************************************************************************************** FUNCTION Help422() aHelp := {} AADD(aHelp, L('Данный режим готовит базы данных для режимов 4.2.2.2, 4.2.2.3, 4.3.2.2, 4.3.2.3, Он имеет две ')) AADD(aHelp, L('программных реализации: старую - на языке xBase++ и новую, - на Питоне. Новая работает гораздо')) AADD(aHelp, L('быстрее, что особенно существенно при больших размерностях моделей. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Кластерно-конструктивный анализ - это математический метод анализа данных, обеспечивающий: ')) AADD(aHelp, L('- выявление классов, наиболее сходных по системе их детерминации и объединение их в кластеры; ')) AADD(aHelp, L('- выявление кластеров классов, наиболее сильно отличающиеся друг от друга по системе их ')) AADD(aHelp, L('детерминации и построение из них полюсов конструктов классов, при этом остальные классы ')) AADD(aHelp, L('включаются в конструкты в качестве промежуточных между полюсами; ')) AADD(aHelp, L('- выявление факторов, наиболее сходных по детерминируемым ими классам и объединение их в кластеры')) AADD(aHelp, L('- выявление кластеров факторов, наиболее сильно отличающиеся по детерминируемым ими классам ')) AADD(aHelp, L('и построение из них полюсов конструктов факторов, при этом остальные факторы включаются ')) AADD(aHelp, L('в конструкты в качестве промежуточных между полюсами. ')) AADD(aHelp, L('Состояния объекта управления, соответствующие классам, включенным в один кластер, могут быть ')) AADD(aHelp, L('достигнуты одновременно, т.е. являются совместимыми (коалиционными) по обуславливающим их ')) AADD(aHelp, L('факторам, т.е. системе их детерминации. ')) AADD(aHelp, L('Состояния объекта управления, соответствующие классам, образующим полюса конструкта, не могут ')) AADD(aHelp, L('быть достигнуты одновременно, т.е. являются противоположными по детерминирующим их факторам ')) AADD(aHelp, L('(антагонистическими ии альтернативными). ')) AADD(aHelp, L('Конструкт классов представляет собой систему противоположных, т.е. наиболее непохожих друг на ')) AADD(aHelp, L('друга классов (которые называются полюсами конструкта) и спектр промежуточных классов, ')) AADD(aHelp, L('распределенных между полюсами в соответствии со своим сходством-различием с полюсами. ')) AADD(aHelp, L('Конструкт признаков (значений факторов) представляет собой систему противоположных, т.е. ')) AADD(aHelp, L('наиболее непохожих друг на друга признаков (которые называются полюсами конструкта) и спектр ')) AADD(aHelp, L('промежуточных признаков, распределенных между полюсами в соответствии со своим сходством- ')) AADD(aHelp, L('различием с полюсами. ')) AADD(aHelp, L('Значения факторов, включенные в один кластер, оказывают сходное влияние на поведение объекта ')) AADD(aHelp, L('управления и могут, при необходимости, быть использованы для замены друг друга. Значения ')) AADD(aHelp, L('факторов, образующие полюса конструкта, оказывают противоположное влияние на поведение объекта')) AADD(aHelp, L('управления. ')) AADD(aHelp, L('Кластерно-конструктивный анализ классов позволяет сравнить их по сходству системы детерминации')) AADD(aHelp, L('и отобразить эту информацию в наглядной графической форме круговых когнитивных диаграмм классов')) AADD(aHelp, L('(2d семантической сети) дендрограмм агломеративной кластеризации классов. ')) AADD(aHelp, L('Кластерно-конструктивный анализ значения факторов позволяет сравнить их по сходству-различию ')) AADD(aHelp, L('их влияния на переход объекта в будущие состояния, соотвествующие классам, и отобразить эту ')) AADD(aHelp, L('информацию в наглядной графической форме когнитивных диаграмм и агломеративных дендрограмм. ')) mHelpMax = -999;FOR h=1 TO LEN(aHelp);mHelpMax = MAX(mHelpMax, LEN(ALLTRIM(aHelp[h])));NEXT s=1;d=0.9;@0,0 DCGROUP oGroup1 CAPTION L(' ') SIZE mHelpMax-13, LEN(aHelp)*d+1.5 FOR h=1 TO LEN(aHelp);@s,2 DCSAY aHelp[h] SIZE 0 PARENT ogroup1;s=s+d;NEXT DCREAD GUI TO lExit FIT TITLE L('Помощь по режиму: 4.2.2. (C) Система "ЭЙДОС-X++"') RETURN NIL ************************************************************************************************** ******** Включить фильтр конструкта класса по классификационной шкале FUNCTION FltrOn4222(mKodClSc) SELECT KonstCls SET ORDER TO SET FILTER TO Kod_ClSc = mKodClSc ReTURN NIL ******** Выключить фильтр конструкта класса по классификационной шкале FUNCTION FltrOff4222(mKodClSc) SELECT KonstCls SET ORDER TO SET FILTER TO ReTURN NIL ******** Показать все записи конструкта FUNCTION WindOff4222() SELECT KonstCls SET ORDER TO SET FILTER TO DBGOTOP() ReTURN NIL **************************************************************************************** ******** Вывод 2d семантических сетей классов (режим 5.1.2.5 DOS-версии) ######## **************************************************************************************** FUNCTION SemNetCls(mParam) LOCAL GetList := {}, oStatic LOCAL oPS, oDevice PRIVATE aAttr // Массив атрибутов отображаемых линий PRIVATE nEvent, mp1, mp2, oXbp // Переменные анализа событий mNumMod = DC_ARestore("_NumMod.arx") * DC_ASave(mNumMod, "_NumMod.arx") M_Recno = RECNO() // Позиция отображения конструкта SELECT KonstCls COUNT TO N_Cls // Кол-во признаков в конструкте с учетом фильтра ****** Присвоить значения отображаемым массивам aKodCls := {} // Массив кодов классов aNameCls := {} // Массив наименований классов aSxodCls := {} // Массив уровней сходства классов конструкта с классом на положительном полюсе конструкта DBGOTOP() DO WHILE .NOT. EOF() AADD(aKodCls , Kod_cls) AADD(aNameCls, DelZeroNameGr(Name_cls)) AADD(aSxodCls, Sxodstvo) DBSKIP(1) ENDDO M_NameAppl = DC_ARestore("_NameAppl.arx") * PUBLIC X_MaxW := 1280, Y_MaxW := 850 // Размер графического окна в пикселях * @ 2,1 DCSTATIC TYPE XBPSTATIC_TYPE_RECESSEDBOX SIZE X_MaxW, Y_MaxW PIXEL; // Размер окна для отображения графика в пикселях (от Тома) * OBJECT oStatic; * EVAL {|| _PresSpace4222(oStatic, aKodCls, aNameCls, aSxodCls, mNumMod) } * DCREAD GUI ; * TITLE L('4.2.2.2. Результаты кластерно-конструктивного анализа классов. (C) Универсальная когнитивная аналитическая система "Эйдос-Х++"') ; // Надпись на окне графика * FIT; * MODAL IF FILE("_WindOn4222.arx") aWindOn4222 = DC_ARestore("_WindOn4222.arx") mNCls = aWindOn4222[1] // Число отображаемых классов mMinSx = aWindOn4222[2] // MIN модуль уровня сходства отображаемых классов mVar = aWindOn4222[3] // mVar=1: Классы с MAX и MIN уровнями сходства, mVar=2: Классы с MAX по модулю уровнем сходства mXSize = aWindOn4222[4] // Разрешение по X mYSize = aWindOn4222[5] // Разрешение по Y ELSE mNCls = 12 mMinSx = 0 mVar = 1 mXSize = 1800 // Разрешение по X mYSize = 900 // Разрешение по Y PRIVATE aWindOn4222[5] aWindOn4222[1] = mNCls // Число отображаемых классов aWindOn4222[2] = mMinSx // MIN модуль уровня сходства отображаемых классов aWindOn4222[3] = mVar // mVar=1: Классы с MAX и MIN уровнями сходства, mVar=2: Классы с MAX по модулю уровнем сходства aWindOn4222[4] = mXSize // Разрешение по X aWindOn4222[5] = mYSize // Разрешение по Y ENDIF * aWindOn4222 = DC_ARestore("_WindOn4222.arx") DC_ASave(aWindOn4222, "_WindOn4222.arx") PUBLIC X_MaxW := mXSize, Y_MaxW := mYSize // Размер графического окна для отображения когнитивных диаграмм в пикселях PUBLIC nXSize := mXSize PUBLIC nYSize := mYSize oScr := DC_WaitOn('Немного подождите! Идет формирование изображения в памяти и его масштабирование',,,,,,,,,,,.F.) // Create new bitmap with given size oPS := XBPPRESSPACE() :new() :Create() oBMP := XBPBITMAP() :New() :Create() * oBMP:Make( nXSize, nYSize, nPlanes, nBits ) oBMP:Make( nXSize, nYSize ) oBMP:presSpace( oPS ) // here your GRA* Code **** Закрасить фон прямоугольника *************** * GraSetColor( oPS, GRA_CLR_WHITE, GRA_CLR_WHITE ) GraSetColor( oPS, BD_LIGHTGREY, BD_LIGHTGREY ) GraBox( oPS, { 0, 0 }, { nXSize, nYSize }, GRA_FILL ) *######################################################################################################################### LC_SemNetCls( oPS, oBMP, aKodCls, aNameCls, aSxodCls ) // Графическая функция <<<===######################### *######################################################################################################################### *My image original, my image scaled ****** Запись полноразмерного графического файла в папку: M_PathAppl+"\SemNetCls2d\" DC_Impl(oScr) IF FILEDATE("SemNetCls2d",16) = CTOD("//") DIRMAKE("SemNetCls2d") aMess := {} AADD(aMess, L('В папке текущего приложения: "'+UPPER(ALLTRIM(M_PathAppl))+'"')) AADD(aMess, L('не было директории "SemNetCls2d" для когнитивных диаграмм классов и она была создана!')) AADD(aMess, L('В эту папку записываются исходные изображения высокого качества (без масштабирования)')) LB_Warning(aMess, L('4.2.2.2. Результаты кластерно-конструктивного анализа классов' )) ENDIF DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения * DC_ASave(mNumMod , "_NumMod.arx") mNumMod = DC_ARestore("_NumMod.arx") DIRCHANGE(M_PathAppl+"\SemNetCls2d\") // Перейти в папку CognDiagrCls cFileName = "SemNetCls2d"+STRTRAN(STR(ADIR("*.*")+1,6)," ","0")+".jpg" ERASE(cFileName) oBMP:SaveFile(cFileName,XBPBMP_FORMAT_JPG) IF nWidth > 1800 * IF mPause = 1 FullView( cFileName, "по верху", 65 ) // Визуализация полноразмерного файла на мониторе высокого разрешения * ENDIF ELSE ****** Формирование с помощью bmp2bmp() и отображение масштабированного изображения aNewSize := {nWidth,nHeight-29} // Новый размер изображения (еще немного уменьшается, чтобы не рисовать по панели задач) oBMP:loadFile(cFileName) // Загрузка полноразмерного изображения oRet := BMP2BMP(oBMP,aNewSize) // Масштабирование изображения cFileNameScale = SUBSTR(cFileName,1,AT(".jpg",cFileName)-1)+"_scaled.jpg" ERASE(cFileNameScale) oRet:saveFile(cFileNameScale,XBPBMP_FORMAT_JPG) // Запись масштабированного графического файла в в папку приложения для визуализации * IF mPause = 1 FullView( cFileNameScale, "по верху", 0 ) // Визуализация масштабированного графического файла на мониторе ограниченного разрешения * ENDIF ENDIF DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения SELECT KonstCls DBGOTOP() SELECT Classes *SET FILTER TO Abs+Int_inf > 0 DBGOTO(M_Recno) RETURN NIL ************************************************* *FUNCTION _PresSpace4222( oStatic, aKodCls, aNameCls, aSxodCls, mNumMod ) * LOCAL oPS, oDevice * oPS := XbpPresSpace():new() // Create a PS * oDevice := oStatic:winDevice() // Get the device context * oPS:create( oDevice ) // Link device context to PS * oPS:SetViewPort( { 0, 0, X_MaxW, Y_MaxW } ) * oStatic:paint := {|mp1,mp2,obj| mp1 := LC_SemNetCls( oPS, oStatic, aKodCls, aNameCls, aSxodCls ) } *RETURN NIL ******************************************************* STATIC FUNCTION LC_SemNetCls( oPS, oStatic, aKodCls, aNameCls, aSxodCls, mNumMod ) DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения mNumMod = DC_ARestore("_NumMod.arx") * DC_ASave(mNumMod, "_NumMod.arx") * MsgBox(STR(mNumMod)) W_Wind = X_MaxW / 2 // Полуширина окна для самого графика H_Wind = Y_MaxW / 2 // Полувысота окна для самого графика LY := 70 // Зона над областью графика для наименования и под областью графика для легенды X0 := W_Wind // Начало координат для эллипса по оси X Y0 := H_Wind // Начало координат для эллипса по оси Y ***** Закрасить фон прямоугольника *************** ***** Закрасить фон прямоугольника *************** GraSetColor( oPS, aColor[98] , aColor[98] ) // Номер цвета в соответствии с _AidosColor.prg GraBox( oPS, { X0-W_Wind, Y0-H_Wind }, { X0+W_Wind, Y0+H_Wind }, GRA_FILL ) GraSetColor( oPS, aColor[222] , aColor[222] ) ***** Нарисовать рамку изображения и отделить место для легенды ******************* aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты ****** Начало координат в центре рисунка GraArc ( oPS, { X0, Y0 }, 2 ) // Начало координат GraLine( oPS, {X0-W_Wind+1, Y0-H_Wind+1}, {X0-W_Wind+1, Y0+H_Wind-1} ) // Нарисовать границу рамки изображения слева GraLine( oPS, {X0+W_Wind-1, Y0-H_Wind+1}, {X0+W_Wind-1, Y0+H_Wind-1} ) // Нарисовать границу рамки изображения справа GraLine( oPS, {X0-W_Wind+1, Y0-H_Wind+1}, {X0+W_Wind-1, Y0-H_Wind+1} ) // Нарисовать границу рамки изображения внизу параллельно оси X GraLine( oPS, {X0-W_Wind+1, Y0+H_Wind-1}, {X0+W_Wind-1, Y0+H_Wind-1} ) // Нарисовать границу рамки изображения вверху параллельно оси X GraLine( oPS, {X0-W_Wind+1, Y0-H_Wind+LY}, {X0+W_Wind-1, Y0-H_Wind+LY} ) // Нарисовать границу рамки легенды на уровне LY параллельно оси X ************************************************************************************************* **** Написать заголовок диаграммы oFont := XbpFont():new():create("22.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraStringAt( oPS, { X_MaxW/2, Y_MaxW-20 }, 'СЕМАНТИЧЕСКАЯ 2D СЕТЬ КЛАССОВ В МОДЕЛИ: "'+UPPER(Ar_Model[mNumMod])+'"' ) oFont := XbpFont():new():create("14.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) SELECT Classes M_KodCls = Kod_cls M_NameCls = Name_cls ***** Цикл определения такой длины строки, которая помещается в рамку ***** Массив отображаемых в рамке строк, включающий наименования и описательных шкал и их градаций ***** Из текстового буфера к отображаемому элементу массива добавляется по одному символу и определяется его длина в пикселях. ***** Если не хватает длины рамки - добавляется строка в массив. Отображение градации шкалы всегда начинается с новой строки. mZone = X_MaxW-600 // Ширина зоны отображения в пикселях с учетом полей слева и справа mMess := 'КОНСТРУКТ КЛАССА: ['+ALLTRIM(STR(M_KodCls, 15))+']-' // Массив отображаемых в рамке строк, включающий наименования и описательных шкал и их градаций mBuff = ALLTRIM(M_NameCls) // Максимальная длина наименования класса, помещающегося в прямоугольнике, равна 90 символов FOR i=1 TO LEN(mBuff) aTxtPar = DC_GraQueryTextbox(mMess + SUBSTR(mBuff,i,1), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox(mMess + SUBSTR(mBuff,i,1)+" "+STR(aTxtPar[1])) IF aTxtPar[1] <= mZone mMess = mMess + SUBSTR(mBuff,i,1) // Полное наименование описательной шкалы посылается в буфер для отображения ELSE mMess = mMess + '...' // Полное наименование описательной шкалы посылается в буфер для отображения EXIT ENDIF NEXT * GraStringAt( oPS, { X_MaxW/2, Y_MaxW-45 }, SUBSTR('- КОНСТРУКТ КЛАССА: '+ALLTRIM(STR(M_KodCls, 15))+' "'+ALLTRIM(M_NameCls)+'."',1,92) ) GraStringAt( oPS, { X_MaxW/2, Y_MaxW-45 }, mMess ) oFont := XbpFont():new():create("14.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) ***** Цикл определения такой длины строки, которая помещается в рамку ***** Массив отображаемых в рамке строк, включающий наименования и описательных шкал и их градаций ***** Из текстового буфера к отображаемому элементу массива добавляется по одному символу и определяется его длина в пикселях. ***** Если не хватает длины рамки - добавляется строка в массив. Отображение градации шкалы всегда начинается с новой строки. mZone = X_MaxW-600 // Ширина зоны отображения в пикселях с учетом полей слева и справа mMess := 'Приложение: ' // Массив отображаемых в рамке строк, включающий наименования и описательных шкал и их градаций M_NameAppl = DC_ARestore("_NameAppl.arx") mBuff = ALLTRIM(M_NameAppl) // Максимальная длина наименования класса, помещающегося в прямоугольнике, равна 90 символов FOR i=1 TO LEN(mBuff) aTxtPar = DC_GraQueryTextbox(mMess + SUBSTR(mBuff,i,1), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox(mMess + SUBSTR(mBuff,i,1)+" "+STR(aTxtPar[1])) IF aTxtPar[1] <= mZone mMess = mMess + SUBSTR(mBuff,i,1) // Полное наименование описательной шкалы посылается в буфер для отображения ELSE mMess = mMess + '...' // Полное наименование описательной шкалы посылается в буфер для отображения EXIT ENDIF NEXT * GraStringAt( oPS, { X_MaxW/2, Y_MaxW-65 }, SUBSTR("Приложение: "+'"'+ALLTRIM(M_NameAppl)+'."',1,110) ) GraStringAt( oPS, { X_MaxW/2, Y_MaxW-65 }, mMess ) ************************************************************************************************* ********* Начало рисования эллипса с кружочками классов и линиями связи: сходства-различия R0 = 30 // Радиус кружочков с кодами классов RS = 12 // Радиус кружочка для указания силы связи Xb := 2*R0*1.618 // Ширина прямоугольника Yb := 2*R0 // Высота прямоугольника R0X = W_Wind - 2 * LY - Xb - 10 // Радиус элипса по X кружочков (это правильно при любом разрешении) R0Y = H_Wind - 2 * LY - Xb - 10 // Радиус элипса по Y кружочков K0 = 360 / N_Cls // Количество градусов в секторе одного класса X := {} // Координаты X центров кружочков классов Y := {} // Координаты Y центров кружочков классов Faza = 0 - K0 // Угол поворота системы кружочков классов вокруг центра эллипса FOR j=1 TO N_Cls AADD(X, X0 - R0X * COS(DTOR(Faza+(j-1)*K0))) AADD(Y, Y0 - R0Y * SIN(DTOR(Faza+(j-1)*K0))) NEXT ****** Рисование кружочков классов и линий связи между ними (брать из матрицы сходства) ****** Рисование линий связи * SELECT KonstCls M_SxodCls = "SxodCls" +Ar_Model[mNumMod] USE (M_SxodCls) EXCLUSIVE NEW // Для рисования 2d семантической сети классов SELECT (M_SxodCls) ****** Атрибуты графического шрифта ****** Загрузить графический шрифт oFont := XbpFont():new():create("14.Arial") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_BOX ] := { RS*1.2, RS*1.2 } // Размер поля вывода aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) *** Полный перебор всех сочетаний классов конструкта D = 7 // Максимальная толщина отображаемых линий *** Поиск минимального и максимального значений толщины линии mSxodMin = +99999999999 mSxodMax = -99999999999 FOR i=1 TO LEN(aKodCls) // Цикл по классам конструкта DBGOTO(aKodCls[i]) FOR j=i+1 TO LEN(aKodCls) // Цикл по классам конструкта mSxodstvo = ABS(FIELDGET(3+aKodCls[j])) mSxodMin = MIN(mSxodMin, mSxodstvo) mSxodMax = MAX(mSxodMax, mSxodstvo) NEXT NEXT K = D / MAX(ABS(mSxodMax), ABS(mSxodMin)) // Масштабный коэффициент * MsgBox(STR(mSxodMax)+STR(mSxodMin)+STR(K)) FOR i=1 TO LEN(aKodCls) // Цикл по классам конструкта DBGOTO(aKodCls[i]) FOR j=i+1 TO LEN(aKodCls) // Цикл по классам конструкта mSxodstvo = FIELDGET(3+aKodCls[j]) ** Не рисовать линий с силой связи ниже заданного порога <<<############################################ IF aWindOn4222[2] < ABS(mSxodstvo) ******* Сделать цвет заливки и линии, а также толщину линии, зависящими от величины и знака сходства-различия aAttr := Array( GRA_AA_COUNT ) // атрибуты области aAttr [ GRA_AA_COLOR ] := IF(mSxodstvo > 0, BD_LIGHTYELLOW, BD_XBP_CYAN) aAttr [ GRA_AA_SYMBOL ] := GRA_SYM_DEFAULT graSetAttrArea( oPS, aAttr ) aAttr := Array( GRA_AL_COUNT ) // атрибуты линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := IF(mSxodstvo > 0, GRA_CLR_RED, GRA_CLR_BLUE) aAttr [ GRA_AL_WIDTH ] := ABS(mSxodstvo) * K // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraLine(oPS, { X[i], Y[i] }, { X[j], Y[j] } ) // Нарисовать линию заданных толщины и цвета ****** Сделать надписи уровней сходства на линиях связи aAttr := Array( GRA_AL_COUNT ) // атрибуты линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := IF(mSxodstvo > 0, GRA_CLR_RED, GRA_CLR_BLUE) aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraArc( oPS, { (X[i]+X[j])/2, (Y[i]+Y[j])/2 }, RS, ,,, GRA_OUTLINEFILL ) GraStringAt( oPS, { (X[i]+X[j])/2, (Y[i]+Y[j])/2 }, ALLTRIM(STR(mSxodstvo,15)) ) ENDIF NEXT NEXT CLOSE (M_SxodCls) ****** Рисование кружочков классов с надписями Xb0 := {} // Координата Xb0 точки пересечения диагоналей прямоугольников с наименованиями классов Yb0 := {} // Координата Yb0 точки пересечения диагоналей прямоугольников с наименованиями классов Xb1 := {} // Координаты X1 прямоугольников с наименованиями классов Yb1 := {} // Координаты Y1 прямоугольников с наименованиями классов Xb2 := {} // Координаты X2 прямоугольников с наименованиями классов Yb2 := {} // Координаты Y2 прямоугольников с наименованиями классов Xb := 2*R0*1.618 // Ширина прямоугольника Yb := 2*R0 // Высота прямоугольника FOR j=1 TO N_Cls AADD(Xb0, X0 - ( R0X + R0*3.2 ) * COS(DTOR(Faza+(j-1)*K0))) AADD(Yb0, Y0 - ( R0Y + R0*2.5 ) * SIN(DTOR(Faza+(j-1)*K0))) AADD(Xb1, Xb0[j] - Xb/2 ) AADD(Yb1, Yb0[j] - Yb/2 ) AADD(Xb2, Xb0[j] + Xb/2 ) AADD(Yb2, Yb0[j] + Yb/2 ) NEXT FOR j=1 TO N_Cls // Цикл по классам конструкта ****** Инициализация графического шрифта oFont := XbpFont():new():create("22.Arial Bold") * oFont := XbpFont():new():create("78.HelveticaBold") // Конкретный шрифт с указанием размера GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_BOX ] := { R0, R0 } // Размер поля вывода aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты ******* Сделать цвет заливки и линии, а также толщину линии, зависящими от величины и знака сходства-различия aAttr := Array( GRA_AA_COUNT ) // атрибуты области aAttr [ GRA_AA_COLOR ] := IF(aSxodCls[j] > 0, BD_LIGHTYELLOW, BD_XBP_CYAN) aAttr [ GRA_AA_SYMBOL ] := GRA_SYM_DEFAULT graSetAttrArea( oPS, aAttr ) aAttr := Array( GRA_AL_COUNT ) // атрибуты линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := IF(aSxodCls[j] > 0, GRA_CLR_RED, GRA_CLR_BLUE) aAttr [ GRA_AL_WIDTH ] := ABS(aSxodCls[j]) * 0.05 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraArc( oPS, { X[j], Y[j] }, R0, ,,, GRA_OUTLINEFILL ) GraStringAt( oPS, { X[j], Y[j] }, ALLTRIM(STR(aKodCls[j],15)) ) **** Сделать надписи наименований классов aAttr := Array( GRA_AA_COUNT ) // атрибуты области * aAttr [ GRA_AA_COLOR ] := IF(aSxodCls[j] > 0, BD_LIGHTYELLOW, BD_XBP_CYAN) aAttr [ GRA_AA_COLOR ] := BD_WHITE aAttr [ GRA_AA_SYMBOL] := GRA_SYM_DEFAULT graSetAttrArea( oPS, aAttr ) aAttr := Array( GRA_AL_COUNT ) // атрибуты линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := IF(aSxodCls[j] > 0, GRA_CLR_RED, GRA_CLR_BLUE) aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) graBox( oPS, { Xb1[j], Yb1[j] }, { Xb2[j], Yb2[j] }, GRA_OUTLINEFILL, 10, 10 ) // прямоугольник очерчен, заполнен и закруглен * GraArc( oPS, { Xb0[j], Yb0[j] }, 2, ,,, GRA_OUTLINEFILL ) GraArc( oPS, { Xb1[j], Yb1[j] }, 2, ,,, GRA_OUTLINEFILL ) GraArc( oPS, { Xb2[j], Yb2[j] }, 2, ,,, GRA_OUTLINEFILL ) ***** Наименование класса внутри прямоугольника NM = SUBSTR(ALLTRIM(aNameCls[j]),1, 90) // Максимальная длина наименования класса, помещающегося в прямоугольнике, равна 90 символов SL = 15 // Длина строки в прямоугольнике в символах SP = 10 // Межстрочный интервал в пикселях L = 1+INT(LEN(NM)/SL) // Число строк в прямоугольнике oFont := XbpFont():new():create("14.Arial") GraSetFont( oPS ,oFont ) aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_BOX ] := { SL, SP } // Размер поля вывода в пикселях aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_TOP // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) **** Здесь сделать цикл по подстрокам наименования класса * GraStringAt( oPS, { MIN(Xb1[j],Xb2[j])+3, MAX(Yb1[j],Yb2[j]-4) }, aNameCls[j] ) * aTxtPar = DC_GraQueryTextbox(aMess[s] + SUBSTR(mBuff1,j,1), oFont) // {101,16} Определяет длину и высоту текста в пикселях для НЕКОТОРЫХ шрифтов * D = LEN(NM) - L * SL // Число символов в последней строке * FOR s=1 TO L // Цикл по строкам * GraStringAt( oPS, { MIN(Xb1[j],Xb2[j])+3, MAX(Yb1[j],Yb2[j]-4-(s-1)*SP) }, SUBSTR(NM,1+(s-1)*SL,SL) ) * NEXT ***** Цикл определения такой длины строки, которая помещается в рамку ***** Массив отображаемых в рамке строк, включающий наименования и описательных шкал и их градаций ***** Из текстового буфера к отображаемому элементу массива добавляется по одному символу и определяется его длина в пикселях. ***** Если не хватает длины рамки - добавляется строка в массив. Отображение градации шкалы всегда начинается с новой строки. mZone = Xb-16 // Ширина зоны отображения в пикселях с учетом полей слева и справа aMess := {} // Массив отображаемых в рамке строк, включающий наименования и описательных шкал и их градаций AADD(aMess, L(" "));s=1 // 1-й элемент - 1-я строка mBuff = ALLTRIM(aNameCls[j]) // Максимальная длина наименования класса, помещающегося в прямоугольнике, равна 90 символов FOR i=1 TO LEN(mBuff) aTxtPar = DC_GraQueryTextbox(aMess[s] + SUBSTR(mBuff,i,1), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox(aMess[s] + SUBSTR(mBuff,i,1)+" "+STR(aTxtPar[1])) IF aTxtPar[1] <= mZone aMess[s] = aMess[s] + SUBSTR(mBuff,i,1) // Полное наименование описательной шкалы посылается в буфер для отображения ELSE IF s < 5 AADD(aMess, SUBSTR(mBuff,i,1)) s++ ELSE EXIT ENDIF ENDIF NEXT mInterval = SP // Межстрочный интервал в пикселях. 1 - строки пишутся без пропуска FOR s=1 TO LEN(aMess) GraStringAt( oPS, { MIN(Xb1[j],Xb2[j])+3, MAX(Yb1[j],Yb2[j]-4-(s-1)*mInterval) }, aMess[s] ) NEXT NEXT ****** Легенда ********************************* oFont := XbpFont():new():create("13.Arial Bold") GraSetFont( oPS ,oFont ) aAttr := ARRAY( GRA_AS_COUNT ) aAttr [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttr [ GRA_AS_BOX ] := { SL, SP*2.0 } // Размер поля вывода в пикселях aAttr [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttr [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttr ) // Установить символьные атрибуты AxName = "Сходство и различие между классами по их признакам (градациям факторов, системе детерминации):" GraStringAt( oPS, { 20, LY-15 }, AxName ) AxName = "СХОДСТВО классов отображается линиями связи КРАСНОГО цвета, толщина линии (приведенная в кружочке в центре линии) отражает степень сходства." GraStringAt( oPS, { 200, LY-35 }, AxName ) AxName = "РАЗЛИЧИЕ классов отображается линиями связи СИНЕГО цвета, толщина линии (приведенная в кружочке в центре линии) отражает степень различия." GraStringAt( oPS, { 200, LY-55 }, AxName ) IF FILE("_WindOn4222.arx") aWindOn4222 = DC_ARestore("_WindOn4222.arx") mNCls = aWindOn4222[1] // Число отображаемых классов mMinSx = aWindOn4222[2] // MIN модуль уровня сходства отображаемых классов mVar = aWindOn4222[3] // mVar=1: Классы с MAX и MIN уровнями сходства, mVar=2: Классы с MAX по модулю уровнем сходства mXSize = aWindOn4222[4] // Разрешение по X mYSize = aWindOn4222[5] // Разрешение по Y ELSE mNCls = 12 mMinSx = 0 mVar = 1 mXSize = 1800 // Разрешение по X mYSize = 900 // Разрешение по Y PRIVATE aWindOn4222[5] aWindOn4222[1] = mNCls // Число отображаемых классов aWindOn4222[2] = mMinSx // MIN модуль уровня сходства отображаемых классов aWindOn4222[3] = mVar // mVar=1: Классы с MAX и MIN уровнями сходства, mVar=2: Классы с MAX по модулю уровнем сходства aWindOn4222[4] = mXSize // Разрешение по X aWindOn4222[5] = mYSize // Разрешение по Y ENDIF * aWindOn4222 = DC_ARestore("_WindOn4222.arx") DC_ASave(aWindOn4222, "_WindOn4222.arx") aAttr [ GRA_AS_COLOR ] := GRA_CLR_DARKRED GraSetAttrString( oPS, aAttr ) // Установить символьные атрибуты D = 16 * P1 = 965 // Это при 1800, а при XRight = X0+W_Wind-1? * P2 = 1155 nXRight = X0+W_Wind-1 // Выравнивание начала надписей о параметрах по правому краю P1 = nXRight-320 P2 = nXRight-320+190 GraStringAt( oPS, { P1, LY+D*5 }, "Диапазон кодов классов:") ;GraStringAt( oPS, { P2, LY+D*5 }, ALLTRIM(STR(aClustParCls[11]))+"-"+ALLTRIM(STR(aClustParCls[12])) ) GraStringAt( oPS, { P1, LY+D*4 }, "Уровень сходства не менее:") ;GraStringAt( oPS, { P2, LY+D*4 }, ALLTRIM(STR(aWindOn4222[2]))+"%" ) GraStringAt( oPS, { P1, LY+D*3 }, "Число отображаемых классов:") ;GraStringAt( oPS, { P2, LY+D*3 }, ALLTRIM(STR(aWindOn4222[1])) ) GraStringAt( oPS, { P1, LY+D*2 }, "Способ выборки классов:") ;GraStringAt( oPS, { P2, LY+D*2 }, IF(aWindOn4222[3]=1,'MAX и MIN ур.сх.','|MAX| ур.сходства') ) GraStringAt( oPS, { P1, LY+D*1 }, "Дата и время создания формы:");GraStringAt( oPS, { P2, LY+D*1 }, DTOC(DATE())+"-"+TIME() ) **** Нарисовать сами линии **** mSxodstvo > 0 aAttr := Array( GRA_AL_COUNT ) // атрибуты линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := GRA_CLR_RED aAttr [ GRA_AL_WIDTH ] := 7 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraLine(oPS, { 23, LY-35 }, { 170, LY-35 } ) // Нарисовать линию заданных толщины и цвета **** mSxodstvo < 0 aAttr := Array( GRA_AL_COUNT ) // атрибуты линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := GRA_CLR_BLUE aAttr [ GRA_AL_WIDTH ] := 7 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraLine(oPS, { 23, LY-55 }, { 170, LY-55 } ) // Нарисовать линию заданных толщины и цвета DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения Running(.F.) RETURN NIL *********************************************************************************************************** ********** РЕЖИМЫ КЛАСТЕРНО-КОНСТРУКТИВНОГО АНАЛИЗА ПО ПРИЗНАКАМ ****************************************** *********************************************************************************************************** ************************************************************************************** ******** На количество признаков с ADS ограничений нет ************************************************************************************** FUNCTION F4_3_2_1(Vie) LOCAL oDial, nTime, oProgr LOCAL Getlist := {}, oProgress, oDialog, lOk := .t., oButton, nEvent, mp1, mp2, oXbp // XSample_14_Ok.prg Roger LOCAL aSay[30], Mess97, Mess98, Mess99 // Массив сообщений отображаемых стадий исполнения (до 30 на экране) Running(.T.) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN(.T.) ENDIF IF ApplChange("4.3.2.1()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF dbeSetDefault('DBFNTX') ** Ели файл параметров калстеризации существует, то просто загрузить его, ** иначе сформировать. В любом случае предоставить возможность корректировки параметров диалоге CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Attributes EXCLUSIVE NEW;N_Atr = RECCOUNT() IF FILE("_aClustParAtr.arx") aClustParAtr = DC_ARestore("_aClustParAtr.arx") * DC_ASave(aClustParAtr, "_aClustParAtr.arx") ELSE ******* Загрузить массив с информацией о созданых моделях, ******* выбрать из него модели, для которых можно расчитать матрицу сходства признаков ******* задать их в диалоге IF FILE("_VerifInf.arx") // Файл с информацией о том, какие модели были верифицированы ранее aVerifInf = DC_ARestore("_VerifInf.arx") ELSE LB_Warning(L("Необходимо предварительно провести рассчет моделей в 3-й подсистеме!")) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF *** Проводить кластеризацию во всех просчитанных моделях PRIVATE aClustParAtr[12] // Массив параметров кластеризации FOR j=1 TO LEN(aVerifInf) aClustParAtr[j] = aVerifInf[j] NEXT aClustParAtr[11] = 1 // Начальный признак диапазона кластеризации (mCls1) aClustParAtr[12] = N_Atr // Конечный признак диапазона кластеризации (mCls2) ENDIF * ********************************************************************************************************************** * // Диалог задания моделей расчета матриц сходства признаков * ********************************************************************************************************************** * @ 0,0 DCGROUP oGroup1 CAPTION L('Задайте модели, для которых проводить кластерно-конструктивный анализ:') SIZE 82,13.5 * @14,0 DCGROUP oGroup2 CAPTION L('' ) SIZE 82,2.5 * @ 1,1 DCSAY L('Статистические базы:') PARENT oGroup1 * @ 2,3 DCCHECKBOX aClustParAtr[ 1] PROMPT L('1. ABS - частный критерий: количество встреч сочетаний: "класс-признак" у объектов обуч.выборки') PARENT oGroup1 * @ 3,3 DCCHECKBOX aClustParAtr[ 2] PROMPT L('2. PRC1 - частный критерий: усл. вероятность i-го признака среди признаков объектов j-го класса ') PARENT oGroup1 * @ 4,3 DCCHECKBOX aClustParAtr[ 3] PROMPT L('3. PRC2 - частный критерий: условная вероятность i-го признака у объектов j-го класса ') PARENT oGroup1 * @ 5.2,1 DCSAY L('Системно-когнитивные модели (Базы знаний):' ) PARENT oGroup1 * @ 6,3 DCCHECKBOX aClustParAtr[ 4] PROMPT L('4. INF1 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC1 ') PARENT oGroup1 * @ 7,3 DCCHECKBOX aClustParAtr[ 5] PROMPT L('5. INF2 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC2 ') PARENT oGroup1 * @ 8,3 DCCHECKBOX aClustParAtr[ 6] PROMPT L('6. INF3 - частный критерий: Xи-квадрат, разности между фактическими и ожидаемыми абс.частотами ') PARENT oGroup1 * @ 9,3 DCCHECKBOX aClustParAtr[ 7] PROMPT L('7. INF4 - частный критерий: ROI (Return On Investment); вероятности из PRC1 ') PARENT oGroup1 * @10,3 DCCHECKBOX aClustParAtr[ 8] PROMPT L('8. INF5 - частный критерий: ROI (Return On Investment); вероятности из PRC2 ') PARENT oGroup1 * @11,3 DCCHECKBOX aClustParAtr[ 9] PROMPT L('9. INF6 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC1 ') PARENT oGroup1 * @12,3 DCCHECKBOX aClustParAtr[10] PROMPT L('10.INF7 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC2 ') PARENT oGroup1 * @ 1, 2.2 DCSAY L("Задайте диапазон кодов признаков (подматрицу) для анализа:") PARENT oGroup2 * @ 1, 50 DCSAY L(" ") GET aClustParAtr[11] PARENT oGroup2 PICTURE "###########" * @ 1, 65 DCSAY L(" ") GET aClustParAtr[12] PARENT oGroup2 PICTURE "###########" * @1,58 DCPUSHBUTTON ; * CAPTION L('Пояснение по режиму') ; * SIZE LEN(L('Пояснение по режиму'))+3, 0.9 ; * ACTION {||Help422()} * DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE * DCREAD GUI ; * TO lExit ; * FIT ; * OPTIONS GetOptions ; * ADDBUTTONS; * MODAL ; * TITLE L('4.3.2.1. Расчет матриц сходства, кластеров и конструктов') * IF lExit * ** Button Ok * ELSE * ************************************************************** * ***** БД, открытые перед запуском главного меню * ***** Восстанавливать их после выхода из функций главного меню * ************************************************************** * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы * USE PathGrAp EXCLUSIVE NEW * USE Appls EXCLUSIVE NEW * USE Users EXCLUSIVE NEW * ************************************************************** * Running(.F.) * RETURN(.F.) * ENDIF * ********************************************************************************************************************** ** Проверить корректность заданных параметров FlagErr = .F. IF aClustParAtr[11] < aClustParAtr[12] ELSE LB_Warning(L('Неверно задан диапазон кодов признаков для анализа: Kod1 должен быть меньше Kod2 !'), L('4.3.2.1. Расчет матриц сходства, кластеров и конструктов признаков')) FlagErr = .T. ENDIF IF aClustParAtr[11] < 1 aClustParAtr[11] = 1 ENDIF IF aClustParAtr[12] > N_Atr aClustParAtr[12] = N_Atr ENDIF **** Если для расчета матриц сходства заданы модели, которые не были рассчитаны, то выдать об этом сообщение и выйти Flag = .T. PRIVATE Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } Mess = L("Необходимо предварительно провести рассчет моделей:") FOR j=1 TO LEN(aVerifInf) IF aClustParAtr[j] = .T. Mess = Mess + IF(Flag," ",", ") + Ar_Model[j] Flag = .F. ENDIF NEXT IF Flag LB_Warning(Mess + ' ' + L("в 3-й подсистеме!"), L('4.3.2.1. Расчет матриц сходства, кластеров и конструктов признаков')) FlagErr = .T. ENDIF IF FlagErr ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN(.F.) ENDIF ********* Записать массив с информацией со ВСЕМИ параметрами кластеризации, заданными для рассчета * aClustParAtr = DC_ARestore("_aClustParAtr.arx") DC_ASave(aClustParAtr, "_aClustParAtr.arx") ********************************************************************************************************************** ********************************************************************************************************************** nRadio = 1 @ 0, 0 DCGROUP oGroup1 CAPTION L('Задайте режим:') SIZE 45.0, 5.0 @ 1, 2 DCRADIO nRadio VALUE 1 PROMPT L('1. Новый вариант (Питон)' ) PARENT oGroup1 @ 2, 2 DCRADIO nRadio VALUE 2 PROMPT L('2. Старый вариант (xBase++)' ) PARENT oGroup1 @ 3, 2 DCRADIO nRadio VALUE 3 PROMPT L('3. Пояснение по режиму' ) PARENT oGroup1 DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; ADDBUTTONS; OPTIONS GetOptions ; MODAL ; TITLE L('4.3.2.1. Расчет матриц сходства признаков') IF lExit ** Button Ok ELSE ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF *********************************************************************** DO CASE CASE nRadio=1 IF FILE('_4321Python.txt') ERASE('_4321Python.txt') ENDIF LC_RunShell("__AIDOS-PY.exe", 717400306, "_4321py") // Мой вариант на Питоне в системе __AIDOS-PY.exe DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения StrFile('', '_4321Python.txt') // Признак, что режим _4321 на Питоне завершился нормально ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL CASE nRadio=2 IF FILE('_4321xBase.txt') ERASE('_4321xBase.txt') ENDIF CASE nRadio=3 Help422() ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDCASE ***** Копирование txt => dbf баз данных заданных моделей ********************** mLenNameMax = CreateStructAll() // Создание файлов структур баз данных всех моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() // Количество классов (градаций классификационных шкал) USE Attributes EXCLUSIVE NEW;N_Atr = RECCOUNT() // Количество признаков (градаций описательных шкал) ***** Копирование основных БД всех моделей из txt в dbf формат с числом полей до 2035 IF N_Atr > 2035 LB_Warning(L("Будут показаны только первые 2035 колонок", 'aAtr2' )) ENDIF * ########################################################################### // Открытие текстовых баз данных ******************************************** *** Создание баз данных в dbf-формате с найденной максимальной длиной наименования шкалы + строки и столбцы, как в Inf# GenDbfAbsOld(mLenNameMax) GenDbfPrcOld(mLenNameMax) GenDbfInfOld(mLenNameMax) PRIVATE Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } IF .NOT. FILE("_InfStruct.arx") aMess := {} AADD(aMess, L("Необходимо предварительно провести рассчет моделей:")) AADD(aMess, L('"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7"')) AADD(aMess, L("в 3-й подсистеме, например в режиме 3.5 !")) LB_Warning(aMess, L('4.3.2.1. Расчет матрицы сходства признаков')) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN(.F.) ELSE * DC_ASave(aInfStruct, "_InfStruct.arx") // Когда БД создается - записывать структуру, когда открывается - считывать aInfStruct = DC_ARestore("_InfStruct.arx") ENDIF *DC_ASave(aStrEmpty, "_aStrEmpty.arx") // Записывать только после расчета Abs.txt, а при расчете остальных БД только считывать *DC_ASave(aColEmpty, "_aColEmpty.arx") aStrEmpty = DC_ARestore("_aStrEmpty.arx") aColEmpty = DC_ARestore("_aColEmpty.arx") ************************************************* ***** Формирование пустой записи N_Col = N_Cls+6 // Число полей CrLf = CHR(13)+CHR(10) // Конец строки (записи) Lc_buf = "" FOR j=1 TO N_Col * S = IF(j=2*INT(j/2),"#","X") // Для отладки S = " " // Для работы Lc_buf = Lc_buf + REPLICATE(S, aInfStruct[j,3]) NEXT Lc_buf = Lc_buf + CrLf PUBLIC Len_LcBuf := LEN(Lc_buf) ****** Создаем стат.базы и базы знаний (7 по частным критериям знаний) Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } PUBLIC nHandle[LEN(Ar_Model)] FOR z=1 TO LEN(Ar_Model) IF aClustParAtr[z] nHandle[z] := FOpen( Ar_Model[z]+".txt", FO_READWRITE ) // Открыть заданные текстовые базы данных ######################################## ENDIF NEXT **** Рассчет массива начальных позиций полей в строке PUBLIC aPos[N_Col] aPos[1] = 1 FOR j=2 TO N_Col aPos[j] = aPos[j-1] + aInfStruct[j-1,3] NEXT * ########################################################################### ***** Открытие основных БД.dbf всех моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() // Количество классов (градаций классификационных шкал) USE Attributes EXCLUSIVE NEW;N_Atr = RECCOUNT() // Количество признаков (градаций описательных шкал) SELECT Classes N_Model = 0 FOR z=1 TO LEN(Ar_Model) IF aClustParAtr[z] M_Inf = Ar_Model[z] USE (M_Inf) EXCLUSIVE NEW ++N_Model ENDIF NEXT ************************************************* * *****************************################################################ // Начало отсчета времени для прогнозирования длительности исполнения Time_progress = 0 // Прошло секунд с начала процесса // Процесс может идти больше суток, поэтому для определения // во всех случаях вычисляется время, прошедшее с начала года T_Mess1 = "Начало:"+" "+TIME() // Начало Sec_1 = (DOY(DATE())-1)*86400+SECONDS() PUBLIC T1 := (DOY(DATE())-1)*86400+SECONDS() // Время предыдущей индикации процесса исполнения PUBLIC T2 := (DOY(DATE())-1)*86400+SECONDS()+1 // Текущее время (1-й раз оно заметно больше T1 чтобы было отображение) PUBLIC T1tp := T1 PUBLIC T2tp := T2 mNModels = 0 // Количество моделей FOR z=1 TO LEN(Ar_Model) IF aClustParAtr[z] mNModels++ ENDIF NEXT Wsego = 0 Wsego = Wsego + mNModels*N_Atr // 1. Копирование БД.txt => БД.dbf. <<<===########################### Wsego = Wsego + mNModels*(N_Atr+(aClustParAtr[12]-aClustParAtr[11]+1)^2) // 2. РАСЧЕТ МАТРИЦ СХОДСТВА ПРИЗНАКОВ. <<<===########################### Wsego = Wsego + mNModels*((aClustParAtr[12]-aClustParAtr[11]+1)^2) // 3. РАСЧЕТ КЛАСТЕРОВ И КОНСТРУКТОВ ПРИЗНАКОВ. <<<===########################### Wsego = Wsego + mNModels*(N_Atr^2) // 4. Физическая сортировка и дорасчет БД кластеров и конструктов признаков во всех моделях <<<===########################### * *****************************################################################ // Отображение стадии исполнения. Будет написано прямо в окне Progress-bar d = 0 @0,0 DCGROUP oGroup1 CAPTION 'Стадии исполнения процесса' FONT "6.Helv" SIZE 105+d, 5.5 PARENT oTabPage1 @7,0 DCGROUP oGroup2 CAPTION 'Прогноз времени исполнения' FONT "6.Helv" SIZE 105+d, 5.0 PARENT oTabPage2 s = 1 @s++,1 DCSAY " " SAYSIZE 100 SAYOBJECT aSay[ 1] FONT "10.Helv" PARENT oGroup1 @s++,1 DCSAY " " SAYSIZE 100 SAYOBJECT aSay[ 2] FONT "10.Helv" PARENT oGroup1 @s++,1 DCSAY " " SAYSIZE 100 SAYOBJECT aSay[ 3] FONT "10.Helv" PARENT oGroup1 @s++,1 DCSAY " " SAYSIZE 100 SAYOBJECT aSay[ 4] FONT "10.Helv" PARENT oGroup1 s++ @s++,1 DCSAY " " SAYSIZE 100 SAYOBJECT oSay97 FONT "10.HelvBold" s++ @0.2+s++,1 DCSAY " " SAYSIZE 100 SAYOBJECT oSay98 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @1.5+s ,1 DCSAY " " SAYSIZE 100 SAYOBJECT oSay99 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @s ,1 DCPROGRESS oProgress ; SIZE 95,1.5 ; PERCENT ; EVERY 1; // Кол-во обновлений изображения MAXCOUNT Wsego; COLOR GRA_CLR_CYAN // Цвет полосы @s++,97 DCPUSHBUTTON CAPTION '&Cancel' ; ACTION {||lOk:=.T.} OBJECT oButton ; SIZE 7,1.5 DCREAD GUI ; TITLE L('4.3.2.1. Расчет матриц сходства, кластеров и конструктов признаков') ; PARENT @oDialog ; FIT ; EXIT ; MODAL oDialog:alwaysOnTop = .T. // Окно открывается на переднем плане oDialog:show() * *****************************################################################ *** Копирование БД.txt => БД.dbf ************** (но не более 2035 полей классов) mNCls = IF(N_Cls<=2035,N_Cls,2035) FOR z=1 TO LEN(Ar_Model) // 1. Копирование БД.txt => БД.dbf. Wsego = Wsego + mNModels*N_Atr <<<===########################### IF aClustParAtr[z] M_Inf = Ar_Model[z] aSay[ 1]:SetCaption(L('1. Копирование БД.txt => БД.dbf в модели: ')+ALLTRIM(STR(z))+'/10-'+M_Inf) SELECT(M_Inf) FOR i=1 TO N_Atr * IF aStrEmpty[i] DBGOTO(i) Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], i, 1 ));FIELDPUT(1, Fv) Fv = LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], i, 2 ) ;FIELDPUT(2, Fv) FOR j=1 TO mNCls * IF aColEmpty[j] Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], i, 2+j ));FIELDPUT(2+j, Fv) * ENDIF NEXT FOR j=1 TO 3 Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], i, mNCls+2+j ));FIELDPUT(mNCls+2+j, Fv) NEXT * ENDIF lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) NEXT FOR i=1 TO 4 DBGOTO(N_Atr+i) Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], N_Atr+i, 1 ));FIELDPUT(1, Fv) Fv = LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], N_Atr+i, 2 ) ;FIELDPUT(2, Fv) FOR j=1 TO mNCls * IF aColEmpty[j] Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], N_Atr+i, 2+j ));FIELDPUT(2+j, Fv) * ENDIF NEXT FOR j=1 TO 3 Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], N_Atr+i, mNCls+2+j ));FIELDPUT(mNCls+2+j, Fv) NEXT NEXT ENDIF NEXT ***** Закрытие основных БД.txt всех заданных моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций FOR z=1 TO LEN(nHandle) IF aClustParAtr[z] FClose( nHandle[z] ) // Закрытие txt баз данных ENDIF NEXT * ########################################################################### **************************************** *** РАСЧЕТ МАТРИЦ СХОДСТВА ПРИЗНАКОВ *** **************************************** ***** Создание матриц сходства признаков для заданных моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Attributes EXCLUSIVE NEW;N_Atr = RECCOUNT() // Количество признаков (градаций классификационных шкал) mLenNameMax = -9999 SELECT Attributes DBGOTOP() DO WHILE .NOT. EOF() mLenNameMax = MAX(mLenNameMax, LEN(ALLTRIM(Name_atr))) DBSKIP(1) ENDDO ********** Структура создаваемой базы *********** aStructure := { { "Kod_atr" , "N", 15, 0},; // 1 { "Kod_OpSc", "N", 15, 0},; // 2 { "Name_atr", "C",mLenNameMax, 0} } // 3 FOR j=1 TO N_Atr FieldName = "N"+ALLTRIM(STR(j,15)) AADD(aStructure, { FieldName, "N", 19, 7 }) NEXT FOR z=1 TO LEN(Ar_Model) IF aClustParAtr[z] cFileName = "SxodAtr"+Ar_Model[z] DbCreate( cFileName, aStructure ) ENDIF NEXT ***** Открытие основных БД.dbf всех заданных моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Attributes EXCLUSIVE NEW;N_Atr = RECCOUNT() // Количество признаков (градаций описательных шкал) Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } FOR m=1 TO LEN(Ar_Model) // 2. РАСЧЕТ МАТРИЦ СХОДСТВА ПРИЗНАКОВ. Wsego = Wsego + mNModels*(N_Atr+(aClustParAtr[12]-aClustParAtr[11]+1)^2) <<<===########################### IF aClustParAtr[m] M_Inf = Ar_Model[m] aSay[ 2]:SetCaption(L('2. Расчет матрицы сходства признаков в модели:')+' '+ALLTRIM(STR(m))+'/10-'+M_Inf) M_SxodAtr = "SxodAtr"+Ar_Model[m] USE (M_SxodAtr) EXCLUSIVE NEW USE (M_Inf) EXCLUSIVE NEW ****** Присвоение записям матрицы сходства кодов и наименований признаков SELECT Attributes DBGOTOP() DO WHILE .NOT. EOF() M_KodAtr = Kod_atr M_KodOpSc = Kod_OpSc M_NameAtr = Name_atr SELECT (M_SxodAtr) APPEND BLANK REPLACE Kod_atr WITH M_KodAtr REPLACE Kod_OpSc WITH M_KodOpSc REPLACE Name_atr WITH M_NameAtr FOR j=1 TO N_Atr FIELDPUT(3+j,0) NEXT lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) SELECT Attributes DBSKIP(1) ENDDO **** Расчет матрицы сходства (M_SxodAtr) **** Похоже как в пакетном распознавании PRIVATE aAtr1[N_Cls], aAtr2[N_Cls] Max = -9999999 Min = 9999999 SELECT (M_Inf) FOR mAtr1 = aClustParAtr[11] TO aClustParAtr[12] // Цикл по признакам подматрицы Inf.dbf заданного диапазона признаков ####### SELECT (M_Inf) DBGOTO(mAtr1) ************** Формирование массива 1-го признака FlagAtr1 = .F. AFILL(aAtr1,0) SumAtr1 = 0 // Сумма FOR j=1 TO N_Cls aAtr1[j] = FIELDGET(2+j) SumAtr1 = SumAtr1 + aAtr1[j] IF aAtr1[j] <> 0 FlagAtr1 = .T. // Флаг наличия данных ENDIF NEXT IF FlagAtr1 // Если есть данные по 1-му классу ИЗ-ЗА ТОГО, ЧТО ЕСТЬ ПРИЗНАКИ БЕЗ ДАННЫХ НЕ ПОЛУЧАЕТСЯ 100% <<<===############################### ***** Расчет среднего и дисперсии массива 1-го признака (из матрицы брать нельзя, т.к. будет большая погрешность расчетов) SrAtr1 = SumAtr1/N_Cls // Среднее массива 1-го признака DiAtr1 = 0 // Дисперсия массива 1-го признака FOR j=1 TO N_Cls DiAtr1 = DiAtr1 + ( aAtr1[j] - SrAtr1 ) ^ 2 NEXT DiAtr1 = SQRT( DiAtr1 / (N_Cls - 1)) // Дорасчет дисперсии массива 1-го признака ENDIF FOR mAtr2 = aClustParAtr[11] TO aClustParAtr[12] // Цикл по признакам подматрицы Inf.dbf заданного диапазона признаков ####### IF FlagAtr1 .AND. mAtr2 >= mAtr1 SELECT (M_Inf) DBGOTO(mAtr2) * msgBox(STR(N_Atr)+STR(N_Cls)+STR(mAtr1)+STR(mAtr2)) **************** Формирование массива 2-го признака FlagAtr2 = .F. AFILL(aAtr2,0) SumAtr2 = 0 // Сумма FOR j=1 TO N_Cls aAtr2[j] = FIELDGET(2+j) SumAtr2 = SumAtr2 + aAtr2[j] IF aAtr2[j] <> 0 FlagAtr2 = .T. // Флаг наличия данных ENDIF NEXT IF FlagAtr2 // Если есть данные по классу2-му ***** Расчет среднего и дисперсии массива 2-го признака SrAtr2 = SumAtr2/N_Cls // Среднее массива 2-го признака DiAtr2 = 0 // Дисперсия массива 2-го признака FOR j=1 TO N_Cls DiAtr2 = DiAtr2 + ( aAtr2[j] - SrAtr2 ) ^ 2 NEXT DiAtr2 = SQRT( DiAtr2 / (N_Cls - 1)) // Дорасчет дисперсии массива 2-го признака ******** Расчет нормированной к 100% корреляции массивов ******** локатора источника и информативностей признаков объекта Korr = 0 FOR j=1 TO N_Cls Korr = Korr + (aAtr1[j] - SrAtr1) * (aAtr2[j] - SrAtr2) NEXT Korr = Korr / ( (N_Cls-1) * DiAtr1 * DiAtr2 ) * 100 *** Вообще-то 1 вычитать не надо, в Help Excel приведена формула без вычитания 1, *** НО в Excel-2003 СЧИТАЕТСЯ ОНА ТАК, КАК БУДТО 1 ВСЕ ЖЕ ВЫЧИТАЕТСЯ (См.: "Кореляция" и "Ковариация") *** В Excel-2007 и выше все считается правильно, а в Excel-2003 просто неверно и формула корреляции приведена неправильная Max = MAX(Max,Korr) Min = MIN(Min,Korr) SELECT (M_SxodAtr) GO mAtr1;FIELDPUT(3+mAtr2,Korr) GO mAtr2;FIELDPUT(3+mAtr1,Korr) ENDIF ENDIF lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) NEXT NEXT ENDIF NEXT ************************************************ *** РАСЧЕТ КЛАСТЕРОВ И КОНСТРУКТОВ ПРИЗНАКОВ *** ************************************************ ***** Создание баз кластеров и конструктов признаков для разных моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Attributes EXCLUSIVE NEW;N_Atr = RECCOUNT() // Количество признаков (градаций описательных шкал) mLenNameMax = -9999 SELECT Attributes DBGOTOP() DO WHILE .NOT. EOF() mLenNameMax = MAX(mLenNameMax, LEN(ALLTRIM(Name_atr))) DBSKIP(1) ENDDO ********** Структура создаваемой базы *********** aStructure := { { "Model" , "C", 4, 0},; // 1 { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } { "Num_Klast", "N", 15, 0},; // 2 { "Num_pp" , "N", 15, 0},; // 3 { "Kod_atr" , "N", 15, 0},; // 4 { "Name_atr" , "C",mLenNameMax, 0},; // 5 { "Sxodstvo" , "N", 19, 7},; // 6 { "Fltr_wind", "C", 1, 0},; // 7 { "Kod_OpSc" , "N", 15, 0} } // 8 FOR z=1 TO LEN(Ar_Model) IF aClustParAtr[z] cFileName = "KlastAtr"+Ar_Model[z] DbCreate( cFileName, aStructure ) ENDIF NEXT DbCreate( 'KonstAtr.dbf' , aStructure ) DbCreate( 'KonstAtrAll.dbf', aStructure ) DbCreate( 'KonstAtrTmp.dbf', aStructure ) *********************** К Л А С Т Е Р И З А Ц И Я **************************** ***** Открытие основных БД.dbf всех заданных моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Attributes EXCLUSIVE NEW;N_Atr = RECCOUNT() // Количество признаков (градаций описательных шкал) USE KonstAtrAll EXCLUSIVE NEW // Одна общая БД для всех конструктов всех моделей USE KonstAtrTmp EXCLUSIVE NEW // Одна общая БД для всех конструктов всех моделей FOR m=1 TO LEN(Ar_Model) // Цикл по заданным моделям IF aClustParAtr[m] M_KlastAtr = "KlastAtr"+Ar_Model[m] USE (M_KlastAtr) EXCLUSIVE NEW ENDIF NEXT aAtrKod = {} // Массив кодов всех признаков SELECT Attributes DBGOTOP() DO WHILE .NOT. EOF() AADD(aAtrKod, ALLTRIM(STR(Kod_atr))) DBSKIP(1) ENDDO Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } FOR m=1 TO LEN(Ar_Model) // 3. РАСЧЕТ КЛАСТЕРОВ И КОНСТРУКТОВ ПРИЗНАКОВ. Wsego = Wsego + mNModels*((aClustParAtr[12]-aClustParAtr[11]+1)^2) <<<===########################### IF aClustParAtr[m] M_Inf = Ar_Model[m] aSay[ 3]:SetCaption(L('3. Расчет кластеров и конструктов признаков в модели:')+' '+ALLTRIM(STR(m))+'/10-'+M_Inf) M_SxodAtr = "SxodAtr"+Ar_Model[m] USE (M_SxodAtr) EXCLUSIVE NEW mNumKlast = 0 // Номер кластера FOR mAtr1 = aClustParAtr[11] TO aClustParAtr[12] // Цикл по признакам заданного диапазона SELECT (M_SxodAtr) mNumKlast++ FOR mAtr2 = aClustParAtr[11] TO aClustParAtr[12] // Цикл по признакам заданного диапазона SELECT (M_SxodAtr) DBGOTO(mAtr2) mSxodstvo = FIELDGET(3+mAtr1) * IF ABS(mSxodstvo) >= aClustParAtr[13] // Исключить середину конструкта mKodAtr = Kod_atr mKodOpSc = Kod_OpSc mNameAtr = Name_atr SELECT KonstAtrAll APPEND BLANK REPLACE Model WITH Ar_Model[m] // Модель REPLACE Num_Klast WITH mNumKlast // Номер кластера REPLACE Kod_atr WITH mKodAtr // Код признака REPLACE Kod_OpSc WITH mKodOpSc // Код классификационной шкалы REPLACE Name_atr WITH mNameAtr // Наименование признака REPLACE Sxodstvo WITH mSxodstvo // Сходство признака * ENDIF lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) NEXT NEXT ENDIF NEXT *** Физическая сортировка и дорасчет БД кластеров и конструктов ***************###################### aSay[ 4]:SetCaption(L('4. Физическая сортировка и дорасчет БД кластеров и конструктов классов в заданных моделях')) SELECT KonstAtrAll INDEX ON Model+STR(Num_Klast,15)+STR(99999.9999999-Sxodstvo,19,7) TO KonstAtrAll DBGOTOP() mNumKlast = Num_klast mNumPP = 0 DO WHILE .NOT. EOF() // 4. Физическая сортировка и дорасчет БД кластеров и конструктов признаков во всех моделях. Wsego = Wsego + mNModels*(N_Atr^2) <<<===########################### ** Нумерация записи IF mNumKlast = Num_klast REPLACE Num_pp WITH ++mNumPP ELSE mNumKlast = Num_klast mNumPP = 0 REPLACE Num_pp WITH ++mNumPP ENDIF ** Копирование записи в рассортированную БД KonstAtrTmp Ar := {} FOR j=1 TO FCOUNT() AADD(Ar, FIELDGET(j)) NEXT SELECT KonstAtrTmp APPEND BLANK FOR j=1 TO LEN(Ar) FIELDPUT(j, Ar[j]) NEXT ** Копирование записи в рассортированную БД (M_KlastAtr) M_KlastAtr = "KlastAtr"+ALLTRIM(Model) IF FILE(M_KlastAtr+'.dbf') // <<<===################# Если для расчета заданы не все модели, то некторые файлы могут быть не созданы SELECT (M_KlastAtr) APPEND BLANK FOR j=1 TO LEN(Ar) FIELDPUT(j, Ar[j]) NEXT ENDIF lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) SELECT KonstAtrAll DBSKIP(1) ENDDO ***** Копирование БД KonstAtrTmp => KonstAtrAll (Может быть использовать ADS_CopyFile()?) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций ERASE("KonstAtrAll.dbf") COPY FILE ("KonstAtrTmp.dbf") TO ("KonstAtrAll.dbf") ERASE("KonstAtrTmp.dbf") FOR m=1 TO LEN(Ar_Model) // 3. РАСЧЕТ КЛАСТЕРОВ И КОНСТРУКТОВ КЛАССОВ. Wsego = Wsego + mNModels*((aClustParCls[12]-aClustParCls[11]+1)^2) <<<===########################### IF aClustParAtr[m] Name_SS = "SxodAtr"+Ar_Model[m]+".dbf" Name_DD = "SxodAtr"+Ar_Model[m]+".xls" * LB_Warning(L("Источник: "+Name_SS+", приемник: "+Name_DD) COPY FILE (Name_SS) TO (Name_DD) ENDIF NEXT StrFile('', '_4321xBase.txt') // Признак, что режим _4321 на xBase++ завершился нормально oSay97:SetCaption(L("РАСЧЕТ МАТРИЦ СХОДСТВА, КЛАСТЕРОВ И КОНСТРУКТОВ ПРИЗНАКОВ ЗАВЕРШЕН УСПЕШНО !!!")) oSay97:SetCaption(oSay97:Caption) oButton:activate := {||PostAppEvent(xbeP_Close,,,oDialog)} //<<<<<< Add This oButton:SetCaption('&Ok') // Деструктурирование окна отображения графического Progress-bar DC_AppEvent( @lOk ) oDialog:Destroy() * aMess := {} * AADD(aMess, L('Расчет матриц сходства классов успешно завершен!')) * AADD(aMess, L(' ')) * AADD(aMess, L('Матрицы сходства классов содержатся в папке текущего приложения:')+' '+M_PathAppl+' '+L('в следующих таблицах MS Excel,')) * AADD(aMess, L('созданных на основе статистических и СК-моделей: "SxodClsAbs.xlsx", "SxodClsPrc1.xlsx", "SxodClsPrc2.xlsx", "SxodClsInf1.xlsx", ')) * AADD(aMess, L('"SxodClsInf2.xlsx", "SxodClsInf3.xlsx", "SxodClsInf4.xlsx", "SxodClsInf5.xlsx", "SxodClsInf6.xlsx", "SxodClsInf7.xlsx".')) * AADD(aMess, L(' ')) * AADD(aMess, L('Эти таблицы создаются в режиме 5.12. Они уже подготовлены для включения их в отчеты, но рекомендуется еще немного их отформатировать.')) * AADD(aMess, L(' ')) * AADD(aMess, L('Наименования колонок в матрице сходства классов являются наименованиями классов, которые есть в каждой строке. Поэтому можно взять ')) * AADD(aMess, L('их из строк и вставить с транспонированием в строку наименований колонок, придав им вертикальную ориентацию и выровняв их по центру. ')) * AADD(aMess, L('Сходство дано в процентах, поэтому можно задать формат ячеек без десятичных знаков и отображать отрицательные значения красным цветом.')) * AADD(aMess, L('Ширину колонок есть смысл минимизировать по реальным значениям данных, а также сделать сетку в таблице.')) * LB_Warning(aMess, L("Сообщение об успешном завершении операции" )) aMess := {} AADD(aMess, L('Расчет матриц сходства признаков успешно завершен!')) AADD(aMess, L(' ')) * AADD(aMess, L('Матрицы сходства классов содержатся в папке текущего приложения:')+' '+M_PathAppl+' '+L('в следующих таблицах MS Excel,')) AADD(aMess, L('созданных на основе статистических и СК-моделей: "SxodAtrAbs.xlsx", "SxodAtrPrc1.xlsx", "SxodAtrPrc2.xlsx", "SxodAtrInf1.xlsx", ')) AADD(aMess, L('"SxodAtrInf2.xlsx", "SxodAtrInf3.xlsx", "SxodAtrInf4.xlsx", "SxodAtrInf5.xlsx", "SxodAtrInf6.xlsx", "SxodAtrInf7.xlsx".')) AADD(aMess, L(' ')) * AADD(aMess, L('Эти таблицы создаются в режиме 5.12. Они уже подготовлены для включения их в отчеты, но рекомендуется еще немного их отформатировать.')) AADD(aMess, L(' ')) AADD(aMess, L('Наименования колонок в матрице сходства признаков являются наименованиями признаков, которые есть в каждой строке. Поэтому можно взять')) AADD(aMess, L('их из строк и вставить с транспонированием в строку наименований колонок, придав им вертикальную ориентацию и выровняв их по центру. ')) AADD(aMess, L('Сходство дано в процентах, поэтому можно задать формат ячеек без десятичных знаков и отображать отрицательные значения красным цветом.')) AADD(aMess, L('Ширину колонок есть смысл минимизировать по реальным значениям данных, а также сделать сетку в таблице.')) LB_Warning(aMess, L("Сообщение об успешном завершении операции" )) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL *********************************************************************************************************************** ******** 4.3.2.2. Результаты кластерно-конструктивного анализа признаков ################ *********************************************************************************************************************** FUNCTION F4_3_2_2() LOCAL GetList := {}, aPres, oBrowse, oToolBar, aColors, bColor, GetOptions Running(.T.) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF ApplChange("4.3.2.2()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF *********************************************************** ***** Проверка на наличие необходимых БД всех моделей ***** *********************************************************** IF .NOT. FILE("Attributes.dbf") // БД градаций класс.шкал: Attributes.dbf LB_Warning(L("Необходимо создать базу данных признаков !!!")) Running(.F.) RETURN NIL ENDIF **** Проверка, существуют ли файлы матриц сходства для моделей, заданных для проведения кластерно-конструктивного анализа * nRadio = 1 * @ 0, 0 DCGROUP oGroup1 CAPTION L('Задайте режим:') SIZE 45.0, 5.0 * @ 1, 2 DCRADIO nRadio VALUE 1 PROMPT L('1. Новый вариант (Питон)' ) PARENT oGroup1 * @ 2, 2 DCRADIO nRadio VALUE 2 PROMPT L('2. Старый вариант (xBase++)' ) PARENT oGroup1 * @ 3, 2 DCRADIO nRadio VALUE 3 PROMPT L('3. Пояснение по режиму' ) PARENT oGroup1 IF FILE('_4321xBase.txt') .OR. FILE('_4321Python.txt') ELSE LB_Warning(L("Предварительно необходимо выполнить режим 4.3.2.1 !!!"),L('4.3.2.2. Результаты кластерно-конструктивного анализа классов')) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ******* Загрузить массив aClustParAtr с информацией о созданных маьтрицах сходства признаков ******* и проверить, созданы ли базы данных сходства признаков, ******* выдать сообщение и выйти, если нет IF FILE("_aClustParAtr.arx") aClustParAtr = DC_ARestore("_aClustParAtr.arx") * DC_ASave(aClustParAtr, "_aClustParAtr.arx") ELSE LB_Warning(L("Предварительно необходимо выполнить расчеты в режиме 4.3.2.1 !!!"),L('4.3.2.2. Результаты кластерно-конструктивного анализа признаков')) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF **** Проверка, существуют ли файлы матриц сходства для моделей, заданных для проведения кластерно-конструктивного анализа PRIVATE Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } Mess = L("Предварительно необходимо выполнить расчет матрицы сходства моделях: ") Flag = .F. FOR j=1 TO LEN(Ar_Model) IF aClustParAtr[j] mName = "SxodAtr"+Ar_Model[j]+'.DBF' IF .NOT. FILE(mName) Mess = Mess + IF(Flag, ", ","") + Ar_Model[j] Flag = .T. ENDIF ENDIF NEXT IF Flag LB_Warning(Mess+L(' в режиме 4.3.2.1 !!!'),L('4.3.2.2. Результаты кластерно-конструктивного анализа признаков')) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF **** Проверка, существуют ли БД с результатами кластерно-конструктивного анализа PRIVATE Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } Mess = L("Необходимо предварительно провести кластерно-конструктивный анализ в моделях: ") Flag = .F. FOR j=1 TO LEN(Ar_Model) IF aClustParAtr[j] mName = "KlastAtr"+Ar_Model[j]+'.DBF' IF .NOT. FILE(mName) Mess = Mess + IF(Flag, ", ","") + Ar_Model[j] Flag = .T. ENDIF ENDIF NEXT IF Flag LB_Warning(Mess+L(' в режиме 4.3.2.1 !!!'),L('4.3.2.2. Результаты кластерно-конструктивного анализа признаков')) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ***** Подготовить БД для визуализации конструктов KonstAtr.dbf IF FILE("_WindOn4322.arx") aWindOn4322 = DC_ARestore("_WindOn4322.arx") mNAtr = aWindOn4322[1] // Число отображаемых признаков mMinSx = aWindOn4322[2] // MIN модуль уровня сходства отображаемых признаков mVar = aWindOn4322[3] // mVar=1: Признаки с MAX и MIN уровнями сходства, mVar=2: Классы с MAX по модулю уровнем сходства mXSize = aWindOn4322[4] // Разрешение по X mYSize = aWindOn4322[5] // Разрешение по Y ELSE mNAtr = 12 mMinSx = 0 mVar = 1 mXSize = 1800 // Разрешение по X mYSize = 900 // Разрешение по Y PRIVATE aWindOn4322[5] aWindOn4322[1] = mNAtr // Число отображаемых признаков aWindOn4322[2] = mMinSx // MIN модуль уровня сходства отображаемых признаков aWindOn4322[3] = mVar // mVar=1: Признаки с MAX и MIN уровнями сходства, mVar=2: Классы с MAX по модулю уровнем сходства aWindOn4322[4] = mXSize // Разрешение по X aWindOn4322[5] = mYSize // Разрешение по Y ENDIF * aWindOn4322 = DC_ARestore("_WindOn4322.arx") DC_ASave(aWindOn4322, "_WindOn4322.arx") ***** Открытие необходимых для работы БД CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Attributes EXCLUSIVE NEW USE KonstAtr EXCLUSIVE NEW mNumMod = 0 FOR m=1 TO LEN(Ar_Model) // Цикл по заданным моделям IF aClustParAtr[m] mNumMod = IF(mNumMod=0, m, mNumMod) M_SxodAtr = "SxodAtr"+Ar_Model[m] USE (M_SxodAtr) EXCLUSIVE NEW M_KlastAtr = "KlastAtr"+Ar_Model[m] USE (M_KlastAtr) EXCLUSIVE NEW ENDIF NEXT ****** Отобразить 1-й конструкт SELECT Attributes DBGOTOP() M_KodAtr = Kod_atr M_NameAtr = Name_atr MessIPC := L('Конструкт признака: ')+ALLTRIM(STR(M_KodAtr, 15))+' "'+DelZeroNameGr(M_NameAtr)+L('" в модели: ')+ALLTRIM(STR(mNumMod, 15))+' "'+UPPER(Ar_Model[mNumMod]+'"') @ 0,0 DCSAY {|| MessIPC } OBJECT oSay1 SAYSIZE 133 FONT "9.HelvBold" // Наименование конструкта KonstAtr(mNumMod) /* ----- Create ToolBar ----- */ @ 28.5, 0 DCTOOLBAR oToolBar SIZE 133, 1.5 DCADDBUTTON CAPTION L('Помощь') ; SIZE LEN(L("Помощь"))+2 ; ACTION {||Help422(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Помощь по режиму 4.2.2.3') DCADDBUTTON CAPTION Ar_Model[1] ; SIZE LEN(Ar_Model[1])+2 ; ACTION {||KonstAtr(1), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Генерация конструкта текущего признака в модели: ')+Ar_Model[1] DCADDBUTTON CAPTION Ar_Model[2] ; SIZE LEN(Ar_Model[2])+1 ; ACTION {||KonstAtr(2), DC_GetRefresh(GetList)}; PARENT oToolBar ; TOOLTIP L('Генерация конструкта текущего признака в модели: ')+Ar_Model[2] DCADDBUTTON CAPTION Ar_Model[3] ; SIZE LEN(Ar_Model[3])+1 ; ACTION {||KonstAtr(3), DC_GetRefresh(GetList)}; PARENT oToolBar ; TOOLTIP L('Генерация конструкта текущего признака в модели: ')+Ar_Model[3] DCADDBUTTON CAPTION Ar_Model[4] ; SIZE LEN(Ar_Model[4])+1 ; ACTION {||KonstAtr(4), DC_GetRefresh(GetList)}; PARENT oToolBar ; TOOLTIP L('Генерация конструкта текущего признака в модели: ')+Ar_Model[4] DCADDBUTTON CAPTION Ar_Model[5] ; SIZE LEN(Ar_Model[5])+1 ; ACTION {||KonstAtr(5), DC_GetRefresh(GetList)}; PARENT oToolBar ; TOOLTIP L('Генерация конструкта текущего признака в модели: ')+Ar_Model[5] DCADDBUTTON CAPTION Ar_Model[6] ; SIZE LEN(Ar_Model[6])+1 ; ACTION {||KonstAtr(6), DC_GetRefresh(GetList)}; PARENT oToolBar ; TOOLTIP L('Генерация конструкта текущего признака в модели: ')+Ar_Model[6] DCADDBUTTON CAPTION Ar_Model[7] ; SIZE LEN(Ar_Model[7])+1 ; ACTION {||KonstAtr(7), DC_GetRefresh(GetList)}; PARENT oToolBar ; TOOLTIP L('Генерация конструкта текущего признака в модели: ')+Ar_Model[7] DCADDBUTTON CAPTION Ar_Model[8] ; SIZE LEN(Ar_Model[8])+1 ; ACTION {||KonstAtr(8), DC_GetRefresh(GetList)}; PARENT oToolBar ; TOOLTIP L('Генерация конструкта текущего признака в модели: ')+Ar_Model[8] DCADDBUTTON CAPTION Ar_Model[9] ; SIZE LEN(Ar_Model[9])+1 ; ACTION {||KonstAtr(9), DC_GetRefresh(GetList)}; PARENT oToolBar ; TOOLTIP L('Генерация конструкта текущего признака в модели: ')+Ar_Model[9] DCADDBUTTON CAPTION Ar_Model[10] ; SIZE LEN(Ar_Model[10])+1 ; ACTION {||KonstAtr(10), DC_GetRefresh(GetList)}; PARENT oToolBar ; TOOLTIP L('Генерация конструкта текущего признака в модели: ')+Ar_Model[10] DCADDBUTTON CAPTION L('График') FONT '9.Arial Bold' ; SIZE LEN(L("График"))+3 ; ACTION {||SemNetAtr("AUTO"), DC_GetRefresh(GetList)} ; PARENT oToolBar COLOR aColor[189] ; TOOLTIP L('Вывод 2d семантической сети признаков') DCADDBUTTON CAPTION L('ВКЛ.фильтр по кл.шкале') ; SIZE LEN(L("ВКЛ.фильтр по кл.шкале"))-2 ; ACTION {||FltrOn4322(KonstAtr->Kod_OpSc), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Включить фильтр по фактору') DCADDBUTTON CAPTION L('ВЫКЛ.фильтр по кл.шкале') ; SIZE LEN(L("ВЫКЛ.фильтр по кл.шкале"))-2 ; ACTION {||FltrOff4322(KonstAtr->Kod_OpSc), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Выключить фильтр по кл.шкале') DCADDBUTTON CAPTION L('Параметры') FONT '9.Arial Bold'; SIZE LEN(L("Параметры"))+3 ; ACTION {||WindOn4322(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Параметры диаграммы') DCADDBUTTON CAPTION L('Показать ВСЕ') ; SIZE LEN(L("Показать ВСЕ")) ; ACTION {||WindOff4322(), DC_GetRefresh(GetList)}; PARENT oToolBar ; TOOLTIP L('Показать все записи конструкта в окне') @ 0,0 DCSAY {|| MessIPC } OBJECT oSay1 SAYSIZE 133 FONT "9.HelvBold" // Наименование инф.портрета /* ----- Create browse Attributes ----- */ @ 1, 0 DCBROWSE oBrowse ALIAS 'Attributes' SIZE 48.8,27 ; PRESENTATION LC_BrowPres() // Только просмотр БД * COLOR {||IIF(2*INT(Attributes->Kod_atr/2)==Attributes->Kod_atr,nil,{nil,GraMakeRGBColor({230,252,213})})} // Вывод строки цветом RGB DCBROWSECOL FIELD Attributes->Kod_atr HEADER L("Код") PARENT oBrowse WIDTH 5 ; COLOR {||IIF(AT('SPECTRINTERV:',Attributes->Name_atr)=0,nil,{nil,GraMakeRGBColor({VAL(SUBSTR(Attributes->Name_atr, AT('{', Attributes->Name_atr)+1, AT('{', Attributes->Name_atr)+ 3-AT('{', Attributes->Name_atr)+1+1)),VAL(SUBSTR(Attributes->Name_atr, AT('{', Attributes->Name_atr)+5, AT('{', Attributes->Name_atr)+ 7-AT('{', Attributes->Name_atr)+5+1)),VAL(SUBSTR(Attributes->Name_atr, AT('{', Attributes->Name_atr)+9, AT('{', Attributes->Name_atr)+11-AT('{', Attributes->Name_atr)+9+1))})})} // Вывод поля цветом RGB DCBROWSECOL FIELD Attributes->Name_atr HEADER L("Наименование признака") PARENT oBrowse WIDTH 23 DCBROWSECOL FIELD Attributes->Int_inf HEADER L("Редукция признака") PARENT oBrowse WIDTH 3 DCBROWSECOL FIELD Attributes->Abs HEADER L("N объектов (абс.)") PARENT oBrowse WIDTH 3 DCBROWSECOL FIELD Attributes->Perc_fiz HEADER L("N объектов (%)") PARENT oBrowse WIDTH 3 /* ----- Create browse (M_KlastAtr) ----- */ PRIVATE bColorBlockZn:={|| iif(KonstAtr->Sxodstvo>0,{GRA_CLR_RED,nil},iif(KonstAtr->Sxodstvo=0,{GRA_CLR_BLACK,nil},{GRA_CLR_BLUE,nil})) } // Клиффорд @ 1,51 DCBROWSE oBrowIpc ALIAS 'KonstAtr' SIZE 82,27 ; PRESENTATION LC_BrowPres() // Только просмотр БД DCSETPARENT oBrowIpc DCBROWSECOL FIELD KonstAtr->Num_pp HEADER L('№') WIDTH 5 DCBROWSECOL FIELD KonstAtr->Kod_atr HEADER L('Код признака') WIDTH 5 ; COLOR {||IIF(AT('SPECTRINTERV:',KonstAtr->Name_atr)=0,nil,{nil,GraMakeRGBColor({VAL(SUBSTR(KonstAtr->Name_atr, AT('{', KonstAtr->Name_atr)+1, AT('{', KonstAtr->Name_atr)+ 3-AT('{', KonstAtr->Name_atr)+1+1)),VAL(SUBSTR(KonstAtr->Name_atr, AT('{', KonstAtr->Name_atr)+5, AT('{', KonstAtr->Name_atr)+ 7-AT('{', KonstAtr->Name_atr)+5+1)),VAL(SUBSTR(KonstAtr->Name_atr, AT('{', KonstAtr->Name_atr)+9, AT('{', KonstAtr->Name_atr)+11-AT('{', KonstAtr->Name_atr)+9+1))})})} // Вывод поля цветом RGB DCBROWSECOL FIELD KonstAtr->Name_atr HEADER L('Наименование признака') WIDTH 31 DCBROWSECOL DATA {|x|x:=KonstAtr->Sxodstvo,IIF(Empty(x),'',Str(x,8,3))} HEADER L("Сходство") FONT "9.Courier" COLOR bColorBlockZn DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; OPTIONS GetOptions ; MODAL ; TITLE L('4.3.2.2. Результаты кластерно-конструктивного анализа признаков') ; // Надпись на окне графика FIT ; CLEAREVENTS ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) ReTURN nil *********************************************************************************************************************** ****************************************************************** ******** Вписать конструкт признака в окно, задать разрешение окна ****************************************************************** FUNCTION WindOn4322() IF FILE("_WindOn4322.arx") aWindOn4322 = DC_ARestore("_WindOn4322.arx") mNAtr = aWindOn4322[1] // Число отображаемых признаков mMinSx = aWindOn4322[2] // MIN модуль уровня сходства отображаемых признаков mVar = aWindOn4322[3] // mVar=1: Признаки с MAX и MIN уровнями сходства, mVar=2: Классы с MAX по модулю уровнем сходства mXSize = aWindOn4322[4] // Разрешение по X mYSize = aWindOn4322[5] // Разрешение по Y ELSE mNAtr = 12 mMinSx = 0 mVar = 1 mXSize = 1800 // Разрешение по X mYSize = 900 // Разрешение по Y PRIVATE aWindOn4322[5] aWindOn4322[1] = mNAtr // Число отображаемых признаков aWindOn4322[2] = mMinSx // MIN модуль уровня сходства отображаемых признаков aWindOn4322[3] = mVar // mVar=1: Признаки с MAX и MIN уровнями сходства, mVar=2: Классы с MAX по модулю уровнем сходства aWindOn4322[4] = mXSize // Разрешение по X aWindOn4322[5] = mYSize // Разрешение по Y ENDIF * aWindOn4322 = DC_ARestore("_WindOn4322.arx") DC_ASave(aWindOn4322, "_WindOn4322.arx") @ 1, 1 DCGROUP oGroup1 CAPTION L('Задание параметров отображения признаков:') SIZE 60.0, 11.0 @ 1, 2 DCSAY L("Задайте число отображаемых признаков:") PARENT oGroup1 @ 1,50 DCGET mNAtr PICTURE "####" PARENT oGroup1 @ 2, 2 DCSAY L("Задайте MIN модуль уровня сходства отображаемых признаков:") PARENT oGroup1 @ 2,50 DCGET mMinSx PICTURE "####" PARENT oGroup1 @ 3, 2 DCGROUP oGroup2 CAPTION L('Задайте способ выбора признаков для отображения:') SIZE 56.0, 3.5 PARENT oGroup1 @ 1, 2 DCRADIO mVar VALUE 1 PROMPT L('Признаки с MAX и MIN уровнями сходства') PARENT oGroup2 @ 2, 2 DCRADIO mVar VALUE 2 PROMPT L('Признаки с MAX по модулю уровнем сходства') PARENT oGroup2 @ 7, 2 DCGROUP oGroup3 CAPTION L('Задайте размер изображения в пикселях (не более 4K):') SIZE 56.0, 3.5 PARENT oGroup1 @ 1, 2 DCSAY L("Размер по X:") PARENT oGroup3;@ 1,15 DCGET mXSize PICTURE "####" PARENT oGroup3 @ 2, 2 DCSAY L("Размер по Y:") PARENT oGroup3;@ 2,15 DCGET mYSize PICTURE "####" PARENT oGroup3 DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; ADDBUTTONS; OPTIONS GetOptions ; MODAL ; TITLE L('4.3.2.2. Задание признаков для отображения') ******************************************************************** IF lExit ** Button Ok ELSE RETURN NIL ENDIF ******************************************************************** *** Записать заданные параметры в виде файла, чтобы можно было загрузить их и отобразить в диаграмме mXSize = IF(mXSize< 100,1800,mXSize ) mXSize = IF(mXSize>4096,4096,mXSize ) mYSize = IF(mYSize< 100, 900,mYSize ) mYSize = IF(mYSize>4096,4096,mYSize ) aWindOn4322[1] = mNAtr // Число отображаемых признаков aWindOn4322[2] = mMinSx // MIN модуль уровня сходства отображаемых признаков aWindOn4322[3] = mVar // mVar=1: Признаки с MAX и MIN уровнями сходства, mVar=2: Классы с MAX по модулю уровнем сходства aWindOn4322[4] = mXSize // Разрешение по X aWindOn4322[5] = mYSize // Разрешение по Y * aWindOn4322 = DC_ARestore("_WindOn4322.arx") DC_ASave(aWindOn4322, "_WindOn4322.arx") SELECT KonstAtr N_Rec = RECCOUNT() * mNCls = N_Rec - N_Del // 23 - число строк, которое помещается в окне N_Del = N_Rec - mNAtr * IF N_Del <= 0 * LB_Warning(L('Заданы условия, при которых не будет отображено ни одного признака !'),L('4.3.2.2. Результаты кластерно-конструктивного анализа признаков')) // Удалять ничего не надо. Выйти * ReTURN NIL * ENDIF // Ничего не показывать SET ORDER TO SET FILTER TO DBGOTOP() DO WHILE .NOT. EOF() REPLACE Fltr_wind WITH " " DBSKIP(1) ENDDO IF mVar = 1 // Классы с MAX и MIN уровнями сходства // Показывать mNAtr наиболее значимых записей SELECT KonstAtr FOR j=1 TO ROUND(mNAtr/2,0) DBGOTO(j) REPLACE Fltr_wind WITH "#" NEXT FOR j=1 TO ROUND(mNAtr/2,0)+IF(mNAtr=2*INT(mNAtr/2), 0, -1) // Поправка на нечетность числа признаков DBGOTO(N_Rec-j+1) REPLACE Fltr_wind WITH "#" NEXT ENDIF IF mVar = 2 // Классы с MAX по модулю уровнем сходства // Не показывать N_Del наименее значимых записей, так, чтобы заполнить окно SELECT KonstAtr INDEX ON STR(99999999.9999999-ABS(Sxodstvo), 19, 7) TO Temp N = 0 DBGOTOP() DO WHILE .NOT. EOF() .AND. (N+1) <= mNAtr REPLACE Fltr_wind WITH "#" ++N DBSKIP(1) ENDDO ENDIF IF mMinSx > 0 // MIN модуль уровня сходства отображаемых признаков // Не показывать наименее значимые записи SELECT KonstAtr SET ORDER TO DBGOTOP() DO WHILE .NOT. EOF() IF ABS(Sxodstvo) < mMinSx REPLACE Fltr_wind WITH " " ENDIF DBSKIP(1) ENDDO ENDIF SET ORDER TO SET FILTER TO Fltr_wind = "#" DBGOTOP() ReTURN NIL ********************************************************************************************************************* ********************************************************************************************************************* ******** Формирование БД для отображения заданного конструкта FUNCTION KonstAtr(mNumMod) * mNumMod = DC_ARestore("_NumMod.arx") DC_ASave(mNumMod, "_NumMod.arx") SELECT Attributes M_Recno = RECNO() M_KodAtr = Kod_atr M_NameAtr = Name_atr PUBLIC MessIPC := L('Конструкт признака: ')+ALLTRIM(STR(M_KodAtr, 15))+' "'+DelZeroNameGr(M_NameAtr)+L('" в модели: ')+ALLTRIM(STR(mNumMod, 15))+' "'+UPPER(Ar_Model[mNumMod]+'"') *LB_Warning(MessIPC) DC_GetRefresh(oSay1) // Наименование информационного портрета ***** Подготовить БД для визуализации конструктов KonstAtr.dbf M_SxodAtr = "SxodAtr" +Ar_Model[mNumMod] M_KlastAtr = "KlastAtr"+Ar_Model[mNumMod] IF .NOT. FILE(M_SxodAtr+'.dbf') LB_Warning(L("Предварительно в режиме 4.3.2.1 нужно посчитать матрицу сходства в модели:")+' '+Ar_Model[mNumMod]) Running(.F.) RETURN NIL ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE KonstAtr EXCLUSIVE NEW;ZAP USE (M_SxodAtr) EXCLUSIVE NEW // Для рисования 2d семантической сети признаков USE (M_KlastAtr) EXCLUSIVE NEW SELECT (M_KlastAtr) SET ORDER TO SET FILTER TO Num_Klast = M_KodAtr COUNT TO N_Rec DBGOTOP() ***************************** nMax = N_Rec + LEN(Ar_Model) Mess = L('Подготовка БД для визуализации конструкта текущего признака') @ 4,5 DCPROGRESS oProgr SIZE 80,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 DCREAD GUI TITLE Mess PARENT @oDial FIT EXIT oDial:show() nTime = 0 DC_GetProgress(oProgr,0,nMax) ***************************** DO WHILE .NOT. EOF() Ar := {} FOR j=1 TO FCOUNT() AADD(Ar, FIELDGET(j)) NEXT SELECT KonstAtr APPEND BLANK FOR j=1 TO LEN(Ar) FIELDPUT(j, Ar[j]) NEXT DC_GetProgress(oProgr, ++nTime, nMax) SELECT (M_KlastAtr) DBSKIP(1) ENDDO ***** Открытие необходимых для работы БД CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Attributes EXCLUSIVE NEW USE KonstAtr EXCLUSIVE NEW FOR m=1 TO LEN(Ar_Model) // Цикл по заданным моделям IF aClustParAtr[m] M_KlastAtr = "KlastAtr"+Ar_Model[m] USE (M_KlastAtr) EXCLUSIVE NEW ENDIF DC_GetProgress(oProgr, ++nTime, nMax) NEXT *MsgBox('STOP') DC_GetProgress(oProgr,nMax,nMax) oDial:Destroy() SELECT KonstAtr DBGOTOP() SELECT Attributes *SET FILTER TO Abs+Int_inf > 0 DBGOTO(M_Recno) ReTURN NIL ******** Включить фильтр конструкта признака по описательной шкале FUNCTION FltrOn4322(mKodOpSc) SELECT KonstAtr SET ORDER TO SET FILTER TO Kod_OpSc = mKodOpSc ReTURN NIL ******** Выключить фильтр конструкта признака по описательной шкале FUNCTION FltrOff4322(mKodOpSc) SELECT KonstAtr SET ORDER TO SET FILTER TO ReTURN NIL ******** Показать все записи конструкта FUNCTION WindOff4322() SELECT KonstAtr SET ORDER TO SET FILTER TO DBGOTOP() ReTURN NIL **************************************************************************************** ******** Вывод 2d семантических сетей признаков (режим 5.2.2.5 DOS-версии) ###### **************************************************************************************** FUNCTION SemNetAtr(mParam) LOCAL GetList := {}, oStatic LOCAL oPS, oDevice PRIVATE aAttr // Массив атрибутов отображаемых линий PRIVATE nEvent, mp1, mp2, oXbp // Переменные анализа событий mNumMod = DC_ARestore("_NumMod.arx") * DC_ASave(mNumMod, "_NumMod.arx") M_Recno = RECNO() // Позиция отображения конструкта SELECT KonstAtr COUNT TO N_Atr // Кол-во признаков в конструкте с учетом фильтра ****** Присвоить значения отображаемым массивам aKodAtr := {} // Массив кодов признаков aNameAtr := {} // Массив наименований признаков aSxodAtr := {} // Массив уровней сходства признаков конструкта с признаком на положительном полюсе конструкта DBGOTOP() * IF SUBSTR(NAME_ATR,1,12) = 'SPECTRINTERV' * aRGBAtr := {} // Массив цветов признаков, если спектр * ENDIF aRGBAtr := {} // Массив цветов признаков, если спектр DO WHILE .NOT. EOF() AADD(aKodAtr , Kod_atr) AADD(aNameAtr, DelZeroNameGr(Name_atr)) AADD(aSxodAtr, Sxodstvo) mScName = NAME_ATR IF SUBSTR(mScName,1,12) = 'SPECTRINTERV' * SpectrInterv: 999/999-{123,123,123} * 123456789012 R G B mPosR1 = AT('{', mScName)+1 mPosR2 = mPosR1+2 mPosG1 = mPosR2+2 mPosG2 = mPosG1+2 mPosB1 = mPosG2+2 mPosB2 = mPosB1+2 mRed = VAL(SUBSTR(mScName, mPosR1, mPosR2-mPosR1+1)) mGreen = VAL(SUBSTR(mScName, mPosG1, mPosG2-mPosG1+1)) mBlue = VAL(SUBSTR(mScName, mPosB1, mPosB2-mPosB1+1)) * MsgBox(mScName+' '+STR(mRed)+','+STR(mGreen)+','+STR(mBlue)) fColor := GraMakeRGBColor({ mRed, mGreen, mBlue}) * SetPixel(hDC1, x, y, AutomationTranslateColor(fColor,.f.) ) * AADD(aRGBAtr, AutomationTranslateColor(fColor,.f.)) AADD(aRGBAtr, fColor) ENDIF DBSKIP(1) ENDDO M_NameAppl = DC_ARestore("_NameAppl.arx") * PUBLIC X_MaxW := 1280, Y_MaxW := 850 // Размер графического окна в пикселях * @ 2,1 DCSTATIC TYPE XBPSTATIC_TYPE_RECESSEDBOX SIZE X_MaxW, Y_MaxW PIXEL; // Размер окна для отображения графика в пикселях (от Тома) * OBJECT oStatic; * EVAL {|| _PresSpace4322(oStatic, aKodAtr, aNameAtr, aSxodAtr, mNumMod) } * DCREAD GUI ; * TITLE L('4.3.2.2. Результаты кластерно-конструктивного анализа признаков признаков. (C) Универсальная когнитивная аналитическая система "Эйдос-Х++"') ; // Надпись на окне графика * FIT; * MODAL IF FILE("_WindOn4322.arx") aWindOn4322 = DC_ARestore("_WindOn4322.arx") mNAtr = aWindOn4322[1] // Число отображаемых признаков mMinSx = aWindOn4322[2] // MIN модуль уровня сходства отображаемых признаков mVar = aWindOn4322[3] // mVar=1: Признаки с MAX и MIN уровнями сходства, mVar=2: Классы с MAX по модулю уровнем сходства mXSize = aWindOn4322[4] // Разрешение по X mYSize = aWindOn4322[5] // Разрешение по Y ELSE mNAtr = 12 mMinSx = 0 mVar = 1 mXSize = 1800 // Разрешение по X mYSize = 900 // Разрешение по Y PRIVATE aWindOn4322[5] aWindOn4322[1] = mNAtr // Число отображаемых признаков aWindOn4322[2] = mMinSx // MIN модуль уровня сходства отображаемых признаков aWindOn4322[3] = mVar // mVar=1: Признаки с MAX и MIN уровнями сходства, mVar=2: Классы с MAX по модулю уровнем сходства aWindOn4322[4] = mXSize // Разрешение по X aWindOn4322[5] = mYSize // Разрешение по Y ENDIF * aWindOn4322 = DC_ARestore("_WindOn4322.arx") DC_ASave(aWindOn4322, "_WindOn4322.arx") PUBLIC X_MaxW := mXSize, Y_MaxW := mYSize // Размер графического окна для отображения когнитивных диаграмм в пикселях PUBLIC nXSize := mXSize PUBLIC nYSize := mYSize oScr := DC_WaitOn('Немного подождите! Идет формирование изображения в памяти и его масштабирование',,,,,,,,,,,.F.) // Create new bitmap with given size oPS := XBPPRESSPACE() :new() :Create() oBMP := XBPBITMAP() :New() :Create() * oBMP:Make( nXSize, nYSize, nPlanes, nBits ) oBMP:Make( nXSize, nYSize ) oBMP:presSpace( oPS ) // here your GRA* Code **** Закрасить фон прямоугольника *************** * GraSetColor( oPS, GRA_CLR_WHITE, GRA_CLR_WHITE ) GraSetColor( oPS, BD_LIGHTGREY, BD_LIGHTGREY ) GraBox( oPS, { 0, 0 }, { nXSize, nYSize }, GRA_FILL ) *######################################################################################################################### LC_SemNetAtr( oPS, oBMP, aKodAtr, aNameAtr, aSxodAtr ) // Графическая функция <<<===######################### *######################################################################################################################### *My image original, my image scaled ****** Запись полноразмерного графического файла в папку: M_PathAppl+"\SemNetCls2d\" DC_Impl(oScr) IF FILEDATE("SemNetAtr2d",16) = CTOD("//") DIRMAKE("SemNetAtr2d") aMess := {} AADD(aMess, L('В папке текущего приложения: "'+UPPER(ALLTRIM(M_PathAppl))+'"')) AADD(aMess, L('не было директории "SemNetAtr2d" для когнитивных диаграмм классов и она была создана!')) AADD(aMess, L('В эту папку записываются исходные изображения высокого качества (без масштабирования)')) LB_Warning(aMess, L('4.2.2.2. Результаты кластерно-конструктивного анализа классов' )) ENDIF DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения * DC_ASave(mNumMod , "_NumMod.arx") mNumMod = DC_ARestore("_NumMod.arx") DIRCHANGE(M_PathAppl+"\SemNetAtr2d\") // Перейти в папку SemNetAtr2d cFileName = "SemNetAtr2d"+STRTRAN(STR(ADIR("*.*")+1,6)," ","0")+".jpg" ERASE(cFileName) oBMP:SaveFile(cFileName,XBPBMP_FORMAT_JPG) IF nWidth > 1800 FullView( cFileName, "по верху", 65 ) // Визуализация полноразмерного файла на мониторе высокого разрешения ELSE ****** Формирование с помощью bmp2bmp() и отображение масштабированного изображения aNewSize := {nWidth,nHeight-29} // Новый размер изображения (еще немного уменьшается, чтобы не рисовать по панели задач) oBMP:loadFile(cFileName) // Загрузка полноразмерного изображения oRet := BMP2BMP(oBMP,aNewSize) // Масштабирование изображения cFileNameScale = SUBSTR(cFileName,1,AT(".jpg",cFileName)-1)+"_scaled.jpg" ERASE(cFileNameScale) oRet:saveFile(cFileNameScale,XBPBMP_FORMAT_JPG) // Запись масштабированного графического файла в в папку приложения для визуализации FullView( cFileNameScale, "по верху", 0 ) // Визуализация масштабированного графического файла на мониторе ограниченного разрешения ENDIF DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения SELECT KonstAtr DBGOTOP() SELECT Attributes *SET FILTER TO Abs+Int_inf > 0 DBGOTO(M_Recno) RETURN NIL ************************************************* *FUNCTION _PresSpace4322( oStatic, aKodAtr, aNameAtr, aSxodAtr, mNumMod ) * LOCAL oPS, oDevice * oPS := XbpPresSpace():new() // Create a PS * oDevice := oStatic:winDevice() // Get the device context * oPS:create( oDevice ) // Link device context to PS * oPS:SetViewPort( { 0, 0, X_MaxW, Y_MaxW } ) * oStatic:paint := {|mp1,mp2,obj| mp1 := LC_SemNetAtr( oPS, oStatic, aKodAtr, aNameAtr, aSxodAtr ) } *RETURN NIL ************************************************************************************** STATIC FUNCTION LC_SemNetAtr( oPS, oStatic, aKodAtr, aNameAtr, aSxodAtr, mNumMod ) DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения mNumMod = DC_ARestore("_NumMod.arx") * DC_ASave(mNumMod, "_NumMod.arx") * MsgBox(STR(mNumMod)) W_Wind = X_MaxW / 2 // Полуширина окна для самого графика H_Wind = Y_MaxW / 2 // Полувысота окна для самого графика LY := 70 // Зона над областью графика для наименования и под областью графика для легенды X0 := W_Wind // Начало координат для эллипса по оси X Y0 := H_Wind // Начало координат для эллипса по оси Y ***** Закрасить фон прямоугольника *************** ***** Закрасить фон прямоугольника *************** GraSetColor( oPS, aColor[98] , aColor[98] ) // Номер цвета в соответствии с _AidosColor.prg GraBox( oPS, { X0-W_Wind, Y0-H_Wind }, { X0+W_Wind, Y0+H_Wind }, GRA_FILL ) GraSetColor( oPS, aColor[222] , aColor[222] ) ***** Нарисовать рамку изображения и отделить место для легенды ******************* aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты ****** Начало координат в центре рисунка GraArc ( oPS, { X0, Y0 }, 2 ) // Начало координат GraLine( oPS, {X0-W_Wind+1, Y0-H_Wind+1}, {X0-W_Wind+1, Y0+H_Wind-1} ) // Нарисовать границу рамки изображения слева GraLine( oPS, {X0+W_Wind-1, Y0-H_Wind+1}, {X0+W_Wind-1, Y0+H_Wind-1} ) // Нарисовать границу рамки изображения справа GraLine( oPS, {X0-W_Wind+1, Y0-H_Wind+1}, {X0+W_Wind-1, Y0-H_Wind+1} ) // Нарисовать границу рамки изображения внизу параллельно оси X GraLine( oPS, {X0-W_Wind+1, Y0+H_Wind-1}, {X0+W_Wind-1, Y0+H_Wind-1} ) // Нарисовать границу рамки изображения вверху параллельно оси X GraLine( oPS, {X0-W_Wind+1, Y0-H_Wind+LY}, {X0+W_Wind-1, Y0-H_Wind+LY} ) // Нарисовать границу рамки легенды на уровне LY параллельно оси X ************************************************************************************************* **** Написать заголовок диаграммы oFont := XbpFont():new():create("22.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraStringAt( oPS, { X_MaxW/2, Y_MaxW-20 }, 'СЕМАНТИЧЕСКАЯ 2D СЕТЬ ПРИЗНАКОВ В МОДЕЛИ: "'+UPPER(Ar_Model[mNumMod])+'"' ) oFont := XbpFont():new():create("14.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) SELECT Attributes M_KodAtr = Kod_Atr M_NameAtr = Name_Atr ***** Цикл определения такой длины строки, которая помещается в рамку ***** Массив отображаемых в рамке строк, включающий наименования и описательных шкал и их градаций ***** Из текстового буфера к отображаемому элементу массива добавляется по одному символу и определяется его длина в пикселях. ***** Если не хватает длины рамки - добавляется строка в массив. Отображение градации шкалы всегда начинается с новой строки. mZone = X_MaxW-600 // Ширина зоны отображения в пикселях с учетом полей слева и справа mMess := 'КОНСТРУКТ ПРИЗНАКА: ['+ALLTRIM(STR(M_KodAtr, 15))+']-' // Массив отображаемых в рамке строк, включающий наименования и описательных шкал и их градаций mBuff = ALLTRIM(M_NameAtr) // Максимальная длина наименования признака, помещающегося в прямоугольнике, равна 90 символов FOR i=1 TO LEN(mBuff) aTxtPar = DC_GraQueryTextbox(mMess + SUBSTR(mBuff,i,1), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox(mMess + SUBSTR(mBuff,i,1)+" "+STR(aTxtPar[1])) IF aTxtPar[1] <= mZone mMess = mMess + SUBSTR(mBuff,i,1) // Полное наименование описательной шкалы посылается в буфер для отображения ELSE mMess = mMess + '...' // Полное наименование описательной шкалы посылается в буфер для отображения EXIT ENDIF NEXT * GraStringAt( oPS, { X_MaxW/2, Y_MaxW-45 }, SUBSTR('- КОНСТРУКТ ПРИЗНАКА: '+ALLTRIM(STR(M_KodAtr, 15))+' "'+ALLTRIM(M_NameAtr)+'."',1,92) ) GraStringAt( oPS, { X_MaxW/2, Y_MaxW-45 }, mMess ) oFont := XbpFont():new():create("14.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) ***** Цикл определения такой длины строки, которая помещается в рамку ***** Массив отображаемых в рамке строк, включающий наименования и описательных шкал и их градаций ***** Из текстового буфера к отображаемому элементу массива добавляется по одному символу и определяется его длина в пикселях. ***** Если не хватает длины рамки - добавляется строка в массив. Отображение градации шкалы всегда начинается с новой строки. mZone = X_MaxW-600 // Ширина зоны отображения в пикселях с учетом полей слева и справа mMess := 'Приложение: ' // Массив отображаемых в рамке строк, включающий наименования и описательных шкал и их градаций M_NameAppl = DC_ARestore("_NameAppl.arx") mBuff = ALLTRIM(M_NameAppl) // Максимальная длина наименования признака, помещающегося в прямоугольнике, равна 90 символов FOR i=1 TO LEN(mBuff) aTxtPar = DC_GraQueryTextbox(mMess + SUBSTR(mBuff,i,1), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox(mMess + SUBSTR(mBuff,i,1)+" "+STR(aTxtPar[1])) IF aTxtPar[1] <= mZone mMess = mMess + SUBSTR(mBuff,i,1) // Полное наименование описательной шкалы посылается в буфер для отображения ELSE mMess = mMess + '...' // Полное наименование описательной шкалы посылается в буфер для отображения EXIT ENDIF NEXT * GraStringAt( oPS, { X_MaxW/2, Y_MaxW-65 }, SUBSTR("Приложение: "+'"'+ALLTRIM(M_NameAppl)+'."',1,110) ) GraStringAt( oPS, { X_MaxW/2, Y_MaxW-65 }, mMess ) ************************************************************************************************* ********* Начало рисования эллипса с кружочками признаков и линиями связи: сходства-различия R0 = 30 // Радиус кружочков с кодами классов RS = 12 // Радиус кружочка для указания силы связи Xb := 2*R0*1.618 // Ширина прямоугольника Yb := 2*R0 // Высота прямоугольника R0X = W_Wind - 2 * LY - Xb - 10 // Радиус элипса по X кружочков (это правильно при любом разрешении) R0Y = H_Wind - 2 * LY - Xb - 10 // Радиус элипса по Y кружочков K0 = 360 / N_Atr // Количество градусов в секторе одного признака X := {} // Координаты X центров кружочков признаков Y := {} // Координаты Y центров кружочков признаков Faza = 0 - K0 // Угол поворота системы кружочков признаков вокруг центра эллипса FOR j=1 TO N_Atr AADD(X, X0 - R0X * COS(DTOR(Faza+(j-1)*K0))) AADD(Y, Y0 - R0Y * SIN(DTOR(Faza+(j-1)*K0))) NEXT ****** Рисование кружочков признаков и линий связи между ними (брать из матрицы сходства) ****** Рисование линий связи * SELECT KonstAtr M_SxodAtr = "SxodAtr" +Ar_Model[mNumMod] USE (M_SxodAtr) EXCLUSIVE NEW // Для рисования 2d семантической сети признаков SELECT (M_SxodAtr) ****** Атрибуты графического шрифта ****** Загрузить графический шрифт oFont := XbpFont():new():create("14.Arial") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_BOX ] := { RS*1.2, RS*1.2 } // Размер поля вывода aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) *** Полный перебор всех сочетаний признаков конструкта D = 7 // Максимальная толщина отображаемых линий *** Поиск минимального и максимального значений толщины линии mSxodMin = +99999999999 mSxodMax = -99999999999 FOR i=1 TO LEN(aKodAtr) // Цикл по классам конструкта DBGOTO(aKodAtr[i]) FOR j=i+1 TO LEN(aKodAtr) // Цикл по классам конструкта mSxodstvo = ABS(FIELDGET(3+aKodAtr[j])) mSxodMin = MIN(mSxodMin, mSxodstvo) mSxodMax = MAX(mSxodMax, mSxodstvo) NEXT NEXT K = D / MAX(ABS(mSxodMax), ABS(mSxodMin)) // Масштабный коэффициент * MsgBox(STR(mSxodMax)+STR(mSxodMin)+STR(K)) FOR i=1 TO LEN(aKodAtr) // Цикл по признакам конструкта DBGOTO(aKodAtr[i]) FOR j=i+1 TO LEN(aKodAtr) // Цикл по признакам конструкта mSxodstvo = FIELDGET(3+aKodAtr[j]) ** Не рисовать линий с толщиной менее заданных IF aWindOn4322[2] < ABS(mSxodstvo) ******* Сделать цвет заливки и линии, а также толщину линии, зависящими от величины и знака сходства-различия aAttr := Array( GRA_AA_COUNT ) // атрибуты области aAttr [ GRA_AA_COLOR ] := IF(mSxodstvo > 0, BD_LIGHTYELLOW, BD_XBP_CYAN) aAttr [ GRA_AA_SYMBOL ] := GRA_SYM_DEFAULT graSetAttrArea( oPS, aAttr ) aAttr := Array( GRA_AL_COUNT ) // атрибуты линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := IF(mSxodstvo > 0, GRA_CLR_RED, GRA_CLR_BLUE) aAttr [ GRA_AL_WIDTH ] := ABS(mSxodstvo) * K // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraLine(oPS, { X[i], Y[i] }, { X[j], Y[j] } ) // Нарисовать линию заданных толщины и цвета ****** Сделать надписи уровней сходства на линиях связи aAttr := Array( GRA_AL_COUNT ) // атрибуты линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := IF(mSxodstvo > 0, GRA_CLR_RED, GRA_CLR_BLUE) aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraArc( oPS, { (X[i]+X[j])/2, (Y[i]+Y[j])/2 }, RS, ,,, GRA_OUTLINEFILL ) GraStringAt( oPS, { (X[i]+X[j])/2, (Y[i]+Y[j])/2 }, ALLTRIM(STR(mSxodstvo,15)) ) ENDIF NEXT NEXT CLOSE (M_SxodAtr) ****** Рисование кружочков признаков с надписями Xb0 := {} // Координата Xb0 точки пересечения диагоналей прямоугольников с наименованиями признаков Yb0 := {} // Координата Yb0 точки пересечения диагоналей прямоугольников с наименованиями признаков Xb1 := {} // Координаты X1 прямоугольников с наименованиями признаков Yb1 := {} // Координаты Y1 прямоугольников с наименованиями признаков Xb2 := {} // Координаты X2 прямоугольников с наименованиями признаков Yb2 := {} // Координаты Y2 прямоугольников с наименованиями признаков Xb := 2*R0*1.618 // Ширина прямоугольника Yb := 2*R0 // Высота прямоугольника FOR j=1 TO N_Atr AADD(Xb0, X0 - ( R0X + R0*3.2 ) * COS(DTOR(Faza+(j-1)*K0))) AADD(Yb0, Y0 - ( R0Y + R0*2.5 ) * SIN(DTOR(Faza+(j-1)*K0))) AADD(Xb1, Xb0[j] - Xb/2 ) AADD(Yb1, Yb0[j] - Yb/2 ) AADD(Xb2, Xb0[j] + Xb/2 ) AADD(Yb2, Yb0[j] + Yb/2 ) NEXT FOR j=1 TO N_Atr // Цикл по признакам конструкта ****** Инициализация графического шрифта oFont := XbpFont():new():create("22.Arial Bold") * oFont := XbpFont():new():create("78.HelveticaBold") // Конкретный шрифт с указанием размера GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_BOX ] := { R0, R0 } // Размер поля вывода aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты ******* Сделать цвет заливки и линии, а также толщину линии, зависящими от величины и знака сходства-различия aAttr := Array( GRA_AA_COUNT ) // атрибуты области aAttr [ GRA_AA_COLOR ] := IF(aSxodAtr[j] > 0, BD_LIGHTYELLOW, BD_XBP_CYAN) aAttr [ GRA_AA_SYMBOL ] := GRA_SYM_DEFAULT graSetAttrArea( oPS, aAttr ) aAttr := Array( GRA_AL_COUNT ) // атрибуты линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := IF(aSxodAtr[j] > 0, GRA_CLR_RED, GRA_CLR_BLUE) aAttr [ GRA_AL_WIDTH ] := ABS(aSxodAtr[j]) * 0.05 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraArc( oPS, { X[j], Y[j] }, R0, ,,, GRA_OUTLINEFILL ) GraStringAt( oPS, { X[j], Y[j] }, ALLTRIM(STR(aKodAtr[j],15)) ) **** Сделать надписи наименований признаков <===############################## Если спектр aAttr := Array( GRA_AA_COUNT ) // атрибуты области * aAttr [ GRA_AA_COLOR ] := IF(aSxodAtr[j] > 0, BD_LIGHTYELLOW, BD_XBP_CYAN) aAttr [ GRA_AA_COLOR ] := BD_WHITE aAttr [ GRA_AA_SYMBOL] := GRA_SYM_DEFAULT graSetAttrArea( oPS, aAttr ) aAttr := Array( GRA_AL_COUNT ) // атрибуты линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := IF(aSxodAtr[j] > 0, GRA_CLR_RED, GRA_CLR_BLUE) aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) graBox( oPS, { Xb1[j], Yb1[j] }, { Xb2[j], Yb2[j] }, GRA_OUTLINEFILL, 10, 10 ) // прямоугольник очерчен, заполнен и закруглен * GraArc( oPS, { Xb0[j], Yb0[j] }, 2, ,,, GRA_OUTLINEFILL ) GraArc( oPS, { Xb1[j], Yb1[j] }, 2, ,,, GRA_OUTLINEFILL ) GraArc( oPS, { Xb2[j], Yb2[j] }, 2, ,,, GRA_OUTLINEFILL ) IF SUBSTR(aNameAtr[j],1,12) = 'SPECTRINTERV' GraSetColor( oPS, aRGBAtr[j] , aRGBAtr[j] ) // Цвет фона для текста - цвет цветового диапазона graBox( oPS, { Xb1[j]+1, Yb1[j]+1 }, { Xb2[j]-1, Yb2[j]-1 }, GRA_OUTLINEFILL, 10, 10 ) // прямоугольник очерчен, заполнен и закруглен ENDIF ***** Наименование признака внутри прямоугольника NM = SUBSTR(ALLTRIM(aNameAtr[j]),1, 90) // Максимальная длина наименования признака, помещающегося в прямоугольнике, равна 90 символов SL = 15 // Длина строки в прямоугольнике в символах SP = 10 // Межстрочный интервал в пикселях L = 1+INT(LEN(NM)/SL) // Число строк в прямоугольнике oFont := XbpFont():new():create("14.Arial") GraSetFont( oPS ,oFont ) aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_BOX ] := { SL, SP } // Размер поля вывода в пикселях aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_TOP // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) **** Здесь сделать цикл по подстрокам наименования признака * GraStringAt( oPS, { MIN(Xb1[j],Xb2[j])+3, MAX(Yb1[j],Yb2[j]-4) }, aNameAtr[j] ) * aTxtPar = DC_GraQueryTextbox(aMess[s] + SUBSTR(mBuff1,j,1), oFont) // {101,16} Определяет длину и высоту текста в пикселях для НЕКОТОРЫХ шрифтов * D = LEN(NM) - L * SL // Число символов в последней строке * FOR s=1 TO L // Цикл по строкам * GraStringAt( oPS, { MIN(Xb1[j],Xb2[j])+3, MAX(Yb1[j],Yb2[j]-4-(s-1)*SP) }, SUBSTR(NM,1+(s-1)*SL,SL) ) * NEXT ***** Цикл определения такой длины строки, которая помещается в рамку ***** Массив отображаемых в рамке строк, включающий наименования и описательных шкал и их градаций ***** Из текстового буфера к отображаемому элементу массива добавляется по одному символу и определяется его длина в пикселях. ***** Если не хватает длины рамки - добавляется строка в массив. Отображение градации шкалы всегда начинается с новой строки. mZone = Xb-16 // Ширина зоны отображения в пикселях с учетом полей слева и справа aMess := {} // Массив отображаемых в рамке строк, включающий наименования и описательных шкал и их градаций AADD(aMess, L(" "));s=1 // 1-й элемент - 1-я строка mBuff = ALLTRIM(aNameAtr[j]) // Максимальная длина наименования признака, помещающегося в прямоугольнике, равна 90 символов FOR i=1 TO LEN(mBuff) aTxtPar = DC_GraQueryTextbox(aMess[s] + SUBSTR(mBuff,i,1), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox(aMess[s] + SUBSTR(mBuff,i,1)+" "+STR(aTxtPar[1])) IF aTxtPar[1] <= mZone aMess[s] = aMess[s] + SUBSTR(mBuff,i,1) // Полное наименование описательной шкалы посылается в буфер для отображения ELSE IF s < 5 AADD(aMess, SUBSTR(mBuff,i,1)) s++ ELSE EXIT ENDIF ENDIF NEXT mInterval = SP // Межстрочный интервал в пикселях. 1 - строки пишутся без пропуска FOR s=1 TO LEN(aMess) GraStringAt( oPS, { MIN(Xb1[j],Xb2[j])+3, MAX(Yb1[j],Yb2[j]-4-(s-1)*mInterval) }, aMess[s] ) NEXT NEXT * CLOSE (M_SxodAtr) ****** Легенда ********************************* oFont := XbpFont():new():create("13.Arial Bold") GraSetFont( oPS ,oFont ) aAttr := ARRAY( GRA_AS_COUNT ) aAttr [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttr [ GRA_AS_BOX ] := { SL, SP*2.0 } // Размер поля вывода в пикселях aAttr [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttr [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttr ) // Установить символьные атрибуты AxName = "Сходство и различие между признаками по их признакам (градациям факторов, системе детерминации):" GraStringAt( oPS, { 20, LY-15 }, AxName ) AxName = "СХОДСТВО признаков отображается линиями связи КРАСНОГО цвета, толщина линии (приведенная в кружочке в центре линии) отражает степень сходства." GraStringAt( oPS, { 200, LY-35 }, AxName ) AxName = "РАЗЛИЧИЕ признаков отображается линиями связи СИНЕГО цвета, толщина линии (приведенная в кружочке в центре линии) отражает степень различия." GraStringAt( oPS, { 200, LY-55 }, AxName ) IF FILE("_WindOn4322.arx") aWindOn4322 = DC_ARestore("_WindOn4322.arx") mNAtr = aWindOn4322[1] // Число отображаемых признаков mMinSx = aWindOn4322[2] // MIN модуль уровня сходства отображаемых признаков mVar = aWindOn4322[3] // mVar=1: Признаки с MAX и MIN уровнями сходства, mVar=2: Классы с MAX по модулю уровнем сходства mXSize = aWindOn4322[4] // Разрешение по X mYSize = aWindOn4322[5] // Разрешение по Y ELSE mNAtr = 12 mMinSx = 0 mVar = 1 mXSize = 1800 // Разрешение по X mYSize = 900 // Разрешение по Y PRIVATE aWindOn4322[5] aWindOn4322[1] = mNAtr // Число отображаемых признаков aWindOn4322[2] = mMinSx // MIN модуль уровня сходства отображаемых признаков aWindOn4322[3] = mVar // mVar=1: Признаки с MAX и MIN уровнями сходства, mVar=2: Классы с MAX по модулю уровнем сходства aWindOn4322[4] = mXSize // Разрешение по X aWindOn4322[5] = mYSize // Разрешение по Y ENDIF * aWindOn4322 = DC_ARestore("_WindOn4322.arx") DC_ASave(aWindOn4322, "_WindOn4322.arx") aAttr [ GRA_AS_COLOR ] := GRA_CLR_DARKRED GraSetAttrString( oPS, aAttr ) // Установить символьные атрибуты D = 16 * P1 = 965 // Это при 1800, а при XRight = X0+W_Wind-1? * P2 = 1155 nXRight = X0+W_Wind-1 // Выравнивание начала надписей о параметрах по правому краю P1 = nXRight-325 P2 = nXRight-325+198 GraStringAt( oPS, { P1, LY+D*5 }, "Диапазон кодов признаков:") ;GraStringAt( oPS, { P2, LY+D*5 }, ALLTRIM(STR(aClustParAtr[11]))+"-"+ALLTRIM(STR(aClustParAtr[12])) ) GraStringAt( oPS, { P1, LY+D*4 }, "Уровень сходства не менее:") ;GraStringAt( oPS, { P2, LY+D*4 }, ALLTRIM(STR(aWindOn4322[2]))+"%" ) GraStringAt( oPS, { P1, LY+D*3 }, "Число отображаемых признаков:");GraStringAt( oPS, { P2, LY+D*3 }, ALLTRIM(STR(aWindOn4322[1])) ) GraStringAt( oPS, { P1, LY+D*2 }, "Способ выборки классов:") ;GraStringAt( oPS, { P2, LY+D*2 }, IF(aWindOn4322[3]=1,'MAX и MIN ур.сх.','|MAX| ур.сходства') ) GraStringAt( oPS, { P1, LY+D*1 }, "Дата и время создания формы:") ;GraStringAt( oPS, { P2, LY+D*1 }, DTOC(DATE())+"-"+TIME() ) **** Нарисовать сами линии **** mSxodstvo > 0 aAttr := Array( GRA_AL_COUNT ) // атрибуты линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := GRA_CLR_RED aAttr [ GRA_AL_WIDTH ] := 7 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraLine(oPS, { 23, LY-35 }, { 170, LY-35 } ) // Нарисовать линию заданных толщины и цвета **** mSxodstvo < 0 aAttr := Array( GRA_AL_COUNT ) // атрибуты линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := GRA_CLR_BLUE aAttr [ GRA_AL_WIDTH ] := 7 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraLine(oPS, { 23, LY-55 }, { 170, LY-55 } ) // Нарисовать линию заданных толщины и цвета DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения Running(.F.) RETURN NIL *********************************************************************************************************** **************************************************************************************** ******** 4.2.3. Когнитивные диаграммы классов. Режим 5.1.3. DOS-версии ########## **************************************************************************************** FUNCTION F4_2_3() LOCAL GetList := {}, aPres, oBrowse, oToolBar, aColors, bColor, GetOptions LOCAL oProgress, oDialog, oStatic, oPS, oDevice, oDlg Running(.T.) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF ApplChange("4.2.3()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF mFlagErr = .F. **** Проверить, существуют ли матрицы сходства классов и признаков, необходимые для выполнения режима Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } FOR j=1 TO LEN(Ar_Model) mName = "SxodCls"+Ar_Model[j]+".dbf" IF .NOT. FILE(mName) Mess = L("Отсуствует матрица сходства классов: "+mName+". Необходимо выполнить режим 4.2.2.1.") LB_Warning(Mess, L('4.2.3. Когнитивные диаграммы классов')) mFlagErr = .T. EXIT ENDIF NEXT FOR j=1 TO LEN(Ar_Model) mName = "SxodAtr"+Ar_Model[j]+".dbf" IF .NOT. FILE(mName) Mess = L("Отсуствует матрица сходства признаков: "+mName+". Необходимо выполнить режим 4.3.2.1.") LB_Warning(Mess, L('4.2.3. Когнитивные диаграммы классов')) mFlagErr = .T. EXIT ENDIF NEXT ***** Создание БД для задания диапазонов признаков по описательным шкалам IF .NOT. FILE("Classes.dbf") // БД класс.шкал + градаций класс.шкал: Classes.dbf LB_Warning(L('Отсуствует БД классификационных шкал и градаций: "Classes.dbf". Зайдите в режим 2.1'), L('4.2.3. Когнитивные диаграммы классов')) mFlagErr = .T. ENDIF IF mFlagErr ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) ReTURN nil ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW SELECT Classes mLenMax = -99999 DBGOTOP() DO WHILE .NOT. EOF() mLenMax = MAX(mLenMax, LEN(ALLTRIM(NAME_CLS))) DBSKIP(1) ENDDO aStr := { { "KOD_ClS" , "N", 15, 0 }, ; { "NAME_ClS", "C",mLenMax, 0 } } DbCreate( 'ClassesKD.dbf', aStr ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW USE ClassesKD EXCLUSIVE NEW;ZAP SELECT ClassesKD APPEND BLANK REPLACE KOD_ClS WITH 0 REPLACE NAME_ClS WITH "ВСЕ КЛАССЫ" SELECT Classes DBGOTOP() DO WHILE .NOT. EOF() mKodClS = KOD_ClS mNameClS = NAME_ClS SELECT ClassesKD APPEND BLANK REPLACE KOD_ClS WITH mKodClS REPLACE NAME_ClS WITH mNameClS SELECT Classes DBSKIP(1) ENDDO ***** Создание БД для задания диапазонов признаков по описательным шкалам *MinMaxGrOpSc() // Формирование минимального и максимального кодов градаций описательных шкал (включено в ApplChange("")) IF .NOT. FILE("Opis_Sc.dbf") // БД описательных шкал LB_Warning(L('Отсуствует БД описательных шкал: "Opis_Sc.dbf". Зайдите в режим 2.1'), L('4.2.3. Когнитивные диаграммы классов')) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) ReTURN nil ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Opis_Sc EXCLUSIVE NEW SELECT Opis_Sc mLenMax = -99999 DBGOTOP() DO WHILE .NOT. EOF() mLenMax = MAX(mLenMax, LEN(ALLTRIM(NAME_OpSc))) DBSKIP(1) ENDDO aStr := { { "KOD_OpSc" , "N", 15, 0 }, ; { "NAME_OpSc" , "C",mLenMax, 0 }, ; { "KodGr_min" , "N", 15, 0 }, ; // Минимальный код градаций описательной шкалы { "KodGr_max" , "N", 15, 0 } } // Максимальный код градаций описательной шкалы DbCreate( 'Opis_ScKD.dbf', aStr ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Opis_Sc EXCLUSIVE NEW USE Opis_ScKD EXCLUSIVE NEW;ZAP USE Attributes EXCLUSIVE NEW SELECT Attributes DBGOTOP() mKodGrMin = Kod_atr DBGOBOTTOM() mKodGrMax = Kod_atr SELECT Opis_ScKD APPEND BLANK REPLACE KOD_OpSc WITH 0 REPLACE NAME_OpSc WITH "ВСЕ ОПИСАТЕЛЬНЫЕ ШКАЛЫ" REPLACE KodGr_min WITH mKodGrMin REPLACE KodGr_max WITH mKodGrMax SELECT Opis_Sc DBGOTOP() DO WHILE .NOT. EOF() mKodOpSc = KOD_OpSc mNameOpSc = NAME_OpSc mKodGrMin = KodGr_min mKodGrMax = KodGr_max SELECT Opis_ScKD APPEND BLANK REPLACE KOD_OpSc WITH mKodOpSc REPLACE NAME_OpSc WITH mNameOpSc REPLACE KodGr_min WITH mKodGrMin REPLACE KodGr_max WITH mKodGrMax SELECT Opis_Sc DBSKIP(1) ENDDO ***** ДИАЛОГ ЗАДАНИЯ ПАРАМЕТРОВ ************** // Если ранее параметры были заданы - скачать массив, иначе сформировать и записать в папке приложения IF .NOT. FILE("_4_2_3.arx") PUBLIC aParKDCls[15] aParKDCls[ 1] = 0 // Код класса левого инф.портрета aParKDCls[ 2] = 0 // Код класса правого инф.портрета aParKDCls[ 3] = 0 // Код оп.шкалы левого инф.портрета aParKDCls[ 4] = 0 // Код оп.шкалы правого инф.портрета aParKDCls[ 5] = .T. // Модель Abs задана для расчетов aParKDCls[ 6] = .T. // Модель Prc1 задана для расчетов aParKDCls[ 7] = .T. // Модель Prc2 задана для расчетов aParKDCls[ 8] = .T. // Модель Inf1 задана для расчетов aParKDCls[ 9] = .T. // Модель Inf2 задана для расчетов aParKDCls[10] = .T. // Модель Inf3 задана для расчетов aParKDCls[11] = .T. // Модель Inf4 задана для расчетов aParKDCls[12] = .T. // Модель Inf5 задана для расчетов aParKDCls[13] = .T. // Модель Inf6 задана для расчетов aParKDCls[14] = .T. // Модель Inf7 задана для расчетов aParKDCls[15] = 999 // Максимальное кол-во отображаемых связей DC_ASave(aParKDCls , "_4_2_3.arx") ELSE aParKDCls = DC_ARestore("_4_2_3.arx") ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE ClassesKD EXCLUSIVE NEW USE Opis_ScKD EXCLUSIVE NEW ****** Подготовка для отображения заданных параметров SELECT ClassesKD DBGOTO(1+aParKDCls[ 1]);mNameCls = Name_Cls PUBLIC mKNClsLeft := 'Класс для левого инф.портрета: ['+ALLTRIM(STR(aParKDCls[ 1], 15))+'] '+ALLTRIM(mNameCls) DBGOTO(1+aParKDCls[ 2]);mNameCls = Name_Cls PUBLIC mKNClsRight := 'Класс для правого инф.портрета: ['+ALLTRIM(STR(aParKDCls[ 2], 15))+'] '+ALLTRIM(mNameCls) DBGOTOP() SELECT Opis_ScKD DBGOTO(1+aParKDCls[ 3]);mNameOpSc = Name_OpSc PUBLIC mKNOpScLeft := 'Описат.шкала для левого инф.портрета: ['+ALLTRIM(STR(aParKDCls[ 3], 15))+'] '+ALLTRIM(mNameOpSc) DBGOTO(1+aParKDCls[ 4]);mNameOpSc = Name_OpSc PUBLIC mKNOpScRight := 'Описат.шкала для правого инф.портрета: ['+ALLTRIM(STR(aParKDCls[ 4], 15))+'] '+ALLTRIM(mNameOpSc) DBGOTOP() Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } PUBLIC aSay[14] mModels = 'Модели, заданные для расчета: ' FlagFirst = .T. FOR j=5 TO 14 IF aParKDCls[ j] mModels = mModels+IF(FlagFirst,"",", ")+Ar_Model[j-4] FlagFirst = .F. ENDIF NEXT /* ----- Create browse ----- */ @ 0,0 DCGROUP oGroup1 CAPTION L('Выбор классов для когнитивной диаграммы') SIZE 135,14.5 @ 1,2 DCSAY L('Задайте коды двух классов, для левого и правого информационных портретов когнитивной диаграммы') PARENT oGroup1 SIZE 0 FONT "10.Helv Bold" COLOR GRA_CLR_DARKBLUE @ 2,2 DCSAY L('по очереди выбирая их курсором в таблице и кликая на соответствующей кнопке ниже нее' ) PARENT oGroup1 SIZE 0 FONT "10.Helv Bold" COLOR GRA_CLR_DARKBLUE @ 3,2 DCBROWSE oBrowse ALIAS 'ClassesKD' SIZE 131,9 HEADLINES 1 PARENT oGroup1 // Кол-во строк в заголовке (перенос строки - ";") DCBROWSECOL FIELD ClassesKD->Kod_cls HEADER L('Код') PARENT oBrowse WIDTH 5 PROTECT {|| .T. } DCBROWSECOL FIELD ClassesKD->Name_cls HEADER L('Наименование класса') PARENT oBrowse WIDTH 75 PROTECT {|| .T. } DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE @ 12.5, 15 DCPUSHBUTTON CAPTION L('Выбор кода класса левого инф.портрета') SIZE 2+LEN(L("Выбор кода класса левого инф.портрета")), 1.1 ACTION {||KodClsLeft(aParKDCls) , DC_GetRefresh(GetList)} PARENT oGroup1 @ DCGUI_ROW, DCGUI_COL+150 DCPUSHBUTTON CAPTION L('Выбор кода класса правого инф.портрета') SIZE 2+LEN(L("Выбор кода класса правого инф.портрета")), 1.1 ACTION {||KodClsRight(aParKDCls), DC_GetRefresh(GetList)} PARENT oGroup1 /* ----- Create browse ----- */ @15,0 DCGROUP oGroup2 CAPTION L('Выбор способа фильтрации признаков в информационных портретах когнитивной диаграммы') SIZE 135,14.5 @ 1,2 DCSAY L('Задайте коды двух описательных шкал, для левого и правого информационных портретов когнитивной') PARENT oGroup2 SIZE 0 FONT "10.Helv Bold" COLOR GRA_CLR_DARKRED @ 2,2 DCSAY L('диаграммы по очереди выбирая их курсором в таблице и кликая на соответствующей кнопке ниже нее') PARENT oGroup2 SIZE 0 FONT "10.Helv Bold" COLOR GRA_CLR_DARKRED @ 3,2 DCBROWSE oBrowse ALIAS 'Opis_ScKD' SIZE 131,9 HEADLINES 2 PARENT oGroup2 // Кол-во строк в заголовке (перенос строки - ";") DCBROWSECOL FIELD Opis_ScKD->KOD_OpSc HEADER L('Код' ) PARENT oBrowse WIDTH 5 PROTECT {|| .T. } DCBROWSECOL FIELD Opis_ScKD->NAME_OpSc HEADER L('Наименование;описательной шкалы') PARENT oBrowse WIDTH 58.7 PROTECT {|| .T. } DCBROWSECOL FIELD Opis_ScKD->KodGr_min HEADER L('Минимальный; код градации' ) PARENT oBrowse WIDTH 7 PROTECT {|| .T. } DCBROWSECOL FIELD Opis_ScKD->KodGr_max HEADER L('Максимальный;код градации' ) PARENT oBrowse WIDTH 8 PROTECT {|| .T. } DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE @ 12.5, 10 DCPUSHBUTTON CAPTION L('Выбор кода описательной шкалы левого инф.портрета') SIZE 2+LEN(L("Выбор кода описательной шкалы левого инф.портрета")), 1.1 ACTION {||KodOpScLeft(aParKDCls) , DC_GetRefresh(GetList)} PARENT oGroup2 @ DCGUI_ROW, DCGUI_COL+70 DCPUSHBUTTON CAPTION L('Выбор кода описательной шкалы правого инф.портрета') SIZE 2+LEN(L("Выбор кода описательной шкалы правого инф.портрета")), 1.1 ACTION {||KodOpScRight(aParKDCls), DC_GetRefresh(GetList)} PARENT oGroup2 /* ----- Create ToolBar ----- */ @30,0 DCGROUP oGroup3 CAPTION L('Задайте модели, в которых проводить расчеты когнитивных диаграмм') SIZE 94,2.7 // ABS, PRC1, PRC2, INF# <<<===########################## FOR j=5 TO 14;aParKDCls[j]=.F.;NEXT;aParKDCls[10]=.T. D = 4 @ 1, 2 DCCHECKBOX aParKDCls[ 5] PROMPT L('Abs' ) ACTION {||TakeModels423(), DC_GetRefresh(GetList)} PARENT oGroup3 @ DCGUI_ROW, DCGUI_COL+D DCCHECKBOX aParKDCls[ 6] PROMPT L('Prc1') ACTION {||TakeModels423(), DC_GetRefresh(GetList)} PARENT oGroup3 @ DCGUI_ROW, DCGUI_COL+D DCCHECKBOX aParKDCls[ 7] PROMPT L('Prc2') ACTION {||TakeModels423(), DC_GetRefresh(GetList)} PARENT oGroup3 @ DCGUI_ROW, DCGUI_COL+D DCCHECKBOX aParKDCls[ 8] PROMPT L('Inf1') ACTION {||TakeModels423(), DC_GetRefresh(GetList)} PARENT oGroup3 @ DCGUI_ROW, DCGUI_COL+D DCCHECKBOX aParKDCls[ 9] PROMPT L('Inf2') ACTION {||TakeModels423(), DC_GetRefresh(GetList)} PARENT oGroup3 @ DCGUI_ROW, DCGUI_COL+D DCCHECKBOX aParKDCls[10] PROMPT L('Inf3') ACTION {||TakeModels423(), DC_GetRefresh(GetList)} PARENT oGroup3 // ПО УМОЛЧАНИЮ ТОЛЬКО В INF3 @ DCGUI_ROW, DCGUI_COL+D DCCHECKBOX aParKDCls[11] PROMPT L('Inf4') ACTION {||TakeModels423(), DC_GetRefresh(GetList)} PARENT oGroup3 @ DCGUI_ROW, DCGUI_COL+D DCCHECKBOX aParKDCls[12] PROMPT L('Inf5') ACTION {||TakeModels423(), DC_GetRefresh(GetList)} PARENT oGroup3 @ DCGUI_ROW, DCGUI_COL+D DCCHECKBOX aParKDCls[13] PROMPT L('Inf6') ACTION {||TakeModels423(), DC_GetRefresh(GetList)} PARENT oGroup3 @ DCGUI_ROW, DCGUI_COL+D DCCHECKBOX aParKDCls[14] PROMPT L('Inf7') ACTION {||TakeModels423(), DC_GetRefresh(GetList)} PARENT oGroup3 @30,96 DCGROUP oGroup4 CAPTION L('Задайте max количество отображаемых связей:') SIZE 39,2.7 // <<<===########################## @ 1, 2 DCSAY L(" ") GET aParKDCls[15] PICTURE "#########" PARENT oGroup4 @ 1,21.1 DCPUSHBUTTON CAPTION L('Помощь') SIZE 2+LEN(L("Помощь")), 1.1 ACTION {||Help423(), DC_GetRefresh(GetList)} PARENT oGroup4 /* ----- Create ToolBar ----- */ @33.2,0 DCGROUP oGroup5 CAPTION L('В диалоге заданы следующие параметры расчета когнитивных диаграмм:') SIZE 94,6.5 // <<<===########################## PUBLIC aSay[14] @ 1,2 DCSAY {|| mKNClsLeft } OBJECT aSay[1] SAYSIZE 90 PARENT oGroup5 FONT "10.Helv Bold" COLOR GRA_CLR_DARKBLUE // Класс для левого инф.портрета @ 2,2 DCSAY {|| mKNClsRight } OBJECT aSay[2] SAYSIZE 90 PARENT oGroup5 FONT "10.Helv Bold" COLOR GRA_CLR_DARKBLUE // Класс для левого инф.портрета @ 3,2 DCSAY {|| mKNOpScLeft } OBJECT aSay[3] SAYSIZE 90 PARENT oGroup5 FONT "10.Helv Bold" COLOR GRA_CLR_DARKRED // Оп.шкала для левого инф.портрета @ 4,2 DCSAY {|| mKNOpScRight} OBJECT aSay[4] SAYSIZE 90 PARENT oGroup5 FONT "10.Helv Bold" COLOR GRA_CLR_DARKRED // Оп.шкала для левого инф.портрета FOR j=5 TO 14 @ 5,2 DCSAY {|| mModels } OBJECT aSay[j] SAYSIZE 90 PARENT oGroup5 FONT "10.Helv Bold" COLOR GRA_CLR_BLACK // Модели, заданные для расчета NEXT PUBLIC mPause := 2 @33.2,96 DCGROUP oGroup6 CAPTION L('Задайте режим вывода когнитивных диаграмм:') SIZE 39,6.5 // <<<===########################## @ 1, 2 DCRADIO mPause VALUE 1 PROMPT L('Показать все диаграммы с остановкой') PARENT oGroup6 @ 2, 2 DCRADIO mPause VALUE 2 PROMPT L('Записать все диаграммы без показа ') PARENT oGroup6 DCREAD GUI ; TO lExit ; FIT ; ADDBUTTONS; OPTIONS GetOptions ; MODAL ; TITLE L('4.2.3. Когнитивные диаграммы классов. Задание параметров генерации выходных форм') ******************************************************************** IF lExit ** Button Ok ELSE ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ******************************************************************** DC_ASave(aParKDCls , "_4_2_3.arx") // Записать параметры для расчетов когнитивных диаграмм, заданные в диалоге * DC_DebugQout( aParKDCls ) ***** КОНЕЦ ДИАЛОГА ЗАДАНИЯ ПАРАМЕТРОВ ***************************** ***** РАСЧЕТ БАЗ ДАННЫХ ДЛЯ ОТОБРАЖЕНИЯ КОГНИТИВНЫХ ДИАГРАММ ******* * aParKDCls[ 1] = 0 // Код класса левого инф.портрета * aParKDCls[ 2] = 0 // Код класса правого инф.портрета * aParKDCls[ 3] = 0 // Код оп.шкалы левого инф.портрета * aParKDCls[ 4] = 0 // Код оп.шкалы правого инф.портрета * aParKDCls[ 5] = .T. // Модель Abs задана для расчетов * aParKDCls[ 6] = .T. // Модель Prc1 задана для расчетов * aParKDCls[ 7] = .T. // Модель Prc2 задана для расчетов * aParKDCls[ 8] = .T. // Модель Inf1 задана для расчетов * aParKDCls[ 9] = .T. // Модель Inf2 задана для расчетов * aParKDCls[10] = .T. // Модель Inf3 задана для расчетов * aParKDCls[11] = .T. // Модель Inf4 задана для расчетов * aParKDCls[12] = .T. // Модель Inf5 задана для расчетов * aParKDCls[13] = .T. // Модель Inf6 задана для расчетов * aParKDCls[14] = .T. // Модель Inf7 задана для расчетов * aParKDCls[15] = 999 // Максимальное кол-во отображаемых связей ** ПОДГОТОВКА ПРЕДЕЛОВ ЦИКЛОВ ПО КЛАССАМ ЛЕВОГО И ПРАВОГО ИНФОРМАЦИОННЫХ ПОРТРЕТОВ * Если aParKDCls[ 1] = 0, то цикл по классам от 1-го до последнего, какие есть в БД Classes.dbf * иначе цикл от класса с кодом aParKDCls[ 1] до класса с кодом aParKDCls[ 1] mLenNameMax = CreateStructAll() // Создание файлов структур баз данных всех моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() SELECT Classes IF aParKDCls[ 1] = 0 DBGOTOP() mCls1Left = Kod_cls DBGOBOTTOM() mCls2Left = Kod_cls ELSE mCls1Left = aParKDCls[ 1] mCls2Left = aParKDCls[ 1] ENDIF * Если aParKDCls[ 2] = 0, то цикл по классам от 1-го до последнего, какие есть в БД Classes.dbf * иначе цикл от класса с кодом aParKDCls[ 2] до класса с кодом aParKDCls[ 2] IF aParKDCls[ 2] = 0 DBGOTOP() mCls1Right = Kod_cls DBGOBOTTOM() mCls2Right = Kod_cls ELSE mCls1Right = aParKDCls[ 2] mCls2Right = aParKDCls[ 2] ENDIF ***** Окрыть текстовые базы данных моделей * ########################################################################### // Открытие текстовых баз данных ******************************************** *DC_ASave(aInfStruct, "_InfStruct.arx") // Когда БД создается - записывать структуру, когда открывается - считывать aInfStruct := DC_ARestore("_InfStruct.arx") *DC_ASave(aStrEmpty, "_aStrEmpty.arx") // Записывать только после расчета Abs.txt, а при расчете остальных БД только считывать *DC_ASave(aColEmpty, "_aColEmpty.arx") aStrEmpty = DC_ARestore("_aStrEmpty.arx") aColEmpty = DC_ARestore("_aColEmpty.arx") ************************************************* ***** Формирование пустой записи N_Col = N_Cls+6 // Число полей CrLf = CHR(13)+CHR(10) // Конец строки (записи) Lc_buf = "" FOR j=1 TO N_Col * S = IF(j=2*INT(j/2),"#","X") // Для отладки S = " " // Для работы Lc_buf = Lc_buf + REPLICATE(S, aInfStruct[j,3]) NEXT Lc_buf = Lc_buf + CrLf PUBLIC Len_LcBuf := LEN(Lc_buf) ****** Открываем стат.базы и базы знаний (7 по частным критериям знаний) Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } PUBLIC nHandle[LEN(Ar_Model)] FOR z=1 TO LEN(Ar_Model) nHandle[z] := FOpen( Ar_Model[z]+".txt", FO_READWRITE ) // Открыть ВСЕ текстовые базы данных ######################################## NEXT **** Рассчет массива начальных позиций полей в строке PUBLIC aPos[N_Col] aPos[1] = 1 FOR j=2 TO N_Col aPos[j] = aPos[j-1] + aInfStruct[j-1,3] NEXT * ########################################################################### ***** Определение максимальной длины наименования описательной шкалы CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Opis_Sc EXCLUSIVE NEW mLenMaxOpSc = -999999 SELECT Opis_Sc DBGOTOP() DO WHILE .NOT. EOF() mLenMaxOpSc = MAX(mLenMaxOpSc, LEN(ALLTRIM(Name_OpSc))) DBSKIP(1) ENDDO ***** Определение максимальной длины наименования градации описательной шкалы CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Gr_OpSc EXCLUSIVE NEW mLenMaxGrOS = -999999 SELECT Gr_OpSc DBGOTOP() DO WHILE .NOT. EOF() mLenMaxGrOS = MAX(mLenMaxGrOS, LEN(ALLTRIM(Name_GrOS))) DBSKIP(1) ENDDO ***** Определение максимальной длины полного наименования признака: шкала+признак CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Attributes EXCLUSIVE NEW mLenMax = -999999 SELECT Attributes DBGOTOP() DO WHILE .NOT. EOF() mLenMax = MAX(mLenMax, LEN(ALLTRIM(Name_atr))) DBSKIP(1) ENDDO // Сформировать пустую БД InfPortCls, как часть БД Attributes aStr := { { "Kod_atr" , "N", 15, 0 }, ; { "Name_atr" , "C", mLenMax, 0 }, ; { "Znach" , "N", 19, 7 }, ; { "Kod_OpSc" , "N", 15, 0 }, ; { "Fltr_Wind", "C", 1, 0 } } // Для фильтра "Вписать в окно" DbCreate( "InfPortCls", aStr ) Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } *mMax423 = (mCls2Left - mCls1Left + 1) * (mCls2Right - mCls1Right + 1) *mTime423 = 0 *@ 4,5 DCPROGRESS oProgress SIZE 70,1.1 MAXCOUNT mMax423 COLOR GRA_CLR_CYAN PERCENT EVERY 100 *DCREAD GUI TITLE L('4.2.3. Когнитивные диаграммы классов. Генерация выходных форм') PARENT @oDialog FIT EXIT *oDialog:show() *DC_GetProgress(oProgress,0,mMax423) PUBLIC X_MaxW := 1800, Y_MaxW := 900 // Размер графического окна для отображения когнитивных диаграмм в пикселях aFonts := XbpFont():new():list() // Загрузка всех графических шрифтов mNCognDiagrCls = 0 FOR mClsLeft = mCls1Left TO mCls2Left // ЦИКЛ ПО КЛАССАМ ЛЕВОГО ИНФОРМАЦИОННОГО ПОРТРЕТА *********** DC_ASave(mClsLeft, "_ClsLeft.arx") // Код левого класса FOR mClsRight = mCls1Right TO mCls2Right // ЦИКЛ ПО КЛАССАМ ПРАВОГО ИНФОРМАЦИОННОГО ПОРТРЕТА ********** DC_ASave(mClsRight, "_ClsRight.arx") // Код правого класса FOR mNumMod = 1 TO LEN(Ar_Model) // ЦИКЛ ПО ВСЕМ МОДЕЛЯМ ************************************** IF aParKDCls[mNumMod+4] // ПРОВЕРКА НА ТО, ЗАДАНА ЛИ ОЧЕРЕДНАЯ МОДЕЛЬ **************** * mNumMod = DC_ARestore("_NumMod.arx") DC_ASave(mNumMod, "_NumMod.arx") ***** ГЕНЕРАЦИЯ ИНФОРМАЦИОННЫХ ПОРТРЕТОВ КЛАССОВ mClsLeft и mClsRight ***** Генерация информационного портрета класса в модели: Ar_Model[M_CurrInf] для класса mCls mMod = Ar_Model[mNumMod] // Наименование БД левого инф.портрета в текущей модели mPrtClsLeftMod = "PrtClsLeft" +Ar_Model[mNumMod] // Наименование БД левого инф.портрета в текущей модели mPrtClsRightMod = "PrtClsRight"+Ar_Model[mNumMod] // Наименование БД правого инф.портрета в текущей модели CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW USE InfPortCls EXCLUSIVE NEW InfPortCls423(mNumMod, mClsLeft) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций COPY FILE ("InfPortCls.dbf") TO (mPrtClsLeftMod+".dbf") CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW USE InfPortCls EXCLUSIVE NEW InfPortCls423(mNumMod, mClsRight) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций COPY FILE ("InfPortCls.dbf") TO (mPrtClsRightMod+".dbf") ***** Если не заданы все описательные шкалы, ***** то исключение из потрета тех признаков, ***** которые не попадают в заданные шкалы. ***** Сделать это и для левого, и для правого инф.портретов * aParKDCls[ 3] = 0 // Код оп.шкалы левого инф.портрета * aParKDCls[ 4] = 0 // Код оп.шкалы правого инф.портрета IF aParKDCls[ 3] <> 0 CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mPrtClsLeftMod) EXCLUSIVE NEW DELETE FOR Kod_OpSc <> aParKDCls[ 3] PACK ENDIF IF aParKDCls[ 4] <> 0 CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mPrtClsRightMod) EXCLUSIVE NEW DELETE FOR Kod_OpSc <> aParKDCls[ 4] PACK ENDIF ******* Формирование массивов кодов признаков, которые встречаются ******* хотя бы в одном из портретов и, заодно, расчет средних и ср.кв.откл. CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mMod) EXCLUSIVE NEW USE Opis_Sc EXCLUSIVE NEW USE Gr_OpSc EXCLUSIVE NEW USE (mPrtClsLeftMod) EXCLUSIVE NEW USE (mPrtClsRightMod) EXCLUSIVE NEW aKodAtr1 := {} aKodOpSc1 := {} aNameAtr1 := {} aNameOpSc1 := {} aNameGrOS1 := {} aInfAtr1 := {} SELECT (mPrtClsLeftMod) INDEX ON STR(Kod_atr,15) TO PrtClsLeft DBGOTOP() mN1 = RECCOUNT() DO WHILE .NOT. EOF() mKodAtr1 = Kod_atr mKodOpSc1 = Kod_OpSc mNameAtr1 = Name_atr mZnach1 = Znach SELECT Opis_Sc DBGOTO(mKodOpSc1) mNameOpSc1 = Name_OpSc SELECT Gr_OpSc DBGOTO(mKodAtr1) mNameGrOS1 = Name_GrOS AADD(aKodAtr1 , mKodAtr1 ) AADD(aKodOpSc1 , mKodOpSc1 ) AADD(aNameAtr1 , DelZeroNameGr(mNameAtr1) ) AADD(aNameOpSc1, mNameOpSc1) AADD(aNameGrOS1, DelZeroNameGr(mNameGrOS1)) AADD(aInfAtr1 , mZnach1 ) SELECT (mPrtClsLeftMod) DBSKIP(1) ENDDO aKodAtr2 := {} aKodOpSc2 := {} aNameAtr2 := {} aNameOpSc2 := {} aNameGrOS2 := {} aInfAtr2 := {} SELECT (mPrtClsRightMod) INDEX ON STR(Kod_atr,15) TO PrtClsRight DBGOTOP() mN2 = RECCOUNT() DO WHILE .NOT. EOF() mKodAtr2 = Kod_atr mKodOpSc2 = Kod_OpSc mNameAtr2 = Name_atr mZnach2 = Znach SELECT Opis_Sc DBGOTO(mKodOpSc2) mNameOpSc2 = Name_OpSc SELECT Gr_OpSc DBGOTO(mKodAtr2) mNameGrOS2 = Name_GrOS AADD(aKodAtr2 , mKodAtr2 ) AADD(aKodOpSc2 , mKodOpSc2 ) AADD(aNameAtr2 , DelZeroNameGr(mNameAtr2) ) AADD(aNameOpSc2, mNameOpSc2) AADD(aNameGrOS2, DelZeroNameGr(mNameGrOS2)) AADD(aInfAtr2 , mZnach2 ) SELECT (mPrtClsRightMod) DBSKIP(1) ENDDO ***** СОЗДАТЬ БД СВЯЗЕЙ КЛАССОВ ДЛЯ ТЕКУЩЕЙ МОДЕЛИ ************* CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций aStr := { { "Kod_atr" , "N", 15, 0},; { "Kod_OpSc", "N", 15, 0},; { "Name_atr", "C", mLenMax, 0} } FOR j=1 TO LEN(aKodAtr2) FieldName = "P"+ALLTRIM(STR(aKodAtr2[j],15)) AADD( aStr, { FieldName, "N", 19, 7 } ) NEXT mRelClsModi = "RelCls"+Ar_Model[mNumMod]+"i" mRelClsModp = "RelCls"+Ar_Model[mNumMod]+"p" mRelClsMods = "RelCls"+Ar_Model[mNumMod]+"s" DbCreate( mRelClsModi, aStr ) DbCreate( mRelClsModp, aStr ) DbCreate( mRelClsMods, aStr ) *** Заполнить БД связей mSxodAtrMod = "SxodAtr"+Ar_Model[mNumMod] CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mMod) EXCLUSIVE NEW USE (mRelClsModi) EXCLUSIVE NEW USE (mRelClsModp) EXCLUSIVE NEW USE (mRelClsMods) EXCLUSIVE NEW USE (mPrtClsLeftMod) INDEX PrtClsLeft EXCLUSIVE NEW USE (mPrtClsRightMod) INDEX PrtClsRight EXCLUSIVE NEW USE (mSxodAtrMod) EXCLUSIVE NEW FOR i=1 TO LEN(aKodAtr1) SELECT (mRelClsModi) APPEND BLANK REPLACE Kod_atr WITH aKodAtr1 [i] REPLACE Kod_OpSc WITH aKodOpSc1[i] REPLACE Name_atr WITH DelZeroNameGr(aNameAtr1[i]) SELECT (mRelClsModp) APPEND BLANK REPLACE Kod_atr WITH aKodAtr1 [i] REPLACE Kod_OpSc WITH aKodOpSc1[i] REPLACE Name_atr WITH DelZeroNameGr(aNameAtr1[i]) SELECT (mRelClsMods) APPEND BLANK REPLACE Kod_atr WITH aKodAtr1 [i] REPLACE Kod_OpSc WITH aKodOpSc1[i] REPLACE Name_atr WITH DelZeroNameGr(aNameAtr1[i]) SELECT (mMod) DBGOTO(aKodAtr1[i]) mSr1 = FIELDGET(N_Cls+4) mDi1 = FIELDGET(N_Cls+5) ****** Расчет силы связи в стандартизированных величинах (точно как коэффициент корреляции, только не два, а три массива) FOR j=1 TO LEN(aKodAtr2) SELECT (mSxodAtrMod) DBGOTO(aKodAtr1[i]) mK12 = 0.01*FIELDGET(3+aKodAtr2[j]) SELECT (mMod) DBGOTO(aKodAtr2[j]) mSr2 = FIELDGET(N_Cls+4) mDi2 = FIELDGET(N_Cls+5) mTeorMaxInf = LOG(N_Cls)/LOG(2) // Теоретически максимальная информативность mInfPerTM1 = aInfAtr1[i]/mTeorMaxInf*100 // Информативность 1-го пр.в % от теор.MAX-возможной mInfPerTM2 = aInfAtr2[j]/mTeorMaxInf*100 // Информативность 2-го пр.в % от теор.MAX-возможной mInfStand1 = (aInfAtr1[i]-mSr1)/mDi1 // Информативность 1-го пр.в стандартизированных величинах mInfStand2 = (aInfAtr2[j]-mSr2)/mDi2 // Информативность 2-го пр.в стандартизированных величинах mRelBit = mK12 * aInfAtr1[i] * aInfAtr2[j] // Сила связи в битах mMaxRelBit = 1 * mTeorMaxInf * mTeorMaxInf // MAX-теоретически возможная сила связи в битах mRelPercTM = mRelBit / mMaxRelBit * 100 // Сила связи в % от теор.MAX-возможной mRelStand = mK12 * mInfStand1 * mInfStand2 / 2 // Сила связи в стандартизированных величинах SELECT (mRelClsModi) FIELDPUT( FIELDNUM("P"+ALLTRIM(STR(aKodAtr2[j],15))), mRelBit ) SELECT (mRelClsModp) FIELDPUT( FIELDNUM("P"+ALLTRIM(STR(aKodAtr2[j],15))), mRelPercTM ) SELECT (mRelClsMods) FIELDPUT( FIELDNUM("P"+ALLTRIM(STR(aKodAtr2[j],15))), mRelStand ) NEXT NEXT ****** Дописать в (mRelClsMod) информационные строки о горизонтальной шапке SELECT (mRelClsModi) APPEND BLANK REPLACE Name_atr WITH 'Имена колонок: P'+REPLICATE("#",100) FOR i=1 TO LEN(aKodAtr2) APPEND BLANK REPLACE Kod_atr WITH aKodAtr2 [i] REPLACE Kod_OpSc WITH aKodOpSc2[i] REPLACE Name_atr WITH DelZeroNameGr(aNameAtr2[i]) NEXT SELECT (mRelClsModp) APPEND BLANK REPLACE Name_atr WITH 'Имена колонок: P'+REPLICATE("#",100) FOR i=1 TO LEN(aKodAtr2) APPEND BLANK REPLACE Kod_atr WITH aKodAtr2 [i] REPLACE Kod_OpSc WITH aKodOpSc2[i] REPLACE Name_atr WITH DelZeroNameGr(aNameAtr2[i]) NEXT SELECT (mRelClsMods) APPEND BLANK REPLACE Name_atr WITH 'Имена колонок: P'+REPLICATE("#",100) FOR i=1 TO LEN(aKodAtr2) APPEND BLANK REPLACE Kod_atr WITH aKodAtr2 [i] REPLACE Kod_OpSc WITH aKodOpSc2[i] REPLACE Name_atr WITH DelZeroNameGr(aNameAtr2[i]) NEXT **** СОЗДАТЬ БАЗУ ДЛЯ ВИЗУАЛИЗАЦИИ ОТНОШЕНИЙ ДВУХ КЛАССОВ (mRelViewClsMod) aStr := { { "Num_pp" , "N", 15, 0 }, ; { "Kod_atr1" , "N", 15, 0 }, ; { "Kod_OpSc1" , "N", 15, 0 }, ; { "Name_OpSc1" , "C", mLenMaxOpSc, 0 }, ; { "Name_GrOS1" , "C", mLenMaxGrOS, 0 }, ; { "Name_Atr1" , "C", mLenMax, 0 }, ; { "Inf_Bit1" , "N", 19, 7 }, ; { "Inf_PerTM1" , "N", 19, 7 }, ; { "Inf_Stand1" , "N", 19, 7 }, ; { "Kod_atr2" , "N", 15, 0 }, ; { "Kod_OpSc2" , "N", 15, 0 }, ; { "Name_OpSc2" , "C", mLenMaxOpSc, 0 }, ; { "Name_GrOS2" , "C", mLenMaxGrOS, 0 }, ; { "Name_Atr2" , "C", mLenMax, 0 }, ; { "Inf_Bit2" , "N", 19, 7 }, ; { "Inf_PerTM2" , "N", 19, 7 }, ; { "Inf_Stand2" , "N", 19, 7 }, ; { "Kor_12" , "N", 19, 7 }, ; { "Rel_bit" , "N", 19, 7 }, ; { "Rel_perTM" , "N", 19, 7 }, ; { "Rel_stand" , "N", 19, 7 }, ; { "Rang1" , "N", 15, 0 }, ; { "Rang2" , "N", 15, 0 } } mRelViewClsMod = "RelViewCls"+Ar_Model[mNumMod] DbCreate( mRelViewClsMod, aStr ) ***** ЗАПОЛНИТЬ БАЗУ ДЛЯ ВИЗУАЛИЗАЦИИ ОТНОШЕНИЙ ДВУХ КЛАССОВ (mRelVClsMod) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mMod) EXCLUSIVE NEW;N_Cls = FCOUNT()-5 USE (mSxodAtrMod) EXCLUSIVE NEW USE (mRelViewClsMod) EXCLUSIVE NEW USE (mPrtClsLeftMod) EXCLUSIVE NEW USE (mPrtClsRightMod) EXCLUSIVE NEW mMaxAbsRel = -99999999 // Фактическая максимальная сила связи FOR i=1 TO LEN(aKodAtr1) SELECT (mMod) DBGOTO(aKodAtr1[i]) mSr1 = FIELDGET(N_Cls+4) mDi1 = FIELDGET(N_Cls+5) FOR j=1 TO LEN(aKodAtr2) SELECT (mSxodAtrMod) DBGOTO(aKodAtr1[i]) mK12 = 0.01*FIELDGET(3+aKodAtr2[j]) // Коэфф.корреляции между признаками, посчитанный по всем признакам ****** Средние и ср.кв.откл.не рассчитывать, а брать из (mMod) SELECT (mMod) DBGOTO(aKodAtr2[j]) mSr2 = FIELDGET(N_Cls+4) mDi2 = FIELDGET(N_Cls+5) IF ABS(mK12) > 0 // Показывать только не нулевые связи (можно задавать порог в диалоге) ******** Расчет показателей mTeorMaxInf = LOG(N_Cls)/LOG(2) // Теоретически максимальная информативность mInfPerTM1 = aInfAtr1[i]/mTeorMaxInf*100 // Информативность 1-го пр.в % от теор.MAX-возможной mInfPerTM2 = aInfAtr2[j]/mTeorMaxInf*100 // Информативность 2-го пр.в % от теор.MAX-возможной mInfStand1 = (aInfAtr1[i]-mSr1)/mDi1 // Информативность 1-го пр.в стандартизированных величинах mInfStand2 = (aInfAtr2[j]-mSr2)/mDi2 // Информативность 2-го пр.в стандартизированных величинах mRelBit = mK12 * aInfAtr1[i] * aInfAtr2[j] // Сила связи в битах mMaxRelBit = 1 * mTeorMaxInf * mTeorMaxInf // MAX-теоретически возможная сила связи в битах mRelPercTM = mRelBit / mMaxRelBit * 100 // Сила связи в % от теор.MAX-возможной mRelStand = mK12 * mInfStand1 * mInfStand2 / 2 // Сила связи в стандартизированных величинах SELECT (mRelViewClsMod) APPEND BLANK REPLACE Kod_atr1 WITH aKodAtr1 [i] REPLACE Kod_OpSc1 WITH aKodOpSc1 [i] REPLACE Name_OpSc1 WITH aNameOpSc1[i] REPLACE Name_GrOS1 WITH DelZeroNameGr(aNameGrOS1[i]) REPLACE Name_atr1 WITH DelZeroNameGr(aNameAtr1 [i]) REPLACE Inf_Bit1 WITH aInfAtr1 [i] REPLACE Inf_PerTM1 WITH mInfPerTM1 REPLACE Inf_stand1 WITH mInfStand1 REPLACE Kod_atr2 WITH aKodAtr2 [j] REPLACE Kod_OpSc2 WITH aKodOpSc2 [j] REPLACE Name_OpSc2 WITH aNameOpSc2[j] REPLACE Name_GrOS2 WITH DelZeroNameGr(aNameGrOS2[j]) REPLACE Name_atr2 WITH DelZeroNameGr(aNameAtr2 [j]) REPLACE Inf_Bit2 WITH aInfAtr2 [j] REPLACE Inf_PerTM2 WITH mInfPerTM2 REPLACE Inf_stand2 WITH mInfStand2 REPLACE Kor_12 WITH mK12 REPLACE Rel_bit WITH mRelBit // Сила связи в Bit REPLACE Rel_perTM WITH mRelPercTM // Сила связи в % от теор.макс.возм. REPLACE Rel_stand WITH mRelStand // Сила связи в стандартизированных величинах ENDIF NEXT NEXT SELECT (mRelViewClsMod) INDEX ON STR(999999.9999999-ABS(Rel_bit),19,7) TO RelViewCls // сделать КД для всех трех видов связей: бит, %бит от ТМ, стандарт. ############### ***** Оставить столько записей с наиболее значимыми связями, ***** чтобы в левом и правом портретах было не более N_Atr признаков mMaxAtrInfPort = 7 // Максимальное количество отображаемых на диаграмме признаков в инф.портрете CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mRelViewClsMod) INDEX RelViewCls EXCLUSIVE NEW SELECT (mRelViewClsMod) SET ORDER TO 1 DBGOTOP() aKodAtr1 := {} // Коды признаков из 1-го портрета AADD(aKodAtr1, STR(999999.9999999-Inf_bit1,19,7)+STR(Kod_atr1,15)) DO WHILE .NOT. EOF() IF ASCAN(aKodAtr1, STR(999999.9999999-Inf_bit1,19,7)+STR(Kod_atr1,15)) = 0 IF LEN(aKodAtr1) < mMaxAtrInfPort AADD(aKodAtr1, STR(999999.9999999-Inf_bit1,19,7)+STR(Kod_atr1,15)) ELSE DELETE ENDIF ENDIF DBSKIP(1) ENDDO DBGOTOP() aKodAtr2 := {} // Коды признаков из 2-го портрета AADD(aKodAtr2, STR(999999.9999999-Inf_bit2,19,7)+STR(Kod_atr2,15)) DO WHILE .NOT. EOF() IF ASCAN(aKodAtr2, STR(999999.9999999-Inf_bit2,19,7)+STR(Kod_atr2,15)) = 0 IF LEN(aKodAtr2) < mMaxAtrInfPort AADD(aKodAtr2, STR(999999.9999999-Inf_bit2,19,7)+STR(Kod_atr2,15)) ELSE DELETE ENDIF ENDIF DBSKIP(1) ENDDO mNum = 0 // Количество связей и порядковые номера DBGOTOP() DO WHILE .NOT. EOF() IF mNum < aParKDCls[15] // Количество отображаемых связей REPLACE Num_pp WITH ++mNum ELSE DELETE ENDIF DBSKIP(1) ENDDO PACK ****** ЕСЛИ БАЗА СВЯЗЕЙ ПУСТА - СООБЩЕНИЕ И ВЫХОД SELECT (mRelViewClsMod) IF RECCOUNT() = 0 * LB_Warning(L('СТРАННО, НО ПРИ ЗАДАННЫХ УСЛОВИЯХ КЛАССЫ НИКАК НЕ СВЯЗАНЫ !!!'), L('4.2.3. Когнитивные диаграммы классов')) * ************************************************************** * ***** БД, открытые перед запуском главного меню * ***** Восстанавливать их после выхода из функций главного меню * ************************************************************** * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы * USE PathGrAp EXCLUSIVE NEW * USE Appls EXCLUSIVE NEW * USE Users EXCLUSIVE NEW * ************************************************************** * Running(.F.) * ReTURN nil ENDIF ***** Прописать ранги признаков и сделать массивы признаков для отображения в КД ############################################################## IF RECCOUNT() > 0 CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mRelViewClsMod) EXCLUSIVE NEW INDEX ON STR(999999.9999999-Inf_bit1,19,7)+STR(Kod_atr1,15) TO RelViewCls1 // Сделать КД для всех трех видов связей: бит, %бит от ТМ, стандарт. mRang1 = 1 DBGOTOP() mOld = STR(999999.9999999-Inf_bit1,19,7)+STR(Kod_atr1,15) DO WHILE .NOT. EOF() IF mOld <> STR(999999.9999999-Inf_bit1,19,7)+STR(Kod_atr1,15) ++mRang1 mOld = STR(999999.9999999-Inf_bit1,19,7)+STR(Kod_atr1,15) ENDIF REPLACE Rang1 WITH mRang1 DBSKIP(1) ENDDO CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mRelViewClsMod) EXCLUSIVE NEW INDEX ON STR(999999.9999999-Inf_bit2,19,7)+STR(Kod_atr2,15) TO RelViewCls2 // Сделать КД для всех трех видов связей: бит, %бит от ТМ, стандарт. mRang2 = 1 DBGOTOP() mOld = STR(999999.9999999-Inf_bit2,19,7)+STR(Kod_atr2,15) DO WHILE .NOT. EOF() IF mOld <> STR(999999.9999999-Inf_bit2,19,7)+STR(Kod_atr2,15) ++mRang2 mOld = STR(999999.9999999-Inf_bit2,19,7)+STR(Kod_atr2,15) ENDIF REPLACE Rang2 WITH mRang2 DBSKIP(1) ENDDO ***** ОТОБРАЖЕНИЕ КОГНИТИВНЫХ ДИАГРАММ ***************************** * @ 2,1 DCSTATIC TYPE XBPSTATIC_TYPE_RECESSEDBOX SIZE X_MaxW, Y_MaxW PIXEL OBJECT oStatic * DCREAD GUI FIT EVAL {||_PresSpace423(oStatic, mClsLeft, mClsRight, mNumMod, aFonts)} ; * TITLE L('4.2.3. Когнитивные диаграммы классов. (C) Универсальная когнитивная аналитическая система "ЭЙДОС-X++"') * oStatic := nil PUBLIC X_MaxW := 1800, Y_MaxW := 900 // Размер графического окна для отображения когнитивных диаграмм в пикселях PUBLIC nXSize := 1800 PUBLIC nYSize := 900 * FOR mClsLeft = mCls1Left TO mCls2Left // ЦИКЛ ПО КЛАССАМ ЛЕВОГО ИНФОРМАЦИОННОГО ПОРТРЕТА *********** * FOR mClsRight = mCls1Right TO mCls2Right // ЦИКЛ ПО КЛАССАМ ПРАВОГО ИНФОРМАЦИОННОГО ПОРТРЕТА ********** * FOR mNumMod = 1 TO LEN(Ar_Model) // ЦИКЛ ПО ВСЕМ МОДЕЛЯМ ************************************** oScr := DC_WaitOn(L('Формируется и записывается когнитивная диаграмма: Левый класс=')+ALLTRIM(STR(mClsLeft))+'/'+ALLTRIM(STR(mCls2Left))+L(', Правый класс=')+ALLTRIM(STR(mClsRight))+'/'+ALLTRIM(STR(mCls2Right))+L(', Модель=')+Ar_Model[mNumMod],,,,,,,,,,,.F.) // Create new bitmap with given size oPS := XBPPRESSPACE() :new() :Create() oBMP := XBPBITMAP() :New() :Create() * oBMP:Make( nXSize, nYSize, nPlanes, nBits ) oBMP:Make( nXSize, nYSize ) oBMP:presSpace( oPS ) // here your GRA* Code **** Закрасить фон прямоугольника *************** * GraSetColor( oPS, GRA_CLR_WHITE, GRA_CLR_WHITE ) GraSetColor( oPS, BD_LIGHTGREY, BD_LIGHTGREY ) GraBox( oPS, { 0, 0 }, { nXSize, nYSize }, GRA_FILL ) *######################################################################################################################### CognDiagrCls( oPS, oBMP, mClsLeft, mClsRight, mNumMod, aFonts ) // Графическая функция <<<===######################### *######################################################################################################################### *My image original, my image scaled ****** Запись полноразмерного графического файла в папку: M_PathAppl+"\CognDiagrCls\" DC_Impl(oScr) IF FILEDATE("CognDiagrCls",16) = CTOD("//") DIRMAKE("CognDiagrCls") aMess := {} AADD(aMess, L('В папке текущего приложения: "'+UPPER(ALLTRIM(M_PathAppl))+'"')) AADD(aMess, L('не было директории "CognDiagrCls" для когнитивных диаграмм классов и она была создана!')) AADD(aMess, L('В эту папку записываются исходные изображения высокого качества (без масштабирования)')) LB_Warning(aMess, L('4.2.3. Когнитивные диаграммы классов' )) ENDIF DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения ****DC_ASave(mClsLeft , "_ClsLeft.arx") // Код левого класса ****DC_ASave(mClsRight, "_ClsRight.arx") // Код правого класса ****DC_ASave(mNumMod , "_NumMod.arx") mClsLeft = DC_ARestore("_ClsLeft.arx") mClsRight = DC_ARestore("_ClsRight.arx") mNumMod = DC_ARestore("_NumMod.arx") DIRCHANGE(M_PathAppl+"\CognDiagrCls\") // Перейти в папку CognDiagrCls cFileName = "CogDiagCls"+STRTRAN(STR(mClsLeft,4)," ","0")+"-"+STRTRAN(STR(mClsRight,4)," ","0")+"-"+STRTRAN(STR(mNumMod,2)," ","0")+".jpg" ERASE(cFileName) oBMP:SaveFile(cFileName,XBPBMP_FORMAT_JPG) IF nWidth > 1800 IF mPause = 1 FullView( cFileName, "по верху", 65 ) // Визуализация полноразмерного файла на мониторе высокого разрешения ENDIF ELSE ****** Формирование с помощью bmp2bmp() и отображение масштабированного изображения aNewSize := {nWidth,nHeight-29} // Новый размер изображения (еще немного уменьшается, чтобы не рисовать по панели задач) oBMP:loadFile(cFileName) // Загрузка полноразмерного изображения oRet := BMP2BMP(oBMP,aNewSize) // Масштабирование изображения cFileNameScale = SUBSTR(cFileName,1,AT(".jpg",cFileName)-1)+"_scaled.jpg" ERASE(cFileNameScale) oRet:saveFile(cFileNameScale,XBPBMP_FORMAT_JPG) // Запись масштабированного графического файла в в папку приложения для визуализации IF mPause = 1 FullView( cFileNameScale, "по верху", 0 ) // Визуализация масштабированного графического файла на мониторе ограниченного разрешения ENDIF ENDIF DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения mNCognDiagrCls++ ENDIF ENDIF // ПРОВЕРКА НА ТО, ЗАДАНА ЛИ ОЧЕРЕДНАЯ МОДЕЛЬ **************** NEXT // ЦИКЛ ПО ВСЕМ МОДЕЛЯМ ************************************** * DC_GetProgress(oProgress, ++mTime423, mMax423) * MsgBox(STR(mTime423)+STR(mClsLeft)+STR(mClsRight)) NEXT // ЦИКЛ ПО КЛАССАМ ПРАВОГО ИНФОРМАЦИОННОГО ПОРТРЕТА ********** NEXT // ЦИКЛ ПО КЛАССАМ ЛЕВОГО ИНФОРМАЦИОННОГО ПОРТРЕТА *********** *DC_GetProgress(oProgress,mMax423,mMax423) *oDialog:Destroy() *** Закрыть все текстовые БД ****** FOR z=1 TO LEN(Ar_Model) FClose( nHandle[z] ) // Закрытие текстовой базы данных ###################################### NEXT aMess := {} AADD(aMess, L('Процесс генерации')+IF(mPause=1,L(', визуализации'),'')+' '+L(' и записи когнитивных диаграмм')) AADD(aMess, L('содержательного сравнения классов успешно звершен !!!')) AADD(aMess, L('')) AADD(aMess, L('В папку: "')+M_PathAppl+'CognDiagrCls\"'+' '+L('сохранено')+' '+ALLTRIM(STR(mNCognDiagrCls))+' '+L('диаграмм.')) LB_Warning(aMess, L('4.2.3. Когнитивные диаграммы классов')) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) ReTURN nil **************************************************************************************** ************************************************************************************************** FUNCTION Help423() aHelp := {} AADD(aHelp, L(' Данный режим формирует и отображает в графической форме когнитивные диаграммы, т.е. ')) AADD(aHelp, L(' автоматизирует содержательное сравнение двух информационных портретов обобщенных образов классов распознавания: ')) AADD(aHelp, L(' ')) AADD(aHelp, L('1. Формируются информационные портреты двух классов. ')) AADD(aHelp, L('2. Выявляются признаки, которые есть по крайней мере в одном из портретов. Такие признаки называются СВЯЗЯМИ, т.к. благодаря')) AADD(aHelp, L(' им существуют определенные ОТНОШЕНИЯ сходства/различия между обобщенными образами классов. ')) AADD(aHelp, L('3. Для каждого признака известно, какое количество информации о принадлежности объекта к данному классу он содержит. ')) AADD(aHelp, L('4. Кроме того для любых двух признаков известно, насколько они являются сходными по смыслу (из матрицы сходства признаков). ')) AADD(aHelp, L('5. Будем считать, что любые два признака вносят определенный вклад в сходство или различие двух классов распознавания, ')) AADD(aHelp, L(' определяемый по формулам: ')) AADD(aHelp, L(' ')) AADD(aHelp, L(' mTeorMaxInf = LOG(N_Cls)/LOG(2) // Теоретически максимальная информативность ')) AADD(aHelp, L(' ')) AADD(aHelp, L(' mInfPerTM1 = aInfAtr1[i]/mTeorMaxInf*100 // Информативность 1-го пр.в % от теор.MAX-возможной ')) AADD(aHelp, L(' mInfPerTM2 = aInfAtr2[j]/mTeorMaxInf*100 // Информативность 2-го пр.в % от теор.MAX-возможной ')) AADD(aHelp, L(' ')) AADD(aHelp, L(' mInfStand1 = (aInfAtr1[i]-mSr1)/mDi1 // Информативность 1-го пр.в стандартизированных величинах ')) AADD(aHelp, L(' mInfStand2 = (aInfAtr2[j]-mSr2)/mDi2 // Информативность 2-го пр.в стандартизированных величинах ')) AADD(aHelp, L(' ')) AADD(aHelp, L(' mRelBit = mK12 * aInfAtr1[i] * aInfAtr2[j] // Сила связи в битах ')) AADD(aHelp, L(' ')) AADD(aHelp, L(' mMaxRelBit = 1 * mTeorMaxInf * mTeorMaxInf // MAX-теоретически возможная сила связи в битах ')) AADD(aHelp, L(' ')) AADD(aHelp, L(' mRelPercTM = mRelBit / mMaxRelBit * 100 // Сила связи в % от теор.MAX-возможной ')) AADD(aHelp, L(' ')) AADD(aHelp, L(' mRelStand = mK12 * mInfStand1 * mInfStand2 / 2 // Сила связи в стандартизированных величинах ')) AADD(aHelp, L(' ')) AADD(aHelp, L(' Где: ')) AADD(aHelp, L(' - mSr1 - средняя информативность 1-го признака; ')) AADD(aHelp, L(' - mSr2 - средняя информативность 2-го признака; ')) AADD(aHelp, L(' - mDi1 - среднеквадратичное отклонение информативносттей 1-го признака; ')) AADD(aHelp, L(' - mDi2 - среднеквадратичное отклонение информативносттей 1-го признака; ')) AADD(aHelp, L(' - mK12 - сходство 1-го и 2-го классов по их системе детерминации из матрицы сходства классов. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('6. На диаграмме отображается 7 признаков, образующих наиболее значимые по модулю связи. Знак связи изображается цветом: ')) AADD(aHelp, L(' красный "+", синий "-", а величина-толщиной линии. ')) mHelpMax = -999;FOR h=1 TO LEN(aHelp);mHelpMax = MAX(mHelpMax, LEN(ALLTRIM(aHelp[h])));NEXT s=1;d=0.9;@0,0 DCGROUP oGroup1 CAPTION L(' ') SIZE mHelpMax-20, LEN(aHelp)*d+1.5 FOR h=1 TO LEN(aHelp);@s,2 DCSAY aHelp[h] SIZE 0 PARENT ogroup1;s=s+d;NEXT DCREAD GUI TO lExit FIT TITLE L('Помощь по режиму: 4.2.3. (C) Система "ЭЙДОС-X++"') RETURN NIL ************************************************************************************************** ******** Выбор кода класса левого инф.портрета FUNCTION KodClsLeft(aParKDCls) SELECT ClassesKD PUBLIC mKNClsLeft := 'Класс для левого инф.портрета: ['+ALLTRIM(STR(Kod_Cls, 15))+'] '+ALLTRIM(Name_Cls) aParKDCls[ 1] = Kod_Cls // Код класса левого инф.портрета DC_ASave(aParKDCls , "_4_2_3.arx") // Записать параметры для расчетов когнитивных диаграмм, заданные в диалоге ReTURN nil *************************************** FUNCTION KodClsRight(aParKDCls) SELECT ClassesKD PUBLIC mKNClsRight := 'Класс для правого инф.портрета: ['+ALLTRIM(STR(Kod_Cls, 15))+'] '+ALLTRIM(Name_Cls) aParKDCls[ 2] = Kod_Cls // Код класса правого инф.портрета DC_ASave(aParKDCls , "_4_2_3.arx") // Записать параметры для расчетов когнитивных диаграмм, заданные в диалоге ReTURN nil *************************************** FUNCTION KodOpScLeft(aParKDCls) SELECT Opis_ScKD PUBLIC mKNOpScLeft := 'Описательная шкала для левого инф.портрета: ['+ALLTRIM(STR(Kod_OpSc, 15))+'] '+ALLTRIM(Name_OpSc) aParKDCls[ 3] = Kod_OpSc // Код описательной шкалы левого правого инф.портрета DC_ASave(aParKDCls , "_4_2_3.arx") // Записать параметры для расчетов когнитивных диаграмм, заданные в диалоге ReTURN nil *************************************** FUNCTION KodOpScRight(aParKDCls) SELECT Opis_ScKD PUBLIC mKNOpScRight := 'Описательная шкала для правого инф.портрета: ['+ALLTRIM(STR(Kod_OpSc, 15))+'] '+ALLTRIM(Name_OpSc) aParKDCls[ 4] = Kod_OpSc // Код описательной шкалы левого правого инф.портрета DC_ASave(aParKDCls , "_4_2_3.arx") // Записать параметры для расчетов когнитивных диаграмм, заданные в диалоге ReTURN nil *************************************** FUNCTION TakeModels423() mModels = 'Модели, заданные для расчета: ' FlagFirst = .T. FOR j=5 TO 14 IF aParKDCls[ j] mModels = mModels+IF(FlagFirst,"",", ")+Ar_Model[j-4] FlagFirst = .F. ENDIF NEXT ReTURN nil *************************************** FUNCTION TakeModels433() mModels = 'Модели, заданные для расчета: ' FlagFirst = .T. FOR j=5 TO 14 IF aParKDAtr[ j] mModels = mModels+IF(FlagFirst,"",", ")+Ar_Model[j-4] FlagFirst = .F. ENDIF NEXT ReTURN nil ******** Формирование минимального и максимального кодов градаций описательных шкал FUNCTION MinMaxGrOpSc() IF .NOT. FILE("Attributes.dbf") ReTURN nil ENDIF IF .NOT. FILE("Opis_Sc.dbf") ReTURN nil ENDIF *USE Opis_Sc EXCLUSIVE NEW *USE Attributes EXCLUSIVE NEW *SELECT Attributes Attributes->(DBGOTOP()) mKodGrMin = Attributes->Kod_atr mKodGrMax = Attributes->Kod_atr mKodOpSc = Attributes->Kod_OpSc DO WHILE .NOT. Attributes->(EOF()) IF mKodOpSc = Attributes->Kod_OpSc mKodGrMax = Attributes->Kod_atr ELSE * SELECT Opis_Sc Opis_Sc->(DBGOTO(mKodOpSc)) REPLACE Opis_Sc->KodGr_min WITH mKodGrMin REPLACE Opis_Sc->KodGr_max WITH mKodGrMax REPLACE Opis_Sc->N_GrOpSc WITH mKodGrMax-mKodGrMin+1 * SELECT Attributes mKodGrMin = Attributes->Kod_atr mKodOpSc = Attributes->Kod_OpSc ENDIF Attributes->(DBSKIP(1)) ENDDO *SELECT Opis_Sc Opis_Sc->(DBGOTO(mKodOpSc)) REPLACE Opis_Sc->KodGr_min WITH mKodGrMin REPLACE Opis_Sc->KodGr_max WITH mKodGrMax REPLACE Opis_Sc->N_GrOpSc WITH mKodGrMax-mKodGrMin+1 *CLOSE Opis_Sc *CLOSE Attributes ReTURN nil ******** Формирование минимального и максимального кодов градаций классификационных шкал FUNCTION MinMaxGrClSc() aMinMaxGr := DC_DataSave() // Сохранение вычислительной среды (открытые и текущие БД и индексы) *DC_DataRest( aMinMaxGr ) // Восстановление вычислительной среды (открытые и текущие БД и индексы) IF .NOT. FILE("Classes.dbf") ReTURN nil ENDIF IF .NOT. FILE("Class_Sc.dbf") ReTURN nil ENDIF *USE Class_Sc EXCLUSIVE NEW *USE Classes EXCLUSIVE NEW *SELECT Classes Classes->(DBGOTOP()) mKodGrMin = Classes->Kod_cls mKodGrMax = Classes->Kod_cls mKodClSc = Classes->Kod_ClSc DO WHILE .NOT. Classes->(EOF()) IF mKodClSc = Classes->Kod_ClSc mKodGrMax = Classes->Kod_cls ELSE * SELECT Class_Sc Class_Sc->(DBGOTO(mKodClSc)) REPLACE Class_Sc->KodGr_min WITH mKodGrMin REPLACE Class_Sc->KodGr_max WITH mKodGrMax REPLACE Class_Sc->N_GrClSc WITH mKodGrMax-mKodGrMin+1 * SELECT Classes mKodGrMin = Classes->Kod_cls mKodClSc = Classes->Kod_ClSc ENDIF Classes->(DBSKIP(1)) ENDDO *SELECT Class_Sc Class_Sc->(DBGOTO(mKodClSc)) REPLACE Class_Sc->KodGr_min WITH mKodGrMin REPLACE Class_Sc->KodGr_max WITH mKodGrMax REPLACE Class_Sc->N_GrClSc WITH mKodGrMax-mKodGrMin+1 *CLOSE Class_Sc *CLOSE Classes *aMinMaxGr := DC_DataSave() // Сохранение вычислительной среды (открытые и текущие БД и индексы) *DC_DataRest( aMinMaxGr ) // Восстановление вычислительной среды (открытые и текущие БД и индексы) с включенным ADS DC_DataRest() НЕ РАБОТАЕТ ReTURN nil ******** Генерация информационного портрета класса в модели Ar_Model[M_CurrInf] для класса mCls FUNCTION InfPortCls423(M_CurrInf, M_KodCls) SELECT Attributes N_Gos = RECCOUNT() // Заполнить БД InfPortCls записями с кодами и наименованиями признаков и их значимостью SELECT InfPortCls;ZAP FOR i=1 TO N_Gos M_KodAtr = VAL(LC_FieldGet( Ar_Model[M_CurrInf]+".txt", nHandle[M_CurrInf], i, 1 )) M_NameAtr = LC_FieldGet( Ar_Model[M_CurrInf]+".txt", nHandle[M_CurrInf], i, 2 ) M_Znach = VAL(LC_FieldGet( Ar_Model[M_CurrInf]+".txt", nHandle[M_CurrInf], i, 2+M_KodCls )) // Инф.портрет класса M_KodCls IF M_Znach <> 0 SELECT Attributes DBGOTO(M_KodAtr) M_KodOpSc = Kod_OpSc SELECT InfPortCls APPEND BLANK REPLACE Kod_atr WITH M_KodAtr REPLACE Name_atr WITH M_NameAtr REPLACE Kod_OpSc WITH M_KodOpSc REPLACE Znach WITH M_Znach ENDIF NEXT ***** Сортировка InfPortCls по полю Znach по убыванию CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE InfPortCls EXCLUSIVE NEW COPY STRUCTURE TO Temp.dbf CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE InfPortCls EXCLUSIVE NEW INDEX ON STR(999999999.9999999-Znach,19,7) TO InfPortCls CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Temp EXCLUSIVE NEW USE InfPortCls INDEX InfPortCls EXCLUSIVE NEW SELECT InfPortCls SET ORDER TO 1 DBGOTOP() DO WHILE .NOT. EOF() a := {} FOR j=1 TO FCOUNT() AADD(a, FIELDGET(j)) NEXT SELECT Temp APPEND BLANK FOR j=1 TO LEN(a) FIELDPUT(j, a[j]) NEXT SELECT InfPortCls DBSKIP(1) ENDDO CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций ERASE("InfPortCls.dbf") RenameFile( "Temp.dbf", "InfPortCls.dbf" ) ReTURN NIL ************************************************* ************************************************* *STATIC FUNCTION _PresSpace423( oStatic, mClsLeft, mClsRight, mNumMod, aFonts ) * LOCAL oPS, oDevice * oPS := XbpPresSpace():new() // Create a PS * oDevice := oStatic:winDevice() // Get the device context * oPS:create( oDevice ) // Link device context to PS * oPS:SetViewPort( { 0, 0, X_MaxW, Y_MaxW } ) * oStatic:paint := {|mp1,mp2,obj| mp1 := CognDiagrCls( oPS, oStatic, mClsLeft, mClsRight, mNumMod, aFonts ) } *RETURN NIL ********************************************************************************** STATIC FUNCTION CognDiagrCls( oPS, oStatic, mClsLeft, mClsRight, mNumMod, aFonts ) * DC_ASave(mClsLeft , "_ClsLeft.arx") // Код левого класса * DC_ASave(mClsRight, "_ClsRight.arx") // Код правого класса * DC_ASave(mNumMod , "_NumMod.arx") mClsLeft = DC_ARestore("_ClsLeft.arx") mClsRight = DC_ARestore("_ClsRight.arx") mNumMod = DC_ARestore("_NumMod.arx") aParKDCls = DC_ARestore("_4_2_3.arx") // Параметры когнитивной диаграммы * DC_DebugQout( aParKDCls ) W_Wind = X_MaxW / 2 // Полуширина окна для самого графика H_Wind = Y_MaxW / 2 // Полувысота окна для самого графика LY := 70 // Зона над областью графика для наименования и под областью графика для легенды X0 := W_Wind // Начало координат для эллипса по оси X Y0 := H_Wind // Начало координат для эллипса по оси Y IndentLeft = 50 // Отступ слева IndentRight = 50 // Отступ справа Area = ( X_MaxW - IndentLeft - IndentRight ) / 3 // Размер зон левого и правового инф.портретов и связей между ними ***** Закрасить фон прямоугольников *************** ***** Закрасить фон прямоугольника всей зоны изображения GraSetColor( oPS, aColor[98] , aColor[98] ) // Номер цвета в соответствии с _AidosColor.prg GraBox( oPS, { X0-W_Wind, Y0-H_Wind }, { X0+W_Wind, Y0+H_Wind }, GRA_FILL ) ***** Закрасить весь фон прямоугольника зоны изображения левого инф.портрета GraSetColor( oPS, aColor[38] , aColor[38] ) // Номер цвета в соответствии с _AidosColor.prg GraBox( oPS, { IndentLeft+0*Area, Y_MaxW-140 }, { IndentLeft+1*Area, Y0-H_Wind+LY+20 }, GRA_FILL ) ***** Закрасить весь фон прямоугольника зоны связей левого и правого инф.портретов GraSetColor( oPS, aColor[71] , aColor[71] ) // Номер цвета в соответствии с _AidosColor.prg GraBox( oPS, { IndentLeft+1*Area, Y_MaxW-140 }, { IndentLeft+2*Area, Y0-H_Wind+LY+20 }, GRA_FILL ) ***** Закрасить весь фон прямоугольника зоны изображения правого инф.портрета GraSetColor( oPS, aColor[38] , aColor[38] ) // Номер цвета в соответствии с _AidosColor.prg GraBox( oPS, { IndentLeft+2*Area, Y_MaxW-140 }, { IndentLeft+3*Area, Y0-H_Wind+LY+20 }, GRA_FILL ) GraSetColor( oPS, aColor[222] , aColor[222] ) *********** Нарисовать левый и правый голубые прямоугольники для информации о признаках ******** Атрибуты области aAttrBox := ARRAY( GRA_AA_COUNT ) // Определить атрибуты заполнения прямоугольника aAttrBox[ GRA_AA_COLOR ] := GRA_CLR_CYAN GraSetAttrArea( oPS, aAttrBox ) ******** Атрибуты границы области (линии) aAttrLine := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttrLine [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttrLine [ GRA_AL_COLOR ] := GRA_CLR_DARKBLUE // Задать цвет линии aAttrLine [ GRA_AL_WIDTH ] := 2 // Задать толщину линии graSetAttrLine( oPS, aAttrLine ) // Установить атрибуты BoxWidth = 140 // Ширина прямоугольника CYAN в пикселях graBox( oPS, { IndentLeft+1*Area-BoxWidth/2, Y_MaxW-140 }, {IndentLeft+1*Area+BoxWidth/2, Y0-H_Wind+LY+20}, GRA_OUTLINEFILL, 7, 7 ) // Прямоугольник очерчен, заполнен и закруглен graBox( oPS, { IndentLeft+2*Area-BoxWidth/2, Y_MaxW-140 }, {IndentLeft+2*Area+BoxWidth/2, Y0-H_Wind+LY+20}, GRA_OUTLINEFILL, 7, 7 ) // Прямоугольник очерчен, заполнен и закруглен ***** Нарисовать рамку изображения и отделить место для легенды ******************* aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты ****** Начало координат в центре рисунка * GraArc ( oPS, { X0, Y0 }, 2 ) // Начало координат GraLine( oPS, {X0-W_Wind+1, Y0-H_Wind+1}, {X0-W_Wind+1, Y0+H_Wind-1} ) // Нарисовать границу рамки изображения слева GraLine( oPS, {X0+W_Wind-1, Y0-H_Wind+1}, {X0+W_Wind-1, Y0+H_Wind-1} ) // Нарисовать границу рамки изображения справа GraLine( oPS, {X0-W_Wind+1, Y0-H_Wind+1}, {X0+W_Wind-1, Y0-H_Wind+1} ) // Нарисовать границу рамки изображения внизу параллельно оси X GraLine( oPS, {X0-W_Wind+1, Y0+H_Wind-1}, {X0+W_Wind-1, Y0+H_Wind-1} ) // Нарисовать границу рамки изображения вверху параллельно оси X GraLine( oPS, {X0-W_Wind+1, Y0-H_Wind+LY}, {X0+W_Wind-1, Y0-H_Wind+LY} ) // Нарисовать границу рамки легенды на уровне LY параллельно оси X **** Написать заголовок диаграммы aFonts := XbpFont():new():list() // Все доступные шрифты oFont := XbpFont():new():create("22.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraStringAt( oPS, { X_MaxW/2, Y_MaxW-20 }, 'КОГНИТИВНАЯ ДИАГРАММА КЛАССОВ В МОДЕЛИ: "'+UPPER(Ar_Model[mNumMod])+'"' ) oFont := XbpFont():new():create("18.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) IF LEN(ALLTRIM(M_NameAppl)) < 70 GraStringAt( oPS, { X_MaxW/2, Y_MaxW-52 }, "Приложение: "+'"'+ALLTRIM(M_NameAppl)+'"' ) ELSE GraStringAt( oPS, { X_MaxW/2, Y_MaxW-52 }, '"'+ALLTRIM(M_NameAppl)+'"' ) ENDIF *********** Отобразить сходство/различие классов mSxodClsMod = "SxodCls"+Ar_Model[mNumMod] CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mSxodClsMod) EXCLUSIVE NEW DBGOTO(mClsLeft) mSxodCls = FIELDGET(mClsRight+3) GraStringAt( oPS, { X_MaxW/2, Y_MaxW-90 }, "Сход./разл.классов: "+ALLTRIM(STR(mSxodCls,15,3))+"%" ) *********** Отобразить наименования классов * mClsLeft = aParKDCls[1] // Код класса левого инф.портрета * mClsRight = aParKDCls[2] // Код класса правого инф.портрета CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Opis_ScKD EXCLUSIVE NEW USE Class_Sc EXCLUSIVE NEW USE Gr_ClSc EXCLUSIVE NEW SELECT Gr_ClSc DBGOTO(mClsLeft) mNameGrClSc1 = ALLTRIM(Name_GrCS) mKodClSc1 = Kod_ClSc SELECT Class_Sc DBGOTO(mKodClSc1) mNameClSc1 = ALLTRIM(Name_ClSc) SELECT Gr_ClSc DBGOTO(mClsRight) mNameGrClSc2 = ALLTRIM(Name_GrCS) mKodClSc2 = Kod_ClSc SELECT Class_Sc DBGOTO(mKodClSc2) mNameClSc2 = ALLTRIM(Name_ClSc) oFont := XbpFont():new():create("12.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) MessLeft1 = "Кл.шкала: ["+ALLTRIM(STR(mKodClSc1))+"] "+mNameClSc1 MessLeft2 = "Класс: ["+ALLTRIM(STR(mClsLeft)) +"] "+mNameGrClSc1 GraStringAt( oPS, { IndentLeft+0*Area , Y_MaxW- 80 }, SUBSTR(MessLeft1 , 1, 70) ) GraStringAt( oPS, { IndentLeft+0*Area , Y_MaxW-100 }, SUBSTR(MessLeft2 , 1, 70) ) MessRight1 = "Кл.шкала: ["+ALLTRIM(STR(mKodClSc2))+"] "+mNameClSc2 MessRight2 = "Класс: ["+ALLTRIM(STR(mClsRight))+"] "+mNameGrClSc2 GraStringAt( oPS, { IndentLeft+2*Area+BoxWidth/2, Y_MaxW- 80 }, SUBSTR(MessRight1, 1, 58) ) GraStringAt( oPS, { IndentLeft+2*Area+BoxWidth/2, Y_MaxW-100 }, SUBSTR(MessRight2, 1, 58) ) oFont := XbpFont():new():create("12.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) GraStringAt( oPS, { IndentLeft+0*Area , Y_MaxW-130 }, "Наименования признаков:" ) GraStringAt( oPS, { IndentLeft+2*Area+BoxWidth/2, Y_MaxW-130 }, "Наименования признаков:" ) ****** Фильтры по описательным шкалам, если 0 - фильтра нет SELECT Opis_ScKD mKodOpSc1 = aParKDCls[ 3] // Код оп.шкалы левого инф.портрета mKodOpSc2 = aParKDCls[ 4] // Код оп.шкалы правого инф.портрета DBGOTO(mKodOpSc1+1) MKodGrMin1 = KodGr_min MKodGrMax1 = KodGr_max mNameOpSc1 = ALLTRIM(Name_OpSc) DBGOTO(mKodOpSc2+1) MKodGrMin2 = KodGr_min MKodGrMax2 = KodGr_max mNameOpSc2 = ALLTRIM(Name_OpSc) MessLeft = "Фильтр по оп.шкале: ["+ALLTRIM(STR(mKodOpSc1))+"] "+mNameOpSc1+" "+ALLTRIM(STR(MKodGrMin1))+"-"+ALLTRIM(STR(MKodGrMax1)) MessRight = "Фильтр по оп.шкале: ["+ALLTRIM(STR(mKodOpSc2))+"] "+mNameOpSc2+" "+ALLTRIM(STR(MKodGrMin2))+"-"+ALLTRIM(STR(MKodGrMax2)) GraStringAt( oPS, { IndentLeft+0*Area , Y0-H_Wind+LY+10 }, SUBSTR(MessLeft ,1, 70) ) GraStringAt( oPS, { IndentLeft+2*Area+BoxWidth/2, Y0-H_Wind+LY+10 }, SUBSTR(MessRight,1, 70) ) ***** Легенда ********************************* oFont := XbpFont():new():create("13.ArialBold") GraSetFont( oPS ,oFont ) aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты AxName = "Сходство и различие между классами по их признакам с учетом сходства/различия между признаками (градациям факторов, системе детерминации):" GraStringAt( oPS, { 20, LY-15 }, AxName ) AxName = "СХОДСТВО классов отображается линиями связи КРАСНОГО цвета, толщина линии (приведенная в кружочке в центре линии) отражает степень сходства." GraStringAt( oPS, { 200, LY-35 }, AxName ) AxName = "РАЗЛИЧИЕ классов отображается линиями связи СИНЕГО цвета, толщина линии (приведенная в кружочке в центре линии) отражает степень различия." GraStringAt( oPS, { 200, LY-55 }, AxName ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_DARKRED GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты AxName = "Форма создана: "+DTOC(DATE())+"-"+TIME()+". Показано количество связей <="+ALLTRIM(STR(aParKDCls[15])) GraStringAt( oPS, { IndentLeft+2*Area+BoxWidth/2, LY-15 }, AxName ) **** Нарисовать сами линии **** mSxodstvo > 0 aAttr := Array( GRA_AL_COUNT ) // атрибуты линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := GRA_CLR_RED aAttr [ GRA_AL_WIDTH ] := 7 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraLine(oPS, { 23, LY-35 }, { 170, LY-35 } ) // Нарисовать линию заданных толщины и цвета **** mSxodstvo < 0 aAttr := Array( GRA_AL_COUNT ) // атрибуты линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := GRA_CLR_BLUE aAttr [ GRA_AL_WIDTH ] := 7 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraLine(oPS, { 23, LY-55 }, { 170, LY-55 } ) // Нарисовать линию заданных толщины и цвета ***** РИСОВАНИЕ ПРЯМОУГОЛЬНИКОВ ПРИЗНАКОВ ЛЕВОГО И ПРАВОГО ИНФ.ПОРТРЕТОВ И НАДПИСЕЙ В НИХ *********** mMaxAtrInfPort = 7 // Максимальное количество отображаемых на диаграмме признаков в инф.портрете ***** Расчет промежутка между прямоугольниками признаков CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mRelViewClsMod) EXCLUSIVE NEW SELECT (mRelViewClsMod) INDEX ON STR(Rang1,15) TO ClsRang1 INDEX ON STR(Rang2,15) TO ClsRang2 *** Определение наиболее сильной по модулю связи для нормировки толщины линии INDEX ON STR(ABS(Rel_bit),19,7) TO ClsRang3 DBGOBOTTOM() mMaxRelBit = ABS(Rel_bit) // Максимальная по модулю сила связи в bit для нормировки силы связи на изображении mMaxRelPix = 20 // Максимальная по модулю сила связи в pix для нормировки силы связи на изображении mKnorm = mMaxRelPix/mMaxRelBit // Коэффициент нормировки и преобразования силы связи из bit в pix CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mRelViewClsMod) INDEX ClsRang1, ClsRang2 EXCLUSIVE NEW *** Определение количества признаков в левом и правом инф.портретах SELECT (mRelViewClsMod) SET ORDER TO 1 DBGOBOTTOM() N_Atr1 = Rang1 // Количество признаков в левом портрете SET ORDER TO 2 DBGOBOTTOM() N_Atr2 = Rang2 // Количество признаков в правом портрете Y_atr = (Y_MaxW-140) - (Y0-H_Wind+LY+20) // Высота зоны для информации о признаках BoxOffset = 10 // Отступ прямоугльников от границ зон рисования и текстов внутри прямоугольников от их границ BoxHeight = 85 // Высота прямоугольника в пикселях BoxWidth = BoxWidth - BoxOffset*2 // Ширина прямоугольника в пикселях DeltaY1 = (Y_atr-BoxHeight*N_Atr1)/(N_Atr1+1) DeltaY2 = (Y_atr-BoxHeight*N_Atr2)/(N_Atr2+1) ******** Вывод наименований обобщ.и первичных признаков **** * DO CASE * CASE Rang1 < Rang2 * SET ORDER TO 1 * CASE Rang2 < Rang1 * SET ORDER TO 2 * CASE Rang1 = Rang2 * SET ORDER TO * ENDCASE SET ORDER TO DBGOTOP() * aTxtPar = DC_GraQueryTextbox('Eugene Lutsenko','10.Arial')// {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов DO WHILE .NOT. EOF() // Цикл по связям. Ограничить кол-во отображаемых связей макс.возможным mMaxAtrInfPort ******* РИСОВАНИЕ ПРЯМОУГОЛЬНИКОВ ПРИЗНАКОВ ЛЕВОГО И ПРАВОГО ИНФ.ПОРТРЕТОВ *********** *** ЛЕВЫЙ *** y1 = (Y_MaxW-140) - DeltaY1 - (BoxHeight+DeltaY1) * (Rang1-1) ******** Атрибуты области aAttrBox := ARRAY( GRA_AA_COUNT ) // Определить атрибуты заполнения прямоугольника aAttrBox[ GRA_AA_COLOR ] := IF(Inf_Bit1>0,BD_LIGHTYELLOW, BD_LIGHTGREEN) // Цвет согласно _AidosColor.exe GraSetAttrArea( oPS, aAttrBox ) ******** Атрибуты границы области (линии) aAttrLine := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttrLine [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttrLine [ GRA_AL_COLOR ] := IF(Inf_Bit1>0,GRA_CLR_DARKRED, GRA_CLR_DARKBLUE) // Задать цвет линии aAttrLine [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttrLine ) // Установить атрибуты graBox( oPS, { IndentLeft+1*Area-BoxWidth/2, y1 }, { IndentLeft+1*Area+BoxWidth/2 , y1-BoxHeight }, GRA_OUTLINEFILL, 0, 0 ) // Малый. Прямоугольник очерчен, заполнен и закруглен graBox( oPS, { IndentLeft+0*Area+BoxOffset , y1 }, { IndentLeft+1*Area-BoxWidth/2-2*BoxOffset, y1-BoxHeight }, GRA_OUTLINEFILL, 0, 0 ) // Большой. Прямоугольник очерчен, заполнен и закруглен *** ПРАВЫЙ *** y2 = (Y_MaxW-140) - DeltaY2 - (BoxHeight+DeltaY2) * (Rang2-1) ******** Атрибуты области aAttrBox := ARRAY( GRA_AA_COUNT ) // Определить атрибуты заполнения прямоугольника aAttrBox[ GRA_AA_COLOR ] := IF(Inf_Bit2>0,BD_LIGHTYELLOW, BD_LIGHTGREEN) // Цвет согласно _AidosColor.exe GraSetAttrArea( oPS, aAttrBox ) ******** Атрибуты границы области (линии) aAttrLine := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttrLine [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttrLine [ GRA_AL_COLOR ] := IF(Inf_Bit2>0,GRA_CLR_DARKRED, GRA_CLR_DARKBLUE) // Задать цвет линии aAttrLine [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttrLine ) // Установить атрибуты graBox( oPS, { IndentLeft+2*Area-BoxWidth/ 2, y2 }, { IndentLeft+2*Area+BoxWidth/2, y2-BoxHeight }, GRA_OUTLINEFILL, 0, 0 ) // Малый. Прямоугольник очерчен, заполнен и закруглен graBox( oPS, { IndentLeft+2*Area+BoxWidth/2+2*BoxOffset, y2 }, { IndentLeft+3*Area-BoxOffset , y2-BoxHeight }, GRA_OUTLINEFILL, 0, 0 ) // Большой. Прямоугольник очерчен, заполнен и закруглен ******* РИСОВАНИЕ НАДПИСЕЙ В ПРЯМОУГОЛЬНИКАХ ПРИЗНАКОВ ********************************* *** ЛЕВЫЙ *** * aTxtPar = DC_GraQueryTextbox('Eugene Lutsenko','10.Arial') // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов oFont := XbpFont():new():create("12.Arial") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := IF(Inf_Bit1>0,GRA_CLR_DARKRED, GRA_CLR_DARKBLUE) // Задать цвет шрифта aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) ***** Цикл определения такой длины строки, которая помещается в рамку ***** Массив отображаемых в рамке строк, включающий наименования и описательных шкал и их градаций ***** Из текстового буфера к отображаемому элементу массива добавляется по одному символу и определяется его длина в пикселях. ***** Если не хватает длины рамки - добавляется строка в массив. Отображение градации шкалы всегда начинается с новой строки. mZone = 50 // Размер зоны отображения в символах aMess := {} // Массив отображаемых в рамке строк, включающий наименования и описательных шкал и их градаций AADD(aMess, L(" "));s=1 // 1-й элемент - 1-я строка mBuff1 = "["+ALLTRIM(STR(Kod_OpSc1))+"] "+ALLTRIM(Name_OpSc1) FOR j=1 TO LEN(mBuff1) * aTxtPar = DC_GraQueryTextbox(aMess[s] + SUBSTR(mBuff1,j,1), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов IF LEN(aMess[s] + SUBSTR(mBuff1,j,1)) <= mZone aMess[s] = aMess[s] + SUBSTR(mBuff1,j,1) // Полное наименование описательной шкалы посылается в буфер для отображения ELSE IF s < 2 AADD(aMess, SUBSTR(mBuff1,j,1)) s++ ELSE EXIT ENDIF ENDIF NEXT ***** Цикл определения такой длины строки, которая помещается в рамку AADD(aMess, L(" ")) s++ mBuff2 = "["+ALLTRIM(STR(Kod_Atr1 ))+"] "+ALLTRIM(Name_GrOS1) // Буфер. Из буфера добавляется по олному символу в отображаемый элемент массива FOR j=1 TO LEN(mBuff2) IF LEN(aMess[s] + SUBSTR(mBuff1,j,1)) <= mZone aMess[s] = aMess[s] + SUBSTR(mBuff2,j,1) // Полное наименование описательной шкалы посылается в буфер для отображения ELSE IF s < 4 AADD(aMess, SUBSTR(mBuff2,j,1)) s++ ELSE EXIT ENDIF ENDIF NEXT *** Отображение ***** y1 = (Y_MaxW-140) - DeltaY1 - (BoxHeight+DeltaY1) * (Rang1-1) mInterval = 18 // Межстрочный интервал в пикселях. 1 - строки пишутся без пропуска FOR s=1 TO LEN(aMess) GraStringAt( oPS, { IndentLeft+0*Area+BoxOffset*2, y1-15-(s-1)*mInterval }, aMess[s] ) NEXT ***** Надписи в маленьких прямоугольниках внутри голубых прямоугольников с информацией по признакам oFont := XbpFont():new():create("12.ArialBold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := IF(Inf_Bit1>0,GRA_CLR_DARKRED, GRA_CLR_DARKBLUE) // Задать цвет шрифта aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) * graBox( oPS, { IndentLeft+1*Area-BoxWidth/2, y1 }, { IndentLeft+1*Area+BoxWidth/2, y1-BoxHeight }, GRA_OUTLINEFILL, 0, 0 ) // Малый левый. Прямоугольник очерчен, заполнен и закруглен mInterval = 21 // Межстрочный интервал в пикселях. 1 - строки пишутся без пропуска GraStringAt( oPS, { IndentLeft+1*Area-BoxWidth/2+BoxOffset, y1-mInterval*1 }, "Ib="+ALLTRIM(STR(Inf_bit1 ,19,3))+IF(mNumMod=4," bit", "") ) GraStringAt( oPS, { IndentLeft+1*Area-BoxWidth/2+BoxOffset, y1-mInterval*2 }, "Ip="+ALLTRIM(STR(Inf_PerTM1,19,3))+IF(mNumMod=4," %ТМ", "") ) GraStringAt( oPS, { IndentLeft+1*Area-BoxWidth/2+BoxOffset, y1-mInterval*3 }, "Ic="+ALLTRIM(STR(Inf_Stand1,19,3))+IF(mNumMod=4,"станд","") ) *** ПРАВЫЙ *** * aTxtPar = DC_GraQueryTextbox('Eugene Lutsenko','10.Arial') // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов oFont := XbpFont():new():create("12.Arial") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := IF(Inf_Bit2>0,GRA_CLR_DARKRED, GRA_CLR_DARKBLUE) // Задать цвет шрифта aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) ***** Цикл определения такой длины строки, которая помещается в рамку ***** Массив отображаемых в рамке строк, включающий наименования и описательных шкал и их градаций ***** Из текстового буфера к отображаемому элементу массива добавляется по одному символу и определяется его длина в пикселях. ***** Если не хватает длины рамки - добавляется строка в массив. Отображение градации шкалы всегда начинается с новой строки. mZone = 50 // Размер зоны отображения в символах aMess := {} // Массив отображаемых в рамке строк, включающий наименования и описательных шкал и их градаций AADD(aMess, L(" "));s=1 // 1-й элемент - 1-я строка mBuff1 = "["+ALLTRIM(STR(Kod_OpSc2))+"] "+ALLTRIM(Name_OpSc2) FOR j=1 TO LEN(mBuff1) * aTxtPar = DC_GraQueryTextbox(aMess[s] + SUBSTR(mBuff1,j,1), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов IF LEN(aMess[s] + SUBSTR(mBuff1,j,1)) <= mZone aMess[s] = aMess[s] + SUBSTR(mBuff1,j,1) // Полное наименование описательной шкалы посылается в буфер для отображения ELSE IF s < 2 AADD(aMess, SUBSTR(mBuff1,j,1)) s++ ELSE EXIT ENDIF ENDIF NEXT ***** Цикл определения такой длины строки, которая помещается в рамку AADD(aMess, L(" ")) s++ mBuff2 = "["+ALLTRIM(STR(Kod_Atr2 ))+"] "+ALLTRIM(Name_GrOS2) // Буфер. Из буфера добавляется по олному символу в отображаемый элемент массива FOR j=1 TO LEN(mBuff2) IF LEN(aMess[s] + SUBSTR(mBuff2,j,1)) <= mZone aMess[s] = aMess[s] + SUBSTR(mBuff2,j,1) // Полное наименование описательной шкалы посылается в буфер для отображения ELSE IF s < 4 AADD(aMess, SUBSTR(mBuff2,j,1)) s++ ELSE EXIT ENDIF ENDIF NEXT *** Отображение ***** y1 = (Y_MaxW-140) - DeltaY2 - (BoxHeight+DeltaY2) * (Rang2-1) mInterval = 18 // Межстрочный интервал в пикселях. 1 - строки пишутся без пропуска FOR s=1 TO LEN(aMess) GraStringAt( oPS, { IndentLeft+2*Area+BoxWidth/2+3*BoxOffset, y1-15-(s-1)*mInterval }, aMess[s] ) NEXT ***** Надписи в маленьких прямоугольниках внутри голубых прямоугольников с информацией по признакам oFont := XbpFont():new():create("12.ArialBold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := IF(Inf_Bit2>0,GRA_CLR_DARKRED, GRA_CLR_DARKBLUE) // Задать цвет шрифта aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) * graBox( oPS, { IndentLeft+2*Area-BoxWidth/2, y2 }, { IndentLeft+2*Area+BoxWidth/2, y2-BoxHeight }, GRA_OUTLINEFILL, 0, 0 ) // Малый правый. Прямоугольник очерчен, заполнен и закруглен mInterval = 21 // Межстрочный интервал в пикселях. 1 - строки пишутся без пропуска GraStringAt( oPS, { IndentLeft+2*Area-BoxWidth/2+BoxOffset, y2-mInterval*1 }, "Ib="+ALLTRIM(STR(Inf_bit2 ,19,3))+IF(mNumMod=4," bit", "") ) GraStringAt( oPS, { IndentLeft+2*Area-BoxWidth/2+BoxOffset, y2-mInterval*2 }, "Ip="+ALLTRIM(STR(Inf_PerTM2,19,3))+IF(mNumMod=4," %ТМ", "") ) GraStringAt( oPS, { IndentLeft+2*Area-BoxWidth/2+BoxOffset, y2-mInterval*3 }, "Ic="+ALLTRIM(STR(Inf_Stand2,19,3))+IF(mNumMod=4,"станд","") ) DBSKIP(1) ENDDO ***** РИСОВАНИЕ ЛИНИЙ ОТНОШЕНИЙ (СВЯЗЕЙ) ПРИЗНАКОВ ЛЕВОГО И ПРАВОГО ИНФ.ПОРТРЕТА *********** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mRelViewClsMod) EXCLUSIVE NEW N_Line = RECCOUNT() x1 = IndentLeft+1*Area+BoxWidth/2+BoxOffset x2 = IndentLeft+2*Area-BoxWidth/2-BoxOffset RS = 12 // Радиус кружочка для указания силы связи SELECT (mRelViewClsMod) DBGOTOP() oFont := XbpFont():new():create("10.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт DO WHILE .NOT. EOF() // Цикл по связям y1 = (Y_MaxW-140) - DeltaY1 - (BoxHeight+DeltaY1) * (Rang1-1) - BoxHeight/2 y2 = (Y_MaxW-140) - DeltaY2 - (BoxHeight+DeltaY2) * (Rang2-1) - BoxHeight/2 ******** Атрибуты границы области (линии) aAttrLine := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttrLine [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttrLine [ GRA_AL_COLOR ] := IF(Rel_bit>0,BD_CANDYRED, BD_RICHBLUE) // Задать цвет линии согласно _AidosColor.exe aAttrLine [ GRA_AL_WIDTH ] := mKnorm * ABS(Rel_bit) // Задать толщину линии (нормированную) graSetAttrLine( oPS, aAttrLine ) // Установить атрибуты GraLine( oPS, { x1, y1 }, { x2, y2 } ) // Нарисовать линию связи заданной толщины и цвета * ****** Сделать надписи уровней сходства на линиях связи * aAttr := Array( GRA_AA_COUNT ) // атрибуты области * aAttr [ GRA_AA_COLOR ] := IF(Rel_bit>0,BD_LIGHTYELLOW, BD_XBP_CYAN) * aAttr [ GRA_AA_SYMBOL ] := GRA_SYM_DEFAULT * graSetAttrArea( oPS, aAttr ) * aAttr := Array( GRA_AL_COUNT ) // атрибуты линии * aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT * aAttr [ GRA_AL_COLOR ] := IF(Rel_bit>0,BD_CANDYRED, BD_RICHBLUE) * aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии * graSetAttrLine( oPS, aAttr ) * aAttrF := ARRAY( GRA_AS_COUNT ) // атрибуты шрифта * aAttrF [ GRA_AS_COLOR ] := IF(Rel_bit>0,BD_CANDYRED, BD_RICHBLUE) * aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода * aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода * GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты * N = IF(Rel_bit>0,3,3/2) * GraArc( oPS, { x1+(x2-x1)/N, y1+(y2-y1)/N }, RS, ,,, GRA_OUTLINEFILL ) * GraStringAt( oPS, { x1+(x2-x1)/N, y1+(y2-y1)/N }, ALLTRIM(STR(Rel_PerTM,15)) ) DBSKIP(1) ENDDO DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения RETURN NIL ************************************************** ******** Запись графического окна в виде bmp-файла ************************************************** FUNCTION DC_Scrn2ImageFile( oXbp, cFileName, nFormat ) LOCAL oSourcePS, oBitmap, oClipBoard, aPos oSourcePS := oXbp:lockPS() IF oXbp:isDerivedFrom('XbpDialog') aPos := { -4, -4 } ELSE aPos := { 0, 0 } ENDIF oBitmap := GraSaveScreen( oSourcePS, aPos, oXbp:currentSize() ) RETURN oBitMap:saveFile( cFileName, nFormat ) **************************************************************************************** ******** 4.3.3. Когнитивные диаграммы признаков. Режим 5.2.3. DOS-версии ########## **************************************************************************************** FUNCTION F4_3_3() LOCAL GetList := {}, aPres, oBrowse, oToolBar, aColors, bColor, GetOptions LOCAL oProgress, oDialog, oStatic, oPS, oDevice, oDlg Running(.T.) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF ApplChange("4.3.3()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF **** Проверить, существуют ли матрицы сходства классов и признаков, необходимые для выполнения режима mFlagErr = .F. Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } FOR j=1 TO LEN(Ar_Model) mName = "SxodCls"+Ar_Model[j]+".dbf" IF .NOT. FILE(mName) Mess = L("Отсуствует матрица сходства классов: "+mName+". Необходимо выполнить режим 4.2.2.1.") LB_Warning(Mess, L('4.3.3. Когнитивные диаграммы признаков')) mFlagErr = .T. ENDIF NEXT FOR j=1 TO LEN(Ar_Model) mName = "SxodAtr"+Ar_Model[j]+".dbf" IF .NOT. FILE(mName) Mess = L("Отсуствует матрица сходства признаков: ")+mName+L(". Необходимо выполнить режим 4.3.2.1.") LB_Warning(Mess, L('4.3.3. Когнитивные диаграммы признаков')) mFlagErr = .T. ENDIF NEXT ***** Создание БД для задания диапазонов признаков по описательным шкалам IF .NOT. FILE("Attributes.dbf") // БД опис.шкал + градаций опис.шкал: Attributes.dbf LB_Warning(L('Отсуствует БД описательных шкал и градаций: "Attributes.dbf". Зайдите в режим 2.2'), L('4.3.3. Когнитивные диаграммы признаков')) mFlagErr = .T. ENDIF IF mFlagErr ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) ReTURN nil ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Attributes EXCLUSIVE NEW SELECT Attributes mLenMax = -99999 DBGOTOP() DO WHILE .NOT. EOF() mLenMax = MAX(mLenMax, LEN(ALLTRIM(NAME_ATR))) DBSKIP(1) ENDDO aStr := { { "KOD_ATR" , "N", 15, 0 }, ; { "NAME_ATR", "C",mLenMax, 0 } } DbCreate( 'AttributesKD.dbf', aStr ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Attributes EXCLUSIVE NEW USE AttributesKD EXCLUSIVE NEW;ZAP SELECT AttributesKD APPEND BLANK REPLACE KOD_ATR WITH 0 REPLACE NAME_ATR WITH "ВСЕ ПРИЗНАКИ" SELECT Attributes DBGOTOP() DO WHILE .NOT. EOF() mKodAtr = KOD_ATR mNameAtr = NAME_ATR SELECT AttributesKD APPEND BLANK REPLACE KOD_ATR WITH mKodAtr REPLACE NAME_ATR WITH mNameAtr SELECT Attributes DBSKIP(1) ENDDO ***** Создание БД для задания диапазонов классов по классификационным шкалам *MinMaxGrClSc() // Формирование минимального и максимального кодов градаций классификационных шкал (включено в ApplChange("")) IF .NOT. FILE("Class_Sc.dbf") // БД классификационных шкал ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) ReTURN nil ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Class_Sc EXCLUSIVE NEW SELECT Class_Sc mLenMax = LEN(L("ВСЕ КЛАССИФИКАЦИОННЫЕ ШКАЛЫ")) DBGOTOP() DO WHILE .NOT. EOF() mLenMax = MAX(mLenMax, LEN(ALLTRIM(NAME_ClSc))) DBSKIP(1) ENDDO aStr := { { "KOD_ClSc" , "N", 15, 0 }, ; { "NAME_ClSc" , "C",mLenMax, 0 }, ; { "KodGr_min" , "N", 15, 0 }, ; // Минимальный код градаций описательной шкалы { "KodGr_max" , "N", 15, 0 } } // Максимальный код градаций описательной шкалы DbCreate( 'Class_ScKD.dbf', aStr ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Class_Sc EXCLUSIVE NEW USE Class_ScKD EXCLUSIVE NEW;ZAP USE Classes EXCLUSIVE NEW SELECT Classes DBGOTOP() mKodGrMin = Kod_cls DBGOBOTTOM() mKodGrMax = Kod_cls SELECT Class_ScKD APPEND BLANK REPLACE KOD_ClSc WITH 0 REPLACE NAME_ClSc WITH "ВСЕ КЛАССИФИКАЦИОННЫЕ ШКАЛЫ" REPLACE KodGr_min WITH mKodGrMin REPLACE KodGr_max WITH mKodGrMax SELECT Class_Sc DBGOTOP() DO WHILE .NOT. EOF() mKodClSc = KOD_ClSc mNameClSc = NAME_ClSc mKodGrMin = KodGr_min mKodGrMax = KodGr_max SELECT Class_ScKD APPEND BLANK REPLACE KOD_ClSc WITH mKodClSc REPLACE NAME_ClSc WITH mNameClSc REPLACE KodGr_min WITH mKodGrMin REPLACE KodGr_max WITH mKodGrMax SELECT Class_Sc DBSKIP(1) ENDDO ***** ДИАЛОГ ЗАДАНИЯ ПАРАМЕТРОВ ************** // Если ранее параметры были заданы - скачать массив, иначе сформировать и записать в папке приложения IF .NOT. FILE("_4_3_3.arx") PUBLIC aParKDAtr[15] aParKDAtr[ 1] = 0 // Код класса левого инф.портрета aParKDAtr[ 2] = 0 // Код класса правого инф.портрета aParKDAtr[ 3] = 0 // Код оп.шкалы левого инф.портрета aParKDAtr[ 4] = 0 // Код оп.шкалы правого инф.портрета aParKDAtr[ 5] = .T. // Модель Abs задана для расчетов aParKDAtr[ 6] = .T. // Модель Prc1 задана для расчетов aParKDAtr[ 7] = .T. // Модель Prc2 задана для расчетов aParKDAtr[ 8] = .T. // Модель Inf1 задана для расчетов aParKDAtr[ 9] = .T. // Модель Inf2 задана для расчетов aParKDAtr[10] = .T. // Модель Inf3 задана для расчетов aParKDAtr[11] = .T. // Модель Inf4 задана для расчетов aParKDAtr[12] = .T. // Модель Inf5 задана для расчетов aParKDAtr[13] = .T. // Модель Inf6 задана для расчетов aParKDAtr[14] = .T. // Модель Inf7 задана для расчетов aParKDAtr[15] = 99999 // Максимальное кол-во отображаемых связей DC_ASave(aParKDAtr , "_4_3_3.arx") ELSE aParKDAtr = DC_ARestore("_4_3_3.arx") ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE AttributesKD EXCLUSIVE NEW USE Class_ScKD EXCLUSIVE NEW ****** Подготовка для отображения заданных параметров SELECT AttributesKD DBGOTO(1+aParKDAtr[ 1]);mNameAtr = Name_Atr PUBLIC mKNAtrLeft := 'Признак для левого инф.портрета: ['+ALLTRIM(STR(aParKDAtr[ 1], 15))+'] '+ALLTRIM(mNameAtr) DBGOTO(1+aParKDAtr[ 2]);mNameAtr = Name_Atr PUBLIC mKNAtrRight := 'Признак для правого инф.портрета: ['+ALLTRIM(STR(aParKDAtr[ 2], 15))+'] '+ALLTRIM(mNameAtr) DBGOTOP() SELECT Class_ScKD DBGOTO(1+aParKDAtr[ 3]);mNameClSc = Name_ClSc PUBLIC mKNClScLeft := 'Классиф.шкала для левого инф.портрета: ['+ALLTRIM(STR(aParKDAtr[ 3], 15))+'] '+ALLTRIM(mNameClSc) DBGOTO(1+aParKDAtr[ 4]);mNameClSc = Name_ClSc PUBLIC mKNClScRight := 'Классиф.шкала для правого инф.портрета: ['+ALLTRIM(STR(aParKDAtr[ 4], 15))+'] '+ALLTRIM(mNameClSc) DBGOTOP() Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } PUBLIC aSay[14] mModels = 'Модели, заданные для расчета: ' FlagFirst = .T. FOR j=5 TO 14 IF aParKDAtr[ j] mModels = mModels+IF(FlagFirst,"",", ")+Ar_Model[j-4] FlagFirst = .F. ENDIF NEXT /* ----- Create browse ----- */ @ 0,0 DCGROUP oGroup1 CAPTION L('Выбор признаков для когнитивной диаграммы') SIZE 135,14.5 @ 1,2 DCSAY L('Задайте коды двух признаков, для левого и правого информационных портретов когнитивной диаграммы') PARENT oGroup1 SIZE 0 FONT "10.Helv Bold" COLOR GRA_CLR_DARKBLUE @ 2,2 DCSAY L('по очереди выбирая их курсором в таблице и кликая на соответствующей кнопке ниже нее' ) PARENT oGroup1 SIZE 0 FONT "10.Helv Bold" COLOR GRA_CLR_DARKBLUE @ 3,2 DCBROWSE oBrowse ALIAS 'AttributesKD' SIZE 131,9 HEADLINES 1 PARENT oGroup1 // Кол-во строк в заголовке (перенос строки - ";") DCBROWSECOL FIELD AttributesKD->Kod_atr HEADER L('Код') PARENT oBrowse WIDTH 5 PROTECT {|| .T. }; COLOR {||IIF(AT('SPECTRINTERV:',AttributesKD->Name_atr)=0,nil,{nil,GraMakeRGBColor({VAL(SUBSTR(AttributesKD->Name_atr, AT('{', AttributesKD->Name_atr)+1, AT('{', AttributesKD->Name_atr)+ 3-AT('{', AttributesKD->Name_atr)+1+1)),VAL(SUBSTR(AttributesKD->Name_atr, AT('{', AttributesKD->Name_atr)+5, AT('{', AttributesKD->Name_atr)+ 7-AT('{', AttributesKD->Name_atr)+5+1)),VAL(SUBSTR(AttributesKD->Name_atr, AT('{', AttributesKD->Name_atr)+9, AT('{', AttributesKD->Name_atr)+11-AT('{', AttributesKD->Name_atr)+9+1))})})} // Вывод поля цветом RGB DCBROWSECOL FIELD AttributesKD->Name_atr HEADER L('Наименование признака') PARENT oBrowse WIDTH 75 PROTECT {|| .T. } DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE @ 12.5, 15 DCPUSHBUTTON CAPTION L('Выбор кода признака левого инф.портрета') SIZE 2+LEN(L("Выбор кода признака левого инф.портрета")), 1.1 ACTION {||KodAtrLeft433(aParKDAtr) , DC_GetRefresh(GetList)} PARENT oGroup1 @ DCGUI_ROW, DCGUI_COL+150 DCPUSHBUTTON CAPTION L('Выбор кода признака правого инф.портрета') SIZE 2+LEN(L("Выбор кода признака правого инф.портрета")), 1.1 ACTION {||KodAtrRight433(aParKDAtr), DC_GetRefresh(GetList)} PARENT oGroup1 /* ----- Create browse ----- */ @15,0 DCGROUP oGroup2 CAPTION L('Выбор способа фильтрации классов в информационных портретах когнитивной диаграммы') SIZE 135,14.5 @ 1,2 DCSAY L('Задайте коды двух классификационных шкал, для левого и правого информационных портретов когнитивной') PARENT oGroup2 SIZE 0 FONT "10.Helv Bold" COLOR GRA_CLR_DARKRED @ 2,2 DCSAY L('диаграммы по очереди выбирая их курсором в таблице и кликая на соответствующей кнопке ниже нее' ) PARENT oGroup2 SIZE 0 FONT "10.Helv Bold" COLOR GRA_CLR_DARKRED @ 3,2 DCBROWSE oBrowse ALIAS 'Class_ScKD' SIZE 131,9 HEADLINES 2 PARENT oGroup2 // Кол-во строк в заголовке (перенос строки - ";") DCBROWSECOL FIELD Class_ScKD->KOD_ClSc HEADER L('Код' ) PARENT oBrowse WIDTH 5 PROTECT {|| .T. } DCBROWSECOL FIELD Class_ScKD->NAME_ClSc HEADER L('Наименование;классификационной шкалы') PARENT oBrowse WIDTH 58.7 PROTECT {|| .T. } DCBROWSECOL FIELD Class_ScKD->KodGr_min HEADER L('Минимальный; код градации' ) PARENT oBrowse WIDTH 7 PROTECT {|| .T. } DCBROWSECOL FIELD Class_ScKD->KodGr_max HEADER L('Максимальный;код градации' ) PARENT oBrowse WIDTH 8 PROTECT {|| .T. } DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE @ 12.5, 10 DCPUSHBUTTON CAPTION L('Выбор кода классификационной шкалы левого инф.портрета') SIZE 2+LEN(L("Выбор кода классификационной шкалы левого инф.портрета")), 1.1 ACTION {||KodClScLeft433(aParKDAtr) , DC_GetRefresh(GetList)} PARENT oGroup2 @ DCGUI_ROW, DCGUI_COL+70 DCPUSHBUTTON CAPTION L('Выбор кода классификационной шкалы правого инф.портрета') SIZE 2+LEN(L("Выбор кода классификационной шкалы правого инф.портрета")), 1.1 ACTION {||KodClScRight433(aParKDAtr), DC_GetRefresh(GetList)} PARENT oGroup2 /* ----- Create ToolBar ----- */ @30,0 DCGROUP oGroup3 CAPTION L('Задайте модели, в которых проводить расчеты когнитивных диаграмм') SIZE 94,2.7 // ABS, PRC1, PRC2, INF# <<<===########################## FOR j=5 TO 14;aParKDAtr[j]=.F.;NEXT;aParKDAtr[10]=.T. D = 4 @ 1, 2 DCCHECKBOX aParKDAtr[ 5] PROMPT L('Abs' ) ACTION {||TakeModels433(), DC_GetRefresh(GetList)} PARENT oGroup3 @ DCGUI_ROW, DCGUI_COL+D DCCHECKBOX aParKDAtr[ 6] PROMPT L('Prc1') ACTION {||TakeModels433(), DC_GetRefresh(GetList)} PARENT oGroup3 @ DCGUI_ROW, DCGUI_COL+D DCCHECKBOX aParKDAtr[ 7] PROMPT L('Prc2') ACTION {||TakeModels433(), DC_GetRefresh(GetList)} PARENT oGroup3 @ DCGUI_ROW, DCGUI_COL+D DCCHECKBOX aParKDAtr[ 8] PROMPT L('Inf1') ACTION {||TakeModels433(), DC_GetRefresh(GetList)} PARENT oGroup3 @ DCGUI_ROW, DCGUI_COL+D DCCHECKBOX aParKDAtr[ 9] PROMPT L('Inf2') ACTION {||TakeModels433(), DC_GetRefresh(GetList)} PARENT oGroup3 @ DCGUI_ROW, DCGUI_COL+D DCCHECKBOX aParKDAtr[10] PROMPT L('Inf3') ACTION {||TakeModels433(), DC_GetRefresh(GetList)} PARENT oGroup3 // ПО УМОЛЧАНИЮ ТОЛЬКО В INF3 @ DCGUI_ROW, DCGUI_COL+D DCCHECKBOX aParKDAtr[11] PROMPT L('Inf4') ACTION {||TakeModels433(), DC_GetRefresh(GetList)} PARENT oGroup3 @ DCGUI_ROW, DCGUI_COL+D DCCHECKBOX aParKDAtr[12] PROMPT L('Inf5') ACTION {||TakeModels433(), DC_GetRefresh(GetList)} PARENT oGroup3 @ DCGUI_ROW, DCGUI_COL+D DCCHECKBOX aParKDAtr[13] PROMPT L('Inf6') ACTION {||TakeModels433(), DC_GetRefresh(GetList)} PARENT oGroup3 @ DCGUI_ROW, DCGUI_COL+D DCCHECKBOX aParKDAtr[14] PROMPT L('Inf7') ACTION {||TakeModels433(), DC_GetRefresh(GetList)} PARENT oGroup3 @30,96 DCGROUP oGroup4 CAPTION L('Задайте max количество отображаемых связей:') SIZE 39,2.7 // <<<===########################## @ 1, 2 DCSAY L(" ") GET aParKDAtr[15] PICTURE "#########" PARENT oGroup4 @ 1,21.1 DCPUSHBUTTON CAPTION L('Помощь') SIZE 2+LEN(L("Помощь")), 1.1 ACTION {||Help433(), DC_GetRefresh(GetList)} PARENT oGroup4 /* ----- Create ToolBar ----- */ @33.2,0 DCGROUP oGroup5 CAPTION L('В диалоге заданы следующие параметры расчета когнитивных диаграмм:') SIZE 94,6.5 // <<<===########################## PUBLIC aSay[14] @ 1,2 DCSAY {|| mKNAtrLeft } OBJECT aSay[1] SAYSIZE 90 PARENT oGroup5 FONT "10.Helv Bold" COLOR GRA_CLR_DARKBLUE // Признак для левого инф.портрета @ 2,2 DCSAY {|| mKNAtrRight } OBJECT aSay[2] SAYSIZE 90 PARENT oGroup5 FONT "10.Helv Bold" COLOR GRA_CLR_DARKBLUE // Признак для левого инф.портрета @ 3,2 DCSAY {|| mKNClScLeft } OBJECT aSay[3] SAYSIZE 90 PARENT oGroup5 FONT "10.Helv Bold" COLOR GRA_CLR_DARKRED // Оп.шкала для левого инф.портрета @ 4,2 DCSAY {|| mKNClScRight} OBJECT aSay[4] SAYSIZE 90 PARENT oGroup5 FONT "10.Helv Bold" COLOR GRA_CLR_DARKRED // Оп.шкала для левого инф.портрета FOR j=5 TO 14 @ 5,2 DCSAY {|| mModels } OBJECT aSay[j] SAYSIZE 90 PARENT oGroup5 FONT "10.Helv Bold" COLOR GRA_CLR_BLACK // Модели, заданные для расчета NEXT PUBLIC mPause := 2 @33.2,96 DCGROUP oGroup6 CAPTION L('Задайте режим вывода когнитивных диаграмм:') SIZE 39,6.5 // <<<===########################## @ 1, 2 DCRADIO mPause VALUE 1 PROMPT L('Показать все диаграммы с остановкой') PARENT oGroup6 @ 2, 2 DCRADIO mPause VALUE 2 PROMPT L('Записать все диаграммы без показа ') PARENT oGroup6 DCREAD GUI ; TO lExit ; FIT ; ADDBUTTONS; OPTIONS GetOptions ; MODAL ; TITLE L('4.3.3. Когнитивные диаграммы признаков. Задание параметров генерации выходных форм') ******************************************************************** IF lExit ** Button Ok ELSE ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ******************************************************************** DC_ASave(aParKDAtr , "_4_3_3.arx") // Записать параметры для расчетов когнитивных диаграмм, заданные в диалоге * DC_DebugQout( aParKDAtr ) ***** КОНЕЦ ДИАЛОГА ЗАДАНИЯ ПАРАМЕТРОВ ***************************** ***** РАСЧЕТ БАЗ ДАННЫХ ДЛЯ ОТОБРАЖЕНИЯ КОГНИТИВНЫХ ДИАГРАММ ******* * aParKDAtr[ 1] = 0 // Код класса левого инф.портрета * aParKDAtr[ 2] = 0 // Код класса правого инф.портрета * aParKDAtr[ 3] = 0 // Код оп.шкалы левого инф.портрета * aParKDAtr[ 4] = 0 // Код оп.шкалы правого инф.портрета * aParKDAtr[ 5] = .T. // Модель Abs задана для расчетов * aParKDAtr[ 6] = .T. // Модель Prc1 задана для расчетов * aParKDAtr[ 7] = .T. // Модель Prc2 задана для расчетов * aParKDAtr[ 8] = .T. // Модель Inf1 задана для расчетов * aParKDAtr[ 9] = .T. // Модель Inf2 задана для расчетов * aParKDAtr[10] = .T. // Модель Inf3 задана для расчетов * aParKDAtr[11] = .T. // Модель Inf4 задана для расчетов * aParKDAtr[12] = .T. // Модель Inf5 задана для расчетов * aParKDAtr[13] = .T. // Модель Inf6 задана для расчетов * aParKDAtr[14] = .T. // Модель Inf7 задана для расчетов * aParKDAtr[15] = 999 // Максимальное кол-во отображаемых связей ** ПОДГОТОВКА ПРЕДЕЛОВ ЦИКЛОВ ПО КЛАССАМ ЛЕВОГО И ПРАВОГО ИНФОРМАЦИОННЫХ ПОРТРЕТОВ * Если aParKDAtr[ 1] = 0, то цикл по классам от 1-го до последнего, какие есть в БД Classes.dbf * иначе цикл от класса с кодом aParKDAtr[ 1] до класса с кодом aParKDAtr[ 1] CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Attributes EXCLUSIVE NEW;N_Atr = RECCOUNT() SELECT Attributes IF aParKDAtr[ 1] = 0 DBGOTOP() mAtr1Left = Kod_atr DBGOBOTTOM() mAtr2Left = Kod_atr ELSE mAtr1Left = aParKDAtr[ 1] mAtr2Left = aParKDAtr[ 1] ENDIF * Если aParKDAtr[ 2] = 0, то цикл по классам от 1-го до последнего, какие есть в БД Classes.dbf * иначе цикл от класса с кодом aParKDAtr[ 2] до класса с кодом aParKDAtr[ 2] IF aParKDAtr[ 2] = 0 DBGOTOP() mAtr1Right = Kod_atr DBGOBOTTOM() mAtr2Right = Kod_atr ELSE mAtr1Right = aParKDAtr[ 2] mAtr2Right = aParKDAtr[ 2] ENDIF ***** Окрыть текстовые базы данных моделей * ########################################################################### // Открытие текстовых баз данных ******************************************** *DC_ASave(aInfStruct, "_InfStruct.arx") // Когда БД создается - записывать структуру, когда открывается - считывать aInfStruct := DC_ARestore("_InfStruct.arx") *DC_ASave(aStrEmpty, "_aStrEmpty.arx") // Записывать только после расчета Abs.txt, а при расчете остальных БД только считывать *DC_ASave(aColEmpty, "_aColEmpty.arx") aStrEmpty = DC_ARestore("_aStrEmpty.arx") aColEmpty = DC_ARestore("_aColEmpty.arx") ************************************************* ***** Формирование пустой записи N_Col = N_Cls+6 // Число полей CrLf = CHR(13)+CHR(10) // Конец строки (записи) Lc_buf = "" FOR j=1 TO N_Col * S = IF(j=2*INT(j/2),"#","X") // Для отладки S = " " // Для работы Lc_buf = Lc_buf + REPLICATE(S, aInfStruct[j,3]) NEXT Lc_buf = Lc_buf + CrLf PUBLIC Len_LcBuf := LEN(Lc_buf) ****** Открываем стат.базы и базы знаний (7 по частным критериям знаний) Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } PUBLIC nHandle[LEN(Ar_Model)] FOR z=1 TO LEN(Ar_Model) nHandle[z] := FOpen( Ar_Model[z]+".txt", FO_READWRITE ) // Открыть ВСЕ текстовые базы данных ######################################## NEXT **** Рассчет массива начальных позиций полей в строке PUBLIC aPos[N_Col] aPos[1] = 1 FOR j=2 TO N_Col aPos[j] = aPos[j-1] + aInfStruct[j-1,3] NEXT * ########################################################################### ***** Определение максимальной длины наименования классификационной шкалы CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Class_Sc EXCLUSIVE NEW mLenMaxClSc = -999999 SELECT Class_Sc DBGOTOP() DO WHILE .NOT. EOF() mLenMaxClSc = MAX(mLenMaxClSc, LEN(ALLTRIM(Name_ClSc))) DBSKIP(1) ENDDO ***** Определение максимальной длины наименования градации классификационной шкалы CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Gr_ClSc EXCLUSIVE NEW mLenMaxGrCS = -999999 SELECT Gr_ClSc DBGOTOP() DO WHILE .NOT. EOF() mLenMaxGrCS = MAX(mLenMaxGrCS, LEN(ALLTRIM(Name_GrCS))) DBSKIP(1) ENDDO ***** Определение максимальной длины полного наименования класса: кл.шкала+класс CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW mLenMax = -999999 SELECT Classes DBGOTOP() DO WHILE .NOT. EOF() mLenMax = MAX(mLenMax, LEN(ALLTRIM(Name_cls))) DBSKIP(1) ENDDO // Сформировать пустую БД InfPortAtr, как часть БД Classes aStr := { { "Kod_cls" , "N", 15, 0 }, ; { "Name_cls" , "C", mLenMax, 0 }, ; { "Znach" , "N", 19, 7 }, ; { "Kod_ClSc" , "N", 15, 0 }, ; { "Fltr_Wind", "C", 1, 0 } } // Для фильтра "Вписать в окно" DbCreate( "InfPortAtr", aStr ) Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } *mMax433 = (mAtr2Left - mAtr1Left + 1) * (mAtr2Right - mAtr1Right + 1) *mTime433 = 0 *@ 4,5 DCPROGRESS oProgress SIZE 70,1.1 MAXCOUNT mMax423 COLOR GRA_CLR_CYAN PERCENT EVERY 100 *DCREAD GUI TITLE L('4.3.3. Когнитивные диаграммы признаков. Генерация выходных форм') PARENT @oDialog FIT EXIT *oDialog:show() *DC_GetProgress(oProgress,0,mMax423) PUBLIC X_MaxW := 1800, Y_MaxW := 900 // Размер графического окна для отображения когнитивных диаграмм в пикселях aFonts := XbpFont():new():list() // Загрузка всех графических шрифтов mNCognDiagrAtr = 0 FOR mAtrLeft = mAtr1Left TO mAtr2Left // ЦИКЛ ПО КЛАССАМ ЛЕВОГО ИНФОРМАЦИОННОГО ПОРТРЕТА *********** DC_ASave(mAtrLeft, "_AtrLeft.arx") // Код левого признака FOR mAtrRight = mAtr1Right TO mAtr2Right // ЦИКЛ ПО КЛАССАМ ПРАВОГО ИНФОРМАЦИОННОГО ПОРТРЕТА ********** DC_ASave(mAtrRight, "_AtrRight.arx") // Код правого признака FOR mNumMod = 1 TO LEN(Ar_Model) // ЦИКЛ ПО ВСЕМ МОДЕЛЯМ ************************************** IF aParKDAtr[mNumMod+4] // ПРОВЕРКА НА ТО, ЗАДАНА ЛИ ОЧЕРЕДНАЯ МОДЕЛЬ **************** * mNumMod = DC_ARestore("_NumMod.arx") DC_ASave(mNumMod, "_NumMod.arx") ***** ГЕНЕРАЦИЯ ИНФОРМАЦИОННЫХ ПОРТРЕТОВ АТРИБУТОВ mAtrLeft и mAtrRight ***** Генерация информационного портрета класса в модели: Ar_Model[M_CurrInf] для класса mCls mMod = Ar_Model[mNumMod] // Наименование БД левого инф.портрета в текущей модели mPrtAtrLeftMod = "PrtAtrLeft" +Ar_Model[mNumMod] // Наименование БД левого инф.портрета в текущей модели mPrtAtrRightMod = "PrtAtrRight"+Ar_Model[mNumMod] // Наименование БД правого инф.портрета в текущей модели CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW USE InfPortAtr EXCLUSIVE NEW InfPortAtr433(mNumMod, mAtrLeft) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций COPY FILE ("InfPortAtr.dbf") TO (mPrtAtrLeftMod+".dbf") CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW USE InfPortAtr EXCLUSIVE NEW InfPortAtr433(mNumMod, mAtrRight) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций COPY FILE ("InfPortAtr.dbf") TO (mPrtAtrRightMod+".dbf") ***** Если не заданы все описательные шкалы, ***** то исключение из потрета тех признаков, ***** которые не попадают в заданные шкалы. ***** Сделать это и для левого, и для правого инф.портретов * aParKDAtr[ 3] = 0 // Код оп.шкалы левого инф.портрета * aParKDAtr[ 4] = 0 // Код оп.шкалы правого инф.портрета IF aParKDAtr[ 3] <> 0 CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mPrtAtrLeftMod) EXCLUSIVE NEW DELETE FOR Kod_ClSc <> aParKDAtr[ 3] PACK ENDIF IF aParKDAtr[ 4] <> 0 CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mPrtAtrRightMod) EXCLUSIVE NEW DELETE FOR Kod_ClSc <> aParKDAtr[ 4] PACK ENDIF ******* Формирование массивов кодов классов, которые встречаются ******* хотя бы в одном из портретов и, заодно, расчет средних и ср.кв.откл. CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mMod) EXCLUSIVE NEW USE Class_Sc EXCLUSIVE NEW USE Gr_ClSc EXCLUSIVE NEW USE (mPrtAtrLeftMod) EXCLUSIVE NEW USE (mPrtAtrRightMod) EXCLUSIVE NEW aKodCls1 := {} aKodClSc1 := {} aNameCls1 := {} aNameClSc1 := {} aNameGrCS1 := {} aInfCls1 := {} SELECT (mPrtAtrLeftMod) INDEX ON STR(Kod_cls,15) TO PrtAtrLeft DBGOTOP() mN1 = RECCOUNT() DO WHILE .NOT. EOF() mKodCls1 = Kod_cls mKodClSc1 = Kod_ClSc mNameCls1 = Name_cls mZnach1 = Znach SELECT Class_Sc DBGOTO(mKodClSc1) mNameClSc1 = Name_ClSc SELECT Gr_ClSc DBGOTO(mKodCls1) mNameGrCS1 = DelZeroNameGr(Name_GrCS) AADD(aKodCls1 , mKodCls1 ) AADD(aKodClSc1 , mKodClSc1 ) AADD(aNameCls1 , mNameCls1 ) AADD(aNameClSc1, mNameClSc1) AADD(aNameGrCS1, mNameGrCS1) AADD(aInfCls1 , mZnach1 ) SELECT (mPrtAtrLeftMod) DBSKIP(1) ENDDO aKodCls2 := {} aKodClSc2 := {} aNameCls2 := {} aNameClSc2 := {} aNameGrCS2 := {} aInfCls2 := {} SELECT (mPrtAtrRightMod) INDEX ON STR(Kod_cls,15) TO PrtAtrRight DBGOTOP() mN2 = RECCOUNT() DO WHILE .NOT. EOF() mKodCls2 = Kod_cls mKodClSc2 = Kod_ClSc mNameCls2 = Name_cls mZnach2 = Znach SELECT Class_Sc DBGOTO(mKodClSc2) mNameClSc2 = Name_ClSc SELECT Gr_ClSc DBGOTO(mKodCls2) mNameGrCS2 = DelZeroNameGr(Name_GrCS) AADD(aKodCls2 , mKodCls2 ) AADD(aKodClSc2 , mKodClSc2 ) AADD(aNameCls2 , mNameCls2 ) AADD(aNameClSc2, mNameClSc2) AADD(aNameGrCS2, mNameGrCS2) AADD(aInfCls2 , mZnach2 ) SELECT (mPrtAtrRightMod) DBSKIP(1) ENDDO ***** СОЗДАТЬ БД СВЯЗЕЙ ПРИЗНАКОВ ДЛЯ ТЕКУЩЕЙ МОДЕЛИ ************* CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций aStr := { { "Kod_cls" , "N", 15, 0},; { "Kod_ClSc", "N", 15, 0},; { "Name_cls", "C", mLenMax, 0} } FOR j=1 TO LEN(aKodCls2) FieldName = "P"+ALLTRIM(STR(aKodCls2[j],15)) AADD( aStr, { FieldName, "N", 19, 7 } ) NEXT mRelAtrModi = "RelAtr"+Ar_Model[mNumMod]+"i" mRelAtrModp = "RelAtr"+Ar_Model[mNumMod]+"p" mRelAtrMods = "RelAtr"+Ar_Model[mNumMod]+"s" DbCreate( mRelAtrModi, aStr ) DbCreate( mRelAtrModp, aStr ) DbCreate( mRelAtrMods, aStr ) *** Заполнить БД связей mSxodClsMod = "SxodCls"+Ar_Model[mNumMod] CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mMod) EXCLUSIVE NEW USE (mRelAtrModi) EXCLUSIVE NEW USE (mRelAtrModp) EXCLUSIVE NEW USE (mRelAtrMods) EXCLUSIVE NEW USE (mPrtAtrLeftMod) INDEX PrtAtrLeft EXCLUSIVE NEW USE (mPrtAtrRightMod) INDEX PrtAtrRight EXCLUSIVE NEW USE (mSxodClsMod) EXCLUSIVE NEW FOR i=1 TO LEN(aKodCls1) SELECT (mRelAtrModi) APPEND BLANK REPLACE Kod_cls WITH aKodCls1 [i] REPLACE Kod_ClSc WITH aKodClSc1[i] REPLACE Name_cls WITH DelZeroNameGr(aNameCls1[i]) SELECT (mRelAtrModp) APPEND BLANK REPLACE Kod_cls WITH aKodCls1 [i] REPLACE Kod_ClSc WITH aKodClSc1[i] REPLACE Name_cls WITH DelZeroNameGr(aNameCls1[i]) SELECT (mRelAtrMods) APPEND BLANK REPLACE Kod_cls WITH aKodCls1 [i] REPLACE Kod_ClSc WITH aKodClSc1[i] REPLACE Name_cls WITH DelZeroNameGr(aNameCls1[i]) SELECT (mMod) DBGOTO(aKodCls1[i]) mSr1 = FIELDGET(N_Cls+4) mDi1 = FIELDGET(N_Cls+5) ****** Расчет силы связи в стандартизированных величинах (точно как коэффициент корреляции, только не два, а три массива) FOR j=1 TO LEN(aKodCls2) SELECT (mSxodClsMod) DBGOTO(aKodCls1[i]) mK12 = 0.01*FIELDGET(3+aKodCls2[j]) SELECT (mMod) DBGOTO(aKodCls2[j]) mSr2 = FIELDGET(N_Cls+4) mDi2 = FIELDGET(N_Cls+5) mTeorMaxInf = LOG(N_Cls)/LOG(2) // Теоретически максимальная информативность mInfPerTM1 = aInfCls1[i]/mTeorMaxInf*100 // Информативность 1-го пр.в % от теор.MAX-возможной mInfPerTM2 = aInfCls2[j]/mTeorMaxInf*100 // Информативность 2-го пр.в % от теор.MAX-возможной mInfStand1 = (aInfCls1[i]-mSr1)/mDi1 // Информативность 1-го пр.в стандартизированных величинах mInfStand2 = (aInfCls2[j]-mSr2)/mDi2 // Информативность 2-го пр.в стандартизированных величинах mRelBit = mK12 * aInfCls1[i] * aInfCls2[j] // Сила связи в битах mMaxRelBit = 1 * mTeorMaxInf * mTeorMaxInf // MAX-теоретически возможная сила связи в битах mRelPercTM = mRelBit / mMaxRelBit * 100 // Сила связи в % от теор.MAX-возможной mRelStand = mK12 * mInfStand1 * mInfStand2 / 2 // Сила связи в стандартизированных величинах SELECT (mRelAtrModi) FIELDPUT( FIELDNUM("P"+ALLTRIM(STR(aKodCls2[j],15))), mRelBit ) SELECT (mRelAtrModp) FIELDPUT( FIELDNUM("P"+ALLTRIM(STR(aKodCls2[j],15))), mRelPercTM ) SELECT (mRelAtrMods) FIELDPUT( FIELDNUM("P"+ALLTRIM(STR(aKodCls2[j],15))), mRelStand ) NEXT NEXT ****** Дописать в (mRelAtrMod) информационные строки о горизонтальной шапке SELECT (mRelAtrModi) APPEND BLANK REPLACE Name_cls WITH 'Имена колонок: P'+REPLICATE("#",100) FOR i=1 TO LEN(aKodCls2) APPEND BLANK REPLACE Kod_cls WITH aKodCls2 [i] REPLACE Kod_ClSc WITH aKodClSc2[i] REPLACE Name_cls WITH DelZeroNameGr(aNameCls2[i]) NEXT SELECT (mRelAtrModp) APPEND BLANK REPLACE Name_cls WITH 'Имена колонок: P'+REPLICATE("#",100) FOR i=1 TO LEN(aKodCls2) APPEND BLANK REPLACE Kod_cls WITH aKodCls2 [i] REPLACE Kod_ClSc WITH aKodClSc2[i] REPLACE Name_cls WITH DelZeroNameGr(aNameCls2[i]) NEXT SELECT (mRelAtrMods) APPEND BLANK REPLACE Name_cls WITH 'Имена колонок: P'+REPLICATE("#",100) FOR i=1 TO LEN(aKodCls2) APPEND BLANK REPLACE Kod_cls WITH aKodCls2 [i] REPLACE Kod_ClSc WITH aKodClSc2[i] REPLACE Name_cls WITH DelZeroNameGr(aNameCls2[i]) NEXT **** СОЗДАТЬ БАЗУ ДЛЯ ВИЗУАЛИЗАЦИИ ОТНОШЕНИЙ ДВУХ ПРИЗНАКОВ (mRelViewAtrMod) aStr := { { "Num_pp" , "N", 15, 0 }, ; { "Kod_cls1" , "N", 15, 0 }, ; { "Kod_ClSc1" , "N", 15, 0 }, ; { "Name_ClSc1" , "C", mLenMaxClSc, 0 }, ; { "Name_GrCS1" , "C", mLenMaxGrCS, 0 }, ; { "Name_cls1" , "C", mLenMax, 0 }, ; { "Inf_Bit1" , "N", 19, 7 }, ; { "Inf_PerTM1" , "N", 19, 7 }, ; { "Inf_Stand1" , "N", 19, 7 }, ; { "Kod_cls2" , "N", 15, 0 }, ; { "Kod_ClSc2" , "N", 15, 0 }, ; { "Name_ClSc2" , "C", mLenMaxClSc, 0 }, ; { "Name_GrCS2" , "C", mLenMaxGrCS, 0 }, ; { "Name_cls2" , "C", mLenMax, 0 }, ; { "Inf_Bit2" , "N", 19, 7 }, ; { "Inf_PerTM2" , "N", 19, 7 }, ; { "Inf_Stand2" , "N", 19, 7 }, ; { "Kor_12" , "N", 19, 7 }, ; { "Rel_bit" , "N", 19, 7 }, ; { "Rel_perTM" , "N", 19, 7 }, ; { "Rel_stand" , "N", 19, 7 }, ; { "Rang1" , "N", 15, 0 }, ; { "Rang2" , "N", 15, 0 } } mRelViewAtrMod = "RelViewAtr"+Ar_Model[mNumMod] DbCreate( mRelViewAtrMod, aStr ) ***** ЗАПОЛНИТЬ БАЗУ ДЛЯ ВИЗУАЛИЗАЦИИ ОТНОШЕНИЙ ДВУХ ПРИЗНАКОВ (mRelVAtrMod) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mMod) EXCLUSIVE NEW;N_Cls = FCOUNT()-5 USE (mSxodClsMod) EXCLUSIVE NEW USE (mRelViewAtrMod) EXCLUSIVE NEW USE (mPrtAtrLeftMod) EXCLUSIVE NEW USE (mPrtAtrRightMod) EXCLUSIVE NEW mMaxAbsRel = -99999999 // Фактическая максимальная сила связи FOR i=1 TO LEN(aKodCls1) SELECT (mMod) DBGOTO(RECCOUNT()-1) mSr1 = FIELDGET(2+aKodCls1[i]) DBGOBOTTOM() mDi1 = FIELDGET(2+aKodCls1[i]) FOR j=1 TO LEN(aKodCls2) SELECT (mSxodClsMod) DBGOTO(aKodCls1[i]) mK12 = 0.01*FIELDGET(3+aKodCls2[j]) // Коэфф.корреляции между классами, посчитанный по всем признакам ****** Средние и ср.кв.откл.не рассчитывать, а брать из (mMod) SELECT (mMod) DBGOTO(RECCOUNT()-1) mSr2 = FIELDGET(2+aKodCls2[j]) DBGOBOTTOM() mDi2 = FIELDGET(2+aKodCls2[j]) IF ABS(mK12) > 0 // Показывать только не нулевые связи (можно задавать порог в диалоге) ******** Расчет показателей mTeorMaxInf = LOG(N_Cls)/LOG(2) // Теоретически максимальная информативность mInfPerTM1 = aInfCls1[i]/mTeorMaxInf*100 // Информативность 1-го класса в % от теор.MAX-возможной mInfPerTM2 = aInfCls2[j]/mTeorMaxInf*100 // Информативность 2-го класса в % от теор.MAX-возможной mInfStand1 = (aInfCls1[i]-mSr1)/mDi1 // Информативность 1-го класса в стандартизированных величинах mInfStand2 = (aInfCls2[j]-mSr2)/mDi2 // Информативность 2-го класса в стандартизированных величинах mRelBit = mK12 * aInfCls1[i] * aInfCls2[j] // Сила связи в битах mMaxRelBit = 1 * mTeorMaxInf * mTeorMaxInf // MAX-теоретически возможная сила связи в битах mRelPercTM = mRelBit / mMaxRelBit * 100 // Сила связи в % от теор.MAX-возможной mRelStand = mK12 * mInfStand1 * mInfStand2 / 2 // Сила связи в стандартизированных величинах SELECT (mRelViewAtrMod) APPEND BLANK REPLACE Kod_cls1 WITH aKodCls1 [i] REPLACE Kod_ClSc1 WITH aKodClSc1 [i] REPLACE Name_ClSc1 WITH aNameClSc1[i] REPLACE Name_GrCS1 WITH DelZeroNameGr(aNameGrCS1[i]) REPLACE Name_cls1 WITH DelZeroNameGr(aNameCls1 [i]) REPLACE Inf_Bit1 WITH aInfCls1 [i] REPLACE Inf_PerTM1 WITH mInfPerTM1 REPLACE Inf_stand1 WITH mInfStand1 REPLACE Kod_cls2 WITH aKodCls2 [j] REPLACE Kod_ClSc2 WITH aKodClSc2 [j] REPLACE Name_ClSc2 WITH aNameClSc2[j] REPLACE Name_GrCS2 WITH DelZeroNameGr(aNameGrCS2[j]) REPLACE Name_cls2 WITH DelZeroNameGr(aNameCls2 [j]) REPLACE Inf_Bit2 WITH aInfCls2 [j] REPLACE Inf_PerTM2 WITH mInfPerTM2 REPLACE Inf_stand2 WITH mInfStand2 REPLACE Kor_12 WITH mK12 REPLACE Rel_bit WITH mRelBit // Сила связи в Bit REPLACE Rel_perTM WITH mRelPercTM // Сила связи в % от теор.макс.возм. REPLACE Rel_stand WITH mRelStand // Сила связи в стандартизированных величинах ENDIF NEXT NEXT SELECT (mRelViewAtrMod) INDEX ON STR(999999.9999999-ABS(Rel_bit),19,7) TO RelViewCls // сделать КД для всех трех видов связей: бит, %бит от ТМ, стандарт. ############### ***** Оставить столько записей с наиболее значимыми связями, ***** чтобы в левом и правом портретах было не более N_Atr признаков mMaxAtrInfPort = 7 // Максимальное количество отображаемых на диаграмме признаков в инф.портрете CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mRelViewAtrMod) INDEX RelViewCls EXCLUSIVE NEW SELECT (mRelViewAtrMod) SET ORDER TO 1 DBGOTOP() aKodCls1 := {} // Коды признаков из 1-го портрета AADD(aKodCls1, STR(999999.9999999-Inf_bit1,19,7)+STR(Kod_cls1,15)) DO WHILE .NOT. EOF() IF ASCAN(aKodCls1, STR(999999.9999999-Inf_bit1,19,7)+STR(Kod_cls1,15)) = 0 IF LEN(aKodCls1) < mMaxAtrInfPort AADD(aKodCls1, STR(999999.9999999-Inf_bit1,19,7)+STR(Kod_cls1,15)) ELSE DELETE ENDIF ENDIF DBSKIP(1) ENDDO DBGOTOP() aKodCls2 := {} // Коды признаков из 2-го портрета AADD(aKodCls2, STR(999999.9999999-Inf_bit2,19,7)+STR(Kod_cls2,15)) DO WHILE .NOT. EOF() IF ASCAN(aKodCls2, STR(999999.9999999-Inf_bit2,19,7)+STR(Kod_cls2,15)) = 0 IF LEN(aKodCls2) < mMaxAtrInfPort AADD(aKodCls2, STR(999999.9999999-Inf_bit2,19,7)+STR(Kod_cls2,15)) ELSE DELETE ENDIF ENDIF DBSKIP(1) ENDDO mNum = 0 // Количество связей и порядковые номера DBGOTOP() DO WHILE .NOT. EOF() IF mNum < aParKDAtr[15] // Количество отображаемых связей REPLACE Num_pp WITH ++mNum ELSE DELETE ENDIF DBSKIP(1) ENDDO PACK ****** ЕСЛИ БАЗА СВЯЗЕЙ ПУСТА - СООБЩЕНИЕ И ВЫХОД SELECT (mRelViewAtrMod) * IF RECCOUNT() = 0 * LB_Warning(L('СТРАННО, НО ПРИ ЗАДАННЫХ УСЛОВИЯХ ПРИЗНАКИ НИКАК НЕ СВЯЗАНЫ !!!'), L('4.3.3. Когнитивные диаграммы признаков')) * ************************************************************** * ***** БД, открытые перед запуском главного меню * ***** Восстанавливать их после выхода из функций главного меню * ************************************************************** * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы * USE PathGrAp EXCLUSIVE NEW * USE Appls EXCLUSIVE NEW * USE Users EXCLUSIVE NEW * ************************************************************** * Running(.F.) * ReTURN nil * ENDIF IF RECCOUNT() > 0 ***** Прописать ранги признаков и сделать массивы признаков для отображения в КД ############################################################## CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mRelViewAtrMod) EXCLUSIVE NEW INDEX ON STR(999999.9999999-Inf_bit1,19,7)+STR(Kod_cls1,15) TO RelViewCls1 // Сделать КД для всех трех видов связей: бит, %бит от ТМ, стандарт. mRang1 = 1 DBGOTOP() mOld = STR(999999.9999999-Inf_bit1,19,7)+STR(Kod_cls1,15) DO WHILE .NOT. EOF() IF mOld <> STR(999999.9999999-Inf_bit1,19,7)+STR(Kod_cls1,15) ++mRang1 mOld = STR(999999.9999999-Inf_bit1,19,7)+STR(Kod_cls1,15) ENDIF REPLACE Rang1 WITH mRang1 DBSKIP(1) ENDDO CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mRelViewAtrMod) EXCLUSIVE NEW INDEX ON STR(999999.9999999-Inf_bit2,19,7)+STR(Kod_cls2,15) TO RelViewCls2 // Сделать КД для всех трех видов связей: бит, %бит от ТМ, стандарт. mRang2 = 1 DBGOTOP() mOld = STR(999999.9999999-Inf_bit2,19,7)+STR(Kod_cls2,15) DO WHILE .NOT. EOF() IF mOld <> STR(999999.9999999-Inf_bit2,19,7)+STR(Kod_cls2,15) ++mRang2 mOld = STR(999999.9999999-Inf_bit2,19,7)+STR(Kod_cls2,15) ENDIF REPLACE Rang2 WITH mRang2 DBSKIP(1) ENDDO ***** ОТОБРАЖЕНИЕ КОГНИТИВНЫХ ДИАГРАММ ***************************** * @ 2,1 DCSTATIC TYPE XBPSTATIC_TYPE_RECESSEDBOX SIZE X_MaxW, Y_MaxW PIXEL OBJECT oStatic * DCREAD GUI FIT EVAL {||_PresSpace433(oStatic, mAtrLeft, mAtrRight, mNumMod, aFonts)} ; * TITLE L('4.3.3. Когнитивные диаграммы признаков. (C) Универсальная когнитивная аналитическая система "ЭЙДОС-X++"') * oStatic := nil PUBLIC X_MaxW := 1800, Y_MaxW := 900 // Размер графического окна для отображения когнитивных диаграмм в пикселях PUBLIC nXSize := 1800 PUBLIC nYSize := 900 * FOR mAtrLeft = mAtr1Left TO mAtr2Left // ЦИКЛ ПО КЛАССАМ ЛЕВОГО ИНФОРМАЦИОННОГО ПОРТРЕТА *********** * FOR mAtrRight = mAtr1Right TO mAtr2Right // ЦИКЛ ПО КЛАССАМ ПРАВОГО ИНФОРМАЦИОННОГО ПОРТРЕТА ********** * FOR mNumMod = 1 TO LEN(Ar_Model) // ЦИКЛ ПО ВСЕМ МОДЕЛЯМ ************************************** oScr := DC_WaitOn(L('Формируется и записывается когнитивная диаграмма: Левый признак=')+ALLTRIM(STR(mAtrLeft))+'/'+ALLTRIM(STR(mAtr2Left))+L(', Правый признак=')+ALLTRIM(STR(mAtrRight))+'/'+ALLTRIM(STR(mAtr2Right))+L(', Модель=')+Ar_Model[mNumMod],,,,,,,,,,,.F.) // Create new bitmap with given size oPS := XBPPRESSPACE() :new() :Create() oBMP := XBPBITMAP() :New() :Create() * oBMP:Make( nXSize, nYSize, nPlanes, nBits ) oBMP:Make( nXSize, nYSize ) oBMP:presSpace( oPS ) // here your GRA* Code **** Закрасить фон прямоугольника *************** * GraSetColor( oPS, GRA_CLR_WHITE, GRA_CLR_WHITE ) GraSetColor( oPS, BD_LIGHTGREY, BD_LIGHTGREY ) GraBox( oPS, { 0, 0 }, { nXSize, nYSize }, GRA_FILL ) *######################################################################################################################### CognDiagrAtr( oPS, oBMP, mAtrLeft, mAtrRight, mNumMod, aFonts ) // Графическая функция <<<===######################### *######################################################################################################################### *My image original, my image scaled ****** Запись полноразмерного графического файла в папку: M_PathAppl+"\CognDiagrCls\" DC_Impl(oScr) IF FILEDATE("CognDiagrAtr",16) = CTOD("//") DIRMAKE("CognDiagrAtr") aMess := {} AADD(aMess, L('В папке текущего приложения: "'+UPPER(ALLTRIM(M_PathAppl))+'"')) AADD(aMess, L('не было директории "CognDiagrAtr" для когнитивных диаграмм признаков и она была создана!')) AADD(aMess, L('В эту папку записываются исходные изображения высокого качества (без масштабирования)')) LB_Warning(aMess, L('4.3.3. Когнитивные диаграммы признаков' )) ENDIF DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения **** DC_ASave(mAtrLeft , "_AtrLeft.arx") // Код левого признака **** DC_ASave(mAtrRight, "_AtrRight.arx") // Код правого признака **** DC_ASave(mNumMod , "_NumMod.arx") mAtrLeft = DC_ARestore("_AtrLeft.arx") mAtrRight = DC_ARestore("_AtrRight.arx") mNumMod = DC_ARestore("_NumMod.arx") DIRCHANGE(M_PathAppl+"\CognDiagrAtr\") // Перейти в папку CognDiagrAtr cFileName = "CogDiagAtr"+STRTRAN(STR(mAtrLeft,4)," ","0")+"-"+STRTRAN(STR(mAtrRight,4)," ","0")+"-"+STRTRAN(STR(mNumMod,2)," ","0")+".jpg" ERASE(cFileName) oBMP:SaveFile(cFileName,XBPBMP_FORMAT_JPG) IF nWidth > 1800 IF mPause = 1 FullView( cFileName, "по верху", 65 ) // Визуализация полноразмерного файла на мониторе высокого разрешения ENDIF ELSE ****** Формирование с помощью bmp2bmp() и отображение масштабированного изображения aNewSize := {nWidth,nHeight-29} // Новый размер изображения (еще немного уменьшается, чтобы не рисовать по панели задач) oBMP:loadFile(cFileName) // Загрузка полноразмерного изображения oRet := BMP2BMP(oBMP,aNewSize) // Масштабирование изображения cFileNameScale = SUBSTR(cFileName,1,AT(".jpg",cFileName)-1)+"_scaled.jpg" ERASE(cFileNameScale) oRet:saveFile(cFileNameScale,XBPBMP_FORMAT_JPG) // Запись масштабированного графического файла в в папку приложения для визуализации IF mPause = 1 FullView( cFileNameScale, "по верху", 0 ) // Визуализация масштабированного графического файла на мониторе ограниченного разрешения ENDIF ENDIF DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения mNCognDiagrAtr++ ENDIF ENDIF // ПРОВЕРКА НА ТО, ЗАДАНА ЛИ ОЧЕРЕДНАЯ МОДЕЛЬ **************** NEXT // ЦИКЛ ПО ВСЕМ МОДЕЛЯМ ************************************** * DC_GetProgress(oProgress, ++mTime423, mMax423) * MsgBox(STR(mTime423)+STR(mAtrLeft)+STR(mAtrRight)) NEXT // ЦИКЛ ПО КЛАССАМ ПРАВОГО ИНФОРМАЦИОННОГО ПОРТРЕТА ********** NEXT // ЦИКЛ ПО КЛАССАМ ЛЕВОГО ИНФОРМАЦИОННОГО ПОРТРЕТА *********** *DC_GetProgress(oProgress,mMax423,mMax423) *oDialog:Destroy() *** Закрыть все текстовые БД ****** FOR z=1 TO LEN(Ar_Model) FClose( nHandle[z] ) // Закрытие текстовой базы данных ###################################### NEXT aMess := {} AADD(aMess, L('Процесс генерации')+IF(mPause=1,L(', визуализации'),'')+' '+L(' и записи когнитивных диаграмм')) AADD(aMess, L('содержательного сравнения признаков успешно звершен !!!')) AADD(aMess, L('')) AADD(aMess, L('В папку: "')+M_PathAppl+'CognDiagrAtr\"'+' '+L('сохранено')+' '+ALLTRIM(STR(mNCognDiagrAtr))+' '+L('диаграмм.')) LB_Warning(aMess, L('4.3.3. Когнитивные диаграммы признаков')) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) ReTURN nil **************************************************************************************** ************************************************************************************************** FUNCTION Help433() aHelp := {} AADD(aHelp, L(' Данный режим формирует и отображает в графической форме когнитивные диаграммы, т.е. ')) AADD(aHelp, L(' автоматизирует содержательное сравнение двух информационных портретов обобщенных образов признаков: ')) AADD(aHelp, L(' ')) AADD(aHelp, L('1. Формируются информационные портреты двух признаков. ')) AADD(aHelp, L('2. Выявляются классы, которые есть по крайней мере в одном из портретов. Такие классы называются СВЯЗЯМИ, т.к. благодаря ')) AADD(aHelp, L(' им существуют определенные ОТНОШЕНИЯ сходства/различия между обобщенными образами признаков. ')) AADD(aHelp, L('3. Для каждого признака известно, какое количество информации о принадлежности объекта с ним к каждому из классов он содержит. ')) AADD(aHelp, L('4. Кроме того для любых двух классов известно, насколько они являются сходными по смыслу (из матрицы сходства классов). ')) AADD(aHelp, L('5. Будем считать, что любые два класса вносят определенный вклад в сходство или различие двух признаков, определяемый формулами:')) AADD(aHelp, L(' ')) AADD(aHelp, L(' mTeorMaxInf = LOG(N_Cls)/LOG(2) // Теоретически максимальная информативность ')) AADD(aHelp, L(' ')) AADD(aHelp, L(' mInfPerTM1 = aInfCls1[i]/mTeorMaxInf*100 // Информативность 1-го класса в % от теор.MAX-возможной ')) AADD(aHelp, L(' mInfPerTM2 = aInfCls2[j]/mTeorMaxInf*100 // Информативность 2-го класса в % от теор.MAX-возможной ')) AADD(aHelp, L(' ')) AADD(aHelp, L(' mInfStand1 = (aInfCls1[i]-mSr1)/mDi1 // Информативность 1-го класса в стандартизированных величинах ')) AADD(aHelp, L(' mInfStand2 = (aInfCls2[j]-mSr2)/mDi2 // Информативность 2-го класса в стандартизированных величинах ')) AADD(aHelp, L(' ')) AADD(aHelp, L(' mRelBit = mK12 * aInfCls1[i] * aInfCls2[j] // Сила связи в битах ')) AADD(aHelp, L(' ')) AADD(aHelp, L(' mMaxRelBit = 1 * mTeorMaxInf * mTeorMaxInf // MAX-теоретически возможная сила связи в битах ')) AADD(aHelp, L(' ')) AADD(aHelp, L(' mRelPercTM = mRelBit / mMaxRelBit * 100 // Сила связи в % от теор.MAX-возможной ')) AADD(aHelp, L(' ')) AADD(aHelp, L(' mRelStand = mK12 * mInfStand1 * mInfStand2 / 2 // Сила связи в стандартизированных величинах ')) AADD(aHelp, L(' ')) AADD(aHelp, L(' Где: ')) AADD(aHelp, L(' - mSr1 - средняя информативность 1-го признака; ')) AADD(aHelp, L(' - mSr2 - средняя информативность 2-го признака; ')) AADD(aHelp, L(' - mDi1 - среднеквадратичное отклонение информативносттей 1-го признака; ')) AADD(aHelp, L(' - mDi2 - среднеквадратичное отклонение информативносттей 1-го признака; ')) AADD(aHelp, L(' - mK12 - сходство 1-го и 2-го классов по их системе детерминации из матрицы сходства классов. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('6. На диаграмме отображается 7 признаков, образующих наиболее значимые по модулю связи. Знак связи изображается цветом: ')) AADD(aHelp, L(' красный "+", синий "-", а величина-толщиной линии. ')) mHelpMax = -999;FOR h=1 TO LEN(aHelp);mHelpMax = MAX(mHelpMax, LEN(ALLTRIM(aHelp[h])));NEXT s=1;d=0.9;@0,0 DCGROUP oGroup1 CAPTION L(' ') SIZE mHelpMax-20, LEN(aHelp)*d+1.5 FOR h=1 TO LEN(aHelp);@s,2 DCSAY aHelp[h] SIZE 0 PARENT ogroup1;s=s+d;NEXT DCREAD GUI TO lExit FIT TITLE L('Помощь по режиму: 4.3.3. (C) Система "ЭЙДОС-X++"') RETURN NIL ************************************************************************************************** ******** Выбор кода признака левого инф.портрета FUNCTION KodAtrLeft433(aParKDAtr) SELECT AttributesKD PUBLIC mKNAtrLeft := 'Признак для левого инф.портрета: ['+ALLTRIM(STR(Kod_atr, 15))+'] '+ALLTRIM(Name_atr) aParKDAtr[ 1] = Kod_atr // Код признака левого инф.портрета DC_ASave(aParKDAtr , "_4_3_3.arx") // Записать параметры для расчетов когнитивных диаграмм, заданные в диалоге ReTURN nil *************************************** FUNCTION KodAtrRight433(aParKDAtr) SELECT AttributesKD PUBLIC mKNAtrRight := 'Признак для правого инф.портрета: ['+ALLTRIM(STR(Kod_atr, 15))+'] '+ALLTRIM(Name_atr) aParKDAtr[ 2] = Kod_atr // Код признака правого инф.портрета DC_ASave(aParKDAtr , "_4_3_3.arx") // Записать параметры для расчетов когнитивных диаграмм, заданные в диалоге ReTURN nil *************************************** FUNCTION KodClScLeft433(aParKDAtr) SELECT Class_ScKD PUBLIC mKNClScLeft := 'Классификационная шкала для левого инф.портрета: ['+ALLTRIM(STR(Kod_ClSc, 15))+'] '+ALLTRIM(Name_ClSc) aParKDAtr[ 3] = Kod_ClSc // Код описательной шкалы левого правого инф.портрета DC_ASave(aParKDAtr , "_4_3_3.arx") // Записать параметры для расчетов когнитивных диаграмм, заданные в диалоге ReTURN nil *************************************** FUNCTION KodClScRight433(aParKDAtr) SELECT Class_ScKD PUBLIC mKNClScRight := 'Классификационная шкала для правого инф.портрета: ['+ALLTRIM(STR(Kod_ClSc, 15))+'] '+ALLTRIM(Name_ClSc) aParKDAtr[ 4] = Kod_ClSc // Код описательной шкалы левого правого инф.портрета DC_ASave(aParKDAtr , "_4_3_3.arx") // Записать параметры для расчетов когнитивных диаграмм, заданные в диалоге ReTURN nil ******** Генерация информационного портрета признака в модели Ar_Model[M_CurrInf] для признака mAtr FUNCTION InfPortAtr433(M_CurrInf, M_KodAtr) SELECT Classes N_Cls = RECCOUNT() // Заполнить БД InfPortAtr записями с кодами и наименованиями признаков и их значимостью SELECT InfPortAtr;ZAP FOR j=1 TO N_Cls M_Znach = VAL(LC_FieldGet( Ar_Model[M_CurrInf]+".txt", nHandle[M_CurrInf], M_KodAtr, 2+j )) // Инф.портрет признака M_KodAtr IF M_Znach <> 0 SELECT Classes DBGOTO(j) M_KodCls = Kod_cls M_NameCls = Name_cls M_KodClSc = Kod_ClSc SELECT InfPortAtr APPEND BLANK REPLACE Kod_cls WITH M_KodCls REPLACE Name_cls WITH M_NameCls REPLACE Kod_ClSc WITH M_KodClSc REPLACE Znach WITH M_Znach ENDIF NEXT ***** Сортировка InfPortAtr по полю Znach по убыванию CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE InfPortAtr EXCLUSIVE NEW COPY STRUCTURE TO Temp.dbf CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE InfPortAtr EXCLUSIVE NEW INDEX ON STR(999999999.9999999-Znach,19,7) TO InfPortAtr CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Temp EXCLUSIVE NEW USE InfPortAtr INDEX InfPortAtr EXCLUSIVE NEW SELECT InfPortAtr SET ORDER TO 1 DBGOTOP() DO WHILE .NOT. EOF() a := {} FOR j=1 TO FCOUNT() AADD(a, FIELDGET(j)) NEXT SELECT Temp APPEND BLANK FOR j=1 TO LEN(a) FIELDPUT(j, a[j]) NEXT SELECT InfPortAtr DBSKIP(1) ENDDO CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций ERASE("InfPortAtr.dbf") RenameFile( "Temp.dbf", "InfPortAtr.dbf" ) ReTURN NIL ****************************** ************************************************* *STATIC FUNCTION _PresSpace433( oStatic, mAtrLeft, mAtrRight, mNumMod, aFonts ) * LOCAL oPS, oDevice * oPS := XbpPresSpace():new() // Create a PS * oDevice := oStatic:winDevice() // Get the device context * oPS:create( oDevice ) // Link device context to PS * oPS:SetViewPort( { 0, 0, X_MaxW, Y_MaxW } ) * oStatic:paint := {|mp1,mp2,obj| mp1 := CognDiagrAtr( oPS, oStatic, mAtrLeft, mAtrRight, mNumMod, aFonts ) } *RETURN NIL ******************************************************* STATIC FUNCTION CognDiagrAtr( oPS, oStatic, mAtrLeft, mAtrRight, mNumMod, aFonts ) * DC_ASave(mAtrLeft , "_AtrLeft.arx") // Код левого класса * DC_ASave(mAtrRight, "_AtrRight.arx") // Код правого класса * DC_ASave(mNumMod , "_NumMod.arx") mAtrLeft = DC_ARestore("_AtrLeft.arx") mAtrRight = DC_ARestore("_AtrRight.arx") mNumMod = DC_ARestore("_NumMod.arx") aParKDAtr = DC_ARestore("_4_3_3.arx") // Параметры когнитивной диаграммы * DC_DebugQout( aParKDAtr ) W_Wind = X_MaxW / 2 // Полуширина окна для самого графика H_Wind = Y_MaxW / 2 // Полувысота окна для самого графика LY := 70 // Зона над областью графика для наименования и под областью графика для легенды X0 := W_Wind // Начало координат для эллипса по оси X Y0 := H_Wind // Начало координат для эллипса по оси Y IndentLeft = 50 // Отступ слева IndentRight = 50 // Отступ справа Area = ( X_MaxW - IndentLeft - IndentRight ) / 3 // Размер зон левого и правового инф.портретов и связей между ними ***** Закрасить фон прямоугольников *************** ***** Закрасить фон прямоугольника всей зоны изображения GraSetColor( oPS, aColor[98] , aColor[98] ) // Номер цвета в соответствии с _AidosColor.prg GraBox( oPS, { X0-W_Wind, Y0-H_Wind }, { X0+W_Wind, Y0+H_Wind }, GRA_FILL ) ***** Закрасить весь фон прямоугольника зоны изображения левого инф.портрета GraSetColor( oPS, aColor[38] , aColor[38] ) // Номер цвета в соответствии с _AidosColor.prg GraBox( oPS, { IndentLeft+0*Area, Y_MaxW-140 }, { IndentLeft+1*Area, Y0-H_Wind+LY+20 }, GRA_FILL ) ***** Закрасить весь фон прямоугольника зоны связей левого и правого инф.портретов GraSetColor( oPS, aColor[71] , aColor[71] ) // Номер цвета в соответствии с _AidosColor.prg GraBox( oPS, { IndentLeft+1*Area, Y_MaxW-140 }, { IndentLeft+2*Area, Y0-H_Wind+LY+20 }, GRA_FILL ) ***** Закрасить весь фон прямоугольника зоны изображения правого инф.портрета GraSetColor( oPS, aColor[38] , aColor[38] ) // Номер цвета в соответствии с _AidosColor.prg GraBox( oPS, { IndentLeft+2*Area, Y_MaxW-140 }, { IndentLeft+3*Area, Y0-H_Wind+LY+20 }, GRA_FILL ) GraSetColor( oPS, aColor[222] , aColor[222] ) *********** Нарисовать левый и правый голубые прямоугольники для информации о признаках ******** Атрибуты области aAttrBox := ARRAY( GRA_AA_COUNT ) // Определить атрибуты заполнения прямоугольника aAttrBox[ GRA_AA_COLOR ] := GRA_CLR_CYAN GraSetAttrArea( oPS, aAttrBox ) ******** Атрибуты границы области (линии) aAttrLine := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttrLine [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttrLine [ GRA_AL_COLOR ] := GRA_CLR_DARKBLUE // Задать цвет линии aAttrLine [ GRA_AL_WIDTH ] := 2 // Задать толщину линии graSetAttrLine( oPS, aAttrLine ) // Установить атрибуты BoxWidth = 140 // Ширина прямоугольника CYAN в пикселях graBox( oPS, { IndentLeft+1*Area-BoxWidth/2, Y_MaxW-140 }, {IndentLeft+1*Area+BoxWidth/2, Y0-H_Wind+LY+20}, GRA_OUTLINEFILL, 7, 7 ) // Прямоугольник очерчен, заполнен и закруглен graBox( oPS, { IndentLeft+2*Area-BoxWidth/2, Y_MaxW-140 }, {IndentLeft+2*Area+BoxWidth/2, Y0-H_Wind+LY+20}, GRA_OUTLINEFILL, 7, 7 ) // Прямоугольник очерчен, заполнен и закруглен ***** Нарисовать рамку изображения и отделить место для легенды ******************* aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты ****** Начало координат в центре рисунка * GraArc ( oPS, { X0, Y0 }, 2 ) // Начало координат GraLine( oPS, {X0-W_Wind+1, Y0-H_Wind+1}, {X0-W_Wind+1, Y0+H_Wind-1} ) // Нарисовать границу рамки изображения слева GraLine( oPS, {X0+W_Wind-1, Y0-H_Wind+1}, {X0+W_Wind-1, Y0+H_Wind-1} ) // Нарисовать границу рамки изображения справа GraLine( oPS, {X0-W_Wind+1, Y0-H_Wind+1}, {X0+W_Wind-1, Y0-H_Wind+1} ) // Нарисовать границу рамки изображения внизу параллельно оси X GraLine( oPS, {X0-W_Wind+1, Y0+H_Wind-1}, {X0+W_Wind-1, Y0+H_Wind-1} ) // Нарисовать границу рамки изображения вверху параллельно оси X GraLine( oPS, {X0-W_Wind+1, Y0-H_Wind+LY}, {X0+W_Wind-1, Y0-H_Wind+LY} ) // Нарисовать границу рамки легенды на уровне LY параллельно оси X **** Написать заголовок диаграммы aFonts := XbpFont():new():list() // Все доступные шрифты oFont := XbpFont():new():create("22.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraStringAt( oPS, { X_MaxW/2, Y_MaxW-20 }, 'КОГНИТИВНАЯ ДИАГРАММА ПРИЗНАКОВ В МОДЕЛИ: "'+UPPER(Ar_Model[mNumMod])+'"' ) oFont := XbpFont():new():create("18.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) IF LEN(ALLTRIM(M_NameAppl)) < 70 GraStringAt( oPS, { X_MaxW/2, Y_MaxW-52 }, "Приложение: "+'"'+ALLTRIM(M_NameAppl)+'"' ) ELSE GraStringAt( oPS, { X_MaxW/2, Y_MaxW-52 }, '"'+ALLTRIM(M_NameAppl)+'"' ) ENDIF *********** Отобразить сходство/различие признаков mSxodAtrMod = "SxodAtr"+Ar_Model[mNumMod] CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mSxodAtrMod) EXCLUSIVE NEW DBGOTO(mAtrLeft) mSxodAtr = FIELDGET(mAtrRight+3) GraStringAt( oPS, { X_MaxW/2, Y_MaxW-90 }, "Сход./разл.признаков: "+ALLTRIM(STR(mSxodAtr,15,3))+"%" ) *********** Отобразить наименования признаков * mAtrLeft = aParKDAtr[1] // Код класса левого инф.портрета * mAtrRight = aParKDAtr[2] // Код класса правого инф.портрета CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Class_ScKD EXCLUSIVE NEW USE Opis_Sc EXCLUSIVE NEW USE Gr_OpSc EXCLUSIVE NEW SELECT Gr_OpSc DBGOTO(mAtrLeft) mNameGrOpSc1 = ALLTRIM(Name_GrOS) mKodOpSc1 = Kod_OpSc SELECT Opis_Sc DBGOTO(mKodOpSc1) mNameOpSc1 = ALLTRIM(Name_OpSc) SELECT Gr_OpSc DBGOTO(mAtrRight) mNameGrOpSc2 = ALLTRIM(Name_GrOS) mKodOpSc2 = Kod_OpSc SELECT Opis_Sc DBGOTO(mKodOpSc2) mNameOpSc2 = ALLTRIM(Name_OpSc) oFont := XbpFont():new():create("12.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) MessLeft1 = "Оп.шкала: ["+ALLTRIM(STR(mKodClSc1))+"] "+mNameOpSc1 MessLeft2 = "Признак: ["+ALLTRIM(STR(mAtrLeft)) +"] "+mNameGrOpSc1 GraStringAt( oPS, { IndentLeft+0*Area , Y_MaxW- 80 }, SUBSTR(MessLeft1 , 1, 70) ) GraStringAt( oPS, { IndentLeft+0*Area , Y_MaxW-100 }, SUBSTR(MessLeft2 , 1, 70) ) MessRight1 = "Оп.шкала: ["+ALLTRIM(STR(mKodClSc2))+"] "+mNameOpSc2 MessRight2 = "Признак: ["+ALLTRIM(STR(mAtrRight))+"] "+mNameGrOpSc2 GraStringAt( oPS, { IndentLeft+2*Area+BoxWidth/2, Y_MaxW- 80 }, SUBSTR(MessRight1, 1, 58) ) GraStringAt( oPS, { IndentLeft+2*Area+BoxWidth/2, Y_MaxW-100 }, SUBSTR(MessRight2, 1, 58) ) oFont := XbpFont():new():create("12.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) GraStringAt( oPS, { IndentLeft+0*Area , Y_MaxW-130 }, "Наименования классов:" ) GraStringAt( oPS, { IndentLeft+2*Area+BoxWidth/2, Y_MaxW-130 }, "Наименования классов:" ) ****** Фильтры по классификационным шкалам, если 0 - фильтра нет SELECT Class_ScKD mKodClSc1 = aParKDAtr[ 3] // Код оп.шкалы левого инф.портрета mKodClSc2 = aParKDAtr[ 4] // Код оп.шкалы правого инф.портрета DBGOTO(mKodClSc1+1) MKodGrMin1 = KodGr_min MKodGrMax1 = KodGr_max mNameClSc1 = ALLTRIM(Name_ClSc) DBGOTO(mKodClSc2+1) MKodGrMin2 = KodGr_min MKodGrMax2 = KodGr_max mNameClSc2 = ALLTRIM(Name_ClSc) MessLeft = "Фильтр по кл.шкале: ["+ALLTRIM(STR(mKodClSc1))+"] "+mNameClSc1+" "+ALLTRIM(STR(MKodGrMin1))+"-"+ALLTRIM(STR(MKodGrMax1)) MessRight = "Фильтр по кл.шкале: ["+ALLTRIM(STR(mKodClSc2))+"] "+mNameClSc2+" "+ALLTRIM(STR(MKodGrMin2))+"-"+ALLTRIM(STR(MKodGrMax2)) GraStringAt( oPS, { IndentLeft+0*Area , Y0-H_Wind+LY+10 }, SUBSTR(MessLeft ,1, 70) ) GraStringAt( oPS, { IndentLeft+2*Area+BoxWidth/2, Y0-H_Wind+LY+10 }, SUBSTR(MessRight,1, 70) ) ***** Легенда ********************************* oFont := XbpFont():new():create("13.ArialBold") GraSetFont( oPS ,oFont ) aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты AxName = "Сходство и различие между признаками по их классам с учетом сходства/различия между классами по системе детерминирующих их признаков:" GraStringAt( oPS, { 20, LY-15 }, AxName ) AxName = "СХОДСТВО признаков отображается линиями связи КРАСНОГО цвета, толщина линии (приведенная в кружочке в центре линии) отражает степень сходства." GraStringAt( oPS, { 200, LY-35 }, AxName ) AxName = "РАЗЛИЧИЕ признаков отображается линиями связи СИНЕГО цвета, толщина линии (приведенная в кружочке в центре линии) отражает степень различия." GraStringAt( oPS, { 200, LY-55 }, AxName ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_DARKRED GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты AxName = "Форма создана: "+DTOC(DATE())+"-"+TIME()+". Показано количество связей <="+ALLTRIM(STR(aParKDAtr[15])) GraStringAt( oPS, { IndentLeft+2*Area+BoxWidth/2, LY-15 }, AxName ) **** Нарисовать сами линии **** mSxodstvo > 0 aAttr := Array( GRA_AL_COUNT ) // атрибуты линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := GRA_CLR_RED aAttr [ GRA_AL_WIDTH ] := 7 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraLine(oPS, { 23, LY-35 }, { 170, LY-35 } ) // Нарисовать линию заданных толщины и цвета **** mSxodstvo < 0 aAttr := Array( GRA_AL_COUNT ) // атрибуты линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := GRA_CLR_BLUE aAttr [ GRA_AL_WIDTH ] := 7 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraLine(oPS, { 23, LY-55 }, { 170, LY-55 } ) // Нарисовать линию заданных толщины и цвета ***** РИСОВАНИЕ ПРЯМОУГОЛЬНИКОВ ПРИЗНАКОВ ЛЕВОГО И ПРАВОГО ИНФ.ПОРТРЕТОВ И НАДПИСЕЙ В НИХ *********** mMaxAtrInfPort = 7 // Максимальное количество отображаемых на диаграмме классов в инф.портрете ***** Расчет промежутка между прямоугольниками признаков CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mRelViewAtrMod) EXCLUSIVE NEW SELECT (mRelViewAtrMod) INDEX ON STR(Rang1,15) TO ClsRang1 INDEX ON STR(Rang2,15) TO ClsRang2 *** Определение наиболее сильной по модулю связи для нормировки толщины линии INDEX ON STR(ABS(Rel_bit),19,7) TO ClsRang3 DBGOBOTTOM() mMaxRelBit = ABS(Rel_bit) // Максимальная по модулю сила связи в bit для нормировки силы связи на изображении mMaxRelPix = 20 // Максимальная по модулю сила связи в pix для нормировки силы связи на изображении mKnorm = mMaxRelPix/mMaxRelBit // Коэффициент нормировки и преобразования силы связи из bit в pix CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mRelViewAtrMod) INDEX ClsRang1, ClsRang2 EXCLUSIVE NEW *** Определение количества признаков в левом и правом инф.портретах SELECT (mRelViewAtrMod) SET ORDER TO 1 DBGOBOTTOM() N_Atr1 = Rang1 // Количество признаков в левом портрете SET ORDER TO 2 DBGOBOTTOM() N_Atr2 = Rang2 // Количество признаков в правом портрете Y_atr = (Y_MaxW-140) - (Y0-H_Wind+LY+20) // Высота зоны для информации о признаках BoxOffset = 10 // Отступ прямоугльников от границ зон рисования и текстов внутри прямоугольников от их границ BoxHeight = 85 // Высота прямоугольника в пикселях BoxWidth = BoxWidth - BoxOffset*2 // Ширина прямоугольника в пикселях DeltaY1 = (Y_atr-BoxHeight*N_Atr1)/(N_Atr1+1) DeltaY2 = (Y_atr-BoxHeight*N_Atr2)/(N_Atr2+1) ******** Вывод наименований обобщ.и первичных признаков **** * DO CASE * CASE Rang1 < Rang2 * SET ORDER TO 1 * CASE Rang2 < Rang1 * SET ORDER TO 2 * CASE Rang1 = Rang2 * SET ORDER TO * ENDCASE SET ORDER TO DBGOTOP() * aTxtPar = DC_GraQueryTextbox('Eugene Lutsenko','10.Arial')// {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов DO WHILE .NOT. EOF() // Цикл по связям. Ограничить кол-во отображаемых связей макс.возможным mMaxAtrInfPort ******* РИСОВАНИЕ ПРЯМОУГОЛЬНИКОВ ПРИЗНАКОВ ЛЕВОГО И ПРАВОГО ИНФ.ПОРТРЕТОВ *********** *** ЛЕВЫЙ *** y1 = (Y_MaxW-140) - DeltaY1 - (BoxHeight+DeltaY1) * (Rang1-1) ******** Атрибуты области aAttrBox := ARRAY( GRA_AA_COUNT ) // Определить атрибуты заполнения прямоугольника aAttrBox[ GRA_AA_COLOR ] := IF(Inf_Bit1>0,BD_LIGHTYELLOW, BD_LIGHTGREEN) // Цвет согласно _AidosColor.exe GraSetAttrArea( oPS, aAttrBox ) ******** Атрибуты границы области (линии) aAttrLine := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttrLine [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttrLine [ GRA_AL_COLOR ] := IF(Inf_Bit1>0,GRA_CLR_DARKRED, GRA_CLR_DARKBLUE) // Задать цвет линии aAttrLine [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttrLine ) // Установить атрибуты graBox( oPS, { IndentLeft+1*Area-BoxWidth/2, y1 }, { IndentLeft+1*Area+BoxWidth/2 , y1-BoxHeight }, GRA_OUTLINEFILL, 0, 0 ) // Малый. Прямоугольник очерчен, заполнен и закруглен graBox( oPS, { IndentLeft+0*Area+BoxOffset , y1 }, { IndentLeft+1*Area-BoxWidth/2-2*BoxOffset, y1-BoxHeight }, GRA_OUTLINEFILL, 0, 0 ) // Большой. Прямоугольник очерчен, заполнен и закруглен *** ПРАВЫЙ *** y2 = (Y_MaxW-140) - DeltaY2 - (BoxHeight+DeltaY2) * (Rang2-1) ******** Атрибуты области aAttrBox := ARRAY( GRA_AA_COUNT ) // Определить атрибуты заполнения прямоугольника aAttrBox[ GRA_AA_COLOR ] := IF(Inf_Bit2>0,BD_LIGHTYELLOW, BD_LIGHTGREEN) // Цвет согласно _AidosColor.exe GraSetAttrArea( oPS, aAttrBox ) ******** Атрибуты границы области (линии) aAttrLine := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttrLine [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttrLine [ GRA_AL_COLOR ] := IF(Inf_Bit2>0,GRA_CLR_DARKRED, GRA_CLR_DARKBLUE) // Задать цвет линии aAttrLine [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttrLine ) // Установить атрибуты graBox( oPS, { IndentLeft+2*Area-BoxWidth/ 2, y2 }, { IndentLeft+2*Area+BoxWidth/2, y2-BoxHeight }, GRA_OUTLINEFILL, 0, 0 ) // Малый. Прямоугольник очерчен, заполнен и закруглен graBox( oPS, { IndentLeft+2*Area+BoxWidth/2+2*BoxOffset, y2 }, { IndentLeft+3*Area-BoxOffset , y2-BoxHeight }, GRA_OUTLINEFILL, 0, 0 ) // Большой. Прямоугольник очерчен, заполнен и закруглен ******* РИСОВАНИЕ НАДПИСЕЙ В ПРЯМОУГОЛЬНИКАХ КЛАССОВ ********************************* *** ЛЕВЫЙ *** * aTxtPar = DC_GraQueryTextbox('Eugene Lutsenko','10.Arial') // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов oFont := XbpFont():new():create("12.Arial") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := IF(Inf_Bit1>0,GRA_CLR_DARKRED, GRA_CLR_DARKBLUE) // Задать цвет шрифта aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) ***** Цикл определения такой длины строки, которая помещается в рамку ***** Массив отображаемых в рамке строк, включающий наименования и описательных шкал и их градаций ***** Из текстового буфера к отображаемому элементу массива добавляется по одному символу и определяется его длина в пикселях. ***** Если не хватает длины рамки - добавляется строка в массив. Отображение градации шкалы всегда начинается с новой строки. mZone = 50 // Размер зоны отображения в символах aMess := {} // Массив отображаемых в рамке строк, включающий наименования и описательных шкал и их градаций AADD(aMess, L(" "));s=1 // 1-й элемент - 1-я строка mBuff1 = "["+ALLTRIM(STR(Kod_ClSc1))+"] "+ALLTRIM(Name_ClSc1) FOR j=1 TO LEN(mBuff1) * aTxtPar = DC_GraQueryTextbox(aMess[s] + SUBSTR(mBuff1,j,1), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов IF LEN(aMess[s] + SUBSTR(mBuff1,j,1)) <= mZone aMess[s] = aMess[s] + SUBSTR(mBuff1,j,1) // Полное наименование описательной шкалы посылается в буфер для отображения ELSE IF s < 2 AADD(aMess, SUBSTR(mBuff1,j,1)) s++ ELSE EXIT ENDIF ENDIF NEXT ***** Цикл определения такой длины строки, которая помещается в рамку AADD(aMess, L(" ")) s++ mBuff2 = "["+ALLTRIM(STR(Kod_cls1 ))+"] "+ALLTRIM(Name_GrCS1) // Буфер. Из буфера добавляется по олному символу в отображаемый элемент массива FOR j=1 TO LEN(mBuff2) IF LEN(aMess[s] + SUBSTR(mBuff1,j,1)) <= mZone aMess[s] = aMess[s] + SUBSTR(mBuff2,j,1) // Полное наименование описательной шкалы посылается в буфер для отображения ELSE IF s < 4 AADD(aMess, SUBSTR(mBuff2,j,1)) s++ ELSE EXIT ENDIF ENDIF NEXT *** Отображение ***** y1 = (Y_MaxW-140) - DeltaY1 - (BoxHeight+DeltaY1) * (Rang1-1) mInterval = 18 // Межстрочный интервал в пикселях. 1 - строки пишутся без пропуска FOR s=1 TO LEN(aMess) GraStringAt( oPS, { IndentLeft+0*Area+BoxOffset*2, y1-15-(s-1)*mInterval }, aMess[s] ) NEXT ***** Надписи в маленьких прямоугольниках внутри голубых прямоугольников с информацией по признакам oFont := XbpFont():new():create("12.ArialBold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := IF(Inf_Bit1>0,GRA_CLR_DARKRED, GRA_CLR_DARKBLUE) // Задать цвет шрифта aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) * graBox( oPS, { IndentLeft+1*Area-BoxWidth/2, y1 }, { IndentLeft+1*Area+BoxWidth/2, y1-BoxHeight }, GRA_OUTLINEFILL, 0, 0 ) // Малый левый. Прямоугольник очерчен, заполнен и закруглен mInterval = 21 // Межстрочный интервал в пикселях. 1 - строки пишутся без пропуска GraStringAt( oPS, { IndentLeft+1*Area-BoxWidth/2+BoxOffset, y1-mInterval*1 }, "Ib="+ALLTRIM(STR(Inf_bit1 ,19,3))+IF(mNumMod=4," bit", "") ) GraStringAt( oPS, { IndentLeft+1*Area-BoxWidth/2+BoxOffset, y1-mInterval*2 }, "Ip="+ALLTRIM(STR(Inf_PerTM1,19,3))+IF(mNumMod=4," %ТМ", "") ) GraStringAt( oPS, { IndentLeft+1*Area-BoxWidth/2+BoxOffset, y1-mInterval*3 }, "Ic="+ALLTRIM(STR(Inf_Stand1,19,3))+IF(mNumMod=4,"станд","") ) *** ПРАВЫЙ *** * aTxtPar = DC_GraQueryTextbox('Eugene Lutsenko','10.Arial') // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов oFont := XbpFont():new():create("12.Arial") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := IF(Inf_Bit2>0,GRA_CLR_DARKRED, GRA_CLR_DARKBLUE) // Задать цвет шрифта aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) ***** Цикл определения такой длины строки, которая помещается в рамку ***** Массив отображаемых в рамке строк, включающий наименования и описательных шкал и их градаций ***** Из текстового буфера к отображаемому элементу массива добавляется по одному символу и определяется его длина в пикселях. ***** Если не хватает длины рамки - добавляется строка в массив. Отображение градации шкалы всегда начинается с новой строки. mZone = 50 // Размер зоны отображения в символах aMess := {} // Массив отображаемых в рамке строк, включающий наименования и описательных шкал и их градаций AADD(aMess, L(" "));s=1 // 1-й элемент - 1-я строка mBuff1 = "["+ALLTRIM(STR(Kod_ClSc2))+"] "+ALLTRIM(Name_ClSc2) FOR j=1 TO LEN(mBuff1) * aTxtPar = DC_GraQueryTextbox(aMess[s] + SUBSTR(mBuff1,j,1), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов IF LEN(aMess[s] + SUBSTR(mBuff1,j,1)) <= mZone aMess[s] = aMess[s] + SUBSTR(mBuff1,j,1) // Полное наименование описательной шкалы посылается в буфер для отображения ELSE IF s < 2 AADD(aMess, SUBSTR(mBuff1,j,1)) s++ ELSE EXIT ENDIF ENDIF NEXT ***** Цикл определения такой длины строки, которая помещается в рамку AADD(aMess, L(" ")) s++ mBuff2 = "["+ALLTRIM(STR(Kod_cls2 ))+"] "+ALLTRIM(Name_GrCS2) // Буфер. Из буфера добавляется по олному символу в отображаемый элемент массива FOR j=1 TO LEN(mBuff2) IF LEN(aMess[s] + SUBSTR(mBuff2,j,1)) <= mZone aMess[s] = aMess[s] + SUBSTR(mBuff2,j,1) // Полное наименование описательной шкалы посылается в буфер для отображения ELSE IF s < 4 AADD(aMess, SUBSTR(mBuff2,j,1)) s++ ELSE EXIT ENDIF ENDIF NEXT *** Отображение ***** y1 = (Y_MaxW-140) - DeltaY2 - (BoxHeight+DeltaY2) * (Rang2-1) mInterval = 18 // Межстрочный интервал в пикселях. 1 - строки пишутся без пропуска FOR s=1 TO LEN(aMess) GraStringAt( oPS, { IndentLeft+2*Area+BoxWidth/2+3*BoxOffset, y1-15-(s-1)*mInterval }, aMess[s] ) NEXT ***** Надписи в маленьких прямоугольниках внутри голубых прямоугольников с информацией по признакам oFont := XbpFont():new():create("12.ArialBold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := IF(Inf_Bit2>0,GRA_CLR_DARKRED, GRA_CLR_DARKBLUE) // Задать цвет шрифта aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) * graBox( oPS, { IndentLeft+2*Area-BoxWidth/2, y2 }, { IndentLeft+2*Area+BoxWidth/2, y2-BoxHeight }, GRA_OUTLINEFILL, 0, 0 ) // Малый правый. Прямоугольник очерчен, заполнен и закруглен mInterval = 21 // Межстрочный интервал в пикселях. 1 - строки пишутся без пропуска GraStringAt( oPS, { IndentLeft+2*Area-BoxWidth/2+BoxOffset, y2-mInterval*1 }, "Ib="+ALLTRIM(STR(Inf_bit2 ,19,3))+IF(mNumMod=4," bit", "") ) GraStringAt( oPS, { IndentLeft+2*Area-BoxWidth/2+BoxOffset, y2-mInterval*2 }, "Ip="+ALLTRIM(STR(Inf_PerTM2,19,3))+IF(mNumMod=4," %ТМ", "") ) GraStringAt( oPS, { IndentLeft+2*Area-BoxWidth/2+BoxOffset, y2-mInterval*3 }, "Ic="+ALLTRIM(STR(Inf_Stand2,19,3))+IF(mNumMod=4,"станд","") ) DBSKIP(1) ENDDO ***** РИСОВАНИЕ ЛИНИЙ ОТНОШЕНИЙ (СВЯЗЕЙ) КЛАССОВ ЛЕВОГО И ПРАВОГО ИНФ.ПОРТРЕТА *********** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mRelViewAtrMod) EXCLUSIVE NEW N_Line = RECCOUNT() x1 = IndentLeft+1*Area+BoxWidth/2+BoxOffset x2 = IndentLeft+2*Area-BoxWidth/2-BoxOffset RS = 12 // Радиус кружочка для указания силы связи SELECT (mRelViewAtrMod) DBGOTOP() oFont := XbpFont():new():create("10.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт DO WHILE .NOT. EOF() // Цикл по связям y1 = (Y_MaxW-140) - DeltaY1 - (BoxHeight+DeltaY1) * (Rang1-1) - BoxHeight/2 y2 = (Y_MaxW-140) - DeltaY2 - (BoxHeight+DeltaY2) * (Rang2-1) - BoxHeight/2 ******** Атрибуты границы области (линии) aAttrLine := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttrLine [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttrLine [ GRA_AL_COLOR ] := IF(Rel_bit>0,BD_CANDYRED, BD_RICHBLUE) // Задать цвет линии согласно _AidosColor.exe aAttrLine [ GRA_AL_WIDTH ] := mKnorm * ABS(Rel_bit) // Задать толщину линии (нормированную) graSetAttrLine( oPS, aAttrLine ) // Установить атрибуты GraLine( oPS, { x1, y1 }, { x2, y2 } ) // Нарисовать линию связи заданной толщины и цвета * ****** Сделать надписи уровней сходства на линиях связи * aAttr := Array( GRA_AA_COUNT ) // атрибуты области * aAttr [ GRA_AA_COLOR ] := IF(Rel_bit>0,BD_LIGHTYELLOW, BD_XBP_CYAN) * aAttr [ GRA_AA_SYMBOL ] := GRA_SYM_DEFAULT * graSetAttrArea( oPS, aAttr ) * aAttr := Array( GRA_AL_COUNT ) // атрибуты линии * aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT * aAttr [ GRA_AL_COLOR ] := IF(Rel_bit>0,BD_CANDYRED, BD_RICHBLUE) * aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии * graSetAttrLine( oPS, aAttr ) * aAttrF := ARRAY( GRA_AS_COUNT ) // атрибуты шрифта * aAttrF [ GRA_AS_COLOR ] := IF(Rel_bit>0,BD_CANDYRED, BD_RICHBLUE) * aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода * aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода * GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты * N = IF(Rel_bit>0,3,3/2) * GraArc( oPS, { x1+(x2-x1)/N, y1+(y2-y1)/N }, RS, ,,, GRA_OUTLINEFILL ) * GraStringAt( oPS, { x1+(x2-x1)/N, y1+(y2-y1)/N }, ALLTRIM(STR(Rel_PerTM,15)) ) DBSKIP(1) ENDDO DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения RETURN NIL ****************************************************************************************** ******** 2.3.2.1. Импорт данных из текстовых файлов. Режим 1.5.1. DOS-версии системы Эйдос ****************************************************************************************** FUNCTION F2_3_2_1() LOCAL GetList := {}, aPres, oBrowse, oToolBar, aColors, bColor, GetOptions LOCAL oProgress, oDialog, oStatic, oPS, oDevice, oDlg, oProgr, oDial Running(.T.) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!",'2.3.2.1. Импорт данных из текстовых файлов')) Running(.F.) RETURN NIL ENDIF CrLf = CHR(13)+CHR(10) // Конец строки (абзаца) (CrLf) *************** ДИАЛОГ ЗАДАНИЯ ПАРАМЕТРОВ ПРЕОБРАЗОВАНИЯ ********************************** * Формат текстовых файлов: DOC, TXT * Если задан TXT, то выбрать кодировку исходных файлов: ANSI (Windows), OEM866 (DOS) // Если ранее параметры были заданы - скачать массив, иначе сформировать и записать в папке приложения IF .NOT. FILE("_2_3_2_1.arx") PUBLIC aPar[11] aPar[ 1] = 1 // Формат текстовых файлов: 1 = TXT, 2 = DOC, 3 = Internet aPar[ 2] = 2 // Кодировка исходных файлов: 1 = ANSI (Windows), 2 = OEM866 (DOS) ### aPar[ 3] = 1 // В качестве признаков рассматривать: 1 = слова, 2 = сочетания слов aPar[10] = 4 // <= Количество символов в словах aPar[11] = 35 // Количество символов в словах <= aPar[ 4] = 1 // Количество слов в сочетаниях слов (мемах) aPar[ 5] = 1 // 1-форм.кл.и оп.шк.и град.и обуч.выборки, 2-форм.расп.выборки aPar[ 6] =.F. // .T. - проводить лемматизацию, .F. не проводить лемматизацию ### // Удалять ковычки, апострофы, знаки препинания и спец.символы ### // Не учитывать слова, короче aPar[10] символов и длиннее aPar[11] ### // Не различать верхний и нижний регистр (переводить все символы в нижний регистр) ### aPar[ 7] =.F. // .T. - Создавать БД Inp_data.dbf для создания моделей (2.3.2.2) прогнозирования последующих слов на основе предшествующих, .F. - не создавать aPar[ 8] = 1 // 1 - работать в папке обучающей выборки: "..AID_DATA/Inp_data/"', 2 - работать в папке распознаваемой выборки: "..AID_DATA/Inp_rasp/" aPar[ 9] = 1 // 1 - имена файлов формировать в стандарте "Эйдос": "id, Class name" брать из номера и имени файла, 2 - в стандарте "http://kaggle.com/": "id, Class name" брать из текста файла DC_ASave(aPar, "_2_3_2_1.arx") ELSE aPar = DC_ARestore("_2_3_2_1.arx") ENDIF * Информация о результатах завершения перекодирования в файле: recoder-v3-1-0.log. Перед перекодированием его надо удалить IF FILE (Disk_dir+'/recoder-v3-1-0.log') ERASE(Disk_dir+'/recoder-v3-1-0.log') ENDIF * Создать файл: recoder-v3-1-0.ini с нужными параметрами (также и в 5.1) ******* CrLf = CHR(13)+CHR(10) // Конец строки (записи) mStr = "[recoder]"+CrLf+; "text_encodings = UTF-8, windows-1251, koi8-r, cp866, ISO 8859-5"+CrLf+; "file_encodings = UTF-8, UTF-8 (BOM), windows-1251, koi8-r, cp866, ISO 8859-5"+CrLf+; "big_file_size = 1048576"+CrLf+; "big_file_lines_chunk = 1000"+CrLf+; ""+CrLf+; "[text_converter]"+CrLf+; "enc_from = windows-1251"+CrLf+; "enc_to = UTF-8"+CrLf+; ""+CrLf+; "[files_converter]"+CrLf+; "path = "+Disk_dir+"\AID_DATA\Inp_data"+CrLf+; "mask = *.txt"+CrLf+; "enc_from = UTF-8"+CrLf+; "enc_to = cp866"+CrLf+; "save_origin = False"+CrLf+; "origin_ext = ~"+CrLf+; "search_in_subdirectories = True"+CrLf+; ""+CrLf+; "[bom_remover]"+CrLf+; "path = C:\2"+CrLf+; "mask = *.*" StrFile(mStr, Disk_dir+'/recoder-v3-1-0.ini') R = 76 D = 22 @ 1, 1 DCGROUP oGroup1 CAPTION L('Укажите Формат текстовых файлов:') SIZE R, 2.5 @ 1, 2 DCRADIO aPar[1] VALUE 1 PROMPT L('TXT' ) PARENT oGroup1 @ 1, D*1 DCRADIO aPar[1] VALUE 2 PROMPT L('DOC' ) PARENT oGroup1 @ 1, D*2 DCRADIO aPar[1] VALUE 3 PROMPT L('Internet') PARENT oGroup1 @0.6, D*2 DCPUSHBUTTON CAPTION L('Помощь') SIZE LEN(L('Перекодировщик TXT-файлов')), 1.5 ACTION {||Help2321()} PARENT oGroup1 @ 4, 1 DCGROUP oGroup2 CAPTION L('Укажите кодировку исходных файлов:') SIZE R, 2.5 HIDE {|| .NOT.aPar[1]=1} @ 1, 2 DCRADIO aPar[2] VALUE 1 PROMPT L('ANSI (Windows)' ) PARENT oGroup2 EDITPROTECT {|| .NOT.aPar[1]=1 } HIDE {|| .NOT.aPar[1]=1 } @ 1, D*1 DCRADIO aPar[2] VALUE 2 PROMPT L('ASCII-OEM866 (DOS)') PARENT oGroup2 EDITPROTECT {|| .NOT.aPar[1]=1 } HIDE {|| .NOT.aPar[1]=1 } @0.6,D*2 DCPUSHBUTTON CAPTION L('Перекодировщик TXT-файлов') SIZE LEN(L('Перекодировщик TXT-файлов')), 1.5 ACTION {||LC_RunShell("recoder-v3-1-0.exe",1332681493)} PARENT oGroup2 @ 7, 1 DCGROUP oGroup3 CAPTION L('В качестве признаков рассматривать:') SIZE R, 3.8 @ 1, 2 DCRADIO aPar[3] VALUE 1 PROMPT L('Слова') PARENT oGroup3 @ 2.3,0.5 DCSAY L("") GET aPar[10] PARENT oGroup3 PICTURE "###" EDITPROTECT {|| .NOT.aPar[3]=1 } HIDE {|| .NOT.aPar[3]=1 } @ 2.3,7 DCSAY L("<= Кол-во символов в словах <=") PARENT oGroup3 EDITPROTECT {|| .NOT.aPar[3]=1 } HIDE {|| .NOT.aPar[3]=1 } @ 2.3 ,31 DCSAY L("") GET aPar[11] PARENT oGroup3 PICTURE "###" EDITPROTECT {|| .NOT.aPar[3]=1 } HIDE {|| .NOT.aPar[3]=1 } @ 1 ,D*1 DCRADIO aPar[3] VALUE 2 PROMPT L('Мемы (сочетания слов)') PARENT oGroup3 @ 1.3,2 DCSAY L("Кол-во слов в мемах: ") PARENT oGroup3 EDITPROTECT {|| .NOT.aPar[3]=2 } HIDE {|| .NOT.aPar[3]=2 } @ 1 ,D*3-3 DCSAY L(" ") GET aPar[4] PARENT oGroup3 PICTURE "###" EDITPROTECT {|| .NOT.aPar[3]=2 } HIDE {|| .NOT.aPar[3]=2 } @ 1 ,D*2 DCCHECKBOX aPar[6] PROMPT L('Проводить лемматизацию?') PARENT oGroup3 @11, 1 DCGROUP oGroup5 CAPTION L('Задайте режим:') SIZE R, 7.5 @ 1, 2 DCRADIO aPar[5] VALUE 1 PROMPT L('Формирование классификационных и описательных шкал и градаций и обуч.выборки ') PARENT oGroup5 @ 2, 2 DCRADIO aPar[5] VALUE 2 PROMPT L('Формирование расп.выборки с имеющимися шкалами и градациями после реж.2.3.2.1') PARENT oGroup5 @ 3, 2 DCRADIO aPar[5] VALUE 3 PROMPT L('Формирование расп.выборки с имеющимися шкалами и градациями после реж.2.3.2.2') PARENT oGroup5 @ 4.5, 2 DCSAY L('Исходные файлы брать из папки обучающей выборки:') PARENT oGroup5 EDITPROTECT {|| .NOT.aPar[5] =1 } HIDE {|| .NOT.aPar[5] =1 } @ 4.5,47 DCSAY Disk_dir+L('\AID_DATA\Inp_data\') PARENT oGroup5 EDITPROTECT {|| .NOT.aPar[5] =1 } HIDE {|| .NOT.aPar[5] =1 } @ 4.5, 2 DCSAY L('Исходные файлы брать из папки распознаваемой выборки:') PARENT oGroup5 EDITPROTECT {|| .NOT.aPar[5]>=2 } HIDE {|| .NOT.aPar[5]>=2 } @ 4.5,47 DCSAY Disk_dir+L('\AID_DATA\Inp_rasp\') PARENT oGroup5 EDITPROTECT {|| .NOT.aPar[5]>=2 } HIDE {|| .NOT.aPar[5]>=2 } @ 5.7, 2 DCCHECKBOX aPar[7] PROMPT L('Формировать БД Inp_data.dbf стандарта 2.3.2.2 для создания моделей продолжения фраз?') PARENT oGroup5 // модели прогнозирования последующих слов на основе предшествующих @19.0, 1 DCGROUP oGroup7 CAPTION L('Задайте стандарт, в котором в именах исходных файлов закодированы имена классов:') SIZE R, 5.5 @ 1, 2 DCRADIO aPar[9] VALUE 1 PROMPT L('1-й стандарт "Эйдос": "id1,...,idn-######.txt": имена классов idn в имени файла через "," до "-"') PARENT oGroup7 @ 2, 2 DCRADIO aPar[9] VALUE 2 PROMPT L('2-й стандарт "Эйдос": "Имя класса-######.txt": имя класса в имени файла до тире') PARENT oGroup7 @ 3, 2 DCRADIO aPar[9] VALUE 3 PROMPT L('3-й стандарт "Эйдос" объединяет 1-й и 2-й стандарты') PARENT oGroup7 @ 4, 2 DCRADIO aPar[9] VALUE 4 PROMPT L('4-й стандарт "http://kaggle.com/": "id, Class name" код и имя класса в тексте файла') PARENT oGroup7 DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; OPTIONS GetOptions ; ADDBUTTONS; MODAL ; TITLE L('2.3.2.1. Импорт данных из текстовых файлов') *************************************************** IF lExit ** Button Ok ELSE ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF *************************************************** ******************************************************************************************* DC_ASave(aPar, "_2_3_2_1.arx") // Записать параметры, заданные в диалоге mFlagErr = .F. IF aPar[1] > 1 // Формат текстовых файлов: 1 = TXT, 2 = DOC, 3 = Internet LB_Warning(L("Данная опция режима в процессе разработки!"), L('2.3.2.1. Импорт данных из текстовых файлов')) mFlagErr = .T. ENDIF IF aPar[2] = 1 LB_Warning(L("Данная опция режима в процессе разработки!"), L('2.3.2.1. Импорт данных из текстовых файлов')) mFlagErr = .T. ENDIF IF mFlagErr ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) ReTURN nil ENDIF aPar[10] = IF(aPar[3]=2, 3, aPar[10]) // Если заданы мемы, то min.длина слов = 3 aPar[11] = IF(aPar[3]=2,255, aPar[11]) // Если заданы мемы, то max.длина слов = 255 IF aPar[6] // .T. - проводить лемматизацию, .F. - не проводить лемматизацию IF .NOT. FILE('Lemma.dbf') aMess := {} AADD(aMess, L('База данных для лемматизации: "Lemma.dbf"')) AADD(aMess, L('отсутствует в текущей директории системы:')) AADD(aMess, Disk_dir+'.') AADD(aMess, L('Ее можно скачать на сайте разработчика:')) AADD(aMess, L('по ссылке: http://lc.kubagro.ru/Lemma.rar')) AADD(aMess, L('разархивировать и записать в папку с системой.')) AADD(aMess, L('А пока будет создана и начнет заполняться')) AADD(aMess, L('пустая база "Lemma.dbf". Корректировка этой')) AADD(aMess, L('базы возможна в режиме 5.13.')) LB_Warning(aMess, L('(c) Система "Эйдос"')) aStructure := { { "Num" , "N", 9, 0 },; { "WordForm", "C", 40, 0 },; { "Lemma" , "C", 40, 0 },; { "Error" , "C", 3, 0 },; { "N_Obr" , "N", 9, 0 } } DbCreate( 'Lemma', aStructure ) ENDIF IF .NOT. FILE('Lemma.ntx') oScrn := DC_WaitOn(L('Переиндексация БД лемматизации: "Lemma.dbf"'),,,,,,,,,,,.F.) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Lemma EXCLUSIVE NEW SELECT Lemma INDEX ON WordForm TO Lemma DC_Impl(oScrn) ENDIF ENDIF CSETSAFETY(.F.) IF aPar[5] = 1 // 1-форм.кл.и оп.шк.и град.и обуч.выборки ****************************** ******** Создать новое пустое приложение ******** и добавить запись с информацией о нем в конец БД Appls.dbf ******** и сделать новое приложение текущим IF aPar[6] // .T. - проводить лемматизацию, .F. - не проводить лемматизацию M_PathAppl = ADD_ZAPPL(L("2.3.2.1. АСК-анализ мемов и атрибуция текстов (с лемматизацией)")) ELSE M_PathAppl = ADD_ZAPPL(L("2.3.2.1. АСК-анализ мемов и атрибуция текстов (без лемматизации)")) ENDIF ENDIF ******* РЕКОГНОСЦИРОВКА ******************* *DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы DO CASE CASE aPar[5] = 1 // Формирование классификационных и описательных шкал и градаций и обуч.выборки DIRCHANGE(Disk_dir+"\AID_DATA\Inp_data\") // Перейти в папку Inp_data Mess = L('В папке: ')+Disk_dir+L('\AID_DATA\Inp_data\ отсутствуют TXT-файлы!') CASE aPar[5] >= 2 // Формирование распознаваемой выборки с имеющимися шкалами и градациями DIRCHANGE(Disk_dir+"\AID_DATA\Inp_rasp\") // Перейти в папку Inp_rasp Mess = L('В папке: ')+Disk_dir+L('\AID_DATA\Inp_rasp\ отсутствуют TXT-файлы!') ENDCASE IF FILE ('API_type.txt') ERASE('API_type.txt') ENDIF IF FILE ('DCERROR.TXT') ERASE('DCERROR.TXT') ENDIF mCountTxt = ADIR("*.TXT") // Кол-во TXT-файлов IF mCountTxt = 0 LB_Warning(Mess, L('2.3.2.1. Импорт данных из текстовых файлов')) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) ReTURN nil ENDIF *** Формировать БД Inp_data.dbf стандарта 2.3.2.2 для создания моделей продолжения фраз. *** Исходные данные для моделей прогнозирования последующих слов на основе предшествующих. IF aPar[7] // Формировать БД Inp_data.dbf стандарта 2.3.2.2 для создания моделей продолжения фраз? aStructure := { { "Object" , "C", 250, 0 },; { "Curr_word" , "C", 40, 0 },; { "Prev_words", "C", 250, 0 } } DbCreate( 'Inp_data', aStructure ) DbCreate( 'Inp_rasp', aStructure ) ENDIF PRIVATE aFileName[mCountTxt], aFileSize[mCountTxt] // Имена и размеры файлов ADIR("*.txt", aFileName, aFileSize) FOR j=1 TO LEN(aFileName) IF aFileName[j] <> 'API_type.txt' .AND. aFileName[j] <> 'DCERROR.TXT' aFileName[j] = ALLTRIM(aFileName[j]) ENDIF NEXT *** Преобразование имен файлов в кодировку OEM и удаление расширения ".txt" IF aPar[1] = 1 oScrn := DC_WaitOn(L('Преобразование имен файлов в кодировку OEM'),,,,,,,,,,,.F.) FOR j=1 TO LEN(aFileName) aFileName[j] = STRTRAN(ALLTRIM(ConvToOemCP(aFileName[j])),".txt","") NEXT DC_Impl(oScrn) ENDIF *DC_DebugQout( aFileName ) *DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения IF ApplChange("2.3.2.1()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF DC_ASave(aPar, "_2_3_2_1.arx") // Записать параметры, заданные в диалоге ***************************************************************** <===########## Создать БД в папке приложения * Создание базы учета обрабатываемых текстовых файлов *********** ***************************************************************** *MsgBox('Файл: '+ALLTRIM(STR(mFile))+'/'+ALLTRIM(STR(LEN(aFileName)))+'-"'+ConvToOemCP(aFileName[mFile])+'". Длина файла в символах='+ALLTRIM(STR(LEN(mLcBuf)))+', число слов в файле='+ALLTRIM(STR(NUMTOKEN(mLcBuf, ' ')))) mLenFN = -999 FOR j=1 TO LEN(aFileName) mLenFN = MAX(mLenFN, LEN(aFileName[j])) NEXT aStructure := { { "Num" , "N", 9, 0 },; { "FileName", "C",mLenFN, 0 },; { "NumChar" , "N", 9, 0 },; { "NumWord" , "N", 9, 0 } } DbCreate( 'TxtFileInf', aStructure ) ********* Генерация классификационных и описательных шкал и градаций ********** ********* Классы - фрагменты названия файла, разделенные запятыми (как авторы статьи) DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения IF aPar[5] = 1 // 1-Формирование классификационных и описательных шкал и градаций и обуч.выборки ****************************** oScrn := DC_WaitOn(L('Создание пустых баз данных нового приложения'),,,,,,,,,,,.F.) GenDbfClSc(.F.) // Классификационные шкалы ######### GenDbfGrClSc(.F.) // Градации классификационных шкал ######### GenDbfClass(.F.) // Классификационные шкалы и градации GenDbfOpSc(.F.) // Описательные шкалы GenDbfGrOpSc(.F.) // Градации описательных шкал GenDbfAttr(.F.) // Описательные шкалы и градации ######### GenDbfObiZag() // Заголовки объектов обучающей выборки GenDbfObiKcl() // Коды классов объектов обучающей выборки GenDbfObiKpr() // Коды признаков объектов обучающей выборки IF .NOT. FILE('Rso_Zag.dbf') .OR.; .NOT. FILE('Rso_Kcl.dbf') .OR.; .NOT. FILE('Rso_Kpr.dbf') GenDbfRsoZag() // Заголовки объектов распознаваемой выборки GenDbfRsoKcl() // Коды классов объектов распознаваемой выборки GenDbfRsoKpr() // Коды признаков объектов распознаваемой выборки ENDIF DC_Impl(oScrn) ENDIF IF aPar[5] >= 2 // 2-Формирование распознаваемой выборки с имеющимися шкалами и градациями ****************************** oScrn := DC_WaitOn(L('Создание пустых баз данных распознаваемой выборки'),,,,,,,,,,,.F.) GenDbfRsoZag() // Заголовки объектов распознаваемой выборки GenDbfRsoKcl() // Коды классов объектов распознаваемой выборки GenDbfRsoKpr() // Коды признаков объектов распознаваемой выборки DC_Impl(oScrn) ENDIF oScrn := DC_WaitOn(L('Открыть базы данных приложения'),,,,,,,,,,,.F.) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;ZAP USE Class_Sc EXCLUSIVE NEW;ZAP USE Gr_ClSc EXCLUSIVE NEW;ZAP USE Attributes EXCLUSIVE NEW;ZAP USE Opis_Sc EXCLUSIVE NEW;ZAP USE Gr_OpSc EXCLUSIVE NEW;ZAP USE Obi_zag EXCLUSIVE NEW;ZAP USE Obi_Kcl EXCLUSIVE NEW;ZAP USE Obi_Kpr EXCLUSIVE NEW;ZAP USE Rso_zag EXCLUSIVE NEW;ZAP USE Rso_Kcl EXCLUSIVE NEW;ZAP USE Rso_Kpr EXCLUSIVE NEW;ZAP USE TxtFileInf EXCLUSIVE NEW IF aPar[6] // .T. - проводить лемматизацию, .F. - не проводить лемматизацию DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE Lemma INDEX Lemma EXCLUSIVE NEW DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения ENDIF IF aPar[7] // Формировать БД Inp_data.dbf стандарта 2.3.2.2 для создания моделей продолжения фраз? DO CASE CASE aPar[5] = 1 // Формирование классификационных и описательных шкал и градаций и обуч.выборки DIRCHANGE(Disk_dir+"\AID_DATA\Inp_data\") // Перейти в папку Inp_data * USE Inp_data EXCLUSIVE NEW CASE aPar[5] >= 2 // Формирование распознаваемой выборки с имеющимися шкалами и градациями DIRCHANGE(Disk_dir+"\AID_DATA\Inp_rasp\") // Перейти в папку Inp_rasp * USE Inp_rasp EXCLUSIVE NEW ENDCASE DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения ENDIF DC_Impl(oScrn) *************************************************************************************************************************************************************** * @ 1, 2 DCRADIO aPar[9] VALUE 1 PROMPT L('1-й стандарт "Эйдос": "id1,...,idn-######.txt": имена классов idn в имени файла через "," до "-"') PARENT oGroup7 * @ 2, 2 DCRADIO aPar[9] VALUE 2 PROMPT L('2-й стандарт "Эйдос": "Имя класса-######.txt": имя класса в имени файла до тире') PARENT oGroup7 * @ 3, 2 DCRADIO aPar[9] VALUE 3 PROMPT L('3-й стандарт "Эйдос" объединяет 1-й и 2-й стандарты') PARENT oGroup7 * @ 4, 2 DCRADIO aPar[9] VALUE 4 PROMPT L('4-й стандарт "http://kaggle.com/": "id, Class name" код и имя класса в тексте файла') PARENT oGroup7 *************************************************************************************************************************************************************** aAutorName := {} DO CASE CASE aPar[9] = 1 // 1-й стандарт "Эйдос": "id1,...,idn-######.txt": имена классов idn в имени файла через "," до "-" oScrn := DC_WaitOn(L('Формирование массива имен авторов'),,,,,,,,,,,.F.) FOR j=1 TO LEN(aFileName) mPos = AT("-",aFileName[j]) IF mPos > 0 mFileName = SUBSTR(aFileName[j],1,mPos-1) ELSE mFileName = aFileName[j] // Если в имени файла нет номера: -######, то для формирования классов использовать все имя файла, а иначе часть имени файла до тире ENDIF FOR a=1 TO NUMTOKEN(mFileName, ",") // Разделитель между словами - запятая mAutorName = TOKEN(mFileName, ",", a) IF ASCAN(aAutorName, mAutorName) = 0 // Исключить повторы имен авторов AADD (aAutorName, mAutorName) ENDIF NEXT NEXT DC_Impl(oScrn) *DC_DebugQout( aAutorName ) ****************************** ****** Классификационные шкалы ****************************** oScrn := DC_WaitOn(L('Формирование классификационных шкал'),,,,,,,,,,,.F.) SELECT Class_Sc IF LEN(aAutorName) > LEN(aFileName) APPEND BLANK REPLACE Kod_ClSc WITH 1 REPLACE Name_ClSc WITH "ИМЕНА АВТОРОВ ФАЙЛА" ENDIF DC_Impl(oScrn) ****** Градации классификационных шкал (классы) oScrn := DC_WaitOn(L('Формирование градаций классификационных шкал (классов)'),,,,,,,,,,,.F.) mKodGrClSc = 0 ASORT(aAutorName) aClasses := {} aGr_ClSc := {} FOR j=1 TO LEN(aAutorName) SELECT Gr_ClSc APPEND BLANK REPLACE Kod_ClSc WITH 1 REPLACE Kod_GrCS WITH ++mKodGrClSc REPLACE Name_GrCS WITH aAutorName[j] AADD( aGr_ClSc, aAutorName[j]) SELECT Classes APPEND BLANK REPLACE Kod_cls WITH mKodGrClSc REPLACE Name_Cls WITH "ИМЕНА АВТОРОВ ФАЙЛА - "+aAutorName[j] REPLACE Kod_ClSc WITH 1 AADD( aClasses, "ИМЕНА АВТОРОВ ФАЙЛА - "+aAutorName[j]) NEXT DC_Impl(oScrn) ************************* ****** Описательные шкалы ************************* oScrn := DC_WaitOn(L('Формирование описательных шкал'),,,,,,,,,,,.F.) SELECT Opis_Sc APPEND BLANK REPLACE Kod_OpSc WITH 1 REPLACE Name_OpSc WITH "СЛОВА" IF aPar[3] = 2 APPEND BLANK REPLACE Kod_OpSc WITH 2 REPLACE Name_OpSc WITH "МЕМЫ (СОЧЕТАНИЯ СЛОВ)" ENDIF DC_Impl(oScrn) * QUIT CASE aPar[9] = 2 // 2-й стандарт "Эйдос": "Имя класса-######.txt": имя класса в имени файла до тире ****************************** ****** Классификационные шкалы ****************************** oScrn := DC_WaitOn(L('Создание классификационных шкал'),,,,,,,,,,,.F.) SELECT Class_Sc APPEND BLANK REPLACE Kod_ClSc WITH 1 REPLACE Name_ClSc WITH "ИМЯ ФАЙЛА" DC_Impl(oScrn) ****** Градации классификационных шкал (классы) oScrn := DC_WaitOn(L('Генерация градаций классификационных шкал (классов)'),,,,,,,,,,,.F.) ASORT(aFileName) aClasses := {} aGr_ClSc := {} FOR j=1 TO LEN(aFileName) mPos = AT("-", aFileName[j]) IF mPos > 0 mClassName = SUBSTR(aFileName[j],1,mPos-1) ELSE mClassName = aFileName[j] ENDIF IF ASCAN(aClasses, mClassName) = 0 // Исключить повторы классов AADD( aClasses, mClassName) AADD( aGr_ClSc, mClassName) ENDIF NEXT FOR j=1 TO LEN(aClasses) SELECT Classes APPEND BLANK REPLACE Kod_cls WITH j REPLACE Name_Cls WITH "ИМЯ ФАЙЛА-"+aGr_ClSc[j] REPLACE Kod_ClSc WITH 1 SELECT Gr_ClSc APPEND BLANK REPLACE Kod_ClSc WITH 1 REPLACE Kod_GrCS WITH j REPLACE Name_GrCS WITH aGr_ClSc[j] NEXT DC_Impl(oScrn) ************************* ****** Описательные шкалы ************************* oScrn := DC_WaitOn(L('Создание описательных шкал'),,,,,,,,,,,.F.) SELECT Opis_Sc APPEND BLANK REPLACE Kod_OpSc WITH 1 REPLACE Name_OpSc WITH "СЛОВА" IF aPar[3] = 2 APPEND BLANK REPLACE Kod_OpSc WITH 2 REPLACE Name_OpSc WITH "МЕМЫ (СОЧЕТАНИЯ СЛОВ)" ENDIF DC_Impl(oScrn) CASE aPar[9] = 3 // 3-й стандарт "Эйдос" объединяет 1-й и 2-й стандарты, т.е. "id1,...,idn-######.txt": имена классов idn в имени файла через "," до "-" И "Имя класса-######.txt": имя класса в имени файла до тире // Сначала сделать классы как во 2-м стандарте, а потом как в 1-м <<<===##################################### // 2-й стандарт "Эйдос": "Имя класса-######.txt": имя класса в имени файла до тире ****************************** ****** Классификационные шкалы ****************************** oScrn := DC_WaitOn(L('Создание классификационных шкал'),,,,,,,,,,,.F.) SELECT Class_Sc APPEND BLANK REPLACE Kod_ClSc WITH 1 REPLACE Name_ClSc WITH "ИМЯ ФАЙЛА" DC_Impl(oScrn) ****** Градации классификационных шкал (классы) oScrn := DC_WaitOn(L('Генерация градаций классификационных шкал (классов)'),,,,,,,,,,,.F.) ASORT(aFileName) aClasses := {} aGr_ClSc := {} FOR j=1 TO LEN(aFileName) mPos = AT("-", aFileName[j]) IF mPos > 0 mClassName = SUBSTR(aFileName[j],1,mPos-1) ELSE mClassName = aFileName[j] ENDIF IF ASCAN(aClasses, mClassName) = 0 // Исключить повторы классов AADD( aClasses, mClassName) AADD( aGr_ClSc, mClassName) ENDIF NEXT FOR j=1 TO LEN(aClasses) SELECT Classes APPEND BLANK REPLACE Kod_cls WITH j REPLACE Name_Cls WITH "ИМЯ ФАЙЛА-"+aGr_ClSc[j] REPLACE Kod_ClSc WITH 1 SELECT Gr_ClSc APPEND BLANK REPLACE Kod_ClSc WITH 1 REPLACE Kod_GrCS WITH j REPLACE Name_GrCS WITH aGr_ClSc[j] NEXT DC_Impl(oScrn) // 1-й стандарт "Эйдос": "id1,...,idn-######.txt": имена классов idn в имени файла через "," до "-" oScrn := DC_WaitOn(L('Формирование массива имен авторов'),,,,,,,,,,,.F.) FOR j=1 TO LEN(aFileName) mPos = AT("-",aFileName[j]) IF mPos > 0 mFileName = SUBSTR(aFileName[j],1,mPos-1) ELSE mFileName = aFileName[j] // Если в имени файла нет номера: -######, то для формирования классов использовать все имя файла, а иначе часть имени файла до тире ENDIF FOR a=1 TO NUMTOKEN(mFileName, ",") // Разделитель между словами - запятая mAutorName = TOKEN(mFileName, ",", a) IF ASCAN(aAutorName, mAutorName) = 0 // Исключить повторы имен авторов AADD (aAutorName, mAutorName) ENDIF NEXT NEXT DC_Impl(oScrn) *DC_DebugQout( aAutorName ) ****************************** ****** Классификационные шкалы ****************************** oScrn := DC_WaitOn(L('Формирование классификационных шкал'),,,,,,,,,,,.F.) SELECT Class_Sc IF LEN(aAutorName) > LEN(aFileName) APPEND BLANK REPLACE Kod_ClSc WITH 2 REPLACE Name_ClSc WITH "ИМЕНА АВТОРОВ ФАЙЛА" ENDIF DC_Impl(oScrn) ****** Градации классификационных шкал (классы) oScrn := DC_WaitOn(L('Формирование градаций классификационных шкал (классов)'),,,,,,,,,,,.F.) * mKodGrClSc = 0 mKodGrClSc = LEN(aClasses) ASORT(aAutorName) * aClasses := {} * aGr_ClSc := {} FOR j=1 TO LEN(aAutorName) SELECT Gr_ClSc APPEND BLANK REPLACE Kod_ClSc WITH 2 REPLACE Kod_GrCS WITH ++mKodGrClSc REPLACE Name_GrCS WITH aAutorName[j] AADD( aGr_ClSc, aAutorName[j]) SELECT Classes APPEND BLANK REPLACE Kod_cls WITH mKodGrClSc REPLACE Name_Cls WITH "ИМЕНА АВТОРОВ ФАЙЛА - "+aAutorName[j] REPLACE Kod_ClSc WITH 2 AADD( aClasses, "ИМЕНА АВТОРОВ ФАЙЛА - "+aAutorName[j]) NEXT DC_Impl(oScrn) ************************* ****** Описательные шкалы ************************* oScrn := DC_WaitOn(L('Формирование описательных шкал'),,,,,,,,,,,.F.) SELECT Opis_Sc APPEND BLANK REPLACE Kod_OpSc WITH 1 REPLACE Name_OpSc WITH "СЛОВА" IF aPar[3] = 2 APPEND BLANK REPLACE Kod_OpSc WITH 2 REPLACE Name_OpSc WITH "МЕМЫ (СОЧЕТАНИЯ СЛОВ)" ENDIF DC_Impl(oScrn) CASE aPar[9] = 4 // 4-й стандарт "http://kaggle.com/": "id, Class name" код и имя класса в тексте файла ****************************** ****** Классификационные шкалы ****************************** oScrn := DC_WaitOn(L('Создание классификационных шкал'),,,,,,,,,,,.F.) SELECT Class_Sc APPEND BLANK REPLACE Kod_ClSc WITH 1 REPLACE Name_ClSc WITH "КЛАССИФИКАЦИЯ" DC_Impl(oScrn) ****** Градации классификационных шкал (классы) oScrn := DC_WaitOn(L('Генерация градаций классификационных шкал (классов)'),,,,,,,,,,,.F.) SELECT Gr_ClSc APPEND BLANK REPLACE Kod_ClSc WITH 1 REPLACE Kod_GrCS WITH 1 REPLACE Name_GrCS WITH 'истина' APPEND BLANK REPLACE Kod_ClSc WITH 1 REPLACE Kod_GrCS WITH 2 REPLACE Name_GrCS WITH 'ложь' DC_Impl(oScrn) ************************* ****** Описательные шкалы ************************* oScrn := DC_WaitOn(L('Создание описательных шкал'),,,,,,,,,,,.F.) SELECT Opis_Sc APPEND BLANK REPLACE Kod_OpSc WITH 1 REPLACE Name_OpSc WITH "СЛОВА" IF aPar[3] = 2 APPEND BLANK REPLACE Kod_OpSc WITH 2 REPLACE Name_OpSc WITH "МЕМЫ (СОЧЕТАНИЯ СЛОВ)" ENDIF DC_Impl(oScrn) ENDCASE ****************************************** *** ЛЕММАТИЗАЦИЯ ФАЙЛОВ ****************** ****************************************** mKodGrOS = 0 // Код градации описательной шкалы aWords1 := {} // Массив всех слов всех файлов aMems1 := {} // Массив сочетаний слов (мемов) всех файлов DO CASE CASE aPar[5] = 1 // Формирование классификационных и описательных шкал и градаций и обуч.выборки DIRCHANGE(Disk_dir+"\AID_DATA\Inp_data\") // Перейти в папку Inp_data CASE aPar[5] >= 2 // Формирование распознаваемой выборки с имеющимися шкалами и градациями DIRCHANGE(Disk_dir+"\AID_DATA\Inp_rasp\") // Перейти в папку Inp_data ENDCASE mCountTxt = ADIR("*.txt", aFileName) // Формирование массива имет TXT-файлов IF aPar[6] .AND. mCountTxt > 0 // .T. - проводить лемматизацию, .F. - не проводить лемматизацию DO CASE CASE aPar[5] = 1 // Формирование классификационных и описательных шкал и градаций и обуч.выборки DO CASE CASE aPar[9] < 4 oScrn := DC_WaitOn(L('Лемматизация файлов обучающей выборки (слова)'),,,,,,,,,,,.F.) CASE aPar[9] = 4 oScrn := DC_WaitOn(L('Лемматизация файлов обучающей выборки (слова и мемы)'),,,,,,,,,,,.F.) ENDCASE CASE aPar[5] >= 2 // Формирование распознаваемой выборки с имеющимися шкалами и градациями DO CASE CASE aPar[9] < 4 oScrn := DC_WaitOn(L('Лемматизация файлов распознаваемой выборки (слова)'),,,,,,,,,,,.F.) CASE aPar[9] = 4 oScrn := DC_WaitOn(L('Лемматизация файлов распознаваемой выборки (слова и мемы)'),,,,,,,,,,,.F.) ENDCASE ENDCASE FOR mFile=1 TO LEN(aFileName) // Цикл по TXT-файлам в дирректории Inp_data (Inp_rasp) ### oProgr=1 ############## ********* Загрузка файла и формирование и запись массива слов файла и сочетаний (мемов) из них. ********* Если задано, то сначала проводить лемматизацию DO CASE CASE aPar[5] = 1 // Формирование классификационных и описательных шкал и градаций и обуч.выборки mLcBuf = ALLTRIM(FILESTR(Disk_dir+"\AID_DATA\Inp_data\"+aFileName[mFile])) // Загрузка файла CASE aPar[5] >= 2 // Формирование распознаваемой выборки с имеющимися шкалами и градациями mLcBuf = ALLTRIM(FILESTR(Disk_dir+"\AID_DATA\Inp_rasp\"+aFileName[mFile])) // Загрузка файла ENDCASE * // Оставить только цифры и буквы, А ТАКЖЕ ПОДЧЕРКИВАНИЕ (95) <===################## * Fv = mLcBuf * FOR j= 1 TO 47;Fv = STRTRAN(Fv,CHR(j),' ');NEXT * FOR j= 58 TO 64;Fv = STRTRAN(Fv,CHR(j),' ');NEXT * FOR j= 91 TO 94;Fv = STRTRAN(Fv,CHR(j),' ');NEXT * FOR j= 96 TO 96;Fv = STRTRAN(Fv,CHR(j),' ');NEXT * FOR j=123 TO 127;Fv = STRTRAN(Fv,CHR(j),' ');NEXT * FOR j=176 TO 223;Fv = STRTRAN(Fv,CHR(j),' ');NEXT * FOR j=242 TO 255;Fv = STRTRAN(Fv,CHR(j),' ');NEXT * mLcBuf = Fv mLemmaFile = '' FOR ww=1 TO NUMTOKEN(mLcBuf, ' ') // Цикл по словам mWord = LOWER(TOKEN(mLcBuf,' ', ww)) mWord = LC_Lemmatization(mWord, aPar[6], aPar[5]) // ЛЕММАТИЗАЦИЯ mLemmaFile = mLemmaFile + mWord + ' ' IF ASCAN(aWords1, mWord) = 0 // В справочник второй раз слово не включается, а в обуч.или расп.выборку - включается AADD (aWords1, mWord) ENDIF NEXT DO CASE CASE aPar[5] = 1 // Формирование классификационных и описательных шкал и градаций и обуч.выборки STRFILE(ALLTRIM(mLemmaFile), Disk_dir+"\AID_DATA\Inp_data\"+STRTRAN(aFileName[mFile],'.txt','.Lem')) // Запись лемматизированного файла CASE aPar[5] >= 2 // Формирование распознаваемой выборки с имеющимися шкалами и градациями STRFILE(ALLTRIM(mLemmaFile), Disk_dir+"\AID_DATA\Inp_rasp\"+STRTRAN(aFileName[mFile],'.txt','.Lem')) // Запись лемматизированного файла ENDCASE NEXT DC_Impl(oScrn) ENDIF IF aPar[5] = 1 // 1-форм.кл.и оп.шк.и град.и обуч.выборки ****************************** ************************************************************************************** ****** Градации описательных шкал (слова и мемы) ****** Скачивать исходные файлы по очереди и формировать описательные шкалы и градации ************************************************************************************** DO CASE CASE aPar[9] < 4 oScrn := DC_WaitOn(L('Формирование градаций описательных шкал (слова)'),,,,,,,,,,,.F.) CASE aPar[9] = 4 oScrn := DC_WaitOn(L('Формирование градаций описательных шкал (слова и мемы)'),,,,,,,,,,,.F.) ENDCASE DIRCHANGE(Disk_dir+"\AID_DATA\Inp_data\") // Перейти в папку Inp_data mCountTxt = ADIR("*.TXT") // Кол-во TXT-файлов IF mCountTxt > 0 // Есть файлы FOR mFile=1 TO LEN(aFileName) // Цикл по TXT-файлам в дирректории Inp_data (Inp_rasp) ### oProgr=2 ############## ********* Загрузка файлов и формирование и запись массива слов файла и сочетаний (мемов) из них. ********* Если задано, то сначала проводить лемматизацию IF aPar[6] // .T. - проводить лемматизацию, .F. - не проводить лемматизацию mLcBuf = ALLTRIM(FILESTR(STRTRAN(aFileName[mFile],'.txt','.Lem'))) // Загрузка LEM-файла ELSE mLcBuf = ALLTRIM(FILESTR(aFileName[mFile])) // Загрузка TXT-файла * // Оставить только цифры и буквы, А ТАКЖЕ ПОДЧЕРКИВАНИЕ (95) <===################## * Fv = mLcBuf * FOR j= 1 TO 47;Fv = STRTRAN(Fv,CHR(j),' ');NEXT * FOR j= 58 TO 64;Fv = STRTRAN(Fv,CHR(j),' ');NEXT * FOR j= 91 TO 94;Fv = STRTRAN(Fv,CHR(j),' ');NEXT * FOR j= 96 TO 96;Fv = STRTRAN(Fv,CHR(j),' ');NEXT * FOR j=123 TO 127;Fv = STRTRAN(Fv,CHR(j),' ');NEXT * FOR j=176 TO 223;Fv = STRTRAN(Fv,CHR(j),' ');NEXT * FOR j=242 TO 255;Fv = STRTRAN(Fv,CHR(j),' ');NEXT * mLcBuf = Fv ENDIF * MsgBox(aFileName[mFile]+STR(LEN(mLcBuf))) // <===############## IF aPar[2] = 1 mLcBuf = ConvToOemCP(mLcBuf) ENDIF * DC_Impl(oScrn) * DC_DebugQout( mLcBuf ) // Если для Каггла, то не спользовать 1-й и последний элементы ####################### * MsgBox('Файл: '+ALLTRIM(STR(mFile))+'/'+ALLTRIM(STR(LEN(aFileName)))+'-"'+ConvToOemCP(aFileName[mFile])+'". Длина файла в символах='+ALLTRIM(STR(LEN(mLcBuf)))+', число слов в файле='+ALLTRIM(STR(NUMTOKEN(mLcBuf, ' ')))) * aStructure := { { "Num" , "N", 9, 0 },; * { "FileName", "C",mLenFN, 0 },; * { "NumChar" , "N", 9, 0 },; * { "NumWord" , "N", 9, 0 } } * DbCreate( 'TxtFileInf', aStructure ) SELECT TxtFileInf APPEND BLANK REPLACE Num WITH RECNO() REPLACE FileName WITH ConvToOemCP(aFileName[mFile]) REPLACE NumChar WITH LEN(mLcBuf) REPLACE NumWord WITH NUMTOKEN(mLcBuf, ' ') ** В каком стандарте закодированы имена исходных файлов: IF aPar[9] < 4 // В стандарте "Эйдос": "id, Class name" брать из номера и имени файла FOR ww=1 TO NUMTOKEN(mLcBuf, ' ') // Цикл по словам mWord = LOWER(TOKEN(mLcBuf,' ', ww)) IF aPar[10] <= LEN(mWord) .AND. LEN(mWord) <= aPar[11] // Включать слово, только если оно не менее aPar[10] символов и не более символов aPar[11] IF ASCAN(aWords1, mWord) = 0 // В справочник второй раз слово не включается, а в обуч.или расп.выборку - включается AADD (aWords1, mWord) ENDIF ENDIF NEXT ENDIF IF aPar[9] = 4 // В стандарте "http://kaggle.com/": "id, Class name" брать из текста файла (при кодировании признаков не использовать 1-й и последний элементы) FOR ww=2 TO NUMTOKEN(mLcBuf, ' ')-1 // Цикл по словам mWord = LOWER(TOKEN(mLcBuf,' ', ww)) IF aPar[10] <= LEN(mWord) .AND. LEN(mWord) <= aPar[11] // Включать слово, только если оно не менее aPar[10] символов и не более символов aPar[11] IF ASCAN(aWords1, mWord) = 0 // В справочник второй раз слово не включается, а в обуч.или расп.выборку - включается AADD (aWords1, mWord) ENDIF ENDIF NEXT ENDIF * DC_DebugQout( aWords1 ) ***** Здесь сделать формирование сочетаний слов (мемов, шинглов) из 2, 3,... подряд идущих слов (без лемматизации не работает) IF aPar[3] = 2 IF LEN(aWords1) > 0 FOR i=1 TO LEN(aWords1) - aPar[4] mMem = aWords1[i] FOR j=i+1 TO i + aPar[4] - 1 mMem = mMem + "_" + aWords1[j] IF ASCAN(aMems1, mMem) = 0 // Повторно мем не включается AADD( aMems1, mMem) ENDIF NEXT NEXT ENDIF ENDIF NEXT * MsgBox(STR(LEN(aWords1))+STR(LEN(aMems1))) // <===########## ********* Запись градаций описательных шкал DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения IF LEN(aWords1) > 0 mKodGrOS = 0 ASORT(aWords1) SELECT Gr_OpSc FOR w=1 TO LEN(aWords1) APPEND BLANK REPLACE Kod_OpSc WITH 1 REPLACE Kod_GrOS WITH ++mKodGrOS REPLACE Name_GrOS WITH aWords1[w] NEXT mKodGrOS = 0 SELECT Attributes FOR w=1 TO LEN(aWords1) APPEND BLANK REPLACE Kod_atr WITH ++mKodGrOS REPLACE Name_atr WITH "СЛОВА - "+aWords1[w] REPLACE Kod_OpSc WITH 1 NEXT ENDIF IF LEN(aMems1) > 0 mKodGrOSmem = mKodGrOS ASORT(aMems1) SELECT Gr_OpSc FOR m=1 TO LEN(aMems1) APPEND BLANK REPLACE Kod_OpSc WITH 2 REPLACE Kod_GrOS WITH ++mKodGrOSmem REPLACE Name_GrOS WITH aMems1[m] NEXT mKodGrOSmem = mKodGrOS SELECT Attributes FOR m=1 TO LEN(aMems1) APPEND BLANK REPLACE Kod_atr WITH ++mKodGrOSmem REPLACE Name_atr WITH "МЕМЫ (СОЧЕТАНИЯ СЛОВ) - "+aMems1[m] REPLACE Kod_OpSc WITH 2 NEXT ENDIF *** Запись массивов aWords, aMems, aFileName и aAutorName и др. для передачи в режим формирования распознаваемой выборки DC_ASave(aWords1, "_2321aWords.arx") DC_ASave(aMems1, "_2321aMems.arx") DC_ASave(aFileName, "_2321aFileName.arx") DC_ASave(aAutorName,"_2321aAutorName.arx") DC_ASave(aClasses, "_2321aClasses.arx") DC_ASave(aGr_ClSc, "_2321aGr_ClSc.arx") * aWords1 = DC_ARestore("_2321aWords.arx") * aMems1 = DC_ARestore("_2321aMems.arx") * aFileName = DC_ARestore("_2321aFileName.arx") * aAutorName = DC_ARestore("_2321aAutorName.arx") * aClasses = DC_ARestore("_2321aClasses.arx") * aGr_ClSc = DC_ARestore("_2321aGr_ClSc.arx") ENDIF DC_Impl(oScrn) ENDIF ************************************************************************************ ***** Формирование обучающей или распознаваемой выборки **************************** ************************************************************************************ oScrn := DC_WaitOn(L('Формирование обучающей или распознаваемой выборки'),,,,,,,,,,,.F.) M_KodObj = 0 // Скачать имена txt-файлов из НУЖНОЙ папки и определить их количество DO CASE CASE aPar[5] = 1 // Формирование классификационных и описательных шкал и градаций и обуч.выборки DIRCHANGE(Disk_dir+"\AID_DATA\Inp_data\") // Перейти в папку Inp_data CASE aPar[5] >= 2 // Формирование распознаваемой выборки с имеющимися шкалами и градациями DIRCHANGE(Disk_dir+"\AID_DATA\Inp_rasp\") // Перейти в папку Inp_rasp ENDCASE mCountTxt = ADIR("*.txt", aFileName) *LB_Warning(aFileName, '(C°) Система "Эйдос-Х++"') *LB_Warning(aClasses,L('2.3.2.1. Импорт данных из текстовых файлов')) IF mCountTxt > 0 // Есть файлы IF aPar[5] = 2 // Формирование распознаваемой выборки с имеющимися шкалами и градациями после реж.2.3.2.1 DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения ** Проверить, есть ли эти файлы и выдать сообщение, если их нет IF .NOT. FILE("_2321aWords.arx") .OR.; .NOT. FILE("_2321aMems.arx") .OR.; .NOT. FILE("_2321aFileName.arx") .OR.; .NOT. FILE("_2321aAutorName.arx").OR.; .NOT. FILE("_2321aClasses.arx") .OR.; .NOT. FILE("_2321aGr_ClSc.arx") aMess := {} AADD(aMess, L('Необходимо выполнить этот режим с опцией: ')) AADD(aMess, L('Формирование классификационных и описательных')) AADD(aMess, L('шкал и градаций и обучающей выборки.')) LB_Warning(aMess,L('2.3.2.1. Импорт данных из текстовых файлов')) *************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню *************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ELSE aWords1 = DC_ARestore("_2321aWords.arx") aMems1 = DC_ARestore("_2321aMems.arx") aFileName1 = DC_ARestore("_2321aFileName.arx") aAutorName1 = DC_ARestore("_2321aAutorName.arx") aClasses = DC_ARestore("_2321aClasses.arx") aGr_ClSc = DC_ARestore("_2321aGr_ClSc.arx") ENDIF ENDIF IF aPar[5] = 3 // 3-формирование распознаваемой выборки после 2.3.2.2 ******************************** DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения aWords1 := {} // Коды слов // Цикл по словам СДЕЛАТЬ ПРОГРЕСС-БАР SELECT Gr_OpSc DBGOTOP() DO WHILE .NOT. EOF() AADD(aWords1, ALLTRIM(LOWER(Name_GrOS))) DBSKIP(1) ENDDO * DC_DebugQout( aWords1 ) // <<<===############### ENDIF DC_Impl(oScrn) ************************************************************************************* *** Отображение стадии и прогноза времени исполнения ******************************** ************************************************************************************* Wsego = LEN(aFileName) DO CASE CASE aPar[5] = 1 // Формирование классификационных и описательных шкал и градаций и обуч.выборки mTitleName = L('API-2.3.2.1. Формирование обучающей выборки. (C) Система "ЭЙДОС-X++"') CASE aPar[5] >= 2 // Формирование распознаваемой выборки с имеющимися шкалами и градациями mTitleName = L('API-2.3.2.1. Формирование распознаваемой выборки. (C) Система "ЭЙДОС-X++"') ENDCASE // Отображение стадии исполнения. Будет написано прямо в окне Progress-bar d = 0 @0,0 DCGROUP oGroup1 CAPTION L('Стадии исполнения процесса') FONT "6.Helv" SIZE 105+d, 2.5 PARENT oTabPage1 @4,0 DCGROUP oGroup2 CAPTION L('Прогноз времени исполнения') FONT "6.Helv" SIZE 105+d, 5.0 PARENT oTabPage2 s = 1 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 1] FONT "10.Helv" s++ @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay97 FONT "10.HelvBold" s++ @0.2+s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay98 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @1.5+s ,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay99 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @s ,1 DCPROGRESS oProgress ; SIZE 95,1.5 ; PERCENT ; EVERY 1+INT(Wsego/nEvery) ; // Кол-во обновлений изображения MAXCOUNT Wsego ; COLOR GRA_CLR_CYAN // Цвет полосы @s++,97 DCPUSHBUTTON CAPTION L('&Cancel') ; ACTION {||lOk:=.T.} OBJECT oButton ; SIZE 7,1.5 DCREAD GUI ; TITLE mTitleName ; PARENT @oDialog ; FIT ; EXIT ; MODAL oDialog:alwaysOnTop = .T. // Окно открывается на переднем плане oDialog:show() // Начало отсчета времени для прогнозирования длительности исполнения Time_progress = 0 // Прошло секунд с начала процесса // Процесс может идти больше суток, поэтому для определения // во всех случаях вычисляется время, прошедшее с начала года T_Mess1 = L("Начало:")+" "+TIME() // Начало Sec_1 = (DOY(DATE())-1)*86400+SECONDS() PUBLIC T1 := (DOY(DATE())-1)*86400+SECONDS() // Время предыдущей индикации процесса исполнения PUBLIC T2 := (DOY(DATE())-1)*86400+SECONDS()+1 // Текущее время (1-й раз оно заметно больше T1 чтобы было отображение) PUBLIC T1tp := T1 PUBLIC T2tp := T2 ********************************************************************************* FOR mFile = 1 TO LEN(aFileName) // Цикл по TXT-файлам в дирректории Inp_data (Inp_rasp) ### oProgr=3 ############## ********* Загрузка файла и формирование и запись массива слов файла и сочетаний (мемов) из них DO CASE CASE aPar[5] = 1 // Формирование классификационных и описательных шкал и градаций и обуч.выборки DIRCHANGE(Disk_dir+"\AID_DATA\Inp_data\") // Перейти в папку Inp_data aSay[ 1]:SetCaption(L('Обрабатывается файл:') +' '+ALLTRIM(STR(mFile))+'/'+ALLTRIM(STR(LEN(aFileName)))+': "'+ALLTRIM(ConvToOemCP(aFileName[mFile]))+'"') CASE aPar[5] >= 2 // Формирование распознаваемой выборки с имеющимися шкалами и градациями DIRCHANGE(Disk_dir+"\AID_DATA\Inp_rasp\") // Перейти в папку Inp_rasp aSay[ 1]:SetCaption(L('Обрабатывается файл:') +' '+ALLTRIM(STR(mFile))+'/'+ALLTRIM(STR(LEN(aFileName)))+': "'+ALLTRIM(ConvToOemCP(aFileName[mFile]))+'"') ENDCASE aKodCls := {} // Массив кодов классов файла aKodAtr := {} // Массив кодов признаков файла aFileWords := {} // Массив слов файла aFileMems := {} // Массив сочетаний слов файла (мемов) IF aPar[6] // .T. - проводить лемматизацию, .F. - не проводить лемматизацию mLcBuf = ALLTRIM(FILESTR(STRTRAN(aFileName[mFile],'.txt','.Lem'))) // Загрузка LEM-файла ELSE mLcBuf = ALLTRIM(FILESTR(aFileName[mFile])) // Загрузка TXT-файла * // Оставить только цифры и буквы, А ТАКЖЕ ПОДЧЕРКИВАНИЕ (95) <===################## * Fv = mLcBuf * FOR j= 1 TO 47;Fv = STRTRAN(Fv,CHR(j),' ');NEXT * FOR j= 58 TO 64;Fv = STRTRAN(Fv,CHR(j),' ');NEXT * FOR j= 91 TO 94;Fv = STRTRAN(Fv,CHR(j),' ');NEXT * FOR j= 96 TO 96;Fv = STRTRAN(Fv,CHR(j),' ');NEXT * FOR j=123 TO 127;Fv = STRTRAN(Fv,CHR(j),' ');NEXT * FOR j=176 TO 223;Fv = STRTRAN(Fv,CHR(j),' ');NEXT * FOR j=242 TO 255;Fv = STRTRAN(Fv,CHR(j),' ');NEXT * mLcBuf = Fv ENDIF IF aPar[2] = 1 mLcBuf = ConvToOemCP(mLcBuf) ENDIF ** В каком стандарте закодированы имена исходных файлов: IF aPar[9] < 4 // В стандарте "Эйдос": "id, Class name" брать из номера и имени файла FOR ww=1 TO NUMTOKEN(mLcBuf, ' ') // Цикл по словам mWord = LOWER(TOKEN(mLcBuf, ' ', ww)) * IF ASCAN(aFileWords, mWord) = 0 // В справочник повторно слово не включается, а в обучающую и распознаваемую выборку - включается AADD (aFileWords, mWord) * ENDIF NEXT *** Формирование массива кодов признаков // Такое впечатление, что иногда в признаки включаются слова, которых нет в тексте. Проверить ############# FOR ww=1 TO NUMTOKEN(mLcBuf, ' ') // Цикл по словам mWord = LOWER(TOKEN(mLcBuf, ' ', ww)) mKodAtr = ASCAN(aWords1, mWord) IF mKodAtr > 0 AADD(aKodAtr, mKodAtr) ENDIF NEXT ENDIF IF aPar[9] = 4 // В стандарте "http://kaggle.com/": "id, Class name" брать из текста файла (при кодировании признаков не использовать 1-й и последний элементы) FOR ww=2 TO NUMTOKEN(mLcBuf, ' ')-1 // Цикл по словам mWord = LOWER(TOKEN(mLcBuf, ' ', ww)) * IF ASCAN(aFileWords, mWord) = 0 // В справочник повторно слово не включается, а в обучающую и распознаваемую выборку - включается AADD (aFileWords, mWord) * ENDIF NEXT *** Формирование массива кодов признаков // Такое впечатление, что иногда в признаки включаются слова, которых нет в тексте. Проверить ############# FOR ww=2 TO NUMTOKEN(mLcBuf, ' ')-1 // Цикл по словам mWord = LOWER(TOKEN(mLcBuf, ' ', ww)) mKodAtr = ASCAN(aWords1, mWord) IF mKodAtr > 0 AADD(aKodAtr, mKodAtr) ENDIF NEXT ENDIF *** Здесь сделать формирование сочетаний слов (мемов) из 2, 3,... подряд идущих слов *** Формирование массива кодов признаков IF aPar[3] = 2 IF LEN(aFileWords) > 0 FOR i=1 TO LEN(aFileWords) - aPar[4] mMem = aFileWords[i] FOR j=i+1 TO i + aPar[4] - 1 mMem = mMem + "_" + aFileWords[j] mKodAtr = ASCAN(aMems1, mMem) IF mKodAtr > 0 AADD(aKodAtr, LEN(aWords1) + mKodAtr) ENDIF NEXT NEXT ENDIF ENDIF *** Формировать БД Inp_data.dbf стандарта 2.3.2.2 для создания моделей продолжения фраз. *** Исходные данные для моделей прогнозирования последующих слов на основе предшествующих. IF aPar[7] * aStructure := { { "Object" , "C", 250, 0 },; * { "Curr_word" , "C", 40, 0 },; * { "Prev_words", "C", 250, 0 } } * DbCreate( 'Inp_data', aStructure ) * DbCreate( 'Inp_rasp', aStructure ) DO CASE CASE aPar[5] = 1 // Формирование классификационных и описательных шкал и градаций и обуч.выборки SELECT Inp_data CASE aPar[5] >= 2 // Формирование распознаваемой выборки с имеющимися шкалами и градациями SELECT Inp_rasp ENDCASE ** Вставить текущее слово как класс и предыдущее слово как признак. Это делать всегда IF LEN(aFileWords) > 1 FOR i=2 TO LEN(aFileWords) mCurrWword = aFileWords[i] mPrevWords = aFileWords[i-1] APPEND BLANK REPLACE Object WITH 'Слово: "'+mCurrWword+'" из файла: "'+ConvToOemCP(aFileName[mFile])+'"' REPLACE Curr_word WITH mCurrWword REPLACE Prev_words WITH mPrevWords NEXT ENDIF ** Если задано формирование мемов, то вставить текущее слово как класс ** и заданное количество предыдущих слов, как минимум 2, (в обратном порядке) как признаки IF aPar[3] = 2 IF LEN(aFileWords) > 2 FOR i=aPar[4]+1 TO LEN(aFileWords) mCurrWword = aFileWords[i] mPrevWords = '' FOR j=i-1 TO i-aPar[4] STEP -1 mPrevWords = mPrevWords + " " + aFileWords[j] NEXT APPEND BLANK REPLACE Object WITH 'Слово: "'+mCurrWword+'" из файла: "'+ConvToOemCP(aFileName[mFile])+'"' REPLACE Curr_word WITH mCurrWword REPLACE Prev_words WITH mPrevWords NEXT ENDIF ENDIF ENDIF DO CASE CASE aPar[5] = 1 // 1-форм.кл.и оп.шк.и град.и обуч.выборки ****************************** *** Формирование массива кодов классов *** Преобразование имен файлов в кодировку OEM ******* В каком стандарте закодированы имена исходных файлов: // Почему-то в моделях нет информации по первому имени в 1-м стандарте <<<===################# // Во 1-м стандарте "Эйдос": Если в имени файла есть тире, то текст до этого тире рассматривается как состоящий из имен классов, раздленных запятыми IF aPar[9] = 1 mPos = AT("-", aFileName[mFile]) IF mPos > 0 mClassName = SUBSTR(ConvToOemCP(aFileName[mFile]),1,mPos-1) ELSE mClassName = ConvToOemCP(STRTRAN(aFileName[mFile],'.txt','')) // Во 1-м стандарте "Эйдос": Если в имени файла нет тире, то все имя файла рассмаривается как состоящее из имен классов, раздленных запятыми ENDIF FOR a=1 TO NUMTOKEN(mClassName, ",") // Разделитель между авторами - запятая mAutorName = TOKEN(mClassName, ",", a) mKodCls = ASCAN(aAutorName, mAutorName) IF mKodCls > 0 * AADD(aKodCls, LEN(aFileName) + mKodCls) AADD(aKodCls, mKodCls) ENDIF NEXT ENDIF // Во 2-м стандарте "Эйдос": Если в имени файла есть тире, то весь текст до этого тире рассматривается как имя класса: "Имя класса-#########.txt" IF aPar[9] = 2 mPos = AT("-", aFileName[mFile]) IF mPos > 0 mClassName = SUBSTR(ConvToOemCP(aFileName[mFile]),1,mPos-1) ELSE mClassName = ConvToOemCP(STRTRAN(aFileName[mFile],'.txt','')) ENDIF mKodCls = ASCAN(aClasses, mClassName) IF mKodCls > 0 AADD(aKodCls, mKodCls) ENDIF ENDIF // Во 3-м стандарте "Эйдос": Если в имени файла есть тире, то весь текст до этого тире рассматривается как имя класса: "Имя класса-#########.txt" // Во 3-м стандарте "Эйдос": Если в имени файла есть тире, то текст до этого тире рассматривается как состоящий из имен классов, раздленных запятыми IF aPar[9] = 3 // <<<===################################ // Как в во 2-м стандарте Эйдос mPos = AT("-", aFileName[mFile]) IF mPos > 0 mClassName = SUBSTR(ConvToOemCP(aFileName[mFile]),1,mPos-1) ELSE mClassName = ConvToOemCP(STRTRAN(aFileName[mFile],'.txt','')) ENDIF mKodCls = ASCAN(aClasses, mClassName) IF mKodCls > 0 AADD(aKodCls, mKodCls) ENDIF // Как в во 1-м стандарте Эйдос mPos = AT("-", aFileName[mFile]) IF mPos > 0 mClassName = SUBSTR(ConvToOemCP(aFileName[mFile]),1,mPos-1) ELSE mClassName = ConvToOemCP(STRTRAN(aFileName[mFile],'.txt','')) // Во 1-м стандарте "Эйдос": Если в имени файла нет тире, то все имя файла рассмаривается как состоящее из имен классов, раздленных запятыми ENDIF FOR a=1 TO NUMTOKEN(mClassName, ",") // Разделитель между авторами - запятая mAutorName = TOKEN(mClassName, ",", a) mKodCls = ASCAN(aAutorName, mAutorName) IF mKodCls > 0 AADD(aKodCls, LEN(aFileName) + mKodCls) // + LEN(aFileName), т.к. коды авторов будут больше на количество файлов ENDIF NEXT ENDIF // В стандарте "http://kaggle.com/": "id, Class name" брать из текста файла IF aPar[9] = 4 * mKodCls = IF(TOKEN(aFileName[mFile],, 2)='True' , 1, IF(TOKEN(aFileName[mFile],, 2)='False', 2, 0)) DO CASE CASE TOKEN(aFileName[mFile],, 2)='True' mKodCls = 1 CASE TOKEN(aFileName[mFile],, 2)='False' mKodCls = 2 OTHERWISE mKodCls = 0 ENDCASE IF mKodCls > 0 AADD(aKodCls, mKodCls) ENDIF ENDIF ********* Запись обучающей выборки DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения SELECT Obi_Zag APPEND BLANK REPLACE Kod_obj WITH ++M_KodObj ******* В каком стандарте закодированы имена исходных файлов: IF aPar[9] < 4 // В стандарте "Эйдос": "id, Class name" брать из номера и имени файла REPLACE Name_obj WITH ConvToOemCP(STRTRAN(aFileName[mFile],'.txt','')) ENDIF IF aPar[9] = 4 // В стандарте "http://kaggle.com/": "id, Class name" брать из текста файла REPLACE Name_obj WITH TOKEN(aFileName[mFile],, 1) // ConvToOemCP <===################### ENDIF REPLACE Date WITH DTOC(DATE()) REPLACE Time WITH TIME() *** Занести массив кодов классов в БД ObI_Kcl SELECT Obi_Kcl APPEND BLANK REPLACE Kod_Obj WITH M_KodObj IF LEN(aKodCls) > 0 k=1 FOR j=1 TO LEN(aKodCls) IF k <= 4 FIELDPUT(1+k++,aKodCls[j]) ELSE k=1 APPEND BLANK REPLACE Kod_Obj WITH M_KodObj FIELDPUT(1+k++,aKodCls[j]) ENDIF NEXT ENDIF *** Занести массив кодов признаков в БД ObI_Kpr SELECT Obi_Kpr APPEND BLANK REPLACE Kod_Obj WITH M_KodObj IF LEN(aKodAtr) > 0 k=1 FOR j=1 TO LEN(aKodAtr) IF k <= 7 FIELDPUT(1+k++,aKodAtr[j]) ELSE k=1 APPEND BLANK REPLACE Kod_Obj WITH M_KodObj FIELDPUT(1+k++,aKodAtr[j]) ENDIF NEXT ENDIF CASE aPar[5] = 2 // 2-формирование распознаваемой выборки после 2.3.2.1 ******************************** * *** Считать с диска массив aClasses, а ранее, когда он был сформирован, записать его <===######### * *** Формирование массива кодов классов * *** Преобразование имен файлов в кодировку OEM * *** В каком стандарте закодированы имена исходных файлов: IF aPar[9] = 1 // Во 1-м стандарте "Эйдос": Если в имени файла есть тире, то текст до этого тире рассматривается как состоящий из имен классов, раздленных запятыми mPos = AT("-", aFileName[mFile]) IF mPos > 0 mClassName = SUBSTR(ConvToOemCP(aFileName[mFile]),1,mPos-1) ELSE mClassName = ConvToOemCP(STRTRAN(aFileName[mFile],'.txt','')) // Во 1-м стандарте "Эйдос": Если в имени файла нет тире, то все имя файла рассмаривается как состоящее из имен классов, раздленных запятыми ENDIF FOR a=1 TO NUMTOKEN(mClassName, ",") // Разделитель между авторами - запятая mAutorName = TOKEN(mClassName, ",", a) mKodCls = ASCAN(aAutorName, mAutorName) IF mKodCls > 0 AADD(aKodCls, LEN(aFileName) + mKodCls) ENDIF NEXT ENDIF // Во 2-м стандарте "Эйдос": Если в имени файла есть тире, то весь текст до этого тире рассмаривается как имя класса: "Имя класса-#########.txt" IF aPar[9] = 2 mPos = AT("-", aFileName[mFile]) IF mPos > 0 mClassName = SUBSTR(ConvToOemCP(aFileName[mFile]),1,mPos-1) ELSE mClassName = ConvToOemCP(STRTRAN(aFileName[mFile],'.txt','')) ENDIF mKodCls = ASCAN(aClasses, mClassName) IF mKodCls > 0 AADD(aKodCls, mKodCls) ENDIF ENDIF ******* Формирование массива кодов признаков // Такое впечатление, что иногда в признаки включаются слова, которых нет в тексте. Проверить ############# aKodAtr := {} FOR ww=1 TO NUMTOKEN(mLcBuf, ' ') // Цикл по словам СДЕЛАТЬ ПРОГРЕСС-БАР (сделал) mWord = LOWER(ALLTRIM(TOKEN(mLcBuf, ' ', ww))) IF aPar[10] <= LEN(mWord) .AND. LEN(mWord) <= aPar[11] // Включать слово, только если оно не менее aPar[10] символов и не более символов aPar[11] mKodAtr = ASCAN(aWords1, mWord) // Почему-то начиная примерно с 800-го объекта обучающей выборки нет признаков <<<===################# IF mKodAtr > 0 AADD(aKodAtr, mKodAtr) ENDIF ENDIF NEXT // Почему-то в моделях нет информации по первому имени в 1-м стандарте <<<===################# * MsgBox(STR(mFile)+STR(LEN(aKodAtr))) * IF mFile > 74 // Почему-то начиная примерно с 800-го объекта обучающей выборки нет признаков <<<===################# * DC_DebugQout( aWords1 ) // Отладка <<<===############# * DC_DebugQout( aKodAtr ) // Отладка <<<===############# * ENDIF * IF aPar[9] = 3 * ENDIF ********* Запись распознаваемой выборки DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения SELECT Rso_Zag APPEND BLANK REPLACE Kod_obj WITH ++M_KodObj ******* В каком стандарте закодированы имена исходных файлов: IF aPar[9] < 4 // В стандарте "Эйдос": "id, Class name" брать из номера и имени файла REPLACE Name_obj WITH ConvToOemCP(aFileName[mFile]) ENDIF IF aPar[9] = 4 // В стандарте "http://kaggle.com/": "id" брать из текста файла REPLACE Name_obj WITH TOKEN(aFileName[mFile],, 1) ENDIF REPLACE Date WITH DTOC(DATE()) REPLACE Time WITH TIME() ****** Занести массив кодов классов в БД Rso_Kcl *** SELECT Rso_Kcl APPEND BLANK REPLACE Kod_Obj WITH M_KodObj IF LEN(aKodCls) > 0 k=1 FOR j=1 TO LEN(aKodCls) IF k <= 4 FIELDPUT(1+k++,aKodCls[j]) ELSE k=1 APPEND BLANK REPLACE Kod_Obj WITH M_KodObj FIELDPUT(1+k++,aKodCls[j]) ENDIF NEXT ENDIF ****** Занести массив кодов признаков в БД Rso_Kpr *** * IF mFile > 74 // Почему-то начиная примерно с 800-го объекта обучающей выборки нет признаков <<<===################# * DC_DebugQout( aWords1 ) // Отладка <<<===############# * DC_DebugQout( aKodAtr ) // Отладка <<<===############# * ENDIF SELECT Rso_Kpr APPEND BLANK REPLACE Kod_Obj WITH M_KodObj IF LEN(aKodAtr) > 0 k=1 FOR j=1 TO LEN(aKodAtr) IF k <= 7 FIELDPUT(1+k++,aKodAtr[j]) ELSE k=1 APPEND BLANK REPLACE Kod_Obj WITH M_KodObj FIELDPUT(1+k++,aKodAtr[j]) ENDIF NEXT ENDIF CASE aPar[5] = 3 // 3-формирование распознаваемой выборки после 2.3.2.2 ******************************** *** Формирование массива кодов признаков // Такое впечатление, что иногда в признаки включаются слова, которых нет в тексте. Проверить ############# aKodAtr := {} FOR ww=1 TO NUMTOKEN(mLcBuf, ' ') // Цикл по словам СДЕЛАТЬ ПРОГРЕСС-БАР (сделал) mWord = LOWER(ALLTRIM(TOKEN(mLcBuf, ' ', ww))) IF aPar[10] <= LEN(mWord) .AND. LEN(mWord) <= aPar[11] // Включать слово, только если оно не менее aPar[10] символов и не более символов aPar[11] mKodAtr = ASCAN(aWords1, mWord) // Почему-то начиная примерно с 800-го объекта обучающей выборки нет признаков <<<===################# IF mKodAtr > 0 AADD(aKodAtr, mKodAtr) ENDIF ENDIF NEXT ********* Запись распознаваемой выборки DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения SELECT Rso_Zag APPEND BLANK REPLACE Kod_obj WITH mFile REPLACE Name_obj WITH ConvToOemCP(aFileName[mFile]) REPLACE Date WITH DTOC(DATE()) REPLACE Time WITH TIME() *** Занести массив кодов признаков в БД Rso_Kpr SELECT Rso_Kpr APPEND BLANK REPLACE Kod_Obj WITH mFile IF LEN(aKodAtr) > 0 // Почему-то начиная примерно с 800-го объекта обучающей выборки нет признаков <<<===################# k=1 FOR j=1 TO LEN(aKodAtr) IF k <= 7 FIELDPUT(1+k++,aKodAtr[j]) ELSE k=1 APPEND BLANK REPLACE Kod_Obj WITH mFile FIELDPUT(1+k++,aKodAtr[j]) ENDIF NEXT ENDIF ENDCASE *** Отображение стадии и прогноза времени исполнения **************** lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) NEXT oSay97:SetCaption(L("Загрузка текстовых файлов успешно завершена !!!")) MILLISEC(5000) oSay97:SetCaption(oSay97:caption) oButton:SetCaption(L('&Ok')) // Деструктурирование окна отображения графического Progress-bar oButton:activate := {||PostAppEvent(xbeP_Close,,,oDialog)} //<<<<<< Add This DC_AppEvent( @lOk ) PostAppEvent(xbeP_Activate,,,DC_GetObject(GetList,'DCGUI_BUTTON_OK')) // Роджер oDialog:Destroy() ENDIF DC_ASave(aPar, Disk_dir+"\AID_DATA\Inp_data\"+"_2_3_2_1.arx") // Скопировать 2_3_2_1.arx в папку Inp_data // Информация о типе используемого API для интеллектуальных облачных Эйдос-приложений, чтобы при их загрузке сразу запускать нужный API StrFile('API_type=2.3.2.1.', Disk_dir+'\AID_DATA\Inp_data\API_type.txt') aMess := {} DO CASE CASE aPar[5] = 1 // 1-формирование кл.и оп.шкал и градаций и обучающей выборки ********************************* AADD(aMess, L('Создание приложения: "АСК-анализ мемов и атрибуция текстов путем импорта данных из текстовых файлов завершено успешно!"')) AADD(aMess,'') AADD(aMess, L('Теперь теперь можно посмотреть классифкационные и описательные шкалы и градации в режимах 2.1 и 2.2, обучающую выборку ')) AADD(aMess, L('в режиме 2.3.1. Затем нужно провести синтез и верификацию моделей в режиме 3.5, оценить их достоверность в режиме 3.4. ')) AADD(aMess,'') AADD(aMess, L('После этого можно решать различные задачи в наиболее достоверной модели, как описано в режиме 6.4. ')) CASE aPar[5] = 2 // 2-формирование распознаваемой выборки после режима 2.3.2.1 ********************************* AADD(aMess, L('Создание распознаваемой выборки для приложения: ')) AADD(aMess, L('"АСК-анализ мемов и атрибуция текстов в модели 2.3.2.1" ')) AADD(aMess, L('путем импорта данных из текстовых файлов завершено успешно!')) AADD(aMess,'') AADD(aMess, L('Теперь в режиме 4.1.2 необходимо провести классификацию ')) AADD(aMess, L('(атрибуцию) текстов в наиболее достоверной модели, заданной')) AADD(aMess, L('текущей в режиме 5.6. ')) CASE aPar[5] = 3 // 3-формирование распознаваемой выборки после режима 2.3.2.2 ********************************* AADD(aMess, L('Создание распознаваемой выборки для приложения: ')) AADD(aMess, L('"АСК-анализ и классификация текстов в модели 2.3.2.2" ')) AADD(aMess, L('путем импорта данных из текстовых файлов завершено успешно!')) AADD(aMess,'') AADD(aMess, L('Теперь в режиме 4.1.2 необходимо провести классификацию ')) AADD(aMess, L('(атрибуцию) текстов в наиболее достоверной модели, заданной')) AADD(aMess, L('текущей в режиме 5.6. ')) ENDCASE LB_Warning(aMess,L('API-2.3.2.1. Импорт данных из текстовых файлов')) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ***************************** FUNCTION LC_Lemmatization(mWord, mGO, mOR) IF .NOT. mGO // Если mGO = .F. - не проводить лемматизацию (возвратить входное слово) RETURN(mWord) ENDIF DIRCHANGE(Disk_dir) // Перейти в папку с системой IF LEN(ALLTRIM(mWord)) <= 3 // Слова короче 4 символов не рассматривать mWord = '' ELSE mFlag = .T. // В слове есть латинская буква, то не лемматизировать его * FOR j=1 TO LEN(mWord) * IF ASC(SUBSTR(mWord,j,1)) < 128 * mFlag = .F. // В слове есть латинская буква, то не лемматизировать его * EXIT * ENDIF * NEXT IF mFlag // Лемматизация ************************** SELECT Lemma;SET ORDER TO 1;T=DBSEEK(mWord) IF T mWord = ALLTRIM(Lemma) // Лемма найдена mNObr = N_Obr REPLACE N_Obr WITH mNObr+1 // Счетчик числа использований лемм ELSE // Если лемма не найдена, то вместо леммы используется нелемматизированное слово SET ORDER TO DBGOBOTTOM() nNum = NUM SET ORDER TO 1 APPEND BLANK // Слово, для которого не найдена лемма, заносится в базу данных лемматизации REPLACE NUM WITH ++nNum DO CASE CASE aPar[2] = 1 REPLACE WORDFORM WITH ConvToOemCP(mWord) REPLACE LEMMA WITH ConvToOemCP(mWord) // В режиме 5.13. "Ввод-корректировка БД лемматизации" можно ввести лемму для данной словоформы CASE aPar[2] = 2 REPLACE WORDFORM WITH mWord REPLACE LEMMA WITH mWord // В режиме 5.13. "Ввод-корректировка БД лемматизации" можно ввести лемму для данной словоформы ENDCASE REPLACE ERROR WITH 'NEW' // В режиме 5.13. "Ввод-корректировка БД лемматизации" можно ввести лемму для данной словоформы REPLACE N_Obr WITH 1 // Счетчик числа использований лемм ENDIF ENDIF ENDIF DO CASE CASE mOR = 1 // Формирование классификационных и описательных шкал и градаций и обуч.выборки DIRCHANGE(Disk_dir+"\AID_DATA\Inp_data\") // Перейти в папку Inp_data CASE mOR = 2 // Формирование распознаваемой выборки с имеющимися шкалами и градациями DIRCHANGE(Disk_dir+"\AID_DATA\Inp_rasp\") // Перейти в папку Inp_data ENDCASE RETURN(mWord) ***************************** *LOCAL oProgr, oDial *nMax = 2 * ( N_Gos + N_Cls + N_Gos * N_Cls ) *Mess = L('Дорасчет итоговых строк и столбцов в БД: "'+Ar_Model[z]+'.txt"' *@ 4,5 DCPROGRESS oProgr SIZE 80,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 *DCREAD GUI TITLE Mess PARENT @oDial FIT EXIT *oDial:show() *nTime = 0 *DC_GetProgress(oProgr,0,nMax) *For i=1 TO N_Gos * DC_GetProgress(oProgr, ++nTime, nMax) *NEXT *DC_GetProgress(oProgr,nMax,nMax) *oDial:Destroy() ***************************** ************************************************************************************************** FUNCTION Help2321() aHelp := {} AADD(aHelp, L('Режим: "2.3.2.1. ИМПОРТ ДАННЫХ ИЗ ТЕКСТОВЫХ ФАЙЛОВ", предназначен для автоматизации ввода ОПРЕДЕЛЕНИЙ (т.е. онтологий) объектов ')) AADD(aHelp, L('обучающей выборки, т.е. для описания конкретных объектов предметной области путем указания более общих категорий, к которым они ')) AADD(aHelp, L('относятся (принадлежность к классам), а также указания признаков, отличающих одни объекты от других. На основе ряда определений ')) AADD(aHelp, L('конкретных объектов, рассматриваемых как примеры конкретных реализаций обобщенных классов (Эйдосов), система "Эйдос" автоматически ')) AADD(aHelp, L('формирует определения этих обобщенных классов. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Имена классов формируются либо из имени файла (два стандарта "Эйдос"), либо из самого текста файла (стандарт Kaggle). ')) AADD(aHelp, L('В 1-м стандарте "Эйдос" для описания объектов используются текстовые файлы. Как классы рассматриваются элементы наименований файлов, ')) AADD(aHelp, L('отделенные запятыми друг от друга и от номера файла: "-######" (или, если его нет, то от расширения файла). ')) AADD(aHelp, L('Например, файлы могут содержать статьи, авторы которых через запятую идут в наименовании файла. Номер файла нужен для возможности ')) AADD(aHelp, L('обработки нескольких статей определенного автора или коллектива авторов. Так могут быть подготовлены данные для создания семантических')) AADD(aHelp, L('ядер (обобщенных лингвистических образов) каждого автора и каждого коллектива авторов. ')) AADD(aHelp, L('Во 2-м стандарте "Эйдос" если в конце имени файла есть тире и номер файла: "-######", то весь текст до этого тире рассмаривается как ')) AADD(aHelp, L('имя класса: "Имя класса-#########.txt". Если же тире в имени файла нет, то как имя класса рассматривается все имя файла. ')) AADD(aHelp, L('Как признаки рассматриваются слова или последовательности нескольких подряд идущих слов (мемы) в самих файлах (см. Ричард Броуди, ')) AADD(aHelp, L('"Психические вирусы", http://www.twirpx.com/file/269987/). ')) AADD(aHelp, L('В 3-м стандарте "Эйдос" объединены 1-й и 2-й стандарты. ')) AADD(aHelp, L('В 4-м стандарте "http://kaggle.com/": "id, Class name" код и имя класса в тексте файла. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Файлы могут быть различных форматов TXT, DOC, HTML с соответствующими расширениями(последние 2 в разработке) и различной кодировки: ')) AADD(aHelp, L('UTF-8, ANSI (Windows) или ASCII-OEM866 (DOS). В текущей версии системы "Эйдос" реализована только обработка txt-файлов кодировки ')) AADD(aHelp, L('OEM866, но есть перекодировщик, позволяющий конверитровать файлы из любой кодировки в OEM866. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Файлы помещаются в папку: ../AID_DATA/Inp_data/. Система анализирует эти файлы и создает новое приложение с наименованием: "2.3.2.1. ')) AADD(aHelp, L('АСК-анализ мемов и атрибуция текстов", т.е. формирует классификационные и описательные шкалы и градации, а затем и обучающую выборку, ')) AADD(aHelp, L('описывающую эти файлы или объекты реальной области, описанные этими файлами. Этого вполне достаточно для синтеза и верификации модели,')) AADD(aHelp, L('например в режиме 3.5. Наименование приложения всегда можно поменять в режиме 1.3. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Если задана опция: "Проводить лемматизацию", то слова заменяются их леммами, т.е. исходными словами, из которых они образованы, ')) AADD(aHelp, L('в форме существительных единственного числа в именительном падеже. Это позволяет существенно сократить размерность модели. ')) AADD(aHelp, L('Если при формализации предметной области лемматизация не использовалась, то и при вводе распознаваемой выборки ее проводить не нужно. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('База лемматизации дана Дмитрием Тумайкиным в статье: https://habrahabr.ru/company/realweb/blog/265375/, за что ему огромная ')) AADD(aHelp, L('благодарность. Автор лишь незначительно модифицировал ее (программно), представив в виде одной таблицы DBF-формата: адрес для ')) AADD(aHelp, L('скачивания: http://lc.kubagro.ru/Lemma.rar. В основу этой базы положена база, созданная академиком РАН РФ профессором Зализняком ')) AADD(aHelp, L('Андреем Анатольевичем, дополненная современными словоформами. База лемматизации "Lemma.dbf" содержит более 2 млн.слов. Она может быть ')) AADD(aHelp, L('сброшена или скорректирована в режиме 5.13. Если ее сбросить, то фактически лемматизация не проводится, т.к. все слова будут ')) AADD(aHelp, L('рассматриваться как новые. При работе системы "Эйдос" новые слова, которые не встретились в базе лемматизации, добавляются в нее ')) AADD(aHelp, L('и отмечаются как и их леммы должны быть введены в режиме 5.13 вручную. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Если задана опция: "Формировать БД Inp_data.dbf и т.д.", то создается база для программного интерфейса 2.3.2.2, в которой в качестве ')) AADD(aHelp, L('класса выступают последующие слова, а в качестве признаков - предшествующие слова (одно или несколько, сколько задано). Это позволяет ')) AADD(aHelp, L('строить модели, отражающие взаимосвязи слов в предложениях, позволяющие прогнозировать какое слово будет следующим, если известны ')) AADD(aHelp, L('одно или несколько предыдущих слов. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Кроме того данный режим позволяет сформировать распознаваемую выборку на уже имеющихся классификационных и описательных шкалах и ')) AADD(aHelp, L('градациях, созданных в режимах 2.3.2.1 и 2.3.2.2, на основе текстовых файлов в папке: ../AID_DATA/Inp_data/ или ../AID_DATA/Inp_rasp/.')) mHelpMax = -999;FOR h=1 TO LEN(aHelp);mHelpMax = MAX(mHelpMax, LEN(ALLTRIM(aHelp[h])));NEXT s=1;d=0.80;@0,0 DCGROUP oGroup1 CAPTION L(' ') SIZE mHelpMax-20, LEN(aHelp)*d+1.5 FOR h=1 TO LEN(aHelp);@s,2 DCSAY aHelp[h] SIZE 0 PARENT ogroup1;s=s+d;NEXT DCREAD GUI TO lExit FIT TITLE L('Помощь по режиму: 2.3.2.1. Импорт данных из текстовых файлов. (C) Система "ЭЙДОС-X++"') RETURN NIL ************************************************************************************************** ************************************************************************************************************* ****** 4.4.8. Количественный SWOT-анализ средствами АСК-анализа. (аналога в DOS-версии системы Эйдос нет) ****** АСК-анализ обеспечивает построение SWOT-матрицы (модели) для заданного класса с указанием силы влияния ****** способствующих и препятствующих факторов непосредственно на основе эмпирических данных и поэтому может ****** рассматриваться как инструмент количественного SWOT-анализа. Классы при этом интерпретируются как целевые ****** и нежелательные состояния фирмы, факторы делятся на внутренние, технологические, описывающие саму фирму, ****** и внешние, характеризующие окружающую среду, а количество информации, содержащееся в значении фактора, ****** рассматривается как сила и направление его влияния на переход фирмы в те или иные будущие состояния ************************************************************************************************************* FUNCTION F4_4_8() LOCAL GetList := {}, aPres, oBrowse, oToolBar, aColors, bColor, GetOptions Running(.T.) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF ApplChange("4.4.8()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF IF FILEDATE("SWOTDiagrCls",16) = CTOD("//") DIRMAKE("SWOTDiagrCls") aMess := {} AADD(aMess, L('В папке текущего приложения: "'+UPPER(ALLTRIM(M_PathAppl))+'"')) AADD(aMess, L('не было директории "SWOTDiagrCls" для SWOT-диаграмм классов и она была создана!')) AADD(aMess, L('В эту папку записываются исходные изображения высокого качества (без масштабирования)')) LB_Warning(aMess, L('4.4.8. Количественный SWOT-анализ классов средствами АСК-анализа' )) ENDIF ***** Проверка на наличие основных БД всех моделей и определение времени их создания. ***** Если оно не изменилось со времени предыдущего применения режима 4_2_1, то копировать txt=>dbf не надо Ar_Model := {"Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } Flag = .F. FOR z=1 TO LEN(Ar_Model) IF .NOT. FILE(Ar_Model[z]+'.txt') Mess = L('Модель: "#" отсутствует. Необходимо провести расчет моделей в 3-й подсистеме !!!') Mess = STRTRAN(Mess, '#', Ar_Model[z]) LB_Warning( Mess, L('4.2.1. Информационные портреты классов' )) Flag = .T. EXIT ENDIF NEXT IF Flag // Если какой-нибудь БД нет, то режим не запускать ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF mLenNameMax = CreateStructAll() // Создание файлов структур баз данных всех моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() // Количество классов (градаций классификационных шкал) USE Gr_OpSc EXCLUSIVE NEW;N_Gos = RECCOUNT() // Количество признаков (градаций описательных шкал) USE Opis_Sc EXCLUSIVE NEW * ########################################################################### // Открытие текстовых баз данных ******************************************** *DC_ASave(aInfStruct, "_InfStruct.arx") // Когда БД создается - записывать структуру, когда открывается - считывать aInfStruct := DC_ARestore("_InfStruct.arx") *DC_ASave(aStrEmpty, "_aStrEmpty.arx") // Записывать только после расчета Abs.txt, а при расчете остальных БД только считывать *DC_ASave(aColEmpty, "_aColEmpty.arx") aStrEmpty = DC_ARestore("_aStrEmpty.arx") aColEmpty = DC_ARestore("_aColEmpty.arx") ************************************************* ***** Формирование пустой записи N_Col = N_Cls+6 // Число полей CrLf = CHR(13)+CHR(10) // Конец строки (записи) Lc_buf = "" FOR j=1 TO N_Col * S = IF(j=2*INT(j/2),"#","X") // Для отладки S = " " // Для работы Lc_buf = Lc_buf + REPLICATE(S, aInfStruct[j,3]) NEXT Lc_buf = Lc_buf + CrLf PUBLIC Len_LcBuf := LEN(Lc_buf) ****** Открываем стат.базы и базы знаний (7 по частным критериям знаний) Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } PUBLIC nHandle[LEN(Ar_Model)] FOR z=1 TO LEN(Ar_Model) nHandle[z] := FOpen( Ar_Model[z]+".txt", FO_READWRITE ) // Открыть все текстовые базы данных ######################################## NEXT **** Рассчет массива начальных позиций полей в строке PUBLIC aPos[N_Col] aPos[1] = 1 FOR j=2 TO N_Col aPos[j] = aPos[j-1] + aInfStruct[j-1,3] NEXT * ########################################################################### ************************************************************* // Определить максимальную длину наименования: ОПИСАТЕЛЬНАЯ ШКАЛА-градация CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Gr_OpSc EXCLUSIVE NEW USE Opis_Sc EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW SELECT Gr_OpSc PUBLIC mLenMaxGOS := -9999999 DBGOTOP() DO WHILE .NOT. EOF() mLenMaxGOS = MAX(mLenMaxGOS, LEN(Name_GrOS)) DBSKIP(1) ENDDO SELECT Opis_Sc PUBLIC mLenMaxOS := -9999999 DBGOTOP() DO WHILE .NOT. EOF() mLenMaxOS = MAX(mLenMaxOS, LEN(Name_OpSc)) DBSKIP(1) ENDDO SELECT Attributes PUBLIC mLenMaxAtr := 33 DBGOTOP() DO WHILE .NOT. EOF() mLenMaxAtr = MAX(mLenMaxAtr, LEN(Name_atr)) DBSKIP(1) ENDDO // Сформировать пустую БД InfPortCls, как часть БД Attributes aStr := { { "Kod_atr" , "N", 15, 0 }, ; { "Name_atr" , "C", mLenMaxAtr, 0 }, ; { "Znach" , "N", 19, 7 }, ; { "Kod_OpSc" , "N", 15, 0 }, ; { "Fltr_Wind", "C", 1, 0 } } // Для фильтра "Вписать в окно" DbCreate( "InfPortCls" , aStr ) DbCreate( "InfPortClsPos", aStr ) DbCreate( "InfPortClsNeg", aStr ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW USE Gr_OpSc EXCLUSIVE NEW USE Opis_Sc EXCLUSIVE NEW USE InfPortCls EXCLUSIVE NEW USE InfPortClsPos EXCLUSIVE NEW USE InfPortClsNeg EXCLUSIVE NEW /* ----- Create ToolBar ----- */ W = 132 // Ширина окна D = 1.5 // Отступ на линейки прокрутки и т.д. P1 = W / 2 // Конечная позиция левого окна P2 = P1 + D // Начальная позиция правого окна ****** Сделать и вывести инф.портрет 1-го класса @0,0 DCGROUP oGroup1 SIZE W+2*D, 33.0 @11, 1 DCSAY {|| MessIPC } OBJECT oSay1 SAYSIZE W FONT "12.Helv Bold" PARENT oGroup1 // Наименование класса и модели в SWOT @12, 1 DCSAY L("Способствующие факторы и сила их влияния") SAYSIZE W/2 FONT "12.Helv Bold" COLOR GRA_CLR_RED PARENT oGroup1 // Наименование класса и модели в SWOT @12,P2 DCSAY L("Препятствующие факторы и сила их влияния") SAYSIZE W/2 FONT "12.Helv Bold" COLOR GRA_CLR_BLUE PARENT oGroup1 // Наименование класса и модели в SWOT SELECT Classes DBGOTOP() PUBLIC mFltrLeftFlag448 := .F. PUBLIC mFltrRightFlag448 := .F. FiltrLeft448(.F.) FiltrRight448(.F.) InfSWOTCls(6) H = 1.4 @ 29.3, 1 DCTOOLBAR oToolBar SIZE W/2, H PARENT oGroup1 DCADDBUTTON CAPTION L("ВКЛЮЧИТЬ фильтр по фактору") ; SIZE LEN(L("ВКЛЮЧИТЬ фильтр по фактору"))+4 ; ACTION {||FiltrLeft448(.T.), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION L("ВЫКЛЮЧИТЬ фильтр по фактору") ; SIZE LEN(L("ВЫКЛЮЧИТЬ фильтр по фактору"))+5 ; ACTION {||FiltrLeft448(.F.), DC_GetRefresh(GetList)}; PARENT oToolBar @ 29.3, W/2+D DCTOOLBAR oToolBar SIZE W/2, H PARENT oGroup1 DCADDBUTTON CAPTION L("ВКЛЮЧИТЬ фильтр по фактору") ; SIZE LEN(L("ВКЛЮЧИТЬ фильтр по фактору"))+5 ; ACTION {||FiltrRight448(.T.), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION L("ВЫКЛЮЧИТЬ фильтр по фактору") ; SIZE LEN(L("ВЫКЛЮЧИТЬ фильтр по фактору"))+5.8 ; ACTION {||FiltrRight448(.F.), DC_GetRefresh(GetList)}; PARENT oToolBar @ 31.0, 1 DCTOOLBAR oToolBar SIZE 20, H PARENT oGroup1 DCADDBUTTON CAPTION L('Помощь') ; SIZE LEN(L("Помощь"))+2 ; ACTION {||Help448(), DC_GetRefresh(GetList)} ; PARENT oToolBar @ 31.0, 13 DCTOOLBAR oToolBar SIZE W/2, H PARENT oGroup1 DCADDBUTTON CAPTION Ar_Model[1] ; SIZE LEN(Ar_Model[1])+2 ; ACTION {||InfSWOTCls(1), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION Ar_Model[2] ; SIZE LEN(Ar_Model[2])+1 ; ACTION {||InfSWOTCls(2), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION Ar_Model[3] ; SIZE LEN(Ar_Model[3])+1 ; ACTION {||InfSWOTCls(3), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION Ar_Model[4] ; SIZE LEN(Ar_Model[4])+1 ; ACTION {||InfSWOTCls(4), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION Ar_Model[5] ; SIZE LEN(Ar_Model[5])+1 ; ACTION {||InfSWOTCls(5), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION Ar_Model[6] ; SIZE LEN(Ar_Model[6])+1 ; ACTION {||InfSWOTCls(6), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION Ar_Model[7] ; SIZE LEN(Ar_Model[7])+1 ; ACTION {||InfSWOTCls(7), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION Ar_Model[8] ; SIZE LEN(Ar_Model[8])+1 ; ACTION {||InfSWOTCls(8), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION Ar_Model[9] ; SIZE LEN(Ar_Model[9])+1 ; ACTION {||InfSWOTCls(9), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION Ar_Model[10] ; SIZE LEN(Ar_Model[10])+1 ; ACTION {||InfSWOTCls(10), DC_GetRefresh(GetList)}; PARENT oToolBar @ 31.0, W/2+D DCTOOLBAR oToolBar SIZE W/2, H PARENT oGroup1 DCADDBUTTON CAPTION L("SWOT-диаграмма") ; SIZE LEN(L("SWOT-диаграмма"))+7.8 ; ACTION {||GraSWOTCls(), DC_GetRefresh(GetList)}; PARENT oToolBar /* ----- Create browse Classes ----- */ @ 1, 1 DCSAY L("Выбор класса, соответствующего будущему состоянию объекта управления") SAYSIZE W FONT "12.Helv Bold" PARENT oGroup1 @ 2, 1 DCBROWSE oBrowse ALIAS 'Classes' SIZE W+0.5, 8 ; COLOR {||IIF(2*INT(Classes->Kod_cls/2)==Classes->Kod_cls,nil,{nil,GraMakeRGBColor({230,252,213})})} ; // Вывод строки цветом RGB PRESENTATION aPres PARENT oGroup1 DCBROWSECOL FIELD Classes->Kod_cls HEADER L("Код" ) PARENT oBrowse WIDTH 6 DCBROWSECOL FIELD Classes->Name_cls HEADER L("Наименование класса") PARENT oBrowse WIDTH 48.5 DCBROWSECOL FIELD Classes->Int_inf HEADER L("Редукция класса" ) PARENT oBrowse WIDTH 3 DCBROWSECOL FIELD Classes->Abs HEADER L("N объектов (абс.)" ) PARENT oBrowse WIDTH 3 DCBROWSECOL FIELD Classes->Perc_fiz HEADER L("N объектов (%)" ) PARENT oBrowse WIDTH 3 /* ----- Create browse InfPortClsPos ----- */ PRIVATE bColorBlockPos:={|| iif(InfPortClsPos->Znach>0,{GRA_CLR_RED,nil},iif(InfPortClsPos->Znach=0,{GRA_CLR_BLACK,nil},{GRA_CLR_BLUE,nil})) } // Клиффорд PRIVATE bColorBlockNeg:={|| iif(InfPortClsNeg->Znach>0,{GRA_CLR_RED,nil},iif(InfPortClsNeg->Znach=0,{GRA_CLR_BLACK,nil},{GRA_CLR_BLUE,nil})) } // Клиффорд @11, 1 DCSAY {|| MessIPC } OBJECT oSay1 SAYSIZE W FONT "12.Helv Bold" PARENT oGroup1 // Наименование класса и модели в SWOT @12, 1 DCSAY L("Способствующие факторы и сила их влияния") SAYSIZE W/2 FONT "12.Helv Bold" COLOR GRA_CLR_RED PARENT oGroup1 // Наименование класса и модели в SWOT @12,P2 DCSAY L("Препятствующие факторы и сила их влияния") SAYSIZE W/2 FONT "12.Helv Bold" COLOR GRA_CLR_BLUE PARENT oGroup1 // Наименование класса и модели в SWOT @13, 1 DCBROWSE oBrowIpc1 ALIAS 'InfPortClsPos' SIZE W/2-1.5, 16 ; HEADLINES 2 ; // Кол-во строк в заголовке (перенос строки - ";") PRESENTATION aPres PARENT oGroup1 DCSETPARENT oBrowIpc1 DCBROWSECOL FIELD InfPortClsPos->KOD_atr HEADER L('Код') WIDTH 6; COLOR {||IIF(AT('SPECTRINTERV:',InfPortClsPos->NAME_atr)=0,nil,{nil,GraMakeRGBColor({VAL(SUBSTR(InfPortClsPos->NAME_atr, AT('{', InfPortClsPos->NAME_atr)+1, AT('{', InfPortClsPos->NAME_atr)+ 3-AT('{', InfPortClsPos->NAME_atr)+1+1)),VAL(SUBSTR(InfPortClsPos->NAME_atr, AT('{', InfPortClsPos->NAME_atr)+5, AT('{', InfPortClsPos->NAME_atr)+ 7-AT('{', InfPortClsPos->NAME_atr)+5+1)),VAL(SUBSTR(InfPortClsPos->NAME_atr, AT('{', InfPortClsPos->NAME_atr)+9, AT('{', InfPortClsPos->NAME_atr)+11-AT('{', InfPortClsPos->NAME_atr)+9+1))})})} // Вывод поля цветом RGB DCBROWSECOL FIELD InfPortClsPos->NAME_atr HEADER L('Наименование фактора;и его интервального значения') WIDTH 26 DCBROWSECOL DATA {|x|x:=InfPortClsPos->Znach,IIF(Empty(x),'',Str(x,11,3))} HEADER L("Сила;влияния") COLOR bColorBlockPos /* ----- Create browse InfPortClsNeg ----- */ DCSETPARENT TO @13,P2 DCBROWSE oBrowIpc2 ALIAS 'InfPortClsNeg' SIZE W/2, 16 ; HEADLINES 2 ; // Кол-во строк в заголовке (перенос строки - ";") PRESENTATION aPres PARENT oGroup1 DCSETPARENT oBrowIpc2 DCBROWSECOL FIELD InfPortClsNeg->KOD_atr HEADER L('Код') WIDTH 6; COLOR {||IIF(AT('SPECTRINTERV:',InfPortClsNeg->NAME_atr)=0,nil,{nil,GraMakeRGBColor({VAL(SUBSTR(InfPortClsNeg->NAME_atr, AT('{', InfPortClsNeg->NAME_atr)+1, AT('{', InfPortClsNeg->NAME_atr)+ 3-AT('{', InfPortClsNeg->NAME_atr)+1+1)),VAL(SUBSTR(InfPortClsNeg->NAME_atr, AT('{', InfPortClsNeg->NAME_atr)+5, AT('{', InfPortClsNeg->NAME_atr)+ 7-AT('{', InfPortClsNeg->NAME_atr)+5+1)),VAL(SUBSTR(InfPortClsNeg->NAME_atr, AT('{', InfPortClsNeg->NAME_atr)+9, AT('{', InfPortClsNeg->NAME_atr)+11-AT('{', InfPortClsNeg->NAME_atr)+9+1))})})} // Вывод поля цветом RGB DCBROWSECOL FIELD InfPortClsNeg->NAME_atr HEADER L('Наименование фактора;и его интервального значения') WIDTH 26 DCBROWSECOL DATA {|x|x:=InfPortClsNeg->Znach,IIF(Empty(x),'',Str(x,13,3))} HEADER L("Сила;влияния") COLOR bColorBlockNeg DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TITLE L('4.4.8. Количественный автоматизированный SWOT-анализ классов средствами АСК-анализа в системе "Эйдос"') ; // Надпись на окне графика FIT; MODAL; CLEAREVENTS *** Закрыть все текстовые БД ****** FOR z=1 TO LEN(Ar_Model) FClose( nHandle[z] ) // Закрытие текстовой базы данных ###################################### NEXT ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) ReTURN nil ********************************************************************************************************** FUNCTION FiltrLeft448(Flag448) SELECT InfPortClsPos PUBLIC mKodOpScLeft448 := Kod_OpSc, mFltrLeftFlag448 := Flag448 PUBLIC mKodOpScRight448 := Kod_OpSc, mFltrRightFlag448 := Flag448 IF Flag448 SET FILTER TO mKodOpScLeft448 = Kod_OpSc .AND. Znach > 0 ELSE SET FILTER TO ENDIF DBGOTOP();DBGOBOTTOM();DBGOTOP() SELECT InfPortClsNeg IF Flag448 SET FILTER TO mKodOpScRight448 = Kod_OpSc .AND. Znach < 0 ELSE SET FILTER TO ENDIF DBGOTOP();DBGOBOTTOM();DBGOTOP() SELECT InfPortClsPos ReTURN nil ******************************* FUNCTION FiltrRight448(Flag448) SELECT InfPortClsNeg PUBLIC mKodOpScRight448 := Kod_OpSc, mFltrRightFlag448 := Flag448 PUBLIC mKodOpScLeft448 := Kod_OpSc, mFltrLeftFlag448 := Flag448 IF Flag448 SET FILTER TO mKodOpScRight448 = Kod_OpSc .AND. Znach < 0 ELSE SET FILTER TO ENDIF DBGOTOP();DBGOBOTTOM();DBGOTOP() SELECT InfPortClsPos IF Flag448 SET FILTER TO mKodOpScLeft448 = Kod_OpSc .AND. Znach > 0 ELSE SET FILTER TO ENDIF DBGOTOP();DBGOBOTTOM();DBGOTOP() SELECT InfPortClsNeg ReTURN nil ****************************** FUNCTION FiltrLeft449(Flag449) SELECT InfPortAtrPos PUBLIC mKodClScLeft449 := Kod_ClSc, mFltrLeftFlag449 := Flag449 PUBLIC mKodClScRight449 := Kod_ClSc, mFltrRightFlag449 := Flag449 IF Flag449 SET FILTER TO mKodClScLeft449 = Kod_ClSc .AND. Znach > 0 ELSE SET FILTER TO ENDIF DBGOTOP();DBGOBOTTOM();DBGOTOP() SELECT InfPortAtrNeg IF Flag449 SET FILTER TO mKodClScRight449 = Kod_ClSc .AND. Znach < 0 ELSE SET FILTER TO ENDIF DBGOTOP();DBGOBOTTOM();DBGOTOP() SELECT InfPortAtrPos ReTURN nil ******************************* FUNCTION FiltrRight449(Flag449) SELECT InfPortAtrNeg PUBLIC mKodClScRight449 := Kod_ClSc, mFltrRightFlag449 := Flag449 PUBLIC mKodClScLeft449 := Kod_ClSc, mFltrLeftFlag449 := Flag449 IF Flag449 SET FILTER TO mKodClScRight449 = Kod_ClSc .AND. Znach < 0 ELSE SET FILTER TO ENDIF DBGOTOP();DBGOBOTTOM();DBGOTOP() SELECT InfPortAtrPos IF Flag449 SET FILTER TO mKodClScLeft449 = Kod_ClSc .AND. Znach > 0 ELSE SET FILTER TO ENDIF DBGOTOP();DBGOBOTTOM();DBGOTOP() SELECT InfPortAtrNeg ReTURN nil ************************************************************************************************** FUNCTION Help448() aHelp := {} AADD(aHelp, L('АСК-анализ обеспечивает построение SWOT-матрицы (модели) с указанием силы влияния ')) AADD(aHelp, L('способствующих и препятствующих факторов непосредственно на основе эмпирических ')) AADD(aHelp, L('данных и поэтому может рассматриваться как инструмент количественного SWOT-анализа.')) AADD(aHelp, L('Классы при этом интерпретируются как целевые и нежелательные состояния фирмы, ')) AADD(aHelp, L('факторы делятся на внутренние, технологические, описывающие саму фирму, и внешние, ')) AADD(aHelp, L('характеризующие окружающую среду, а количество информации, содержащееся в значении ')) AADD(aHelp, L('фактора, рассматривается как сила и направление его влияния на переход фирмы в те ')) AADD(aHelp, L('или иные будущие состояния. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Таким образом, данный режим в наглядной и понятной форме отображает систему ')) AADD(aHelp, L('детерминации будущих состояний объекта управления значениями факторов. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Луценко Е.В. Количественный автоматизированный SWOT- и PEST-анализ средствами АСК- ')) AADD(aHelp, L('анализа и интеллектуальной системы <Эйдос-Х++> / Е.В. Луценко // Политематический ')) AADD(aHelp, L('сетевой электронный научный журнал Кубанского государственного аграрного ')) AADD(aHelp, L('университета (Научный журнал КубГАУ) [Электронный ресурс]. - Краснодар: КубГАУ, ')) AADD(aHelp, L('2014. - №07(101). С. 1367 - 1409. - IDA [article ID]: 1011407090. - Режим доступа: ')) AADD(aHelp, L('http://ej.kubagro.ru/2014/07/pdf/90.pdf, 2,688 у.п.л. ')) mHelpMax = -999;FOR h=1 TO LEN(aHelp);mHelpMax = MAX(mHelpMax, LEN(ALLTRIM(aHelp[h])));NEXT s=1;d=0.9;@0,0 DCGROUP oGroup1 CAPTION L(' ') SIZE mHelpMax-10, LEN(aHelp)*d+1.5 FOR h=1 TO LEN(aHelp);@s,2 DCSAY aHelp[h] SIZE 0 PARENT ogroup1;s=s+d;NEXT DCREAD GUI TO lExit FIT TITLE L('Помощь по режиму: 4.4.8. (C) Система "ЭЙДОС-X++"') RETURN NIL ************************************************************************************************** ****************************************************************************************************************** ******** Генерация позитивного и негативного информационных портретов текущего класса в модели Ar_Model[M_CurrInf] ******** и заполнение SWOT-матрицы класса для графической визуализации ****************************************************************************************************************** FUNCTION InfSWOTCls(M_CurrInf) LOCAL Getlist := {}, oProgress, oDialog DC_ASave(M_CurrInf, "_NumMod.arx") * mNumMod = DC_ARestore("_NumMod.arx") SELECT Attributes;N_Gos = RECCOUNT() SELECT Classes M_Recno = RECNO() M_KodCls = Kod_cls M_NameCls = Name_cls PUBLIC MessIPC := L('SWOT-анализ класса: ')+ALLTRIM(STR(M_KodCls, 15))+' "'+ALLTRIM(M_NameCls)+L('" в модели: ')+ALLTRIM(STR(M_CurrInf, 15))+' "'+UPPER(Ar_Model[M_CurrInf]+'"') * LB_Warning(MessIPC) DC_GetRefresh(oSay1) // Наименование SWOT-матрицы nMax = N_Gos * 4 @ 4,5 DCPROGRESS oProgress SIZE 70,1.1 MAXCOUNT nMax COLOR GRA_CLR_RED PERCENT EVERY 100 DCREAD GUI TITLE L('4.4.8. Формирование SWOT-матрицы класса') PARENT @oDialog FIT EXIT oDialog:show() nTime = 0 // Заполнить БД InfPortCls записями с кодами и наименованиями признаков и их значимостью SELECT InfPortCls;ZAP DC_GetProgress(oProgress,0,nMax) FOR i=1 TO N_Gos M_KodAtr = VAL(LC_FieldGet( Ar_Model[M_CurrInf]+".txt", nHandle[M_CurrInf], i, 1 )) M_NameAtr = LC_FieldGet( Ar_Model[M_CurrInf]+".txt", nHandle[M_CurrInf], i, 2 ) M_Znach = VAL(LC_FieldGet( Ar_Model[M_CurrInf]+".txt", nHandle[M_CurrInf], i, 2+M_KodCls )) // Инф.портрет класса M_KodCls IF M_Znach <> 0 SELECT Attributes DBGOTO(M_KodAtr) M_KodOpSc = Kod_OpSc SELECT InfPortCls APPEND BLANK REPLACE Kod_atr WITH M_KodAtr REPLACE Name_atr WITH M_NameAtr REPLACE Kod_OpSc WITH M_KodOpSc REPLACE Znach WITH M_Znach ENDIF DC_GetProgress(oProgress, ++nTime, nMax) NEXT ***** Сортировка InfPortCls по полю Znach по убыванию CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE InfPortCls EXCLUSIVE NEW COPY STRUCTURE TO Temp.dbf CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE InfPortCls EXCLUSIVE NEW INDEX ON STR(999999.9999999-Znach,15,7) TO InfPortCls CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Temp EXCLUSIVE NEW USE InfPortCls INDEX InfPortCls EXCLUSIVE NEW SELECT InfPortCls SET ORDER TO 1 DBGOTOP() DO WHILE .NOT. EOF() a := {} FOR j=1 TO FCOUNT() AADD(a, FIELDGET(j)) NEXT SELECT Temp APPEND BLANK FOR j=1 TO LEN(a) FIELDPUT(j, a[j]) NEXT DC_GetProgress(oProgress, ++nTime, nMax) SELECT InfPortCls DBSKIP(1) ENDDO CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций ERASE( "InfPortCls.dbf" ) RenameFile( "Temp.dbf", "InfPortCls.dbf" ) // Сформировать БД SWOT-матрицы aStr := { { "Num_pp" , "N", 15, 0 }, ; { "Kod_atr1" , "N", 15, 0 }, ; { "Kod_OpSc1" , "N", 15, 0 }, ; { "Name_OpSc1" , "C", mLenMaxOS, 0 }, ; { "Name_GrOS1" , "C", mLenMaxGOS, 0 }, ; { "Name_Atr1" , "C", mLenMaxAtr, 0 }, ; { "Znach1" , "N", 15, 7 }, ; { "Znach1Perc" , "N", 15, 7 }, ; { "Kod_atr2" , "N", 15, 0 }, ; { "Kod_OpSc2" , "N", 15, 0 }, ; { "Name_OpSc2" , "C", mLenMaxOS, 0 }, ; { "Name_GrOS2" , "C", mLenMaxGOS, 0 }, ; { "Name_Atr2" , "C", mLenMaxAtr, 0 }, ; { "Znach2" , "N", 15, 7 }, ; { "Znach2Perc" , "N", 15, 7 } } mSWOTName = "SWOTCls"+STRTRAN(STR(M_KodCls,4)," ","0")+Ar_Model[M_CurrInf] DbCreate( mSWOTName, aStr ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mSWOTName) EXCLUSIVE NEW USE Classes EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW USE Gr_OpSc EXCLUSIVE NEW USE Opis_Sc EXCLUSIVE NEW USE InfPortCls EXCLUSIVE NEW USE InfPortClsPos EXCLUSIVE NEW;ZAP USE InfPortClsNeg EXCLUSIVE NEW;ZAP ****** Для InfPortClsPos SELECT InfPortCls SET FILTER TO Znach > 0 DBGOTOP() DO WHILE .NOT. EOF() a := {} FOR j=1 TO FCOUNT() AADD(a, FIELDGET(j)) NEXT SELECT InfPortClsPos APPEND BLANK FOR j=1 TO LEN(a) FIELDPUT(j, a[j]) NEXT DC_GetProgress(oProgress, ++nTime, nMax) SELECT InfPortCls DBSKIP(1) ENDDO ****** Для InfPortClsNeg SELECT InfPortCls SET FILTER TO Znach < 0 DBGOBOTTOM() DO WHILE .NOT. BOF() a := {} FOR j=1 TO FCOUNT() AADD(a, FIELDGET(j)) NEXT SELECT InfPortClsNeg APPEND BLANK FOR j=1 TO LEN(a) FIELDPUT(j, a[j]) NEXT DC_GetProgress(oProgress, ++nTime, nMax) SELECT InfPortCls DBSKIP(-1) ENDDO ****** ЗАПОЛНИТЬ ПОЛЯ БД (mSWOTName) SWOT-матрицы ДЛЯ ВИЗУАЛИЗАЦИИ SELECT InfPortClsPos PUBLIC N_GosPos := RECCOUNT() SELECT InfPortClsNeg PUBLIC N_GosNeg := RECCOUNT() N_GosMax = MAX(N_GosPos, N_GosNeg) SELECT (mSWOTName) FOR j=1 TO N_GosMax APPEND BLANK REPLACE Num_pp WITH j NEXT aStr := { { "Num_pp" , "N", 15, 0 }, ; { "Kod_atr1" , "N", 15, 0 }, ; { "Kod_OpSc1" , "N", 15, 0 }, ; { "Name_OpSc1" , "C", mLenMaxOS, 0 }, ; { "Name_GrOS1" , "C", mLenMaxGOS, 0 }, ; { "Name_Atr1" , "C", mLenMaxAtr, 0 }, ; { "Znach1" , "N", 15, 7 }, ; { "Znach1Perc" , "N", 15, 7 }, ; { "Kod_atr2" , "N", 15, 0 }, ; { "Kod_OpSc2" , "N", 15, 0 }, ; { "Name_OpSc2" , "C", mLenMaxOS, 0 }, ; { "Name_GrOS2" , "C", mLenMaxGOS, 0 }, ; { "Name_Atr2" , "C", mLenMaxAtr, 0 }, ; { "Znach2" , "N", 15, 7 }, ; { "Znach2Perc" , "N", 15, 7 } } SELECT InfPortClsPos mNumRec = 0 mZnach1Sum = 0 DBGOTOP() DO WHILE .NOT. EOF() mKodAtr1 = Kod_Atr mNameAtr1 = Name_Atr mZnach1 = Znach mKodOpSc1 = Kod_OpSc SELECT Gr_OpSc DBGOTO(mKodAtr1) mNameGrOS1 = Name_GrOS SELECT Opis_Sc DBGOTO(mKodOpSc1) mNameOpSc1 = Name_OpSc SELECT (mSWOTName) DBGOTO(++mNumRec) REPLACE Num_pp WITH mNumRec REPLACE Kod_atr1 WITH mKodAtr1 REPLACE Kod_OpSc1 WITH mKodOpSc1 REPLACE Name_OpSc1 WITH mNameOpSc1 REPLACE Name_GrOS1 WITH mNameGrOS1 REPLACE Name_Atr1 WITH mNameAtr1 REPLACE Znach1 WITH mZnach1 mZnach1Sum = mZnach1Sum + mZnach1 DC_GetProgress(oProgress, ++nTime, nMax) SELECT InfPortClsPos DBSKIP(1) ENDDO SELECT InfPortClsNeg mNumRec = 0 mZnach2Sum = 0 DBGOTOP() DO WHILE .NOT. EOF() mKodAtr2 = Kod_Atr mNameAtr2 = Name_Atr mZnach2 = Znach mKodOpSc2 = Kod_OpSc SELECT Gr_OpSc DBGOTO(mKodAtr2) mNameGrOS2 = Name_GrOS SELECT Opis_Sc DBGOTO(mKodOpSc2) mNameOpSc2 = Name_OpSc SELECT (mSWOTName) DBGOTO(++mNumRec) REPLACE Num_pp WITH mNumRec REPLACE Kod_atr2 WITH mKodAtr2 REPLACE Kod_OpSc2 WITH mKodOpSc2 REPLACE Name_OpSc2 WITH mNameOpSc2 REPLACE Name_GrOS2 WITH mNameGrOS2 REPLACE Name_Atr2 WITH mNameAtr2 REPLACE Znach2 WITH mZnach2 mZnach2Sum = mZnach2Sum + mZnach2 DC_GetProgress(oProgress, ++nTime, nMax) SELECT InfPortClsNeg DBSKIP(1) ENDDO SELECT (mSWOTName) DBGOTOP() DO WHILE .NOT. EOF() REPLACE Znach1Perc WITH Znach1 / mZnach1Sum * 100 REPLACE Znach2Perc WITH Znach2 / mZnach2Sum * 100 DBSKIP(1) ENDDO DC_GetProgress(oProgress,nMax,nMax) oDialog:Destroy() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW USE Gr_OpSc EXCLUSIVE NEW USE Opis_Sc EXCLUSIVE NEW USE InfPortCls EXCLUSIVE NEW USE InfPortClsPos EXCLUSIVE NEW USE InfPortClsNeg EXCLUSIVE NEW SELECT InfPortClsPos DBGOTOP() SELECT InfPortClsNeg DBGOTOP() SELECT Classes * SET FILTER TO Abs+Int_inf > 0 DBGOTO(M_Recno) ReTURN NIL ****************************** *********************************************************************************************************************** ****** 4.4.9. Количественный SWOT-анализ факторов средствами АСК-анализа. (аналога в DOS-версии системы Эйдос нет) ****** АСК-анализ обеспечивает построение количественной SWOT-матрицы (модели) для заданного значения фактора ****** с указанием степени, в которой он способствует или препятствует переходу объекта управления в различные будущие ****** состояния, соответствующие классам. Эта модель строится непосредственно на основе эмпирических данных и поэтому ****** АСК-анализ может рассматриваться как инструмент количественного SWOT-анализа. Факторы делятся на внутренние, ****** технологические, описывающие саму фирму, и внешние, характеризующие окружающую среду *********************************************************************************************************************** FUNCTION F4_4_9() LOCAL GetList := {}, aPres, oBrowse, oToolBar, aColors, bColor, GetOptions Running(.T.) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF ApplChange("4.4.9()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF IF FILEDATE("SWOTDiagrAtr",16) = CTOD("//") DIRMAKE("SWOTDiagrAtr") aMess := {} AADD(aMess, L('В папке текущего приложения: "'+UPPER(ALLTRIM(M_PathAppl))+'"')) AADD(aMess, L('не было директории "SWOTDiagrAtr" для SWOT-диаграмм признаков и она была создана!')) AADD(aMess, L('В эту папку записываются исходные изображения высокого качества (без масштабирования)')) LB_Warning(aMess, L('4.4.8. Количественный SWOT-анализ классов средствами АСК-анализа' )) ENDIF ***** Проверка на наличие основных БД всех моделей и определение времени их создания. ***** Если оно не изменилось со времени предыдущего применения режима 4_2_1, то копировать txt=>dbf не надо Ar_Model := {"Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } Flag = .F. FOR z=1 TO LEN(Ar_Model) IF .NOT. FILE(Ar_Model[z]+'.txt') Mess = L('Модель: "#" отсутствует. Необходимо провести расчет моделей в 3-й подсистеме !!!') Mess = STRTRAN(Mess, '#', Ar_Model[z]) LB_Warning( Mess, L('4.2.1. Информационные портреты классов' )) Flag = .T. EXIT ENDIF NEXT IF Flag // Если какой-нибудь БД нет, то режим не запускать ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF mLenNameMax = CreateStructAll() // Создание файлов структур баз данных всех моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() // Количество классов (градаций классификационных шкал) USE Gr_OpSc EXCLUSIVE NEW;N_Gos = RECCOUNT() // Количество признаков (градаций описательных шкал) USE Opis_Sc EXCLUSIVE NEW * ########################################################################### // Открытие текстовых баз данных ******************************************** *DC_ASave(aInfStruct, "_InfStruct.arx") // Когда БД создается - записывать структуру, когда открывается - считывать aInfStruct := DC_ARestore("_InfStruct.arx") *DC_ASave(aStrEmpty, "_aStrEmpty.arx") // Записывать только после расчета Abs.txt, а при расчете остальных БД только считывать *DC_ASave(aColEmpty, "_aColEmpty.arx") aStrEmpty = DC_ARestore("_aStrEmpty.arx") aColEmpty = DC_ARestore("_aColEmpty.arx") ************************************************* ***** Формирование пустой записи N_Col = N_Cls+6 // Число полей CrLf = CHR(13)+CHR(10) // Конец строки (записи) Lc_buf = "" FOR j=1 TO N_Col * S = IF(j=2*INT(j/2),"#","X") // Для отладки S = " " // Для работы Lc_buf = Lc_buf + REPLICATE(S, aInfStruct[j,3]) NEXT Lc_buf = Lc_buf + CrLf PUBLIC Len_LcBuf := LEN(Lc_buf) ****** Открываем стат.базы и базы знаний (7 по частным критериям знаний) Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } PUBLIC nHandle[LEN(Ar_Model)] FOR z=1 TO LEN(Ar_Model) nHandle[z] := FOpen( Ar_Model[z]+".txt", FO_READWRITE ) // Открыть все текстовые базы данных ######################################## NEXT **** Рассчет массива начальных позиций полей в строке PUBLIC aPos[N_Col] aPos[1] = 1 FOR j=2 TO N_Col aPos[j] = aPos[j-1] + aInfStruct[j-1,3] NEXT * ########################################################################### ************************************************************* // Определить максимальную длину наименования: ОПИСАТЕЛЬНАЯ ШКАЛА-градация CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Gr_ClSc EXCLUSIVE NEW USE Class_Sc EXCLUSIVE NEW USE Classes EXCLUSIVE NEW SELECT Gr_ClSc PUBLIC mLenMaxGCS := -9999999 DBGOTOP() DO WHILE .NOT. EOF() mLenMaxGCS = MAX(mLenMaxGCS, LEN(Name_GrCS)) DBSKIP(1) ENDDO SELECT Class_Sc PUBLIC mLenMaxCS := -9999999 DBGOTOP() DO WHILE .NOT. EOF() mLenMaxCS = MAX(mLenMaxCS, LEN(Name_ClSc)) DBSKIP(1) ENDDO PUBLIC mLenMaxCls := -9999999 CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW DBGOTOP() DO WHILE .NOT. EOF() mLenMaxCls = MAX(mLenMaxCls, LEN(Name_cls)) DBSKIP(1) ENDDO // Сформировать пустую БД InfPortAtr, как часть БД Attributes aStr := { { "Kod_cls" , "N", 15, 0 }, ; { "Name_cls" , "C", mLenMaxCls, 0 }, ; { "Znach" , "N", 19, 7 }, ; { "Kod_ClSc" , "N", 15, 0 }, ; { "Fltr_Wind", "C", 1, 0 } } // Для фильтра "Вписать в окно" DbCreate( "InfPortAtr", aStr ) DbCreate( "InfPortAtrPos", aStr ) DbCreate( "InfPortAtrNeg", aStr ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW USE Gr_ClSc EXCLUSIVE NEW USE Class_Sc EXCLUSIVE NEW USE InfPortAtr EXCLUSIVE NEW USE InfPortAtrPos EXCLUSIVE NEW USE InfPortAtrNeg EXCLUSIVE NEW /* ----- Create ToolBar ----- */ W = 132 // Ширина окна D = 1.5 // Отступ на линейки прокрутки и т.д. P1 = W / 2 // Конечная позиция левого окна P2 = P1 + D // Начальная позиция правого окна ****** Сделать и вывести инф.портрет 1-го значения фактора @0,0 DCGROUP oGroup1 SIZE W+2*D, 33.0 S = 10 @11, 1 DCSAY {|| MessIPC } OBJECT oSay1 SAYSIZE W FONT "12.Helv Bold" PARENT oGroup1 // Наименование значения фактора и модели в SWOT @12, 1+S DCSAY L("СПОСОБСТВУЕТ:") SAYSIZE 30 FONT "12.Helv Bold" COLOR GRA_CLR_RED PARENT oGroup1 // Наименование значения фактора и модели в SWOT @12,P2+S DCSAY L("ПРЕПЯТСТВУЕТ:") SAYSIZE 30 FONT "12.Helv Bold" COLOR GRA_CLR_BLUE PARENT oGroup1 // Наименование значения фактора и модели в SWOT SELECT Attributes DBGOTOP() FiltrLeft449(.F.) FiltrRight449(.F.) InfSWOTAtr(6) H = 1.4 @ 29.3, 1 DCTOOLBAR oToolBar SIZE W/2, H PARENT oGroup1 DCADDBUTTON CAPTION L("ВКЛЮЧИТЬ фильтр по кл.шкале") ; SIZE LEN(L("ВКЛЮЧИТЬ фильтр по фактору"))+4 ; ACTION {||FiltrLeft449(.T.), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION L("ВЫКЛЮЧИТЬ фильтр по кл.шкале") ; SIZE LEN(L("ВЫКЛЮЧИТЬ фильтр по фактору"))+5 ; ACTION {||FiltrLeft449(.F.), DC_GetRefresh(GetList)}; PARENT oToolBar @ 29.3, W/2+D DCTOOLBAR oToolBar SIZE W/2, H PARENT oGroup1 DCADDBUTTON CAPTION L("ВКЛЮЧИТЬ фильтр по кл.шкале") ; SIZE LEN(L("ВКЛЮЧИТЬ фильтр по фактору"))+5 ; ACTION {||FiltrRight449(.T.), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION L("ВЫКЛЮЧИТЬ фильтр по кл.шкале") ; SIZE LEN(L("ВЫКЛЮЧИТЬ фильтр по фактору"))+5.8 ; ACTION {||FiltrRight449(.F.), DC_GetRefresh(GetList)}; PARENT oToolBar @ 31.0, 1 DCTOOLBAR oToolBar SIZE 20, H PARENT oGroup1 DCADDBUTTON CAPTION L('Помощь' ) ; SIZE LEN(L("Помощь"))+2 ; ACTION {||Help449(), DC_GetRefresh(GetList)} ; PARENT oToolBar @ 31.0, 13 DCTOOLBAR oToolBar SIZE W/2, H PARENT oGroup1 DCADDBUTTON CAPTION Ar_Model[1] ; SIZE LEN(Ar_Model[1])+2 ; ACTION {||InfSWOTAtr(1), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION Ar_Model[2] ; SIZE LEN(Ar_Model[2])+1 ; ACTION {||InfSWOTAtr(2), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION Ar_Model[3] ; SIZE LEN(Ar_Model[3])+1 ; ACTION {||InfSWOTAtr(3), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION Ar_Model[4] ; SIZE LEN(Ar_Model[4])+1 ; ACTION {||InfSWOTAtr(4), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION Ar_Model[5] ; SIZE LEN(Ar_Model[5])+1 ; ACTION {||InfSWOTAtr(5), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION Ar_Model[6] ; SIZE LEN(Ar_Model[6])+1 ; ACTION {||InfSWOTAtr(6), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION Ar_Model[7] ; SIZE LEN(Ar_Model[7])+1 ; ACTION {||InfSWOTAtr(7), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION Ar_Model[8] ; SIZE LEN(Ar_Model[8])+1 ; ACTION {||InfSWOTAtr(8), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION Ar_Model[9] ; SIZE LEN(Ar_Model[9])+1 ; ACTION {||InfSWOTAtr(9), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION Ar_Model[10] ; SIZE LEN(Ar_Model[10])+1 ; ACTION {||InfSWOTAtr(10), DC_GetRefresh(GetList)}; PARENT oToolBar @ 31.0, W/2+D DCTOOLBAR oToolBar SIZE W/2, H PARENT oGroup1 DCADDBUTTON CAPTION L("SWOT-диаграмма") ; SIZE LEN(L("SWOT-диаграмма"))+7.8 ; ACTION {||GraSWOTAtr(), DC_GetRefresh(GetList)}; PARENT oToolBar /* ----- Create browse Attributes ----- */ @ 1, 1 DCSAY L("Выбор значения фактора, оказывающего влияние на переход объекта управления в будущие состояния") SAYSIZE W FONT "12.Helv Bold" PARENT oGroup1 @ 2, 1 DCBROWSE oBrowse ALIAS 'Attributes' SIZE W+0.5, 8 ; PRESENTATION aPres PARENT oGroup1; COLOR {||IIF(2*INT(Attributes->Kod_atr/2)==Attributes->Kod_atr,nil,{nil,GraMakeRGBColor({230,252,213})})} // Вывод строки цветом RGB DCBROWSECOL FIELD Attributes->Kod_atr HEADER L("Код") PARENT oBrowse WIDTH 5; COLOR {||IIF(AT('SPECTRINTERV:',Attributes->Name_atr)=0,nil,{nil,GraMakeRGBColor({VAL(SUBSTR(Attributes->Name_atr, AT('{', Attributes->Name_atr)+1, AT('{', Attributes->Name_atr)+ 3-AT('{', Attributes->Name_atr)+1+1)),VAL(SUBSTR(Attributes->Name_atr, AT('{', Attributes->Name_atr)+5, AT('{', Attributes->Name_atr)+ 7-AT('{', Attributes->Name_atr)+5+1)),VAL(SUBSTR(Attributes->Name_atr, AT('{', Attributes->Name_atr)+9, AT('{', Attributes->Name_atr)+11-AT('{', Attributes->Name_atr)+9+1))})})} // Вывод поля цветом RGB DCBROWSECOL FIELD Attributes->Name_atr HEADER L("Наименование значения фактора") PARENT oBrowse WIDTH 76.5 DCBROWSECOL FIELD Attributes->Int_inf HEADER L("Редукция значения фактора" ) PARENT oBrowse WIDTH 3 DCBROWSECOL FIELD Attributes->Abs HEADER L("N объектов (абс.)" ) PARENT oBrowse WIDTH 3 DCBROWSECOL FIELD Attributes->Perc_fiz HEADER L("N объектов (%)" ) PARENT oBrowse WIDTH 3 /* ----- Create browse InfPortAtrPos ----- */ PRIVATE bColorBlockPos:={|| iif(InfPortAtrPos->Znach>0,{GRA_CLR_RED,nil},iif(InfPortAtrPos->Znach=0,{GRA_CLR_BLACK,nil},{GRA_CLR_BLUE,nil})) } // Клиффорд PRIVATE bColorBlockNeg:={|| iif(InfPortAtrNeg->Znach>0,{GRA_CLR_RED,nil},iif(InfPortAtrNeg->Znach=0,{GRA_CLR_BLACK,nil},{GRA_CLR_BLUE,nil})) } // Клиффорд @11, 1 DCSAY {|| MessIPC } OBJECT oSay1 SAYSIZE W FONT "12.Helv Bold" PARENT oGroup1 // Наименование значения фактора и модели в SWOT @12, 1+S DCSAY L("СПОСОБСТВУЕТ:") SAYSIZE 30 FONT "12.Helv Bold" COLOR GRA_CLR_RED PARENT oGroup1 // Наименование значения фактора и модели в SWOT @12,P2+S DCSAY L("ПРЕПЯТСТВУЕТ:") SAYSIZE 30 FONT "12.Helv Bold" COLOR GRA_CLR_BLUE PARENT oGroup1 // Наименование значения фактора и модели в SWOT @13, 1 DCBROWSE oBrowIpc1 ALIAS 'InfPortAtrPos' SIZE W/2-1.5, 16 ; HEADLINES 2 ; // Кол-во строк в заголовке (перенос строки - ";") PRESENTATION aPres PARENT oGroup1 DCSETPARENT oBrowIpc1 DCBROWSECOL FIELD InfPortAtrPos->Kod_cls HEADER L('Код') WIDTH 5 DCBROWSECOL FIELD InfPortAtrPos->Name_cls HEADER L('Состояния объекта управления, переходу в которые;данное значение фактора СПОСОБСТВУЕТ') WIDTH 27 DCBROWSECOL DATA {|x|x:=InfPortAtrPos->Znach,IIF(Empty(x),'',Str(x,10,3))} HEADER L("Сила;влияния") COLOR bColorBlockPos /* ----- Create browse InfPortAtrNeg ----- */ DCSETPARENT TO @13,P2 DCBROWSE oBrowIpc2 ALIAS 'InfPortAtrNeg' SIZE W/2, 16 ; HEADLINES 2 ; // Кол-во строк в заголовке (перенос строки - ";") PRESENTATION aPres PARENT oGroup1 DCSETPARENT oBrowIpc2 DCBROWSECOL FIELD InfPortAtrNeg->Kod_cls HEADER L('Код') WIDTH 5 DCBROWSECOL FIELD InfPortAtrNeg->Name_cls HEADER L('Состояния объекта управления, переходу в которые;данное значение фактора ПРЕПЯТСТВУЕТ') WIDTH 28 DCBROWSECOL DATA {|x|x:=InfPortAtrNeg->Znach,IIF(Empty(x),'',Str(x,11,3))} HEADER L("Сила;влияния") COLOR bColorBlockNeg DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TITLE L('4.4.9 Количественный автоматизированный SWOT-анализ значений факторов средствами АСК-анализа в системе "Эйдос"') ; // Надпись на окне графика FIT; MODAL; CLEAREVENTS *** Закрыть все текстовые БД ****** FOR z=1 TO LEN(Ar_Model) FClose( nHandle[z] ) // Закрытие текстовой базы данных ###################################### NEXT ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) ReTURN nil ************************************************************************************************** FUNCTION Help449() aHelp := {} AADD(aHelp, L('АСК-анализ обеспечивает построение количественной SWOT-матрицы (модели) для заданного')) AADD(aHelp, L('значения фактора с указанием степени, в которой он способствует или препятствует ')) AADD(aHelp, L('переходу объекта управления в различные будущие состояния, соответствующие классам. ')) AADD(aHelp, L('Эта модель строится непосредственно на основе эмпирических данных и поэтому АСК- ')) AADD(aHelp, L('анализ может рассматриваться как инструмент количественного SWOT-анализа. Факторы ')) AADD(aHelp, L('делятся на внутренние, технологические, описывающие саму фирму, зависящие от нас, и ')) AADD(aHelp, L('внешние, от нас не зависящие и характеризующие окружающую среду. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Луценко Е.В. Количественный автоматизированный SWOT- и PEST-анализ средствами АСК- ')) AADD(aHelp, L('анализа и интеллектуальной системы <Эйдос-Х++> / Е.В. Луценко // Политематический ')) AADD(aHelp, L('сетевой электронный научный журнал Кубанского государственного аграрного университета')) AADD(aHelp, L('(Научный журнал КубГАУ) [Электронный ресурс]. - Краснодар: КубГАУ, 2014. - №07(101). ')) AADD(aHelp, L('С. 1367 - 1409. - IDA [article ID]: 1011407090. - Режим доступа: ')) AADD(aHelp, L('http://ej.kubagro.ru/2014/07/pdf/90.pdf, 2,688 у.п.л. ')) mHelpMax = -999;FOR h=1 TO LEN(aHelp);mHelpMax = MAX(mHelpMax, LEN(ALLTRIM(aHelp[h])));NEXT s=1;d=0.9;@0,0 DCGROUP oGroup1 CAPTION L(' ') SIZE mHelpMax-10, LEN(aHelp)*d+1.5 FOR h=1 TO LEN(aHelp);@s,2 DCSAY aHelp[h] SIZE 0 PARENT ogroup1;s=s+d;NEXT DCREAD GUI TO lExit FIT TITLE L('Помощь по режиму: 4.4.9. (C) Система "ЭЙДОС-X++"') RETURN NIL ************************************************************************************************** **************************************************************************************************************************** ******** Генерация позитивного и негативного информационных портретов текущего значения фактора в модели Ar_Model[M_CurrInf] ******** и заполнение SWOT-матрицы значения фактора для графической визуализации **************************************************************************************************************************** FUNCTION InfSWOTAtr(M_CurrInf) LOCAL Getlist := {}, oProgress, oDialog DC_ASave(M_CurrInf, "_NumMod.arx") * mNumMod = DC_ARestore("_NumMod.arx") SELECT Classes;N_Cls = RECCOUNT() SELECT Attributes M_Recno = RECNO() M_KodAtr = Kod_atr M_NameAtr = Name_atr PUBLIC MessIPC := L('SWOT-анализ значения фактора: ')+ALLTRIM(STR(M_KodAtr, 15))+' "'+ALLTRIM(M_NameAtr)+L('" в модели: ')+ALLTRIM(STR(M_CurrInf, 15))+' "'+UPPER(Ar_Model[M_CurrInf]+'"') * LB_Warning(MessIPC) DC_GetRefresh(oSay1) // Наименование SWOT-матрицы nMax = N_Gos * 4 @ 4,5 DCPROGRESS oProgress SIZE 70,1.1 MAXCOUNT nMax COLOR GRA_CLR_BLUE PERCENT EVERY 100 DCREAD GUI TITLE L('4.4.9. Формирование SWOT-матрицы значения фактора') PARENT @oDialog FIT EXIT oDialog:show() nTime = 0 // Заполнить БД InfPortAtr записями с кодами и наименованиями признаков и их значимостью SELECT InfPortAtr;ZAP DC_GetProgress(oProgress,0,nMax) FOR j=1 TO N_Cls M_Znach = VAL(LC_FieldGet( Ar_Model[M_CurrInf]+".txt", nHandle[M_CurrInf], M_KodAtr, 2+j )) // Инф.портрет признака M_KodAtr IF M_Znach <> 0 SELECT Classes DBGOTO(j) M_KodCls = Kod_cls M_NameCls = Name_cls M_KodClSc = Kod_ClSc SELECT InfPortAtr APPEND BLANK REPLACE Kod_cls WITH M_KodCls REPLACE Name_cls WITH M_NameCls REPLACE Kod_ClSc WITH M_KodClSc REPLACE Znach WITH M_Znach ENDIF DC_GetProgress(oProgress, ++nTime, nMax) NEXT ***** Сортировка InfPortAtr по полю Znach по убыванию CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE InfPortAtr EXCLUSIVE NEW COPY STRUCTURE TO Temp.dbf CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE InfPortAtr EXCLUSIVE NEW INDEX ON STR(999999.9999999-Znach,15,7) TO InfPortAtr CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Temp EXCLUSIVE NEW USE InfPortAtr INDEX InfPortAtr EXCLUSIVE NEW SELECT InfPortAtr SET ORDER TO 1 DBGOTOP() DO WHILE .NOT. EOF() a := {} FOR j=1 TO FCOUNT() AADD(a, FIELDGET(j)) NEXT SELECT Temp APPEND BLANK FOR j=1 TO LEN(a) FIELDPUT(j, a[j]) NEXT DC_GetProgress(oProgress, ++nTime, nMax) SELECT InfPortAtr DBSKIP(1) ENDDO CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций ERASE( "InfPortAtr.dbf" ) RenameFile( "Temp.dbf", "InfPortAtr.dbf" ) // Сформировать БД SWOT-матрицы aStr := { { "Num_pp" , "N", 15, 0 }, ; { "Kod_Cls1" , "N", 15, 0 }, ; { "Kod_ClSc1" , "N", 15, 0 }, ; { "Name_ClSc1" , "C", mLenMaxCS, 0 }, ; { "Name_GrCS1" , "C", mLenMaxGCS, 0 }, ; { "Name_Cls1" , "C", mLenMaxCls, 0 }, ; { "Znach1" , "N", 19, 7 }, ; { "Kod_Cls2" , "N", 15, 0 }, ; { "Kod_ClSc2" , "N", 15, 0 }, ; { "Name_ClSc2" , "C", mLenMaxCS, 0 }, ; { "Name_GrCS2" , "C", mLenMaxGCS, 0 }, ; { "Name_Cls2" , "C", mLenMaxCls, 0 }, ; { "Znach2" , "N", 19, 7 } } mSWOTName = "SWOTAtr"+STRTRAN(STR(M_KodAtr,4)," ","0")+Ar_Model[M_CurrInf] DbCreate( mSWOTName, aStr ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mSWOTName) EXCLUSIVE NEW USE Classes EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW USE Gr_ClSc EXCLUSIVE NEW USE Class_Sc EXCLUSIVE NEW USE InfPortAtr EXCLUSIVE NEW USE InfPortAtrPos EXCLUSIVE NEW;ZAP USE InfPortAtrNeg EXCLUSIVE NEW;ZAP ****** Для InfPortAtrPos SELECT InfPortAtr SET FILTER TO Znach > 0 DBGOTOP() DO WHILE .NOT. EOF() a := {} FOR j=1 TO FCOUNT() AADD(a, FIELDGET(j)) NEXT SELECT InfPortAtrPos APPEND BLANK FOR j=1 TO LEN(a) FIELDPUT(j, a[j]) NEXT DC_GetProgress(oProgress, ++nTime, nMax) SELECT InfPortAtr DBSKIP(1) ENDDO ****** Для InfPortAtrNeg SELECT InfPortAtr SET FILTER TO Znach < 0 DBGOBOTTOM() DO WHILE .NOT. BOF() a := {} FOR j=1 TO FCOUNT() AADD(a, FIELDGET(j)) NEXT SELECT InfPortAtrNeg APPEND BLANK FOR j=1 TO LEN(a) FIELDPUT(j, a[j]) NEXT DC_GetProgress(oProgress, ++nTime, nMax) SELECT InfPortAtr DBSKIP(-1) ENDDO ****** ЗАПОЛНИТЬ ПОЛЯ БД (mSWOTName) SWOT-матрицы ДЛЯ ВИЗУАЛИЗАЦИИ SELECT InfPortAtrPos PUBLIC N_ClsPos := RECCOUNT() SELECT InfPortAtrNeg PUBLIC N_ClsNeg := RECCOUNT() N_ClsMax = MAX(N_ClsPos, N_ClsNeg) SELECT (mSWOTName) FOR j=1 TO N_ClsMax APPEND BLANK REPLACE Num_pp WITH j NEXT aStr := { { "Num_pp" , "N", 15, 0 }, ; { "Kod_Cls1" , "N", 15, 0 }, ; { "Kod_ClSc1" , "N", 15, 0 }, ; { "Name_ClSc1" , "C", mLenMaxCS, 0 }, ; { "Name_GrCS1" , "C", mLenMaxGCS, 0 }, ; { "Name_Cls1" , "C", mLenMaxCls, 0 }, ; { "Znach1" , "N", 19, 7 }, ; { "Kod_Cls2" , "N", 15, 0 }, ; { "Kod_ClSc2" , "N", 15, 0 }, ; { "Name_ClSc2" , "C", mLenMaxCS, 0 }, ; { "Name_GrCS2" , "C", mLenMaxGCS, 0 }, ; { "Name_Cls2" , "C", mLenMaxCls, 0 }, ; { "Znach2" , "N", 19, 7 } } SELECT InfPortAtrPos mNumRec = 0 DBGOTOP() DO WHILE .NOT. EOF() mKodCls1 = Kod_Cls mNameCls1 = Name_Cls mZnach1 = Znach mKodClSc1 = Kod_ClSc SELECT Gr_ClSc DBGOTO(mKodCls1) mNameGrCS1 = Name_GrCS SELECT Class_Sc DBGOTO(mKodClSc1) mNameClSc1 = Name_ClSc SELECT (mSWOTName) DBGOTO(++mNumRec) REPLACE Num_pp WITH mNumRec REPLACE Kod_Cls1 WITH mKodCls1 REPLACE Kod_ClSc1 WITH mKodClSc1 REPLACE Name_ClSc1 WITH mNameClSc1 REPLACE Name_GrCS1 WITH mNameGrCS1 REPLACE Name_Cls1 WITH mNameCls1 REPLACE Znach1 WITH mZnach1 DC_GetProgress(oProgress, ++nTime, nMax) SELECT InfPortAtrPos DBSKIP(1) ENDDO SELECT InfPortAtrNeg mNumRec = 0 DBGOTOP() DO WHILE .NOT. EOF() mKodCls2 = Kod_Cls mNameCls2 = Name_Cls mZnach2 = Znach mKodClSc2 = Kod_ClSc SELECT Gr_ClSc DBGOTO(mKodCls2) mNameGrCS2 = Name_GrCS SELECT Class_Sc DBGOTO(mKodClSc2) mNameClSc2 = Name_ClSc SELECT (mSWOTName) DBGOTO(++mNumRec) REPLACE Num_pp WITH mNumRec REPLACE Kod_Cls2 WITH mKodCls2 REPLACE Kod_ClSc2 WITH mKodClSc2 REPLACE Name_ClSc2 WITH mNameClSc2 REPLACE Name_GrCS2 WITH mNameGrCS2 REPLACE Name_Cls2 WITH mNameCls2 REPLACE Znach2 WITH mZnach2 DC_GetProgress(oProgress, ++nTime, nMax) SELECT InfPortAtrNeg DBSKIP(1) ENDDO DC_GetProgress(oProgress,nMax,nMax) oDialog:Destroy() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW USE Gr_ClSc EXCLUSIVE NEW USE Class_Sc EXCLUSIVE NEW USE InfPortAtr EXCLUSIVE NEW USE InfPortAtrPos EXCLUSIVE NEW USE InfPortAtrNeg EXCLUSIVE NEW SELECT InfPortAtrPos DBGOTOP() SELECT InfPortAtrNeg DBGOTOP() SELECT Attributes * SET FILTER TO Abs+Int_inf > 0 DBGOTO(M_Recno) ReTURN NIL ***************************************** ********************************************************************************************************************************* ******** Отображение SWOT-матрицы классов с формированием изображения в памяти и с отображением с масштабированием ********************************************************************************************************************************* FUNCTION GraSWOTCls() GraSWOTCls := DC_DataSave() // Сохранение вычислительной среды (открытые и текущие БД и индексы) * DC_DataRest( GraSWOTCls ) // Восстановление вычислительной среды (открытые и текущие БД и индексы) SELECT Classes mRecno = RECNO() mKodCls = Kod_cls PUBLIC X_MaxW := 1800, Y_MaxW := 900 // Размер графического окна для отображения когнитивных диаграмм в пикселях PUBLIC nXSize := 1800 PUBLIC nYSize := 900 oScr := DC_WaitOn('Немного подождите! Идет формирование изображения в памяти и его масштабирование',,,,,,,,,,,.F.) // Create new bitmap with given size oPS := XBPPRESSPACE() :new() :Create() oBMP := XBPBITMAP() :New() :Create() * oBMP:Make( nXSize, nYSize, nPlanes, nBits ) oBMP:Make( nXSize, nYSize ) oBMP:presSpace( oPS ) // here your GRA* Code **** Закрасить фон прямоугольника *************** * GraSetColor( oPS, GRA_CLR_WHITE, GRA_CLR_WHITE ) GraSetColor( oPS, BD_LIGHTGREY, BD_LIGHTGREY ) GraBox( oPS, { 0, 0 }, { nXSize, nYSize }, GRA_FILL ) *####################################################################################################### SWOTCls( oPS, oBMP, mKodCls, 'File' ) // Графическая функция <<<===######################### *####################################################################################################### *My image original, my image scaled ****** Запись полноразмерного графического файла в папку: M_PathAppl+"\SWOTDiagrCls\" DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения * DC_ASave(mNumMod , "_NumMod.arx") mNumMod = DC_ARestore("_NumMod.arx") DIRCHANGE(M_PathAppl+"\SWOTDiagrCls\") // Перейти в папку SWOTDiagrCls cFileName = "SWOTDiagrCls"+STRTRAN(STR(mKodCls,4)," ","0")+"-"+STRTRAN(STR(mNumMod,2)," ","0")+".jpg" ERASE(cFileName) oBMP:SaveFile(cFileName,XBPBMP_FORMAT_JPG) DC_Impl(oScr) IF nWidth > 1800 FullView( cFileName, "по верху", 65 ) // Визуализация полноразмерного файла на мониторе высокого разрешения ELSE ****** Формирование с помощью bmp2bmp() и отображение масштабированного изображения aNewSize := {nWidth,nHeight-29} // Новый размер изображения (еще немного уменьшается, чтобы не рисовать по панели задач) oBMP:loadFile(cFileName) // Загрузка полноразмерного изображения oRet := BMP2BMP(oBMP,aNewSize) // Масштабирование изображения cFileNameScale = SUBSTR(cFileName,1,AT(".jpg",cFileName)-1)+"_scaled.jpg" ERASE(cFileNameScale) oRet:saveFile(cFileNameScale,XBPBMP_FORMAT_JPG) // Запись масштабированного графического файла в в папку приложения для визуализации FullView( cFileNameScale, "по верху", 0 ) // Визуализация масштабированного графического файла на мониторе ограниченного разрешения ENDIF DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения * GraSWOTCls := DC_DataSave() // Сохранение вычислительной среды (открытые и текущие БД и индексы) DC_DataRest( GraSWOTCls ) // Восстановление вычислительной среды (открытые и текущие БД и индексы) FiltrLeft448(.F.) FiltrRight448(.F.) Running(.F.) ReTURN NIL ********************************************************************************************************************************** ********* Отображение SWOT-матрицы классов ********************************************************************************************************************************** *FUNCTION GraSWOTClsOld() * GraSWOTCls := DC_DataSave() // Сохранение вычислительной среды (открытые и текущие БД и индексы) ** DC_DataRest( GraSWOTCls ) // Восстановление вычислительной среды (открытые и текущие БД и индексы) ******* Узнать разрешение экрана и не показывать изображений большой размерности **************** *********** Роджер *********************** **aWorkArea := DC_GetWorkArea() **nWidth := aWorkArea[3] - aWorkArea[1] **nHeight := aWorkArea[4] - aWorkArea[2] ****************************************** *nWidth := AppDeskTop():currentSize()[1] // current screen size width in pixels *nHeight := AppDeskTop():currentSize()[2] // current screen size height in pixels *IF nWidth < 1800 * aMess := {} * AADD(aMess, L("Для правильного отображения графической формы")) * AADD(aMess, L("необходимо разрешение экрана 1800 pix по горизонтали,")) * AADD(aMess, L("а фактически установлено: ")+ALLTRIM(STR(nWidth))+" pix") * LB_Warning(aMess ) * GraSWOTCls := DC_DataSave() // Сохранение вычислительной среды (открытые и текущие БД и индексы) * FiltrLeft448(.F.) * FiltrRight448(.F.) * Running(.F.) * ReTURN NIL *ENDIF *IF nHeight < 850 * aMess := {} * AADD(aMess, L("Для правильного отображения графической формы")) * AADD(aMess, L("необходимо разрешение экрана 850 pix по вертикали,")) * AADD(aMess, L("а фактически установлено: ")+ALLTRIM(STR(nHeight))+" pix") * LB_Warning(aMess ) * GraSWOTCls := DC_DataSave() // Сохранение вычислительной среды (открытые и текущие БД и индексы) * FiltrLeft448(.F.) * FiltrRight448(.F.) * Running(.F.) * ReTURN NIL *ENDIF ************************************************************************************************* * SELECT Classes * mRecno = RECNO() * mKodCls = Kod_cls * PUBLIC X_MaxW := 1800, Y_MaxW := 900 // Размер графического окна для отображения когнитивных диаграмм в пикселях *@ 2,1 DCSTATIC TYPE XBPSTATIC_TYPE_RECESSEDBOX SIZE X_MaxW, Y_MaxW PIXEL OBJECT oStatic * DCREAD GUI FIT EVAL {||_PresSpace448(oStatic, mKodCls )} ; * TITLE L('4.4.8. Количественный SWOT-анализ классов средствами АСК-анализа. (C) Универсальная когнитивная аналитическая система "ЭЙДОС-X++"') * oStatic := nil ** GraSWOTCls := DC_DataSave() // Сохранение вычислительной среды (открытые и текущие БД и индексы) * DC_DataRest( GraSWOTCls ) // Восстановление вычислительной среды (открытые и текущие БД и индексы) * FiltrLeft448(.F.) * FiltrRight448(.F.) *ReTURN NIL ***************************************** ***************************************** *STATIC FUNCTION _PresSpace448( oStatic, mKodCls ) * LOCAL oPS, oDevice * oPS := XbpPresSpace():new() // Create a PS * oDevice := oStatic:winDevice() // Get the device context * oPS:create( oDevice ) // Link device context to PS * oPS:SetViewPort( { 0, 0, X_MaxW, Y_MaxW } ) * oStatic:paint := {|mp1,mp2,obj| mp1 := SWOTCls( oPS, oStatic, mKodCls, 'Screen' ) } *RETURN NIL ***************************************** ***************************************** STATIC FUNCTION SWOTCls( oPS, oStatic, mKodCls, mPar ) * DC_ASave(mNumMod , "_NumMod.arx") mNumMod = DC_ARestore("_NumMod.arx") InfSWOTCls(mNumMod) SELECT Classes mRecno = RECNO() mKodCls = Kod_cls mNameCls = ALLTRIM(Name_cls) * mSWOTName = "SWOTCls"+STRTRAN(STR(mKodCls,4)," ","0")+Ar_Model[mNumMod] * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * USE (mSWOTName) EXCLUSIVE NEW W_Wind = X_MaxW / 2 // Полуширина окна для самого графика H_Wind = Y_MaxW / 2 // Полувысота окна для самого графика LY := 70 // Зона над областью графика для наименования и под областью графика для легенды X0 := W_Wind // Начало координат для эллипса по оси X Y0 := H_Wind // Начало координат для эллипса по оси Y IndentLeft = 50 // Отступ слева IndentRight = 50 // Отступ справа Area = ( X_MaxW - IndentLeft - IndentRight ) / 3 // Размер зон левого и правового инф.портретов и связей между ними ***** Закрасить фон прямоугольников *************** ***** Закрасить фон прямоугольника всей зоны изображения GraSetColor( oPS, aColor[98] , aColor[98] ) // Номер цвета в соответствии с _AidosColor.prg GraBox( oPS, { X0-W_Wind, Y0-H_Wind }, { X0+W_Wind, Y0+H_Wind }, GRA_FILL ) ***** Закрасить весь фон прямоугольника зоны изображения левого инф.портрета GraSetColor( oPS, aColor[38] , aColor[38] ) // Номер цвета в соответствии с _AidosColor.prg GraBox( oPS, { IndentLeft+0*Area, Y_MaxW-140 }, { IndentLeft+1*Area, Y0-H_Wind+LY+20 }, GRA_FILL ) ***** Закрасить весь фон прямоугольника зоны связей левого и правого инф.портретов GraSetColor( oPS, aColor[71] , aColor[71] ) // Номер цвета в соответствии с _AidosColor.prg GraBox( oPS, { IndentLeft+1*Area, Y_MaxW-140 }, { IndentLeft+2*Area, Y0-H_Wind+LY+20 }, GRA_FILL ) ***** Закрасить весь фон прямоугольника зоны изображения правого инф.портрета GraSetColor( oPS, aColor[38] , aColor[38] ) // Номер цвета в соответствии с _AidosColor.prg GraBox( oPS, { IndentLeft+2*Area, Y_MaxW-140 }, { IndentLeft+3*Area, Y0-H_Wind+LY+20 }, GRA_FILL ) GraSetColor( oPS, aColor[222] , aColor[222] ) *********** Нарисовать левый и правый голубые прямоугольники для информации о признаках ******** Атрибуты области aAttrBox := ARRAY( GRA_AA_COUNT ) // Определить атрибуты заполнения прямоугольника aAttrBox[ GRA_AA_COLOR ] := GRA_CLR_CYAN GraSetAttrArea( oPS, aAttrBox ) ******** Атрибуты границы области (линии) aAttrLine := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttrLine [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttrLine [ GRA_AL_COLOR ] := GRA_CLR_DARKBLUE // Задать цвет линии aAttrLine [ GRA_AL_WIDTH ] := 2 // Задать толщину линии graSetAttrLine( oPS, aAttrLine ) // Установить атрибуты BoxWidth = 140 // Ширина прямоугольника CYAN в пикселях graBox( oPS, { IndentLeft+1*Area-BoxWidth/2, Y_MaxW-140 }, {IndentLeft+1*Area+BoxWidth/2, Y0-H_Wind+LY+20}, GRA_OUTLINEFILL, 7, 7 ) // Прямоугольник очерчен, заполнен и закруглен graBox( oPS, { IndentLeft+2*Area-BoxWidth/2, Y_MaxW-140 }, {IndentLeft+2*Area+BoxWidth/2, Y0-H_Wind+LY+20}, GRA_OUTLINEFILL, 7, 7 ) // Прямоугольник очерчен, заполнен и закруглен ***** Нарисовать рамку изображения и отделить место для легенды ******************* aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты ****** Начало координат в центре рисунка * GraArc ( oPS, { X0, Y0 }, 5 ) // Начало координат GraLine( oPS, {X0-W_Wind+1, Y0-H_Wind+1}, {X0-W_Wind+1, Y0+H_Wind-1} ) // Нарисовать границу рамки изображения слева GraLine( oPS, {X0+W_Wind-1, Y0-H_Wind+1}, {X0+W_Wind-1, Y0+H_Wind-1} ) // Нарисовать границу рамки изображения справа GraLine( oPS, {X0-W_Wind+1, Y0-H_Wind+1}, {X0+W_Wind-1, Y0-H_Wind+1} ) // Нарисовать границу рамки изображения внизу параллельно оси X GraLine( oPS, {X0-W_Wind+1, Y0+H_Wind-1}, {X0+W_Wind-1, Y0+H_Wind-1} ) // Нарисовать границу рамки изображения вверху параллельно оси X GraLine( oPS, {X0-W_Wind+1, Y0-H_Wind+LY}, {X0+W_Wind-1, Y0-H_Wind+LY} ) // Нарисовать границу рамки легенды на уровне LY параллельно оси X **** Написать заголовок диаграммы aFonts := XbpFont():new():list() // Все доступные шрифты oFont := XbpFont():new():create("22.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraStringAt( oPS, { X_MaxW/2, Y_MaxW-20 }, 'SWOT-ДИАГРАММА КЛАССА В МОДЕЛИ: "'+UPPER(Ar_Model[mNumMod])+'"') oFont := XbpFont():new():create("18.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) IF LEN(ALLTRIM(M_NameAppl)) < 70 GraStringAt( oPS, { X_MaxW/2, Y_MaxW-50 }, "Приложение: "+'"'+ALLTRIM(M_NameAppl)+'"' ) ELSE GraStringAt( oPS, { X_MaxW/2, Y_MaxW-50 }, '"'+ALLTRIM(M_NameAppl)+'"' ) ENDIF ***** Отобразить наименование класса CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Opis_Sc EXCLUSIVE NEW USE Class_Sc EXCLUSIVE NEW USE Gr_ClSc EXCLUSIVE NEW SELECT Gr_ClSc DBGOTO(mKodCls) mNameGrCS = DelZeroNameGr(Name_GrCS) mKodClSc = Kod_ClSc SELECT Class_Sc DBGOTO(mKodClSc) mNameClSc = ALLTRIM(Name_ClSc) GraStringAt( oPS, { X_MaxW/2, Y_MaxW- 85 }, "Шкала: ["+ALLTRIM(STR(mKodClSc))+"] "+mNameClSc ) GraStringAt( oPS, { X_MaxW/2, Y_MaxW-110 }, "Класс: ["+ALLTRIM(STR(mKodCls ))+"] "+mNameGrCS ) *********** Отобразить заголовки для левого и правого инф.портретов oFont := XbpFont():new():create("12.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_RED aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) GraStringAt( oPS, { IndentLeft+0*Area , Y_MaxW-130 }, "СПОСОБСТВУЮЩИЕ значения факторов и сила их влияния:" ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLUE GraSetAttrString( oPS, aAttrF ) GraStringAt( oPS, { IndentLeft+2*Area+BoxWidth/2, Y_MaxW-130 }, "ПРЕПЯТСТВУЮЩИЕ значения факторов и сила их влияния:" ) ****** Фильтры по факторам, если .F. - фильтра нет ****** mFltrFlag448 = .T./.F. , если .T., то: SET FILTER TO mKodOpSc448 = Kod_OpSc SELECT Opis_Sc IF mFltrLeftFlag448 DBGOTO(mKodOpScLeft448) MKodGrMin1 = KodGr_min MKodGrMax1 = KodGr_max mNameOpSc1 = ALLTRIM(Name_OpSc) MessLeft = "Фильтр по фактору: ["+ALLTRIM(STR(mKodOpScLeft448))+"] "+mNameOpSc1+": "+ALLTRIM(STR(MKodGrMin1))+"-"+ALLTRIM(STR(MKodGrMax1)) ELSE DBGOTOP() ;MKodGrMin1 = KodGr_min DBGOBOTTOM();MKodGrMax1 = KodGr_max mNameOpSc1 = "ВСЕ ФАКТОРЫ:" MessLeft = "Фильтр по факторам ВЫКЛЮЧЕН. Диапазон кодов значений: "+ALLTRIM(STR(MKodGrMin1))+"-"+ALLTRIM(STR(MKodGrMax1)) ENDIF IF mFltrRightFlag448 DBGOTO(mKodOpScRight448) MKodGrMin2 = KodGr_min MKodGrMax2 = KodGr_max mNameOpSc2 = ALLTRIM(Name_OpSc) MessRight = "Фильтр по фактору: ["+ALLTRIM(STR(mKodOpScRight448))+"] "+mNameOpSc2+": "+ALLTRIM(STR(MKodGrMin2))+"-"+ALLTRIM(STR(MKodGrMax2)) ELSE DBGOTOP() ;MKodGrMin2 = KodGr_min DBGOBOTTOM();MKodGrMax2 = KodGr_max mNameOpSc2 = "ВСЕ ФАКТОРЫ:" MessRight = "Фильтр по факторам ВЫКЛЮЧЕН. Диапазон кодов значений: "+ALLTRIM(STR(MKodGrMin2))+"-"+ALLTRIM(STR(MKodGrMax2)) ENDIF aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK GraSetAttrString( oPS, aAttrF ) GraStringAt( oPS, { IndentLeft+0*Area , Y0-H_Wind+LY+10 }, SUBSTR(MessLeft ,1, 70) ) GraStringAt( oPS, { IndentLeft+2*Area+BoxWidth/2, Y0-H_Wind+LY+10 }, SUBSTR(MessRight,1, 70) ) // <===########## ***** Легенда ********************************* oFont := XbpFont():new():create("13.ArialBold") GraSetFont( oPS ,oFont ) aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты AxName = "СИСТЕМА ДЕТЕРМИНАЦИИ КЛАССА ФАКТОРАМИ И ИХ ЗНАЧЕНИЯМИ:" GraStringAt( oPS, { 20, LY-15 }, AxName ) AxName = "Значения факторов, СПОСОБСТВУЮЩИЕ переходу объекта управления в состояние, соотвествующее классу, отображается линиями связи КРАСНОГО цвета. Толщина линии отражает степень влияния." GraStringAt( oPS, { 200, LY-35 }, AxName ) AxName = "Значения факторов, ПРЕПЯТСТВУЮЩИЕ переходу объекта управления в состояние, соотвествующее классу, отображается линиями связи СИНЕГО цвета. Толщина линии отражает степень влияния." GraStringAt( oPS, { 200, LY-55 }, AxName ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_DARKRED GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты AxName = "Форма создана: "+DTOC(DATE())+"-"+TIME() GraStringAt( oPS, { IndentLeft+2*Area+BoxWidth/2, LY-15 }, AxName ) **** Нарисовать сами линии **** mSxodstvo > 0 aAttr := Array( GRA_AL_COUNT ) // атрибуты линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := GRA_CLR_RED aAttr [ GRA_AL_WIDTH ] := 7 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraLine(oPS, { 23, LY-35 }, { 170, LY-35 } ) // Нарисовать линию заданных толщины и цвета **** mSxodstvo < 0 aAttr := Array( GRA_AL_COUNT ) // атрибуты линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := GRA_CLR_BLUE aAttr [ GRA_AL_WIDTH ] := 7 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraLine(oPS, { 23, LY-55 }, { 170, LY-55 } ) // Нарисовать линию заданных толщины и цвета ***** РИСОВАНИЕ ПРЯМОУГОЛЬНИКОВ ПРИЗНАКОВ ЛЕВОГО И ПРАВОГО ИНФ.ПОРТРЕТОВ И НАДПИСЕЙ В НИХ *********** mMaxAtrInfPort = 7 // Максимальное количество отображаемых на диаграмме признаков в инф.портрете ***** Расчет промежутка между прямоугольниками признаков mSWOTName = "SWOTCls"+STRTRAN(STR(mKodCls,4)," ","0")+Ar_Model[mNumMod] CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mSWOTName) EXCLUSIVE NEW SELECT (mSWOTName) *** Определение наиболее сильной по модулю связи для нормировки толщины линии DBGOTOP() mMaxZnachBit = MAX(ABS(Znach1), ABS(Znach2)) // Максимальное по модулю влияние в bit для нормировки силы связи на изображении mMaxZnachPix = 20 // Максимальная по модулю сила связи в pix для нормировки силы связи на изображении mKnorm = mMaxZnachPix/mMaxZnachBit // Коэффициент нормировки и преобразования силы связи из bit в pix IF SUBSTR(NAME_ATR1,1,12) = 'SPECTRINTERV' aRGBAtr1 := {} // Массив цветов признаков, если спектр aRGBAtr2 := {} // Массив цветов признаков, если спектр DO WHILE .NOT. EOF() mScName = NAME_ATR1 IF SUBSTR(mScName,1,12) = 'SPECTRINTERV' * SpectrInterv: 999/999-{123,123,123} * 123456789012 R G B mPosR1 = AT('{', mScName)+1 mPosR2 = mPosR1+2 mPosG1 = mPosR2+2 mPosG2 = mPosG1+2 mPosB1 = mPosG2+2 mPosB2 = mPosB1+2 mRed = VAL(SUBSTR(mScName, mPosR1, mPosR2-mPosR1+1)) mGreen = VAL(SUBSTR(mScName, mPosG1, mPosG2-mPosG1+1)) mBlue = VAL(SUBSTR(mScName, mPosB1, mPosB2-mPosB1+1)) fColor := GraMakeRGBColor({ mRed, mGreen, mBlue}) AADD(aRGBAtr1, fColor) ENDIF mScName = NAME_ATR2 IF SUBSTR(mScName,1,12) = 'SPECTRINTERV' * SpectrInterv: 999/999-{123,123,123} * 123456789012 R G B mPosR1 = AT('{', mScName)+1 mPosR2 = mPosR1+2 mPosG1 = mPosR2+2 mPosG2 = mPosG1+2 mPosB1 = mPosG2+2 mPosB2 = mPosB1+2 mRed = VAL(SUBSTR(mScName, mPosR1, mPosR2-mPosR1+1)) mGreen = VAL(SUBSTR(mScName, mPosG1, mPosG2-mPosG1+1)) mBlue = VAL(SUBSTR(mScName, mPosB1, mPosB2-mPosB1+1)) fColor := GraMakeRGBColor({ mRed, mGreen, mBlue}) AADD(aRGBAtr2, fColor) ENDIF DBSKIP(1) ENDDO ENDIF ******** Вывод наименований обобщ.и первичных признаков **** ************************************************************************************************************************* *** Фильтр для левого портрета ****************************************************************************************** ************************************************************************************************************************* CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mSWOTName) EXCLUSIVE NEW USE InfPortClsPos EXCLUSIVE NEW SELECT InfPortClsPos IF mFltrLeftFlag448 SET FILTER TO mKodOpScLeft448 = Kod_OpSc ENDIF COUNT TO N_GosPos *** Определение количества значений факторов в левом и правом инф.портретах N_Atr1 = IF(N_GosPos<=7, N_GosPos, 7) // Количество признаков в левом портрете N_Atr2 = IF(N_GosNeg<=7, N_GosNeg, 7) // Количество признаков в правом портрете Y_atr = (Y_MaxW-140) - (Y0-H_Wind+LY+20) // Высота зоны для информации о признаках BoxOffset = 10 // Отступ прямоугльников от границ зон рисования и текстов внутри прямоугольников от их границ BoxHeight = 85 // Высота прямоугольника в пикселях BoxWidth = 140 // Ширина прямоугольника CYAN в пикселях BoxWidth = BoxWidth - BoxOffset*2 // Ширина прямоугольника в пикселях DeltaY1 = (Y_atr-BoxHeight*N_Atr1)/(N_Atr1+1) DeltaY2 = (Y_atr-BoxHeight*N_Atr2)/(N_Atr2+1) DBGOTOP() mNumPp = 0 DO WHILE mNumPp < N_Atr1 .AND. .NOT. EOF() // Цикл по связям. Ограничить кол-во отображаемых связей макс.возможным 7 ++mNumPp mRecno = RECNO() SELECT (mSWOTName) DBGOTO(mRecno) ******* РИСОВАНИЕ ПРЯМОУГОЛЬНИКОВ ПРИЗНАКОВ ЛЕВОГО ИНФ.ПОРТРЕТА *********** *** ЛЕВЫЙ *** y1 = (Y_MaxW-140) - DeltaY1 - (BoxHeight+DeltaY1) * (mNumPp-1) ******** Атрибуты области aAttrBox := ARRAY( GRA_AA_COUNT ) // Определить атрибуты заполнения прямоугольника aAttrBox[ GRA_AA_COLOR ] := IF(Znach1>0,BD_LIGHTYELLOW, BD_LIGHTGREEN) // Цвет согласно _AidosColor.exe GraSetAttrArea( oPS, aAttrBox ) ******** Атрибуты границы области (линии) aAttrLine := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttrLine [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttrLine [ GRA_AL_COLOR ] := IF(Znach1>0,GRA_CLR_DARKRED, GRA_CLR_DARKBLUE) // Задать цвет линии aAttrLine [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttrLine ) // Установить атрибуты graBox( oPS, { IndentLeft+0*Area+BoxOffset , y1 }, { IndentLeft+1*Area-BoxWidth/2-2*BoxOffset, y1-BoxHeight }, GRA_OUTLINEFILL, 0, 0 ) // Большой. Прямоугольник очерчен, заполнен и закруглен IF SUBSTR(NAME_ATR1,1,12) = 'SPECTRINTERV' GraSetColor( oPS, aRGBAtr1[mNumPp] , aRGBAtr1[mNumPp] ) // Цвет фона для текста - цвет цветового диапазона ENDIF graBox( oPS, { IndentLeft+1*Area-BoxWidth/2, y1 }, { IndentLeft+1*Area+BoxWidth/2 , y1-BoxHeight }, GRA_OUTLINEFILL, 0, 0 ) // Малый. Прямоугольник очерчен, заполнен и закруглен ******** Атрибуты границы области (линии) aAttrLine := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttrLine [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttrLine [ GRA_AL_COLOR ] := IF(Znach1>0,GRA_CLR_DARKRED, GRA_CLR_DARKBLUE) // Задать цвет линии aAttrLine [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttrLine ) // Установить атрибуты GraBox( oPS, { IndentLeft+1*Area-BoxWidth/2, y1 }, { IndentLeft+1*Area+BoxWidth/2 , y1-BoxHeight }, GRA_OUTLINE, 0, 0 ) // Малый. Прямоугольник очерчен, заполнен и закруглен ******* РИСОВАНИЕ НАДПИСЕЙ В ПРЯМОУГОЛЬНИКАХ ПРИЗНАКОВ ********************************* *** ЛЕВЫЙ *** * aTxtPar = DC_GraQueryTextbox('Eugene Lutsenko','10.Arial') // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов oFont := XbpFont():new():create("12.Arial") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := IF(Znach1>0,GRA_CLR_DARKRED, GRA_CLR_DARKBLUE) // Задать цвет шрифта aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) ***** Цикл определения такой длины строки, которая помещается в рамку ***** Массив отображаемых в рамке строк, включающий наименования и описательных шкал и их градаций ***** Из текстового буфера к отображаемому элементу массива добавляется по одному символу и определяется его длина в пикселях. ***** Если не хватает длины рамки - добавляется строка в массив. Отображение градации шкалы всегда начинается с новой строки. mZone = 46 // Размер зоны отображения в символах aMess := {} // Массив отображаемых в рамке строк, включающий наименования и описательных шкал и их градаций AADD(aMess, L(" "));s=1 // 1-й элемент - 1-я строка mBuff1 = "["+ALLTRIM(STR(Kod_OpSc1))+"] "+ALLTRIM(Name_OpSc1) FOR j=1 TO LEN(mBuff1) * aTxtPar = DC_GraQueryTextbox(aMess[s] + SUBSTR(mBuff1,j,1), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов IF LEN(aMess[s] + SUBSTR(mBuff1,j,1)) <= mZone aMess[s] = aMess[s] + SUBSTR(mBuff1,j,1) // Полное наименование описательной шкалы посылается в буфер для отображения ELSE IF s < 2 AADD(aMess, SUBSTR(mBuff1,j,1)) s++ ELSE EXIT ENDIF ENDIF NEXT ***** Цикл определения такой длины строки, которая помещается в рамку AADD(aMess, L(" ")) s++ mBuff2 = "["+ALLTRIM(STR(Kod_Atr1 ))+"] "+DelZeroNameGr(Name_GrOS1) // Буфер. Из буфера добавляется по олному символу в отображаемый элемент массива FOR j=1 TO LEN(mBuff2) IF LEN(aMess[s] + SUBSTR(mBuff1,j,1)) <= mZone aMess[s] = aMess[s] + SUBSTR(mBuff2,j,1) // Полное наименование описательной шкалы посылается в буфер для отображения ELSE IF s < 4 AADD(aMess, SUBSTR(mBuff2,j,1)) s++ ELSE EXIT ENDIF ENDIF NEXT *** Отображение ***** y1 = (Y_MaxW-140) - DeltaY1 - (BoxHeight+DeltaY1) * (mNumPp-1) mInterval = 18 // Межстрочный интервал в пикселях. 1 - строки пишутся без пропуска FOR s=1 TO LEN(aMess) GraStringAt( oPS, { IndentLeft+0*Area+BoxOffset*2, y1-15-(s-1)*mInterval }, aMess[s] ) NEXT ***** Надписи в маленьких прямоугольниках внутри голубых прямоугольников с информацией по признакам oFont := XbpFont():new():create("12.ArialBold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := IF(Znach1>0,GRA_CLR_DARKRED, GRA_CLR_DARKBLUE) // Задать цвет шрифта aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) * graBox( oPS, { IndentLeft+1*Area-BoxWidth/2, y1 }, { IndentLeft+1*Area+BoxWidth/2, y1-BoxHeight }, GRA_OUTLINEFILL, 0, 0 ) // Малый левый. Прямоугольник очерчен, заполнен и закруглен mInterval = 21 // Межстрочный интервал в пикселях. 1 - строки пишутся без пропуска GraStringAt( oPS, { IndentLeft+1*Area-BoxWidth/2+BoxOffset, y1-mInterval*2 }, "I="+ALLTRIM(STR(Znach1 ,19,3))+IF(mNumMod=4," bit", "") ) SELECT InfPortClsPos DBSKIP(1) ENDDO ***** РИСОВАНИЕ ЛИНИЙ ОТНОШЕНИЙ (СВЯЗЕЙ) ПРИЗНАКОВ ЛЕВОГО ИНФ.ПОРТРЕТА *********** x1 = IndentLeft+1*Area+BoxWidth/2+BoxOffset x2 = IndentLeft+2*Area-BoxWidth/2-BoxOffset oFont := XbpFont():new():create("10.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт mNumPp = 0 DBGOTOP() DO WHILE mNumPp < N_Atr1 .AND. .NOT. EOF() // Цикл по связям. Ограничить кол-во отображаемых связей макс.возможным 7 ++mNumPp mRecno = RECNO() SELECT (mSWOTName) DBGOTO(mRecno) y1 = (Y_MaxW-140) - DeltaY1 - (BoxHeight+DeltaY1) * (mNumPp-1) - BoxHeight/2 y2 = (Y_MaxW-140) - DeltaY2 - (BoxHeight+DeltaY2) * (mNumPp-1) - BoxHeight/2 ******** Атрибуты границы области (линии) aAttrLine := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttrLine [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttrLine [ GRA_AL_COLOR ] := IF(Znach1>0,BD_CANDYRED, BD_RICHBLUE) // Задать цвет линии согласно _AidosColor.exe aAttrLine [ GRA_AL_WIDTH ] := mKnorm * ABS(Znach1) // Задать толщину линии (нормированную) graSetAttrLine( oPS, aAttrLine ) // Установить атрибуты GraLine( oPS, { x1, y1 }, { X_MaxW/2, Y_MaxW-120-2*mMaxZnachPix } ) // Нарисовать линию связи заданной толщины и цвета SELECT InfPortClsPos DBSKIP(1) ENDDO ************************************************************************************************************************* *** Фильтр для правого портрета ***************************************************************************************** ************************************************************************************************************************* CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mSWOTName) EXCLUSIVE NEW USE InfPortClsNeg EXCLUSIVE NEW SELECT InfPortClsNeg IF mFltrRightFlag448 SET FILTER TO mKodOpScRight448 = Kod_OpSc ENDIF COUNT TO N_GosNeg *** Определение количества значений факторов в левом и правом инф.портретах N_Atr1 = IF(N_GosPos<=7, N_GosPos, 7) // Количество признаков в левом портрете N_Atr2 = IF(N_GosNeg<=7, N_GosNeg, 7) // Количество признаков в правом портрете Y_atr = (Y_MaxW-140) - (Y0-H_Wind+LY+20) // Высота зоны для информации о признаках BoxOffset = 10 // Отступ прямоугльников от границ зон рисования и текстов внутри прямоугольников от их границ BoxHeight = 85 // Высота прямоугольника в пикселях BoxWidth = 140 // Ширина прямоугольника CYAN в пикселях BoxWidth = BoxWidth - BoxOffset*2 // Ширина прямоугольника в пикселях DeltaY1 = (Y_atr-BoxHeight*N_Atr1)/(N_Atr1+1) DeltaY2 = (Y_atr-BoxHeight*N_Atr2)/(N_Atr2+1) DBGOTOP() mNumPp = 0 DO WHILE mNumPp < N_Atr2 .AND. .NOT. EOF() // Цикл по связям. Ограничить кол-во отображаемых связей макс.возможным 7 ++mNumPp mRecno = RECNO() SELECT (mSWOTName) DBGOTO(mRecno) ******* РИСОВАНИЕ ПРЯМОУГОЛЬНИКОВ ПРИЗНАКОВ ЛЕВОГО И ПРАВОГО ИНФ.ПОРТРЕТОВ *********** *** ПРАВЫЙ *** y2 = (Y_MaxW-140) - DeltaY2 - (BoxHeight+DeltaY2) * (mNumPp-1) ******** Атрибуты области aAttrBox := ARRAY( GRA_AA_COUNT ) // Определить атрибуты заполнения прямоугольника aAttrBox[ GRA_AA_COLOR ] := IF(Znach2>0,BD_LIGHTYELLOW, BD_LIGHTGREEN) // Цвет согласно _AidosColor.exe GraSetAttrArea( oPS, aAttrBox ) ******** Атрибуты границы области (линии) aAttrLine := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttrLine [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttrLine [ GRA_AL_COLOR ] := IF(Znach2>0,GRA_CLR_DARKRED, GRA_CLR_DARKBLUE) // Задать цвет линии aAttrLine [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttrLine ) // Установить атрибуты graBox( oPS, { IndentLeft+2*Area+BoxWidth/2+2*BoxOffset, y2 }, { IndentLeft+3*Area-BoxOffset , y2-BoxHeight }, GRA_OUTLINEFILL, 0, 0 ) // Большой. Прямоугольник очерчен, заполнен и закруглен IF SUBSTR(NAME_ATR2,1,12) = 'SPECTRINTERV' GraSetColor( oPS, aRGBAtr2[mNumPp] , aRGBAtr2[mNumPp] ) // Цвет фона для текста - цвет цветового диапазона ENDIF graBox( oPS, { IndentLeft+2*Area-BoxWidth/ 2, y2 }, { IndentLeft+2*Area+BoxWidth/2, y2-BoxHeight }, GRA_OUTLINEFILL, 0, 0 ) // Малый. Прямоугольник очерчен, заполнен и закруглен ******** Атрибуты границы области (линии) aAttrLine := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttrLine [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttrLine [ GRA_AL_COLOR ] := IF(Znach2>0,GRA_CLR_DARKRED, GRA_CLR_DARKBLUE) // Задать цвет линии aAttrLine [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttrLine ) // Установить атрибуты graBox( oPS, { IndentLeft+2*Area-BoxWidth/ 2, y2 }, { IndentLeft+2*Area+BoxWidth/2, y2-BoxHeight }, GRA_OUTLINE, 0, 0 ) // Малый. Прямоугольник очерчен, заполнен и закруглен ******* РИСОВАНИЕ НАДПИСЕЙ В ПРЯМОУГОЛЬНИКАХ ПРИЗНАКОВ ********************************* *** ПРАВЫЙ *** * aTxtPar = DC_GraQueryTextbox('Eugene Lutsenko','10.Arial') // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов oFont := XbpFont():new():create("12.Arial") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := IF(Znach2>0,GRA_CLR_DARKRED, GRA_CLR_DARKBLUE) // Задать цвет шрифта aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) ***** Цикл определения такой длины строки, которая помещается в рамку ***** Массив отображаемых в рамке строк, включающий наименования и описательных шкал и их градаций ***** Из текстового буфера к отображаемому элементу массива добавляется по одному символу и определяется его длина в пикселях. ***** Если не хватает длины рамки - добавляется строка в массив. Отображение градации шкалы всегда начинается с новой строки. mZone = 46 // Размер зоны отображения в символах aMess := {} // Массив отображаемых в рамке строк, включающий наименования и описательных шкал и их градаций AADD(aMess, L(" "));s=1 // 1-й элемент - 1-я строка mBuff1 = "["+ALLTRIM(STR(Kod_OpSc2))+"] "+ALLTRIM(Name_OpSc2) FOR j=1 TO LEN(mBuff1) * aTxtPar = DC_GraQueryTextbox(aMess[s] + SUBSTR(mBuff1,j,1), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов IF LEN(aMess[s] + SUBSTR(mBuff1,j,1)) <= mZone aMess[s] = aMess[s] + SUBSTR(mBuff1,j,1) // Полное наименование описательной шкалы посылается в буфер для отображения ELSE IF s < 2 AADD(aMess, SUBSTR(mBuff1,j,1)) s++ ELSE EXIT ENDIF ENDIF NEXT ***** Цикл определения такой длины строки, которая помещается в рамку AADD(aMess, L(" ")) s++ mBuff2 = "["+ALLTRIM(STR(Kod_Atr2 ))+"] "+DelZeroNameGr(Name_GrOS2) // Буфер. Из буфера добавляется по олному символу в отображаемый элемент массива FOR j=1 TO LEN(mBuff2) IF LEN(aMess[s] + SUBSTR(mBuff2,j,1)) <= mZone aMess[s] = aMess[s] + SUBSTR(mBuff2,j,1) // Полное наименование описательной шкалы посылается в буфер для отображения ELSE IF s < 4 AADD(aMess, SUBSTR(mBuff2,j,1)) s++ ELSE EXIT ENDIF ENDIF NEXT *** Отображение ***** y1 = (Y_MaxW-140) - DeltaY2 - (BoxHeight+DeltaY2) * (mNumPp-1) mInterval = 18 // Межстрочный интервал в пикселях. 1 - строки пишутся без пропуска FOR s=1 TO LEN(aMess) GraStringAt( oPS, { IndentLeft+2*Area+BoxWidth/2+3*BoxOffset, y1-15-(s-1)*mInterval }, aMess[s] ) NEXT ***** Надписи в маленьких прямоугольниках внутри голубых прямоугольников с информацией по признакам oFont := XbpFont():new():create("12.ArialBold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := IF(Znach2>0,GRA_CLR_DARKRED, GRA_CLR_DARKBLUE) // Задать цвет шрифта aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) * graBox( oPS, { IndentLeft+2*Area-BoxWidth/2, y2 }, { IndentLeft+2*Area+BoxWidth/2, y2-BoxHeight }, GRA_OUTLINEFILL, 0, 0 ) // Малый правый. Прямоугольник очерчен, заполнен и закруглен mInterval = 21 // Межстрочный интервал в пикселях. 1 - строки пишутся без пропуска GraStringAt( oPS, { IndentLeft+2*Area-BoxWidth/2+BoxOffset, y2-mInterval*2 }, "I="+ALLTRIM(STR(Znach2 ,19,3))+IF(mNumMod=4," bit", "") ) SELECT InfPortClsNeg DBSKIP(1) ENDDO ***** РИСОВАНИЕ ЛИНИЙ ОТНОШЕНИЙ (СВЯЗЕЙ) ПРИЗНАКОВ ЛЕВОГО И ПРАВОГО ИНФ.ПОРТРЕТА *********** x1 = IndentLeft+1*Area+BoxWidth/2+BoxOffset x2 = IndentLeft+2*Area-BoxWidth/2-BoxOffset oFont := XbpFont():new():create("10.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт mNumPp = 0 DBGOTOP() DO WHILE mNumPp < N_Atr2 .AND. .NOT. EOF() // Цикл по связям. Ограничить кол-во отображаемых связей макс.возможным 7 ++mNumPp mRecno = RECNO() SELECT (mSWOTName) DBGOTO(mRecno) y1 = (Y_MaxW-140) - DeltaY1 - (BoxHeight+DeltaY1) * (mNumPp-1) - BoxHeight/2 y2 = (Y_MaxW-140) - DeltaY2 - (BoxHeight+DeltaY2) * (mNumPp-1) - BoxHeight/2 ******** Атрибуты границы области (линии) aAttrLine := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttrLine [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttrLine [ GRA_AL_COLOR ] := IF(Znach2>0,BD_CANDYRED, BD_RICHBLUE) // Задать цвет линии согласно _AidosColor.exe aAttrLine [ GRA_AL_WIDTH ] := mKnorm * ABS(Znach2) // Задать толщину линии (нормированную) graSetAttrLine( oPS, aAttrLine ) // Установить атрибуты GraLine( oPS, { x2, y2 }, { X_MaxW/2, Y_MaxW-120-2*mMaxZnachPix } ) // Нарисовать линию связи заданной толщины и цвета SELECT InfPortClsNeg DBSKIP(1) ENDDO FOR R=0 TO 2*mMaxZnachPix IF R=2*INT(R/2) aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := BD_CANDYRED // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 2 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты ELSE aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := BD_RICHBLUE // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 2 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты ENDIF GraArc ( oPS, { X_MaxW/2, Y_MaxW-120-3*mMaxZnachPix }, R ) NEXT ********* Записать файл изображения с именем - код левого класса + код правого класса + номер модели в папке SWOTDiagrCls IF FILEDATE("SWOTDiagrCls",16) = CTOD("//") DC_Impl(oScr) DIRMAKE("SWOTDiagrCls") aMess := {} AADD(aMess, L('В папке текущего приложения: "'+UPPER(ALLTRIM(M_PathAppl))+'"')) AADD(aMess, L('не было директории "SWOTDiagrCls" для SWOT-диаграмм классов и она была создана!')) AADD(aMess, L('В эту папку записываются исходные изображения высокого качества (без масштабирования)')) LB_Warning(aMess, L('4.4.8. Количественный SWOT-анализ классов средствами АСК-анализа' )) oScr := DC_WaitOn('Немного подождите! Идет формирование изображения в памяти и его масштабирование',,,,,,,,,,,.F.) ENDIF * DC_ASave(mClsLeft , "_ClsLeft.arx") // Код левого класса * DC_ASave(mClsRight, "_ClsRight.arx") // Код правого класса * DC_ASave(mNumMod , "_NumMod.arx") mClsLeft = DC_ARestore("_ClsLeft.arx") mClsRight = DC_ARestore("_ClsRight.arx") mNumMod = DC_ARestore("_NumMod.arx") IF mPar = 'Screen' DIRCHANGE(M_PathAppl+"\SWOTDiagrCls\") // Перейти в папку SWOTDiagrCls cFileName = "SWOTDiagrCls"+STRTRAN(STR(mKodCls,4)," ","0")+"-"+STRTRAN(STR(mNumMod,2)," ","0")+".bmp" ERASE(cFileName) DC_Scrn2ImageFile( oStatic, cFileName ) ENDIF DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения RETURN NIL ********************************************************************************************************************************* ******** Отображение SWOT-матрицы значений факторов с формированием изображения в памяти и с отображением с масштабированием ********************************************************************************************************************************* FUNCTION GraSWOTAtr() GraSWOTAtr := DC_DataSave() // Сохранение вычислительной среды (открытые и текущие БД и индексы) * DC_DataRest( GraSWOTAtr ) // Восстановление вычислительной среды (открытые и текущие БД и индексы) SELECT Attributes mRecno = RECNO() mKodAtr = Kod_atr PUBLIC X_MaxW := 1800, Y_MaxW := 900 // Размер графического окна для отображения когнитивных диаграмм в пикселях PUBLIC nXSize := 1800 PUBLIC nYSize := 900 oScr := DC_WaitOn('Немного подождите! Идет формирование изображения в памяти и его масштабирование',,,,,,,,,,,.F.) // Create new bitmap with given size oPS := XBPPRESSPACE() :new() :Create() oBMP := XBPBITMAP() :New() :Create() * oBMP:Make( nXSize, nYSize, nPlanes, nBits ) oBMP:Make( nXSize, nYSize ) oBMP:presSpace( oPS ) // here your GRA* Code **** Закрасить фон прямоугольника *************** * GraSetColor( oPS, GRA_CLR_WHITE, GRA_CLR_WHITE ) GraSetColor( oPS, BD_LIGHTGREY, BD_LIGHTGREY ) GraBox( oPS, { 0, 0 }, { nXSize, nYSize }, GRA_FILL ) *####################################################################################################### SWOTAtr( oPS, oBMP, mKodAtr, 'File' ) // Графическая функция <<<===######################### *####################################################################################################### *My image original, my image scaled ****** Запись полноразмерного графического файла в папку: M_PathAppl+"\SWOTDiagrAtr\" DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения * DC_ASave(mNumMod , "_NumMod.arx") mNumMod = DC_ARestore("_NumMod.arx") DIRCHANGE(M_PathAppl+"\SWOTDiagrAtr\") // Перейти в папку SWOTDiagrCls cFileName = "SWOTDiagrAtr"+STRTRAN(STR(mKodAtr,4)," ","0")+"-"+STRTRAN(STR(mNumMod,2)," ","0")+".jpg" ERASE(cFileName) oBMP:SaveFile(cFileName,XBPBMP_FORMAT_JPG) DC_Impl(oScr) IF nWidth > 1800 FullView( cFileName, "по верху", 65 ) // Визуализация полноразмерного файла на мониторе высокого разрешения ELSE ****** Формирование с помощью bmp2bmp() и отображение масштабированного изображения aNewSize := {nWidth,nHeight-29} // Новый размер изображения (еще немного уменьшается, чтобы не рисовать по панели задач) oBMP:loadFile(cFileName) // Загрузка полноразмерного изображения oRet := BMP2BMP(oBMP,aNewSize) // Масштабирование изображения cFileNameScale = SUBSTR(cFileName,1,AT(".jpg",cFileName)-1)+"_scaled.jpg" ERASE(cFileNameScale) oRet:saveFile(cFileNameScale,XBPBMP_FORMAT_JPG) // Запись масштабированного графического файла в в папку приложения для визуализации FullView( cFileNameScale, "по верху", 0 ) // Визуализация масштабированного графического файла на мониторе ограниченного разрешения ENDIF DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения * GraSWOTAtr := DC_DataSave() // Сохранение вычислительной среды (открытые и текущие БД и индексы) DC_DataRest( GraSWOTAtr ) // Восстановление вычислительной среды (открытые и текущие БД и индексы) FiltrLeft449(.F.) FiltrRight449(.F.) Running(.F.) ReTURN NIL ********************************************************************************************************************************** ********* Отображение SWOT-матрицы градаций факторов ********************************************************************************************************************************** *FUNCTION GraSWOTAtrOld() * GraSWOTAtr := DC_DataSave() // Сохранение вычислительной среды (открытые и текущие БД и индексы) ** DC_DataRest( GraSWOTAtr ) // Восстановление вычислительной среды (открытые и текущие БД и индексы) ******* Узнать разрешение экрана и не показывать изображений большой размерности **************** *nWidth := AppDeskTop():currentSize()[1] // current screen size width in pixels *nHeight := AppDeskTop():currentSize()[2] // current screen size height in pixels *IF nWidth < 1800 * aMess := {} * AADD(aMess, L("Для правильного отображения графической формы")) * AADD(aMess, L("необходимо разрешение экрана 1800 pix по горизонтали,")) * AADD(aMess, L("а фактически установлено: ")+ALLTRIM(STR(nWidth))+" pix") * LB_Warning(aMess ) * GraSWOTAtr := DC_DataSave() // Сохранение вычислительной среды (открытые и текущие БД и индексы) * FiltrLeft449(.F.) * FiltrRight449(.F.) * Running(.F.) * ReTURN NIL *ENDIF *IF nHeight < 850 * aMess := {} * AADD(aMess, L("Для правильного отображения графической формы")) * AADD(aMess, L("необходимо разрешение экрана 850 pix по вертикали,")) * AADD(aMess, L("а фактически установлено: ")+ALLTRIM(STR(nHeight))+" pix") * LB_Warning(aMess ) * GraSWOTAtr := DC_DataSave() // Сохранение вычислительной среды (открытые и текущие БД и индексы) * FiltrLeft449(.F.) * FiltrRight449(.F.) * Running(.F.) * ReTURN NIL *ENDIF ************************************************************************************************* * SELECT Attributes * mRecno = RECNO() * mKodAtr = Kod_atr * PUBLIC X_MaxW := 1800, Y_MaxW := 900 // Размер графического окна для отображения когнитивных диаграмм в пикселях *@ 2,1 DCSTATIC TYPE XBPSTATIC_TYPE_RECESSEDBOX SIZE X_MaxW, Y_MaxW PIXEL OBJECT oStatic * DCREAD GUI FIT EVAL {||_PresSpace449(oStatic, mKodAtr )} ; * TITLE L('4.4.9. Количественный SWOT-анализ градаций факторов средствами АСК-анализа. (C) Универсальная когнитивная аналитическая система "ЭЙДОС-X++"') * oStatic := nil ** GraSWOTAtr := DC_DataSave() // Сохранение вычислительной среды (открытые и текущие БД и индексы) * DC_DataRest( GraSWOTAtr ) // Восстановление вычислительной среды (открытые и текущие БД и индексы) * FiltrLeft449(.F.) * FiltrRight449(.F.) *ReTURN NIL ***************************************** ***************************************** *STATIC FUNCTION _PresSpace449( oStatic, mKodCls ) * LOCAL oPS, oDevice * oPS := XbpPresSpace():new() // Create a PS * oDevice := oStatic:winDevice() // Get the device context * oPS:create( oDevice ) // Link device context to PS * oPS:SetViewPort( { 0, 0, X_MaxW, Y_MaxW } ) * oStatic:paint := {|mp1,mp2,obj| mp1 := SWOTAtr( oPS, oStatic, mKodAtr, 'Screen' ) } *RETURN NIL ****************************************************** ****************************************************** STATIC FUNCTION SWOTAtr( oPS, oStatic, mKodAtr, mPar ) * DC_ASave(mNumMod , "_NumMod.arx") mNumMod = DC_ARestore("_NumMod.arx") InfSWOTAtr(mNumMod) SELECT Attributes mRecno = RECNO() mKodAtr = Kod_atr mNameAtr = ALLTRIM(Name_atr) * mSWOTName = "SWOTAtr"+STRTRAN(STR(mKodAtr,4)," ","0")+Ar_Model[mNumMod] * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * USE (mSWOTName) EXCLUSIVE NEW W_Wind = X_MaxW / 2 // Полуширина окна для самого графика H_Wind = Y_MaxW / 2 // Полувысота окна для самого графика LY := 70 // Зона над областью графика для наименования и под областью графика для легенды X0 := W_Wind // Начало координат для эллипса по оси X Y0 := H_Wind // Начало координат для эллипса по оси Y IndentLeft = 50 // Отступ слева IndentRight = 50 // Отступ справа Area = ( X_MaxW - IndentLeft - IndentRight ) / 3 // Размер зон левого и правового инф.портретов и связей между ними ***** Закрасить фон прямоугольников *************** ***** Закрасить фон прямоугольника всей зоны изображения GraSetColor( oPS, aColor[98] , aColor[98] ) // Номер цвета в соответствии с _AidosColor.prg GraBox( oPS, { X0-W_Wind, Y0-H_Wind }, { X0+W_Wind, Y0+H_Wind }, GRA_FILL ) ***** Закрасить весь фон прямоугольника зоны изображения левого инф.портрета GraSetColor( oPS, aColor[38] , aColor[38] ) // Номер цвета в соответствии с _AidosColor.prg GraBox( oPS, { IndentLeft+0*Area, Y_MaxW-140 }, { IndentLeft+1*Area, Y0-H_Wind+LY+20 }, GRA_FILL ) ***** Закрасить весь фон прямоугольника зоны связей левого и правого инф.портретов GraSetColor( oPS, aColor[71] , aColor[71] ) // Номер цвета в соответствии с _AidosColor.prg GraBox( oPS, { IndentLeft+1*Area, Y_MaxW-140 }, { IndentLeft+2*Area, Y0-H_Wind+LY+20 }, GRA_FILL ) ***** Закрасить весь фон прямоугольника зоны изображения правого инф.портрета GraSetColor( oPS, aColor[38] , aColor[38] ) // Номер цвета в соответствии с _AidosColor.prg GraBox( oPS, { IndentLeft+2*Area, Y_MaxW-140 }, { IndentLeft+3*Area, Y0-H_Wind+LY+20 }, GRA_FILL ) GraSetColor( oPS, aColor[222] , aColor[222] ) *********** Нарисовать левый и правый голубые прямоугольники для информации о признаках ******** Атрибуты области aAttrBox := ARRAY( GRA_AA_COUNT ) // Определить атрибуты заполнения прямоугольника aAttrBox[ GRA_AA_COLOR ] := GRA_CLR_CYAN GraSetAttrArea( oPS, aAttrBox ) ******** Атрибуты границы области (линии) aAttrLine := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttrLine [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttrLine [ GRA_AL_COLOR ] := GRA_CLR_DARKBLUE // Задать цвет линии aAttrLine [ GRA_AL_WIDTH ] := 2 // Задать толщину линии graSetAttrLine( oPS, aAttrLine ) // Установить атрибуты BoxWidth = 140 // Ширина прямоугольника CYAN в пикселях graBox( oPS, { IndentLeft+1*Area-BoxWidth/2, Y_MaxW-140 }, {IndentLeft+1*Area+BoxWidth/2, Y0-H_Wind+LY+20}, GRA_OUTLINEFILL, 7, 7 ) // Прямоугольник очерчен, заполнен и закруглен graBox( oPS, { IndentLeft+2*Area-BoxWidth/2, Y_MaxW-140 }, {IndentLeft+2*Area+BoxWidth/2, Y0-H_Wind+LY+20}, GRA_OUTLINEFILL, 7, 7 ) // Прямоугольник очерчен, заполнен и закруглен ***** Нарисовать рамку изображения и отделить место для легенды ******************* aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты ****** Начало координат в центре рисунка * GraArc ( oPS, { X0, Y0 }, 5 ) // Начало координат GraLine( oPS, {X0-W_Wind+1, Y0-H_Wind+1}, {X0-W_Wind+1, Y0+H_Wind-1} ) // Нарисовать границу рамки изображения слева GraLine( oPS, {X0+W_Wind-1, Y0-H_Wind+1}, {X0+W_Wind-1, Y0+H_Wind-1} ) // Нарисовать границу рамки изображения справа GraLine( oPS, {X0-W_Wind+1, Y0-H_Wind+1}, {X0+W_Wind-1, Y0-H_Wind+1} ) // Нарисовать границу рамки изображения внизу параллельно оси X GraLine( oPS, {X0-W_Wind+1, Y0+H_Wind-1}, {X0+W_Wind-1, Y0+H_Wind-1} ) // Нарисовать границу рамки изображения вверху параллельно оси X GraLine( oPS, {X0-W_Wind+1, Y0-H_Wind+LY}, {X0+W_Wind-1, Y0-H_Wind+LY} ) // Нарисовать границу рамки легенды на уровне LY параллельно оси X **** Написать заголовок диаграммы aFonts := XbpFont():new():list() // Все доступные шрифты mMess = 'SWOT-ДИАГРАММА ЗНАЧЕНИЯ ФАКТОРА В МОДЕЛИ: "'+UPPER(Ar_Model[mNumMod])+'"' oFont := XbpFont():new():create("22.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт * aTxtPar = DC_GraQueryTextbox(mMess, oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox('STOP-22='+STR(aTxtPar[1])) aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraStringAt( oPS, { X_MaxW/2, Y_MaxW-20 }, mMess) oFont := XbpFont():new():create("18.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) IF LEN(ALLTRIM(M_NameAppl)) < 70 GraStringAt( oPS, { X_MaxW/2, Y_MaxW-50 }, "Приложение: "+'"'+ALLTRIM(M_NameAppl)+'"' ) ELSE GraStringAt( oPS, { X_MaxW/2, Y_MaxW-50 }, '"'+ALLTRIM(M_NameAppl)+'"' ) ENDIF ***** Отобразить наименование градации фактора CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Opis_Sc EXCLUSIVE NEW USE Gr_OpSc EXCLUSIVE NEW USE Class_Sc EXCLUSIVE NEW SELECT Gr_OpSc;N_Col = RECCOUNT() DBGOTO(mKodAtr) mNameGrOS = ALLTRIM(Name_GrOS) mKodOpSc = Kod_OpSc mKodGrOS = Kod_GrOS SELECT Opis_Sc DBGOTO(mKodOpSc) mNameOpSc = ALLTRIM(Name_OpSc) GraStringAt( oPS, { X_MaxW/2, Y_MaxW- 85 }, "Фактор: ["+ALLTRIM(STR(mKodOpSc))+"] "+mNameOpSc ) GraStringAt( oPS, { X_MaxW/2, Y_MaxW-110 }, "Значение: ["+ALLTRIM(STR(mKodAtr ))+"] "+DelZeroNameGr(mNameGrOS) ) *********** Отобразить заголовки для левого и правого инф.портретов oFont := XbpFont():new():create("12.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_RED aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) GraStringAt( oPS, { IndentLeft+0*Area , Y_MaxW-130 }, "Состояния, которым данное знач.фактора СПОСОБСТВУЕТ:" ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLUE GraSetAttrString( oPS, aAttrF ) GraStringAt( oPS, { IndentLeft+2*Area+BoxWidth/2, Y_MaxW-130 }, "Состояния, которым данное знач.фактора ПРЕПЯТСТВУЕТ:" ) ****** Фильтры по классам, если .F. - фильтра нет ****** mFltrFlag449 = .T./.F. , если .T., то: SET FILTER TO mKodClSc449 = Kod_ClSc SELECT Class_Sc IF mFltrLeftFlag449 DBGOTO(mKodClScLeft449) MKodGrMin1 = KodGr_min MKodGrMax1 = KodGr_max mNameClSc1 = ALLTRIM(Name_ClSc) MessLeft = "Фильтр по классам: ["+ALLTRIM(STR(mKodClScLeft449))+"] "+mNameClSc1+": "+ALLTRIM(STR(MKodGrMin1))+"-"+ALLTRIM(STR(MKodGrMax1)) ELSE DBGOTOP() ;MKodGrMin1 = KodGr_min DBGOBOTTOM();MKodGrMax1 = KodGr_max mNameClSc1 = "ВСЕ КЛАССЫ:" MessLeft = "Фильтр по классам ВЫКЛЮЧЕН. Диапазон кодов: "+ALLTRIM(STR(MKodGrMin1))+"-"+ALLTRIM(STR(MKodGrMax1)) ENDIF IF mFltrRightFlag449 DBGOTO(mKodClScRight449) MKodGrMin2 = KodGr_min MKodGrMax2 = KodGr_max mNameClSc2 = ALLTRIM(Name_ClSc) MessRight = "Фильтр по классам: ["+ALLTRIM(STR(mKodClScRight449))+"] "+mNameClSc2+": "+ALLTRIM(STR(MKodGrMin2))+"-"+ALLTRIM(STR(MKodGrMax2)) ELSE DBGOTOP() ;MKodGrMin2 = KodGr_min DBGOBOTTOM();MKodGrMax2 = KodGr_max mNameClSc2 = "ВСЕ КЛАССЫ:" MessRight = "Фильтр по классам ВЫКЛЮЧЕН. Диапазон кодов: "+ALLTRIM(STR(MKodGrMin2))+"-"+ALLTRIM(STR(MKodGrMax2)) ENDIF aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK GraSetAttrString( oPS, aAttrF ) GraStringAt( oPS, { IndentLeft+0*Area , Y0-H_Wind+LY+10 }, SUBSTR(MessLeft ,1, 70) ) GraStringAt( oPS, { IndentLeft+2*Area+BoxWidth/2, Y0-H_Wind+LY+10 }, SUBSTR(MessRight,1, 70) ) ***** Легенда ********************************* oFont := XbpFont():new():create("13.ArialBold") GraSetFont( oPS ,oFont ) aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты AxName = "ВЛИЯНИЕ ДАННОГО ЗНАЧЕНИЯ ФАКТОРА НА ПЕРЕХОД ОБЪЕКТА УПРАВЛЕНИЯ В СОСТОЯНИЯ, СООТВЕТСТВУЮЩИЕ КЛАССАМ:" GraStringAt( oPS, { 20, LY-15 }, AxName ) AxName = "Состояния объекта управления (классы), переходу в которые данное значение фактора СПОСОБСТВУЕТ, отображается линиями связи КРАСНОГО цвета. Толщина линии отражает степень влияния." GraStringAt( oPS, { 200, LY-35 }, AxName ) AxName = "Состояния объекта управления (классы), переходу в которые данное значение фактора ПРЕПЯТСТВУЕТ, отображается линиями связи СИНЕГО цвета. Толщина линии отражает степень влияния." GraStringAt( oPS, { 200, LY-55 }, AxName ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_DARKRED GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты AxName = "Форма создана: "+DTOC(DATE())+"-"+TIME() GraStringAt( oPS, { IndentLeft+2*Area+BoxWidth/2, LY-15 }, AxName ) **** Нарисовать сами линии **** mSxodstvo > 0 aAttr := Array( GRA_AL_COUNT ) // атрибуты линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := GRA_CLR_RED aAttr [ GRA_AL_WIDTH ] := 7 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraLine(oPS, { 23, LY-35 }, { 170, LY-35 } ) // Нарисовать линию заданных толщины и цвета **** mSxodstvo < 0 aAttr := Array( GRA_AL_COUNT ) // атрибуты линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := GRA_CLR_BLUE aAttr [ GRA_AL_WIDTH ] := 7 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraLine(oPS, { 23, LY-55 }, { 170, LY-55 } ) // Нарисовать линию заданных толщины и цвета ***** РИСОВАНИЕ ПРЯМОУГОЛЬНИКОВ ПРИЗНАКОВ ЛЕВОГО И ПРАВОГО ИНФ.ПОРТРЕТОВ И НАДПИСЕЙ В НИХ *********** mMaxAtrInfPort = 7 // Максимальное количество отображаемых на диаграмме признаков в инф.портрете ***** Расчет промежутка между прямоугольниками признаков mSWOTName = "SWOTAtr"+STRTRAN(STR(mKodAtr,4)," ","0")+Ar_Model[mNumMod] CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mSWOTName) EXCLUSIVE NEW SELECT (mSWOTName) *** Определение наиболее сильной по модулю связи для нормировки толщины линии DBGOTOP() mMaxZnachBit = MAX(ABS(Znach1), ABS(Znach2)) // Максимальное по модулю влияние в bit для нормировки силы связи на изображении mMaxZnachPix = 20 // Максимальная по модулю сила связи в pix для нормировки силы связи на изображении mKnorm = mMaxZnachPix/mMaxZnachBit // Коэффициент нормировки и преобразования силы связи из bit в pix ******** Вывод наименований обобщ.и первичных признаков **** ************************************************************************************************************************* *** Фильтр для левого портрета ****************************************************************************************** ************************************************************************************************************************* CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mSWOTName) EXCLUSIVE NEW USE InfPortAtrPos EXCLUSIVE NEW SELECT InfPortAtrPos IF mFltrLeftFlag449 SET FILTER TO mKodClScLeft449 = Kod_ClSc ENDIF COUNT TO N_ClsPos *** Определение количества значений факторов в левом и правом инф.портретах N_Cls1 = IF(N_ClsPos<=7, N_ClsPos, 7) // Количество признаков в левом портрете N_Cls2 = IF(N_ClsNeg<=7, N_ClsNeg, 7) // Количество признаков в правом портрете Y_cls = (Y_MaxW-140) - (Y0-H_Wind+LY+20) // Высота зоны для информации о признаках BoxOffset = 10 // Отступ прямоугльников от границ зон рисования и текстов внутри прямоугольников от их границ BoxHeight = 85 // Высота прямоугольника в пикселях BoxWidth = 140 // Ширина прямоугольника CYAN в пикселях BoxWidth = BoxWidth - BoxOffset*2 // Ширина прямоугольника в пикселях DeltaY1 = (Y_cls-BoxHeight*N_Cls1)/(N_Cls1+1) DeltaY2 = (Y_cls-BoxHeight*N_Cls2)/(N_Cls2+1) DBGOTOP() mNumPp = 0 DO WHILE mNumPp < N_Cls1 .AND. .NOT. EOF() // Цикл по связям. Ограничить кол-во отображаемых связей макс.возможным 7 ++mNumPp mRecno = RECNO() SELECT (mSWOTName) DBGOTO(mRecno) ******* РИСОВАНИЕ ПРЯМОУГОЛЬНИКОВ ПРИЗНАКОВ ЛЕВОГО ИНФ.ПОРТРЕТА *********** *** ЛЕВЫЙ *** y1 = (Y_MaxW-140) - DeltaY1 - (BoxHeight+DeltaY1) * (mNumPp-1) ******** Атрибуты области aAttrBox := ARRAY( GRA_AA_COUNT ) // Определить атрибуты заполнения прямоугольника aAttrBox[ GRA_AA_COLOR ] := IF(Znach1>0,BD_LIGHTYELLOW, BD_LIGHTGREEN) // Цвет согласно _AidosColor.exe GraSetAttrArea( oPS, aAttrBox ) ******** Атрибуты границы области (линии) aAttrLine := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttrLine [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttrLine [ GRA_AL_COLOR ] := IF(Znach1>0,GRA_CLR_DARKRED, GRA_CLR_DARKBLUE) // Задать цвет линии aAttrLine [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttrLine ) // Установить атрибуты graBox( oPS, { IndentLeft+1*Area-BoxWidth/2, y1 }, { IndentLeft+1*Area+BoxWidth/2 , y1-BoxHeight }, GRA_OUTLINEFILL, 0, 0 ) // Малый. Прямоугольник очерчен, заполнен и закруглен graBox( oPS, { IndentLeft+0*Area+BoxOffset , y1 }, { IndentLeft+1*Area-BoxWidth/2-2*BoxOffset, y1-BoxHeight }, GRA_OUTLINEFILL, 0, 0 ) // Большой. Прямоугольник очерчен, заполнен и закруглен ******* РИСОВАНИЕ НАДПИСЕЙ В ПРЯМОУГОЛЬНИКАХ ПРИЗНАКОВ ********************************* *** ЛЕВЫЙ *** * aTxtPar = DC_GraQueryTextbox('Eugene Lutsenko','10.Arial') // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов oFont := XbpFont():new():create("12.Arial") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := IF(Znach1>0,GRA_CLR_DARKRED, GRA_CLR_DARKBLUE) // Задать цвет шрифта aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) ***** Цикл определения такой длины строки, которая помещается в рамку ***** Массив отображаемых в рамке строк, включающий наименования и описательных шкал и их градаций ***** Из текстового буфера к отображаемому элементу массива добавляется по одному символу и определяется его длина в пикселях. ***** Если не хватает длины рамки - добавляется строка в массив. Отображение градации шкалы всегда начинается с новой строки. mZone = 50 // Размер зоны отображения в символах aMess := {} // Массив отображаемых в рамке строк, включающий наименования и описательных шкал и их градаций AADD(aMess, L(" "));s=1 // 1-й элемент - 1-я строка mBuff1 = "["+ALLTRIM(STR(Kod_ClSc1))+"] "+ALLTRIM(Name_ClSc1) FOR j=1 TO LEN(mBuff1) * aTxtPar = DC_GraQueryTextbox(aMess[s] + SUBSTR(mBuff1,j,1), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов IF LEN(aMess[s] + SUBSTR(mBuff1,j,1)) <= mZone aMess[s] = aMess[s] + SUBSTR(mBuff1,j,1) // Полное наименование описательной шкалы посылается в буфер для отображения ELSE IF s < 2 AADD(aMess, SUBSTR(mBuff1,j,1)) s++ ELSE EXIT ENDIF ENDIF NEXT ***** Цикл определения такой длины строки, которая помещается в рамку AADD(aMess, L(" ")) s++ mBuff2 = "["+ALLTRIM(STR(Kod_Cls1 ))+"] "+DelZeroNameGr(Name_GrCS1) // Буфер. Из буфера добавляется по олному символу в отображаемый элемент массива FOR j=1 TO LEN(mBuff2) IF LEN(aMess[s] + SUBSTR(mBuff1,j,1)) <= mZone aMess[s] = aMess[s] + SUBSTR(mBuff2,j,1) // Полное наименование описательной шкалы посылается в буфер для отображения ELSE IF s < 4 AADD(aMess, SUBSTR(mBuff2,j,1)) s++ ELSE EXIT ENDIF ENDIF NEXT *** Отображение ***** y1 = (Y_MaxW-140) - DeltaY1 - (BoxHeight+DeltaY1) * (mNumPp-1) mInterval = 18 // Межстрочный интервал в пикселях. 1 - строки пишутся без пропуска FOR s=1 TO LEN(aMess) GraStringAt( oPS, { IndentLeft+0*Area+BoxOffset*2, y1-15-(s-1)*mInterval }, aMess[s] ) NEXT ***** Надписи в маленьких прямоугольниках внутри голубых прямоугольников с информацией по признакам oFont := XbpFont():new():create("12.ArialBold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := IF(Znach1>0,GRA_CLR_DARKRED, GRA_CLR_DARKBLUE) // Задать цвет шрифта aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) * graBox( oPS, { IndentLeft+1*Area-BoxWidth/2, y1 }, { IndentLeft+1*Area+BoxWidth/2, y1-BoxHeight }, GRA_OUTLINEFILL, 0, 0 ) // Малый левый. Прямоугольник очерчен, заполнен и закруглен mInterval = 21 // Межстрочный интервал в пикселях. 1 - строки пишутся без пропуска GraStringAt( oPS, { IndentLeft+1*Area-BoxWidth/2+BoxOffset, y1-mInterval*2 }, "I="+ALLTRIM(STR(Znach1,19,3))+IF(mNumMod=4," bit", "") ) SELECT InfPortAtrPos DBSKIP(1) ENDDO ***** РИСОВАНИЕ ЛИНИЙ ОТНОШЕНИЙ (СВЯЗЕЙ) ПРИЗНАКОВ ЛЕВОГО ИНФ.ПОРТРЕТА *********** x1 = IndentLeft+1*Area+BoxWidth/2+BoxOffset x2 = IndentLeft+2*Area-BoxWidth/2-BoxOffset oFont := XbpFont():new():create("10.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт mNumPp = 0 DBGOTOP() DO WHILE mNumPp < N_Cls1 .AND. .NOT. EOF() // Цикл по связям. Ограничить кол-во отображаемых связей макс.возможным 7 ++mNumPp mRecno = RECNO() SELECT (mSWOTName) DBGOTO(mRecno) y1 = (Y_MaxW-140) - DeltaY1 - (BoxHeight+DeltaY1) * (mNumPp-1) - BoxHeight/2 y2 = (Y_MaxW-140) - DeltaY2 - (BoxHeight+DeltaY2) * (mNumPp-1) - BoxHeight/2 ******** Атрибуты границы области (линии) aAttrLine := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttrLine [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttrLine [ GRA_AL_COLOR ] := IF(Znach1>0,BD_CANDYRED, BD_RICHBLUE) // Задать цвет линии согласно _AidosColor.exe aAttrLine [ GRA_AL_WIDTH ] := mKnorm * ABS(Znach1) // Задать толщину линии (нормированную) graSetAttrLine( oPS, aAttrLine ) // Установить атрибуты GraLine( oPS, { x1, y1 }, { X_MaxW/2, Y_MaxW-120-2*mMaxZnachPix } ) // Нарисовать линию связи заданной толщины и цвета SELECT InfPortAtrPos DBSKIP(1) ENDDO ************************************************************************************************************************* *** Фильтр для правого портрета ***************************************************************************************** ************************************************************************************************************************* CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mSWOTName) EXCLUSIVE NEW USE InfPortAtrNeg EXCLUSIVE NEW SELECT InfPortAtrNeg IF mFltrRightFlag449 SET FILTER TO mKodClScRight449 = Kod_ClSc ENDIF COUNT TO N_ClsNeg *** Определение количества значений факторов в левом и правом инф.портретах N_Cls1 = IF(N_ClsPos<=7, N_ClsPos, 7) // Количество признаков в левом портрете N_Cls2 = IF(N_ClsNeg<=7, N_ClsNeg, 7) // Количество признаков в правом портрете Y_cls = (Y_MaxW-140) - (Y0-H_Wind+LY+20) // Высота зоны для информации о признаках BoxOffset = 10 // Отступ прямоугльников от границ зон рисования и текстов внутри прямоугольников от их границ BoxHeight = 85 // Высота прямоугольника в пикселях BoxWidth = 140 // Ширина прямоугольника CYAN в пикселях BoxWidth = BoxWidth - BoxOffset*2 // Ширина прямоугольника в пикселях DeltaY1 = (Y_cls-BoxHeight*N_Cls1)/(N_Cls1+1) DeltaY2 = (Y_cls-BoxHeight*N_Cls2)/(N_Cls2+1) SELECT InfPortAtrNeg DBGOTOP() mNumPp = 0 DO WHILE mNumPp < N_Cls2 .AND. .NOT. EOF() // Цикл по связям. Ограничить кол-во отображаемых связей макс.возможным 7 ++mNumPp mRecno = RECNO() SELECT (mSWOTName) DBGOTO(mRecno) ******* РИСОВАНИЕ ПРЯМОУГОЛЬНИКОВ ПРИЗНАКОВ ЛЕВОГО И ПРАВОГО ИНФ.ПОРТРЕТОВ *********** *** ПРАВЫЙ *** y2 = (Y_MaxW-140) - DeltaY2 - (BoxHeight+DeltaY2) * (mNumPp-1) ******** Атрибуты области aAttrBox := ARRAY( GRA_AA_COUNT ) // Определить атрибуты заполнения прямоугольника aAttrBox[ GRA_AA_COLOR ] := IF(Znach2>0,BD_LIGHTYELLOW, BD_LIGHTGREEN) // Цвет согласно _AidosColor.exe GraSetAttrArea( oPS, aAttrBox ) ******** Атрибуты границы области (линии) aAttrLine := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttrLine [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttrLine [ GRA_AL_COLOR ] := IF(Znach2>0,GRA_CLR_DARKRED, GRA_CLR_DARKBLUE) // Задать цвет линии aAttrLine [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttrLine ) // Установить атрибуты graBox( oPS, { IndentLeft+2*Area-BoxWidth/ 2, y2 }, { IndentLeft+2*Area+BoxWidth/2, y2-BoxHeight }, GRA_OUTLINEFILL, 0, 0 ) // Малый. Прямоугольник очерчен, заполнен и закруглен graBox( oPS, { IndentLeft+2*Area+BoxWidth/2+2*BoxOffset, y2 }, { IndentLeft+3*Area-BoxOffset , y2-BoxHeight }, GRA_OUTLINEFILL, 0, 0 ) // Большой. Прямоугольник очерчен, заполнен и закруглен ******* РИСОВАНИЕ НАДПИСЕЙ В ПРЯМОУГОЛЬНИКАХ ПРИЗНАКОВ ********************************* *** ПРАВЫЙ *** * aTxtPar = DC_GraQueryTextbox('Eugene Lutsenko','10.Arial') // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов oFont := XbpFont():new():create("12.Arial") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := IF(Znach2>0,GRA_CLR_DARKRED, GRA_CLR_DARKBLUE) // Задать цвет шрифта aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) ***** Цикл определения такой длины строки, которая помещается в рамку ***** Массив отображаемых в рамке строк, включающий наименования и описательных шкал и их градаций ***** Из текстового буфера к отображаемому элементу массива добавляется по одному символу и определяется его длина в пикселях. ***** Если не хватает длины рамки - добавляется строка в массив. Отображение градации шкалы всегда начинается с новой строки. mZone = 50 // Размер зоны отображения в символах aMess := {} // Массив отображаемых в рамке строк, включающий наименования и описательных шкал и их градаций AADD(aMess, L(" "));s=1 // 1-й элемент - 1-я строка mBuff1 = "["+ALLTRIM(STR(Kod_ClSc2))+"] "+ALLTRIM(Name_ClSc2) FOR j=1 TO LEN(mBuff1) * aTxtPar = DC_GraQueryTextbox(aMess[s] + SUBSTR(mBuff1,j,1), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов IF LEN(aMess[s] + SUBSTR(mBuff1,j,1)) <= mZone aMess[s] = aMess[s] + SUBSTR(mBuff1,j,1) // Полное наименование описательной шкалы посылается в буфер для отображения ELSE IF s < 2 AADD(aMess, SUBSTR(mBuff1,j,1)) s++ ELSE EXIT ENDIF ENDIF NEXT ***** Цикл определения такой длины строки, которая помещается в рамку AADD(aMess, L(" ")) s++ mBuff2 = "["+ALLTRIM(STR(Kod_Cls2 ))+"] "+DelZeroNameGr(Name_GrCS2) // Буфер. Из буфера добавляется по олному символу в отображаемый элемент массива FOR j=1 TO LEN(mBuff2) IF LEN(aMess[s] + SUBSTR(mBuff2,j,1)) <= mZone aMess[s] = aMess[s] + SUBSTR(mBuff2,j,1) // Полное наименование описательной шкалы посылается в буфер для отображения ELSE IF s < 4 AADD(aMess, SUBSTR(mBuff2,j,1)) s++ ELSE EXIT ENDIF ENDIF NEXT *** Отображение ***** y1 = (Y_MaxW-140) - DeltaY2 - (BoxHeight+DeltaY2) * (mNumPp-1) mInterval = 18 // Межстрочный интервал в пикселях. 1 - строки пишутся без пропуска FOR s=1 TO LEN(aMess) GraStringAt( oPS, { IndentLeft+2*Area+BoxWidth/2+3*BoxOffset, y1-15-(s-1)*mInterval }, aMess[s] ) NEXT ***** Надписи в маленьких прямоугольниках внутри голубых прямоугольников с информацией по признакам oFont := XbpFont():new():create("12.ArialBold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := IF(Znach2>0,GRA_CLR_DARKRED, GRA_CLR_DARKBLUE) // Задать цвет шрифта aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) * graBox( oPS, { IndentLeft+2*Area-BoxWidth/2, y2 }, { IndentLeft+2*Area+BoxWidth/2, y2-BoxHeight }, GRA_OUTLINEFILL, 0, 0 ) // Малый правый. Прямоугольник очерчен, заполнен и закруглен mInterval = 21 // Межстрочный интервал в пикселях. 1 - строки пишутся без пропуска GraStringAt( oPS, { IndentLeft+2*Area-BoxWidth/2+BoxOffset, y2-mInterval*2 }, "I="+ALLTRIM(STR(Znach2,19,3))+IF(mNumMod=4," bit", "") ) SELECT InfPortAtrNeg DBSKIP(1) ENDDO ***** РИСОВАНИЕ ЛИНИЙ ОТНОШЕНИЙ (СВЯЗЕЙ) ПРИЗНАКОВ ЛЕВОГО И ПРАВОГО ИНФ.ПОРТРЕТА *********** x1 = IndentLeft+1*Area+BoxWidth/2+BoxOffset x2 = IndentLeft+2*Area-BoxWidth/2-BoxOffset oFont := XbpFont():new():create("10.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт mNumPp = 0 DBGOTOP() DO WHILE mNumPp < N_Cls2 .AND. .NOT. EOF() // Цикл по связям. Ограничить кол-во отображаемых связей макс.возможным 7 ++mNumPp mRecno = RECNO() SELECT (mSWOTName) DBGOTO(mRecno) y1 = (Y_MaxW-140) - DeltaY1 - (BoxHeight+DeltaY1) * (mNumPp-1) - BoxHeight/2 y2 = (Y_MaxW-140) - DeltaY2 - (BoxHeight+DeltaY2) * (mNumPp-1) - BoxHeight/2 ******** Атрибуты границы области (линии) aAttrLine := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttrLine [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttrLine [ GRA_AL_COLOR ] := IF(Znach2>0,BD_CANDYRED, BD_RICHBLUE) // Задать цвет линии согласно _AidosColor.exe aAttrLine [ GRA_AL_WIDTH ] := mKnorm * ABS(Znach2) // Задать толщину линии (нормированную) graSetAttrLine( oPS, aAttrLine ) // Установить атрибуты GraLine( oPS, { x2, y2 }, { X_MaxW/2, Y_MaxW-120-2*mMaxZnachPix } ) // Нарисовать линию связи заданной толщины и цвета SELECT InfPortAtrNeg DBSKIP(1) ENDDO ******************************************************************************************* *** Нарисовать окружности в начале линий связи ******************************************** ******************************************************************************************* IF SUBSTR(mNameOpSc,1,12) = 'SPECTRINTERV' ******* Если спектральный АСК-анализ изображений *************** aRGBAtr := {} // Массив цветов признаков, если спектр FOR j = 1 TO N_Col mNameAtr = ALLTRIM(mNameGrOS) * SpectrInterv: 999/999-{123,123,123} * 123456789012 R G B mPosR1 = AT('{', mNameAtr)+1 mPosR2 = mPosR1+2 mPosG1 = mPosR2+2 mPosG2 = mPosG1+2 mPosB1 = mPosG2+2 mPosB2 = mPosB1+2 mRed = VAL(SUBSTR(mNameAtr, mPosR1, mPosR2-mPosR1+1)) mGreen = VAL(SUBSTR(mNameAtr, mPosG1, mPosG2-mPosG1+1)) mBlue = VAL(SUBSTR(mNameAtr, mPosB1, mPosB2-mPosB1+1)) * MsgBox(mScName+' '+STR(mRed)+','+STR(mGreen)+','+STR(mBlue)) fColor := GraMakeRGBColor({ mRed, mGreen, mBlue}) * SetPixel(hDC1, x, y, AutomationTranslateColor(fColor,.f.) ) * AADD(aRGBAtr, AutomationTranslateColor(fColor,.f.)) AADD(aRGBAtr, fColor) NEXT GraSetColor( oPS, aRGBAtr[mKodGrOS] , aRGBAtr[mKodGrOS] ) // Цвет фона для текста - цвет цветового диапазона FOR R=0 TO 2*mMaxZnachPix STEP 0.5 aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT * aAttr [ GRA_AL_COLOR ] := BD_CANDYRED // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты GraArc ( oPS, { X_MaxW/2, Y_MaxW-120-3*mMaxZnachPix }, R ) NEXT ELSE FOR R=0 TO 2*mMaxZnachPix IF R=2*INT(R/2) aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := BD_CANDYRED // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 2 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты ELSE aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := BD_RICHBLUE // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 2 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты ENDIF GraArc ( oPS, { X_MaxW/2, Y_MaxW-120-3*mMaxZnachPix }, R ) NEXT ENDIF R = 2*mMaxZnachPix aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := BD_BLACK // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 2 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты GraArc ( oPS, { X_MaxW/2, Y_MaxW-120-3*mMaxZnachPix }, R ) ********* Записать файл изображения с именем - код левого класса + код правого класса + номер модели в папке SWOTDiagrAtr IF FILEDATE("SWOTDiagrAtr",16) = CTOD("//") DC_Impl(oScr) DIRMAKE("SWOTDiagrAtr") aMess := {} AADD(aMess, L('В папке текущего приложения: "'+UPPER(ALLTRIM(M_PathAppl))+'"')) AADD(aMess, L('не было директории "SWOTDiagrAtr" для SWOT-диаграмм признаков и она была создана!')) AADD(aMess, L('В эту папку записываются исходные изображения высокого качества (без масштабирования)')) LB_Warning(aMess, L('4.4.9. Количественный SWOT-анализ градаций факторов средствами АСК-анализа' )) oScr := DC_WaitOn('Немного подождите! Идет формирование изображения в памяти и его масштабирование',,,,,,,,,,,.F.) ENDIF * DC_ASave(mClsLeft , "_ClsLeft.arx") // Код левого класса * DC_ASave(mClsRight, "_ClsRight.arx") // Код правого класса * DC_ASave(mNumMod , "_NumMod.arx") mClsLeft = DC_ARestore("_ClsLeft.arx") mClsRight = DC_ARestore("_ClsRight.arx") mNumMod = DC_ARestore("_NumMod.arx") IF mPar = 'Screen' DIRCHANGE(M_PathAppl+"\SWOTDiagrAtr\") // Перейти в папку SWOTDiagrAtr cFileName = "SWOTDiagrAtr"+STRTRAN(STR(mKodAtr,4)," ","0")+"-"+STRTRAN(STR(mNumMod,2)," ","0")+".bmp" ERASE(cFileName) DC_Scrn2ImageFile( oStatic, cFileName ) ENDIF DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения RETURN NIL ******************************************************************************************************************* ******************************************************************************************************************* ******** 4.4.10.Графическое отображение нелокальных нейронов. (Аналогичен режиму 6.5 DOS-версии системы Эйдос) ******** ЭКРАННАЯ ФОРМА ДЛЯ ДИАЛОГА: ******** Отметить в колонке любым символом классы для отображения в форме нейронов. Кнопки: "Выбрать все" "Очистить" ******** Сортировать рецепторы по информативности (как в инф. портрете класса) или по модулю информативности ******** Отображать с наименованиями рецепторов или только с кодами ******** Отображать не более #### рецепторов ******** Порог силы связи рецепторов ### ******** Задать модель: abs, per#, inf# ******************************************************************************************************************* FUNCTION F4_4_10() LOCAL GetList := {}, aPres, oBrowse, oToolBar, aColors, bColor, GetOptions Running(.T.) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF ApplChange("4.4.10()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF ***** Проверка на наличие основных БД всех моделей и определение времени их создания. ***** Если оно не изменилось со времени предыдущего применения режима 4_2_1, то копировать txt=>dbf не надо Ar_Model := {"Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } Flag = .F. FOR z=1 TO LEN(Ar_Model) IF .NOT. FILE(Ar_Model[z]+'.txt') Mess = L('Модель: "#" отсутствует. Необходимо провести расчет моделей в 3-й подсистеме !!!') Mess = STRTRAN(Mess, '#', Ar_Model[z]) LB_Warning( Mess, L('4.2.1. Информационные портреты классов' )) Flag = .T. EXIT ENDIF NEXT IF Flag // Если какой-нибудь БД нет, то режим не запускать ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF mLenNameMax = CreateStructAll() // Создание файлов структур баз данных всех моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() // Количество классов (градаций классификационных шкал) USE Gr_OpSc EXCLUSIVE NEW;N_Gos = RECCOUNT() // Количество признаков (градаций описательных шкал) USE Opis_Sc EXCLUSIVE NEW * ########################################################################### // Открытие текстовых баз данных ******************************************** *DC_ASave(aInfStruct, "_InfStruct.arx") // Когда БД создается - записывать структуру, когда открывается - считывать aInfStruct := DC_ARestore("_InfStruct.arx") *DC_ASave(aStrEmpty, "_aStrEmpty.arx") // Записывать только после расчета Abs.txt, а при расчете остальных БД только считывать *DC_ASave(aColEmpty, "_aColEmpty.arx") aStrEmpty = DC_ARestore("_aStrEmpty.arx") aColEmpty = DC_ARestore("_aColEmpty.arx") ************************************************* ***** Формирование пустой записи N_Col = N_Cls+6 // Число полей CrLf = CHR(13)+CHR(10) // Конец строки (записи) Lc_buf = "" FOR j=1 TO N_Col * S = IF(j=2*INT(j/2),"#","X") // Для отладки S = " " // Для работы Lc_buf = Lc_buf + REPLICATE(S, aInfStruct[j,3]) NEXT Lc_buf = Lc_buf + CrLf PUBLIC Len_LcBuf := LEN(Lc_buf) ****** Открываем стат.базы и базы знаний (7 по частным критериям знаний) Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } PUBLIC nHandle[LEN(Ar_Model)] FOR z=1 TO LEN(Ar_Model) nHandle[z] := FOpen( Ar_Model[z]+".txt", FO_READWRITE ) // Открыть все текстовые базы данных ######################################## NEXT **** Рассчет массива начальных позиций полей в строке PUBLIC aPos[N_Col] aPos[1] = 1 FOR j=2 TO N_Col aPos[j] = aPos[j-1] + aInfStruct[j-1,3] NEXT * ########################################################################### ************************************************************* // Определить максимальную длину наименования: ОПИСАТЕЛЬНАЯ ШКАЛА-градация CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Gr_OpSc EXCLUSIVE NEW USE Opis_Sc EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW SELECT Gr_OpSc PUBLIC mLenMaxGOS := -9999999 DBGOTOP() DO WHILE .NOT. EOF() mLenMaxGOS = MAX(mLenMaxGOS, LEN(Name_GrOS)) DBSKIP(1) ENDDO SELECT Opis_Sc PUBLIC mLenMaxOS := -9999999 DBGOTOP() DO WHILE .NOT. EOF() mLenMaxOS = MAX(mLenMaxOS, LEN(Name_OpSc)) DBSKIP(1) ENDDO SELECT Attributes PUBLIC mLenMaxAtr := 33 DBGOTOP() DO WHILE .NOT. EOF() mLenMaxAtr = MAX(mLenMaxAtr, LEN(Name_atr)) DBSKIP(1) ENDDO // Сформировать пустую БД InfPortCls, как часть БД Attributes aStr := { { "Kod_atr" , "N", 15, 0 }, ; { "Name_atr" , "C", mLenMaxAtr, 0 }, ; { "Znach" , "N", 19, 7 }, ; { "Kod_OpSc" , "N", 15, 0 }, ; { "Fltr_Wind", "C", 1, 0 } } // Для фильтра "Вписать в окно" DbCreate( "InfPortCls" , aStr ) DbCreate( "InfPortClsPos", aStr ) DbCreate( "InfPortClsNeg", aStr ) DbCreate( "InfPortClsAbs", aStr ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW SELECT Classes mLenMaxCls = -99999 DBGOTOP() DO WHILE .NOT. EOF() mLenMaxCls = MAX(mLenMaxCls, LEN(ALLTRIM(NAME_CLS))) DBSKIP(1) ENDDO aStr := { { "KOD_ClS" , "N", 15 , 0 },; { "NAME_ClS", "C",mLenMaxCls, 0 },; { "tag" , "L", 2 , 0 } } DbCreate( 'ClassNeuro.dbf', aStr ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW USE ClassNeuro EXCLUSIVE NEW;ZAP SELECT Classes *SET FILTER TO Abs+Int_inf > 0 DBGOTOP() DO WHILE .NOT. EOF() mKodClS = KOD_ClS mNameClS = NAME_ClS SELECT ClassNeuro APPEND BLANK REPLACE KOD_ClS WITH mKodClS REPLACE NAME_ClS WITH mNameClS REPLACE tag WITH .F. SELECT Classes DBSKIP(1) ENDDO CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW USE ClassNeuro EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW USE Gr_OpSc EXCLUSIVE NEW USE Opis_Sc EXCLUSIVE NEW USE InfPortCls EXCLUSIVE NEW USE InfPortClsPos EXCLUSIVE NEW USE InfPortClsNeg EXCLUSIVE NEW USE InfPortClsAbs EXCLUSIVE NEW /* ----- Create ToolBar ----- */ W = 132 // Ширина окна D = 1.5 // Отступ на линейки прокрутки и т.д. P1 = W / 2 // Конечная позиция левого окна P2 = P1 + D // Начальная позиция правого окна ****** Сделать и вывести инф.портрет 1-го класса @0,0 DCGROUP oGroup1 SIZE W+2*D, 33.0 @13, 1 DCSAY {|| MessIPC } OBJECT oSay1 SAYSIZE W FONT "12.Helv Bold" PARENT oGroup1 // Наименование класса и модели в SWOT @14, 1 DCSAY L("АКТИВИРУЮЩИЕ рецепторы и сила их влияния") SAYSIZE W/2 FONT "12.Helv Bold" COLOR GRA_CLR_RED PARENT oGroup1 // Наименование класса и модели в SWOT @14,P2 DCSAY L("ТОРМОЗЯЩИЕ рецепторы и сила их влияния") SAYSIZE W/2 FONT "12.Helv Bold" COLOR GRA_CLR_BLUE PARENT oGroup1 // Наименование класса и модели в SWOT SELECT ClassNeuro DBGOTOP() PUBLIC mFltrLeftFlag44A := .F. PUBLIC mFltrRightFlag44A := .F. FiltrLeft44A(.F.) FiltrRight44A(.F.) InfNeuroCls(6) ******** V Сортировать рецепторы по информативности (как в инф. портрете класса) или по модулю информативности ******** V Отображать с наименованиями рецепторов или только с кодами ******** V Отображать не более #### рецепторов ******** V Порог силы связи рецепторов ### ******** V Задать модель: abs, per#, inf# H = 1.4 @ 27.3, 1 DCTOOLBAR oToolBar SIZE W/2, H PARENT oGroup1 DCADDBUTTON CAPTION L("ВКЛЮЧИТЬ фильтр по фактору") ; SIZE LEN(L("ВКЛЮЧИТЬ фильтр по фактору"))+5 ; ACTION {||FiltrLeft44A(.T.), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION L("ВЫКЛЮЧИТЬ фильтр по фактору") ; SIZE LEN(L("ВЫКЛЮЧИТЬ фильтр по фактору"))+5.5 ; ACTION {||FiltrLeft44A(.F.), DC_GetRefresh(GetList)}; PARENT oToolBar @ 27.3, W/2+D DCTOOLBAR oToolBar SIZE W/2, H PARENT oGroup1 DCADDBUTTON CAPTION L("ВКЛЮЧИТЬ фильтр по фактору") ; SIZE LEN(L("ВКЛЮЧИТЬ фильтр по фактору"))+5 ; ACTION {||FiltrRight44A(.T.), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION L("ВЫКЛЮЧИТЬ фильтр по фактору") ; SIZE LEN(L("ВЫКЛЮЧИТЬ фильтр по фактору"))+5.8 ; ACTION {||FiltrRight44A(.F.), DC_GetRefresh(GetList)}; PARENT oToolBar @ 29.0, 1 DCTOOLBAR oToolBar SIZE 20, H PARENT oGroup1 DCADDBUTTON CAPTION L('Помощь') ; SIZE LEN(L("Помощь"))+5 ; ACTION {||Help44A(), DC_GetRefresh(GetList)} ; PARENT oToolBar @ 30.7, 1 DCTOOLBAR oToolBar SIZE W/2, 1.2*H FONT "9.Helv Bold" PARENT oGroup1 DCADDBUTTON CAPTION L("НЕЙРОН") ; SIZE LEN(L("НЕЙРОН"))+5 ; ACTION {||GraNeuron(), DC_GetRefresh(GetList)}; PARENT oToolBar PUBLIC mViewMax := 999 @30.7, 14.7 DCSAY L("Максимальное количество отображаемых рецепторов:") PARENT oGroup1 @30.7, 55.7 DCGET mViewMax PICTURE "#######" COLOR "n/gb+" PARENT oGroup1 PUBLIC mViewPorog := 0 @31.7, 14.7 DCSAY L("Минимальный вес.коэфф.отображаемых рецепторов:") PARENT oGroup1 @31.7, 55.7 DCGET mViewPorog PICTURE "###.###" COLOR "n/gb+" PARENT oGroup1 @ 29.0, 14.7 DCTOOLBAR oToolBar SIZE W/2, H PARENT oGroup1 DCADDBUTTON CAPTION Ar_Model[1] ; SIZE LEN(Ar_Model[1])+1.9 ; ACTION {||InfNeuroCls(1), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION Ar_Model[2] ; SIZE LEN(Ar_Model[2])+1 ; ACTION {||InfNeuroCls(2), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION Ar_Model[3] ; SIZE LEN(Ar_Model[3])+1 ; ACTION {||InfNeuroCls(3), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION Ar_Model[4] ; SIZE LEN(Ar_Model[4])+1 ; ACTION {||InfNeuroCls(4), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION Ar_Model[5] ; SIZE LEN(Ar_Model[5])+1 ; ACTION {||InfNeuroCls(5), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION Ar_Model[6] ; SIZE LEN(Ar_Model[6])+1 ; ACTION {||InfNeuroCls(6), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION Ar_Model[7] ; SIZE LEN(Ar_Model[7])+1 ; ACTION {||InfNeuroCls(7), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION Ar_Model[8] ; SIZE LEN(Ar_Model[8])+1 ; ACTION {||InfNeuroCls(8), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION Ar_Model[9] ; SIZE LEN(Ar_Model[9])+1 ; ACTION {||InfNeuroCls(9), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION Ar_Model[10] ; SIZE LEN(Ar_Model[10])+1 ; ACTION {||InfNeuroCls(10), DC_GetRefresh(GetList)}; PARENT oToolBar PUBLIC mSort := 1 @ 29.0, W/2+D DCGROUP oGroup2 CAPTION L('Сортировать рецепторы:') SIZE 31.0, 3.5 PARENT oGroup1 @ 1, 2 DCRADIO mSort VALUE 1 PROMPT L('по информативности') PARENT oGroup2 @ 2, 2 DCRADIO mSort VALUE 2 PROMPT L('по модулю информативности') PARENT oGroup2 PUBLIC mViewName := 1 @ 29.0, W/2+D+31.1 DCGROUP oGroup3 CAPTION L('Отображать рецепторы:') SIZE 32.9, 3.5 PARENT oGroup1 @ 1, 2 DCRADIO mViewName VALUE 1 PROMPT L('с наименованиями') PARENT oGroup3 @ 2, 2 DCRADIO mViewName VALUE 2 PROMPT L('только с кодами' ) PARENT oGroup3 /* ----- Create browse Classes ----- */ @ 1, 1 DCSAY L("Выбор нелокального нейрона (класса) для визуализации") SAYSIZE W FONT "12.Helv Bold" PARENT oGroup1 @ 2, 1 DCBROWSE oBrowse ALIAS 'ClassNeuro' SIZE W+0.5, 11 ; HEADLINES 1 ; // Кол-во строк в заголовке (перенос строки - ";") EDIT xbeBRW_ItemSelected MODE DCGUI_BROWSE_EDITDOWN ; PRESENTATION aPres PARENT oGroup1; COLOR {||IIF(2*INT(ClassNeuro->Kod_cls/2)==ClassNeuro->Kod_cls,nil,{nil,GraMakeRGBColor({230,252,213})})} // Вывод строки цветом RGB DCBROWSECOL FIELD ClassNeuro->Kod_cls HEADER L("Код") PARENT oBrowse WIDTH 5 PROTECT {|| .T. } DCBROWSECOL FIELD ClassNeuro->Name_cls HEADER L("Наименование нелокального нейрона (класса)") PARENT oBrowse WIDTH 76.7 PROTECT {|| .T. } /* ----- Create browse InfPortClsPos ----- */ PRIVATE bColorBlockPos:={|| iif(InfPortClsPos->Znach>0,{GRA_CLR_RED,nil},iif(InfPortClsPos->Znach=0,{GRA_CLR_BLACK,nil},{GRA_CLR_BLUE,nil})) } // Клиффорд PRIVATE bColorBlockNeg:={|| iif(InfPortClsNeg->Znach>0,{GRA_CLR_RED,nil},iif(InfPortClsNeg->Znach=0,{GRA_CLR_BLACK,nil},{GRA_CLR_BLUE,nil})) } // Клиффорд *@13, 1 DCSAY {|| MessIPC } OBJECT oSay1 SAYSIZE W FONT "12.Helv Bold") PARENT oGroup1 // Наименование класса и модели в SWOT *@14, 1 DCSAY L("АКТИВИРУЮЩИЕ рецепторы и сила их влияния") SAYSIZE W/2 FONT "12.Helv Bold" COLOR GRA_CLR_RED PARENT oGroup1 // Наименование класса и модели в SWOT *@14,P2 DCSAY L("ТОРМОЗЯЩИЕ рецепторы и сила их влияния") SAYSIZE W/2 FONT "12.Helv Bold" COLOR GRA_CLR_BLUE PARENT oGroup1 // Наименование класса и модели в SWOT @15, 1 DCBROWSE oBrowIpc1 ALIAS 'InfPortClsPos' SIZE W/2, 12; HEADLINES 2 ; // Кол-во строк в заголовке (перенос строки - ";") PRESENTATION aPres PARENT oGroup1 DCSETPARENT oBrowIpc1 DCBROWSECOL FIELD InfPortClsPos->KOD_atr HEADER L('Код') WIDTH 5; COLOR {||IIF(AT('SPECTRINTERV:',InfPortClsPos->NAME_atr)=0,nil,{nil,GraMakeRGBColor({VAL(SUBSTR(InfPortClsPos->NAME_atr, AT('{', InfPortClsPos->NAME_atr)+1, AT('{', InfPortClsPos->NAME_atr)+ 3-AT('{', InfPortClsPos->NAME_atr)+1+1)),VAL(SUBSTR(InfPortClsPos->NAME_atr, AT('{', InfPortClsPos->NAME_atr)+5, AT('{', InfPortClsPos->NAME_atr)+ 7-AT('{', InfPortClsPos->NAME_atr)+5+1)),VAL(SUBSTR(InfPortClsPos->NAME_atr, AT('{', InfPortClsPos->NAME_atr)+9, AT('{', InfPortClsPos->NAME_atr)+11-AT('{', InfPortClsPos->NAME_atr)+9+1))})})} // Вывод поля цветом RGB DCBROWSECOL FIELD InfPortClsPos->NAME_atr HEADER L('Наименование фактора;и его интервального значения') WIDTH 28 DCBROWSECOL DATA {|x|x:=InfPortClsPos->Znach,IIF(Empty(x),'',Str(x,11,3))} HEADER L("Сила;влияния") COLOR bColorBlockPos /* ----- Create browse InfPortClsNeg ----- */ DCSETPARENT TO @15,P2 DCBROWSE oBrowIpc2 ALIAS 'InfPortClsNeg' SIZE W/2, 12 ; HEADLINES 2 ; // Кол-во строк в заголовке (перенос строки - ";") PRESENTATION aPres PARENT oGroup1 DCSETPARENT oBrowIpc2 DCBROWSECOL FIELD InfPortClsNeg->KOD_atr HEADER L('Код') WIDTH 5; COLOR {||IIF(AT('SPECTRINTERV:',InfPortClsNeg->NAME_atr)=0,nil,{nil,GraMakeRGBColor({VAL(SUBSTR(InfPortClsNeg->NAME_atr, AT('{', InfPortClsNeg->NAME_atr)+1, AT('{', InfPortClsNeg->NAME_atr)+ 3-AT('{', InfPortClsNeg->NAME_atr)+1+1)),VAL(SUBSTR(InfPortClsNeg->NAME_atr, AT('{', InfPortClsNeg->NAME_atr)+5, AT('{', InfPortClsNeg->NAME_atr)+ 7-AT('{', InfPortClsNeg->NAME_atr)+5+1)),VAL(SUBSTR(InfPortClsNeg->NAME_atr, AT('{', InfPortClsNeg->NAME_atr)+9, AT('{', InfPortClsNeg->NAME_atr)+11-AT('{', InfPortClsNeg->NAME_atr)+9+1))})})} // Вывод поля цветом RGB DCBROWSECOL FIELD InfPortClsNeg->NAME_atr HEADER L('Наименование фактора;и его интервального значения') WIDTH 27 DCBROWSECOL DATA {|x|x:=InfPortClsNeg->Znach,IIF(Empty(x),'',Str(x,13,3))} HEADER L("Сила;влияния") COLOR bColorBlockNeg DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TITLE L('4.4.10.Графическое отображение нелокального нейрона в системе "Эйдос"') ; // Надпись на окне графика FIT; MODAL; CLEAREVENTS *** Закрыть все текстовые БД ****** FOR z=1 TO LEN(Ar_Model) FClose( nHandle[z] ) // Закрытие текстовой базы данных ###################################### NEXT ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) ReTURN nil ********************************************************************************************************** FUNCTION FiltrLeft44A(Flag44A) SELECT InfPortClsPos PUBLIC mKodOpScLeft44A := Kod_OpSc, mFltrLeftFlag44A := Flag44A IF Flag44A SET FILTER TO mKodOpScLeft44A = Kod_OpSc ELSE SET FILTER TO ENDIF ReTURN nil ******************************* FUNCTION FiltrRight44A(Flag44A) SELECT InfPortClsNeg PUBLIC mKodOpScRight44A := Kod_OpSc, mFltrRightFlag44A := Flag44A IF Flag44A SET FILTER TO mKodOpScRight44A = Kod_OpSc ELSE SET FILTER TO ENDIF ReTURN nil ************************************************************************************************** FUNCTION Help44A() aHelp := {} AADD(aHelp, L('АСК-анализ обеспечивает построение нелокальных нейронов с указанием силы и ')) AADD(aHelp, L('направления влияния активирующих и тормозящих рецепторов непосредственно на')) AADD(aHelp, L('основе эмпирических данных и поэтому может рассматриваться как инструмент ')) AADD(aHelp, L('построения нейронной сети. Классы при этом интерпретируются как нейроны, а ')) AADD(aHelp, L('значения факторов - как рецепторы. Количество информации, содержащееся в ')) AADD(aHelp, L('значениях фактора, рассматривается весовые коэффициенты, отражающие силу и ')) AADD(aHelp, L('направление влияния рецепторов на состояние нейрона. Таким образом, данный ')) AADD(aHelp, L('режим в наглядной и понятной форме отображает систему детерминации будущих ')) AADD(aHelp, L('состояний объекта управления значениями действующих на него факторов. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Луценко Е.В. Системная теория информации и нелокальные интерпретируемые ')) AADD(aHelp, L('нейронные сети прямого счета / Е.В. Луценко // Политематический сетевой ')) AADD(aHelp, L('электронный научный журнал Кубанского государственного аграрного ')) AADD(aHelp, L('университета (Научный журнал КубГАУ) [Электронный ресурс]. - Краснодар: ')) AADD(aHelp, L('КубГАУ, 2003. - №01(001). С. 79 - 91. - IDA [article ID]: 0010301011. - ')) AADD(aHelp, L('Режим доступа: http://ej.kubagro.ru/2003/01/pdf/11.pdf, 0,812 у.п.л. ')) mHelpMax = -999;FOR h=1 TO LEN(aHelp);mHelpMax = MAX(mHelpMax, LEN(ALLTRIM(aHelp[h])));NEXT s=1;d=0.9;@0,0 DCGROUP oGroup1 CAPTION L(' ') SIZE mHelpMax-10, LEN(aHelp)*d+1.5 FOR h=1 TO LEN(aHelp);@s,2 DCSAY aHelp[h] SIZE 0 PARENT ogroup1;s=s+d;NEXT DCREAD GUI TO lExit FIT TITLE L('Помощь по режиму: 4.4.10. (C) Система "ЭЙДОС-X++"') RETURN NIL ************************************************************************************************** ****************************************************************************************************************** ******** Генерация информационных портретов класса в модели Ar_Model[M_CurrInf]: ******** - классического, т.е. с сортировкой по информативности (InfPortCls); ******** - с сортировкой по модулю информативности (InfPortClsAbs); ******** - позитивного (InfPortClsPos); ******** - негативного (InfPortClsNeg); ******** и заполнение SWOT-матрицы класса для визуализации в экранной форме ****************************************************************************************************************** FUNCTION InfNeuroCls(M_CurrInf) LOCAL Getlist := {}, oProgress, oDialog DC_ASave(M_CurrInf, "_NumbMod.arx") * mNumMod = DC_ARestore("_NumbMod.arx") SELECT ClassNeuro M_RecnoINC = RECNO() M_KodCls = Kod_cls M_NameCls = Name_cls CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW USE ClassNeuro EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW USE Gr_OpSc EXCLUSIVE NEW USE Opis_Sc EXCLUSIVE NEW USE InfPortCls EXCLUSIVE NEW USE InfPortClsPos EXCLUSIVE NEW USE InfPortClsNeg EXCLUSIVE NEW USE InfPortClsAbs EXCLUSIVE NEW *SELECT ClassNeuro *M_Recno = RECNO() *M_KodCls = Kod_cls *M_NameCls = Name_cls SELECT Attributes;N_Gos = RECCOUNT() PUBLIC MessIPC := L('Подготовка визуализации нейрона: ')+ALLTRIM(STR(M_KodCls, 15))+' "'+ALLTRIM(M_NameCls)+L('" в модели: ')+ALLTRIM(STR(M_CurrInf, 15))+' "'+UPPER(Ar_Model[M_CurrInf]+'"') * LB_Warning(MessIPC) DC_GetRefresh(oSay1) // Наименование SWOT-матрицы nMax = N_Gos * 5 @ 4,5 DCPROGRESS oProgress SIZE 80,1.1 MAXCOUNT nMax COLOR GRA_CLR_RED PERCENT EVERY 100 DCREAD GUI TITLE L('4.4.10.Графическое отображение нелокальных нейронов в системе "Эйдос"') PARENT @oDialog FIT EXIT oDialog:show() nTime = 0 // Заполнить БД InfPortCls записями с кодами и наименованиями признаков и их значимостью SELECT Classes SELECT InfPortCls;ZAP DC_GetProgress(oProgress,0,nMax) FOR i=1 TO N_Gos M_KodAtr = VAL(LC_FieldGet( Ar_Model[M_CurrInf]+".txt", nHandle[M_CurrInf], i, 1 )) M_NameAtr = LC_FieldGet( Ar_Model[M_CurrInf]+".txt", nHandle[M_CurrInf], i, 2 ) M_Znach = VAL(LC_FieldGet( Ar_Model[M_CurrInf]+".txt", nHandle[M_CurrInf], i, 2+M_KodCls )) // Инф.портрет класса M_KodCls IF M_Znach <> 0 SELECT Attributes DBGOTO(M_KodAtr) M_KodOpSc = Kod_OpSc SELECT InfPortCls APPEND BLANK REPLACE Kod_atr WITH M_KodAtr REPLACE Name_atr WITH M_NameAtr REPLACE Kod_OpSc WITH M_KodOpSc REPLACE Znach WITH M_Znach ENDIF DC_GetProgress(oProgress, ++nTime, nMax) NEXT ***** Сортировка InfPortCls по полю Znach по убыванию CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE InfPortCls EXCLUSIVE NEW COPY STRUCTURE TO TempInf.dbf COPY STRUCTURE TO TempAbs.dbf CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE InfPortCls EXCLUSIVE NEW INDEX ON STR(999999.9999999-Znach,19,7) TO NeuroInf INDEX ON STR(999999.9999999-ABS(Znach),19,7) TO NeuroAbs CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE TempInf EXCLUSIVE NEW USE TempAbs EXCLUSIVE NEW USE InfPortCls INDEX NeuroInf, NeuroAbs EXCLUSIVE NEW SELECT InfPortCls SET ORDER TO 1 DBGOTOP() DO WHILE .NOT. EOF() a := {} FOR j=1 TO FCOUNT() AADD(a, FIELDGET(j)) NEXT SELECT TempInf APPEND BLANK FOR j=1 TO LEN(a) FIELDPUT(j, a[j]) NEXT DC_GetProgress(oProgress, ++nTime, nMax) SELECT InfPortCls DBSKIP(1) ENDDO SELECT InfPortCls SET ORDER TO 2 DBGOTOP() DO WHILE .NOT. EOF() a := {} FOR j=1 TO FCOUNT() AADD(a, FIELDGET(j)) NEXT SELECT TempAbs APPEND BLANK FOR j=1 TO LEN(a) FIELDPUT(j, a[j]) NEXT DC_GetProgress(oProgress, ++nTime, nMax) SELECT InfPortCls DBSKIP(1) ENDDO CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций ERASE( "InfPortCls.dbf" ) ERASE( "InfPortClsAbs.dbf" ) RenameFile( "TempInf.dbf", "InfPortCls.dbf" ) RenameFile( "TempAbs.dbf", "InfPortClsAbs.dbf" ) // Сформировать БД SWOT-матрицы aStr := { { "Num_pp" , "N", 15, 0 }, ; { "Kod_atr1" , "N", 15, 0 }, ; { "Kod_OpSc1" , "N", 15, 0 }, ; { "Name_OpSc1" , "C", mLenMaxOS, 0 }, ; { "Name_GrOS1" , "C", mLenMaxGOS, 0 }, ; { "Name_Atr1" , "C", mLenMaxAtr, 0 }, ; { "Znach1" , "N", 19, 7 }, ; { "Kod_atr2" , "N", 15, 0 }, ; { "Kod_OpSc2" , "N", 15, 0 }, ; { "Name_OpSc2" , "C", mLenMaxOS, 0 }, ; { "Name_GrOS2" , "C", mLenMaxGOS, 0 }, ; { "Name_Atr2" , "C", mLenMaxAtr, 0 }, ; { "Znach2" , "N", 19, 7 } } mNeuroName = "NeuroCls"+STRTRAN(STR(M_KodCls,15)," ","0")+Ar_Model[M_CurrInf] DbCreate( mNeuroName, aStr ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mNeuroName) EXCLUSIVE NEW USE Classes EXCLUSIVE NEW USE ClassNeuro EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW USE Gr_OpSc EXCLUSIVE NEW USE Opis_Sc EXCLUSIVE NEW USE InfPortCls EXCLUSIVE NEW USE InfPortClsAbs EXCLUSIVE NEW USE InfPortClsPos EXCLUSIVE NEW;ZAP USE InfPortClsNeg EXCLUSIVE NEW;ZAP ****** Для InfPortClsPos SELECT InfPortCls SET FILTER TO Znach > 0 DBGOTOP() DO WHILE .NOT. EOF() a := {} FOR j=1 TO FCOUNT() AADD(a, FIELDGET(j)) NEXT SELECT InfPortClsPos APPEND BLANK FOR j=1 TO LEN(a) FIELDPUT(j, a[j]) NEXT DC_GetProgress(oProgress, ++nTime, nMax) SELECT InfPortCls DBSKIP(1) ENDDO ****** Для InfPortClsNeg SELECT InfPortCls SET FILTER TO Znach < 0 DBGOBOTTOM() DO WHILE .NOT. BOF() a := {} FOR j=1 TO FCOUNT() AADD(a, FIELDGET(j)) NEXT SELECT InfPortClsNeg APPEND BLANK FOR j=1 TO LEN(a) FIELDPUT(j, a[j]) NEXT DC_GetProgress(oProgress, ++nTime, nMax) SELECT InfPortCls DBSKIP(-1) ENDDO ****** ЗАПОЛНИТЬ ПОЛЯ БД (mSWOTName) SWOT-матрицы ДЛЯ ВИЗУАЛИЗАЦИИ SELECT InfPortClsPos PUBLIC N_GosPos := RECCOUNT() SELECT InfPortClsNeg PUBLIC N_GosNeg := RECCOUNT() N_GosMax = MAX(N_GosPos, N_GosNeg) SELECT (mNeuroName) FOR j=1 TO N_GosMax APPEND BLANK REPLACE Num_pp WITH j NEXT aStr := { { "Num_pp" , "N", 15, 0 }, ; { "Kod_atr1" , "N", 15, 0 }, ; { "Kod_OpSc1" , "N", 15, 0 }, ; { "Name_OpSc1" , "C", mLenMaxOS, 0 }, ; { "Name_GrOS1" , "C", mLenMaxGOS, 0 }, ; { "Name_Atr1" , "C", mLenMaxAtr, 0 }, ; { "Znach1" , "N", 19, 7 }, ; { "Kod_atr2" , "N", 15, 0 }, ; { "Kod_OpSc2" , "N", 15, 0 }, ; { "Name_OpSc2" , "C", mLenMaxOS, 0 }, ; { "Name_GrOS2" , "C", mLenMaxGOS, 0 }, ; { "Name_Atr2" , "C", mLenMaxAtr, 0 }, ; { "Znach2" , "N", 19, 7 } } SELECT InfPortClsPos mNumRec = 0 DBGOTOP() DO WHILE .NOT. EOF() mKodAtr1 = Kod_Atr mNameAtr1 = Name_Atr mZnach1 = Znach mKodOpSc1 = Kod_OpSc SELECT Gr_OpSc DBGOTO(mKodAtr1) mNameGrOS1 = Name_GrOS SELECT Opis_Sc DBGOTO(mKodOpSc1) mNameOpSc1 = Name_OpSc SELECT (mNeuroName) DBGOTO(++mNumRec) REPLACE Num_pp WITH mNumRec REPLACE Kod_atr1 WITH mKodAtr1 REPLACE Kod_OpSc1 WITH mKodOpSc1 REPLACE Name_OpSc1 WITH mNameOpSc1 REPLACE Name_GrOS1 WITH mNameGrOS1 REPLACE Name_Atr1 WITH mNameAtr1 REPLACE Znach1 WITH mZnach1 DC_GetProgress(oProgress, ++nTime, nMax) SELECT InfPortClsPos DBSKIP(1) ENDDO SELECT InfPortClsNeg mNumRec = 0 DBGOTOP() DO WHILE .NOT. EOF() mKodAtr2 = Kod_Atr mNameAtr2 = Name_Atr mZnach2 = Znach mKodOpSc2 = Kod_OpSc SELECT Gr_OpSc DBGOTO(mKodAtr2) mNameGrOS2 = Name_GrOS SELECT Opis_Sc DBGOTO(mKodOpSc2) mNameOpSc2 = Name_OpSc SELECT (mNeuroName) DBGOTO(++mNumRec) REPLACE Num_pp WITH mNumRec REPLACE Kod_atr2 WITH mKodAtr2 REPLACE Kod_OpSc2 WITH mKodOpSc2 REPLACE Name_OpSc2 WITH mNameOpSc2 REPLACE Name_GrOS2 WITH mNameGrOS2 REPLACE Name_Atr2 WITH mNameAtr2 REPLACE Znach2 WITH mZnach2 DC_GetProgress(oProgress, ++nTime, nMax) SELECT InfPortClsNeg DBSKIP(1) ENDDO DC_GetProgress(oProgress,nMax,nMax) oDialog:Destroy() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW USE ClassNeuro EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW USE Gr_OpSc EXCLUSIVE NEW USE Opis_Sc EXCLUSIVE NEW USE InfPortCls EXCLUSIVE NEW USE InfPortClsPos EXCLUSIVE NEW USE InfPortClsNeg EXCLUSIVE NEW USE InfPortClsAbs EXCLUSIVE NEW SELECT InfPortClsPos DBGOTOP() SELECT InfPortClsNeg DBGOTOP() SELECT ClassNeuro * SET FILTER TO Abs+Int_inf > 0 DBGOTO(M_RecnoINC) ReTURN NIL ****************************************** ********************************************************************************************************************************* ******** Графическая визуализация нейронов с формированием изображения в памяти и с отображением с масштабированием ********************************************************************************************************************************* FUNCTION GraNeuron() LOCAL GetList := {}, oStatic LOCAL oPS, oDevice SELECT ClassNeuro mRecnoGN = RECNO() * PUBLIC X_MaxW := 1280, Y_MaxW := 720 // Размер графического окна в пикселях PUBLIC X_MaxW := 1800, Y_MaxW := 900 // Размер графического окна в пикселях nXSize = 1800 nYSize = 900 mKodNeuro = Kod_Cls STRFILE(STR(mKodNeuro,15), "_KodNeuro.txt") // Записать mKodNeuro и потом там, где надо загружать его oScr := DC_WaitOn('Немного подождите! Идет формирование изображения в памяти и его масштабирование',,,,,,,,,,,.F.) // Create new bitmap with given size oPS := XBPPRESSPACE() :new() :Create() oBMP := XBPBITMAP() :New() :Create() * oBMP:Make( nXSize, nYSize, nPlanes, nBits ) oBMP:Make( nXSize, nYSize ) oBMP:presSpace( oPS ) // here your GRA* Code **** Закрасить фон прямоугольника *************** * GraSetColor( oPS, GRA_CLR_WHITE, GRA_CLR_WHITE ) GraSetColor( oPS, BD_LIGHTGREY, BD_LIGHTGREY ) GraBox( oPS, { 0, 0 }, { nXSize, nYSize }, GRA_FILL ) *####################################################################################################### mKodNeuro = VAL(FILESTR("_KodNeuro.txt")) // Код нейрона для визуализации LC_Neuron( oPS, oBMP, mKodNeuro, 'File' ) // Графическая функция <<<===######################### *####################################################################################################### *My image original, my image scaled ****** Запись полноразмерного графического файла в папку: M_PathAppl+"\NeuronsDiagr\" DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения * DC_ASave(mNumMod , "_NumMod.arx") mNumMod = DC_ARestore("_NumMod.arx") DIRCHANGE(M_PathAppl+"\NeuronsDiagr\") // Перейти в папку SWOTDiagrCls cFileName = "Neuron"+STRTRAN(STR(mKodNeuro,4)," ","0")+Ar_Model[M_CurrInf]+".jpg" ERASE(cFileName) oBMP:SaveFile(cFileName,XBPBMP_FORMAT_JPG) DC_Impl(oScr) IF nWidth > 1800 FullView( cFileName, "по верху", 65 ) // Визуализация полноразмерного файла на мониторе высокого разрешения ELSE ****** Формирование с помощью bmp2bmp() и отображение масштабированного изображения aNewSize := {nWidth,nHeight-29} // Новый размер изображения (еще немного уменьшается, чтобы не рисовать по панели задач) oBMP:loadFile(cFileName) // Загрузка полноразмерного изображения oRet := BMP2BMP(oBMP,aNewSize) // Масштабирование изображения cFileNameScale = SUBSTR(cFileName,1,AT(".jpg",cFileName)-1)+"_scaled.jpg" ERASE(cFileNameScale) oRet:saveFile(cFileNameScale,XBPBMP_FORMAT_JPG) // Запись масштабированного графического файла в в папку приложения для визуализации FullView( cFileNameScale, "по верху", 0 ) // Визуализация масштабированного графического файла на мониторе ограниченного разрешения ENDIF DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW USE ClassNeuro EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW USE Gr_OpSc EXCLUSIVE NEW USE Opis_Sc EXCLUSIVE NEW USE InfPortCls EXCLUSIVE NEW USE InfPortClsPos EXCLUSIVE NEW USE InfPortClsNeg EXCLUSIVE NEW USE InfPortClsAbs EXCLUSIVE NEW SELECT InfPortClsPos DBGOTOP() SELECT InfPortClsNeg DBGOTOP() SELECT ClassNeuro * SET FILTER TO Abs+Int_inf > 0 DBGOTO(mRecnoGN) ReTURN NIL ******************************************* ********* Графическая визуализация нейронов ******************************************* *FUNCTION GraNeuronOld() * LOCAL GetList := {}, oStatic * LOCAL oPS, oDevice * SELECT ClassNeuro * mRecnoGN = RECNO() ******* Узнать разрешение экрана и не показывать изображений большой размерности **************** *nWidth := AppDeskTop():currentSize()[1] // current screen size width in pixels *nHeight := AppDeskTop():currentSize()[2] // current screen size height in pixels *mFlag = .F. *IF nWidth < 1800 * aMess := {} * AADD(aMess, L("Для правильного отображения графической формы")) * AADD(aMess, L("необходимо разрешение экрана 1800 pix по горизонтали,")) * AADD(aMess, L("а фактически установлено: ")+ALLTRIM(STR(nWidth))+" pix") * LB_Warning(aMess ) * mFlag = .T. *ENDIF *IF nHeight < 850 * aMess := {} * AADD(aMess, L("Для правильного отображения графической формы")) * AADD(aMess, L("необходимо разрешение экрана 850 pix по вертикали,")) * AADD(aMess, L("а фактически установлено: ")+ALLTRIM(STR(nHeight))+" pix") * LB_Warning(aMess ) * mFlag = .T. *ENDIF *IF mFlag * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * USE Classes EXCLUSIVE NEW * USE ClassNeuro EXCLUSIVE NEW * USE Attributes EXCLUSIVE NEW * USE Gr_OpSc EXCLUSIVE NEW * USE Opis_Sc EXCLUSIVE NEW * USE InfPortCls EXCLUSIVE NEW * USE InfPortClsPos EXCLUSIVE NEW * USE InfPortClsNeg EXCLUSIVE NEW * USE InfPortClsAbs EXCLUSIVE NEW * SELECT InfPortClsPos * DBGOTOP() * SELECT InfPortClsNeg * DBGOTOP() * SELECT ClassNeuro ** SET FILTER TO Abs+Int_inf > 0 * DBGOTO(mRecnoGN) * Running(.F.) * ReTURN NIL *ENDIF ************************************************************************************************* * SELECT ClassNeuro * mRecnoGN = RECNO() ** PUBLIC X_MaxW := 1280, Y_MaxW := 720 // Размер графического окна в пикселях * PUBLIC X_MaxW := 1800, Y_MaxW := 900 // Размер графического окна в пикселях * mKodNeuro = Kod_Cls * STRFILE(STR(mKodNeuro,15), "_KodNeuro.txt") // Записать mKodNeuro и потом там, где надо загружать его * @ 2,1 DCSTATIC TYPE XBPSTATIC_TYPE_RECESSEDBOX SIZE X_MaxW, Y_MaxW PIXEL; // Размер окна для отображения графика в пикселях (от Тома) * OBJECT oStatic; * EVAL {|| _PresSpace44A( oStatic, mKodNeuro ) } * DCREAD GUI ; * TITLE L('4.4.10. Графическое отображение нелокальных нейронов в системе "Эйдос"') ; // Надпись на окне графика * FIT; * MODAL * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * USE Classes EXCLUSIVE NEW * USE ClassNeuro EXCLUSIVE NEW * USE Attributes EXCLUSIVE NEW * USE Gr_OpSc EXCLUSIVE NEW * USE Opis_Sc EXCLUSIVE NEW * USE InfPortCls EXCLUSIVE NEW * USE InfPortClsPos EXCLUSIVE NEW * USE InfPortClsNeg EXCLUSIVE NEW * USE InfPortClsAbs EXCLUSIVE NEW * SELECT InfPortClsPos * DBGOTOP() * SELECT InfPortClsNeg * DBGOTOP() * SELECT ClassNeuro ** SET FILTER TO Abs+Int_inf > 0 * DBGOTO(mRecnoGN) *RETURN NIL ************************************************* *FUNCTION _PresSpace44A( oStatic, mKodNeuro ) * LOCAL oPS, oDevice * mKodNeuro = VAL(FILESTR("_KodNeuro.txt")) // Код нейрона для визуализации * oPS := XbpPresSpace():new() // Create a PS * oDevice := oStatic:winDevice() // Get the device context * oPS:create( oDevice ) // Link device context to PS * oPS:SetViewPort( { 0, 0, X_MaxW, Y_MaxW } ) * oStatic:paint := {|mp1,mp2,obj| mp1 := LC_Neuron( oPS, oStatic, mKodNeuro, 'Screen' ) } *RETURN NIL ********************************************************** STATIC FUNCTION LC_Neuron( oPS, oStatic, mKodNeuro, mPar ) ************************** Параметры формирования нейронов *************************** // mKodNeuro = VAL(FILESTR("_KodNeuro.txt")) // Код нейрона для визуализации // PUBLIC aNeuro := {} // Коды нейронов (классов) надо вытаскивать из БД самому // PUBLIC mFltrLeftFlag44A := .F. // Есть фильтр или нет по фактору > 0 // Если фильтр есть, то по коду: mKodOpScLeft44A // PUBLIC mFltrRightFlag44A := .F. // Есть фильтр или нет по фактору < 0 // Если фильтр есть, то по коду: mKodOpScRight44A // PUBLIC mViewMax := 12 // кол-во рецепторов // PUBLIC mViewPorog := 0 // порог модуля * // PUBLIC mSort := 1 // 1 - по инф., 2 - по ABS // PUBLIC mViewName := 1 // 1 - с наим., 2 - только коды - это уже непосредственно при визуализации // *DC_ASave(M_CurrInf, "_NumbMod.arx") // mNumMod = DC_ARestore("_NumbMod.arx") // Номер модели ************************************************************************************** ******* Подготовка базы данных для визуализации нейрона в соответсвии с заданными параметрами **************************** mKodNeuro = VAL(FILESTR("_KodNeuro.txt")) // Код нейрона для визуализации mNumMod = DC_ARestore("_NumbMod.arx") // Номер модели InfNeuroCls(mNumMod) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE InfPortCls EXCLUSIVE NEW COPY STRUCTURE TO GraNeuroView.dbf // Создать базу для визуализации нейрона CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW USE ClassNeuro EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW USE Class_Sc EXCLUSIVE NEW USE Gr_ClSc EXCLUSIVE NEW USE Gr_OpSc EXCLUSIVE NEW USE Opis_Sc EXCLUSIVE NEW USE InfPortCls EXCLUSIVE NEW USE InfPortClsPos EXCLUSIVE NEW USE InfPortClsNeg EXCLUSIVE NEW USE InfPortClsAbs EXCLUSIVE NEW USE GraNeuroView EXCLUSIVE NEW;ZAP SELECT Gr_ClSc DBGOTO(mKodNeuro) mKodCls = Kod_GrCS mNameGrCS = Name_GrCS mKodClSc = Kod_ClSc SELECT Class_Sc DBGOTO(mKodClSc) mNameCS = Name_ClSc SELECT ClassNeuro DBGOTO(mKodNeuro) InfNeuroCls(mNumMod) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW USE ClassNeuro EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW USE Class_Sc EXCLUSIVE NEW USE Gr_ClSc EXCLUSIVE NEW USE Gr_OpSc EXCLUSIVE NEW USE Opis_Sc EXCLUSIVE NEW USE InfPortCls EXCLUSIVE NEW USE InfPortClsPos EXCLUSIVE NEW USE InfPortClsNeg EXCLUSIVE NEW USE InfPortClsAbs EXCLUSIVE NEW USE GraNeuroView EXCLUSIVE NEW;ZAP IF mSort = 2 mNum = 0 SELECT InfPortClsAbs IF mFltrLeftFlag44A SET FILTER TO mKodOpScLeft44A = Kod_OpSc ELSE SET FILTER TO ENDIF IF mFltrRightFlag44A SET FILTER TO mKodOpScRight44A = Kod_OpSc ELSE SET FILTER TO ENDIF ******* Определение максимального по модулю значения, принимаемого за 100% относительной силы влияния DBGOTOP() mMaxZnach = ABS(Znach) // Максимальное по модулю влияние для нормировки силы связи на изображении DBGOTOP() DO WHILE mNum < mViewMax .AND. .NOT. EOF() IF ABS(Znach) > mMaxZnach * mViewPorog / 100 ++mNum a := {} FOR j=1 TO FCOUNT() AADD(a, FIELDGET(j)) NEXT SELECT GraNeuroView APPEND BLANK FOR j=1 TO LEN(a) FIELDPUT(j, a[j]) NEXT SELECT InfPortClsAbs ENDIF DBSKIP(1) ENDDO DBGOTOP() ENDIF IF mSort = 1 SELECT InfPortClsPos IF mFltrLeftFlag44A SET FILTER TO mKodOpScLeft44A = Kod_OpSc ELSE SET FILTER TO ENDIF IF mFltrRightFlag44A SET FILTER TO mKodOpScRight44A = Kod_OpSc ELSE SET FILTER TO ENDIF ******* Определение максимального по модулю значения, принимаемого за 100% относительной силы влияния DBGOTOP() SELECT InfPortClsPos mMaxZnachPos = ABS(Znach) // Максимальное по модулю влияние для нормировки силы связи на изображении SELECT InfPortClsNeg mMaxZnachNeg = ABS(Znach) // Максимальное по модулю влияние для нормировки силы связи на изображении mMaxZnach = MAX(mMaxZnachPos, mMaxZnachNeg) mNum = 0 SELECT InfPortClsPos DBGOTOP() DO WHILE mNum < mViewMax/2 .AND. .NOT. EOF() IF ABS(Znach) > mMaxZnach * mViewPorog / 100 ++mNum a := {} FOR j=1 TO FCOUNT() AADD(a, FIELDGET(j)) NEXT SELECT GraNeuroView APPEND BLANK FOR j=1 TO LEN(a) FIELDPUT(j, a[j]) NEXT SELECT InfPortClsPos ENDIF DBSKIP(1) ENDDO DBGOTOP() mMaxZnachPos = ABS(Znach) // Максимальное по модулю влияние для нормировки силы связи на изображении mNum = 0 SELECT InfPortClsNeg IF mFltrLeftFlag44A SET FILTER TO mKodOpScLeft44A = Kod_OpSc ELSE SET FILTER TO ENDIF IF mFltrRightFlag44A SET FILTER TO mKodOpScRight44A = Kod_OpSc ELSE SET FILTER TO ENDIF DBGOTOP() DO WHILE mNum < mViewMax/2 .AND. .NOT. EOF() IF ABS(Znach) > mMaxZnach * mViewPorog / 100 ++mNum a := {} FOR j=1 TO FCOUNT() AADD(a, FIELDGET(j)) NEXT SELECT GraNeuroView APPEND BLANK FOR j=1 TO LEN(a) FIELDPUT(j, a[j]) NEXT SELECT InfPortClsNeg ENDIF DBSKIP(1) ENDDO DBGOTOP() ENDIF SELECT GraNeuroView N_Recept = RECCOUNT() ************************************************************************************************************************** IF N_Recept = 0 // При заданных параметрах нечего визуализировать RETURN NIL ENDIF *** Определение наиболее сильной по модулю связи для нормировки толщины линии mMaxZnachPix = 20 // Максимальная по модулю сила связи в pix для нормировки силы связи на изображении mKnorm = mMaxZnachPix/mMaxZnach // Коэффициент нормировки и преобразования силы связи из bit в pix W_Wind = X_MaxW / 2 // Полуширина окна для самого графика H_Wind = Y_MaxW / 2 // Полувысота окна для самого графика LY := 70 // Зона над областью графика для наименования и под областью графика для легенды X0 := W_Wind // Начало координат для эллипса по оси X Y0 := H_Wind // Начало координат для эллипса по оси Y ***** Закрасить фон прямоугольника *************** ***** Закрасить фон прямоугольника *************** GraSetColor( oPS, aColor[98] , aColor[98] ) // Номер цвета в соответствии с _AidosColor.prg GraBox( oPS, { X0-W_Wind, Y0-H_Wind }, { X0+W_Wind, Y0+H_Wind }, GRA_FILL ) GraSetColor( oPS, aColor[222] , aColor[222] ) ***** Нарисовать рамку изображения и отделить место для легенды ******************* aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты ****** Начало координат в центре рисунка GraArc ( oPS, { X0, Y0 }, 1 ) // Начало координат GraArc ( oPS, { X0, Y0 }, 2 ) // Начало координат GraArc ( oPS, { X0, Y0 }, 3 ) // Начало координат GraLine( oPS, {X0-W_Wind+1, Y0-H_Wind+1}, {X0-W_Wind+1, Y0+H_Wind-1} ) // Нарисовать границу рамки изображения слева GraLine( oPS, {X0+W_Wind-1, Y0-H_Wind+1}, {X0+W_Wind-1, Y0+H_Wind-1} ) // Нарисовать границу рамки изображения справа GraLine( oPS, {X0-W_Wind+1, Y0-H_Wind+1}, {X0+W_Wind-1, Y0-H_Wind+1} ) // Нарисовать границу рамки изображения внизу параллельно оси X GraLine( oPS, {X0-W_Wind+1, Y0+H_Wind-1}, {X0+W_Wind-1, Y0+H_Wind-1} ) // Нарисовать границу рамки изображения вверху параллельно оси X GraLine( oPS, {X0-W_Wind+1, Y0-H_Wind+LY}, {X0+W_Wind-1, Y0-H_Wind+LY} ) // Нарисовать границу рамки легенды на уровне LY параллельно оси X *********************************************************************************************************************** *###################################################################################################################### *********************************************************************************************************************** **** Написать заголовок диаграммы oFont := XbpFont():new():create("22.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraStringAt( oPS, { X_MaxW/2, Y_MaxW-20 }, 'НЕЛОКАЛЬНЫЙ НЕЙРОН В МОДЕЛИ: "'+UPPER(Ar_Model[mNumMod])+'"' ) oFont := XbpFont():new():create("14.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) SELECT Classes DBGOTO(mKodNeuro) M_KodCls = Kod_cls M_NameCls = Name_cls ***** Цикл определения такой длины строки, которая помещается в рамку ***** Массив отображаемых в рамке строк, включающий наименования и описательных шкал и их градаций ***** Из текстового буфера к отображаемому элементу массива добавляется по одному символу и определяется его длина в пикселях. ***** Если не хватает длины рамки - добавляется строка в массив. Отображение градации шкалы всегда начинается с новой строки. mZone = X_MaxW-850 // Ширина зоны отображения в пикселях с учетом полей слева и справа mMess := 'Нейрон: ['+ALLTRIM(STR(M_KodCls, 15))+']-' // Массив отображаемых в рамке строк, включающий наименования и описательных шкал и их градаций mBuff = ALLTRIM(M_NameCls) // Максимальная длина наименования класса, помещающегося в прямоугольнике, равна 90 символов FOR i=1 TO LEN(mBuff) aTxtPar = DC_GraQueryTextbox(mMess + SUBSTR(mBuff,i,1), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox(mMess + SUBSTR(mBuff,i,1)+" "+STR(aTxtPar[1])) IF aTxtPar[1] <= mZone mMess = mMess + SUBSTR(mBuff,i,1) // Полное наименование описательной шкалы посылается в буфер для отображения ELSE mMess = mMess + '...' // Полное наименование описательной шкалы посылается в буфер для отображения EXIT ENDIF NEXT GraStringAt( oPS, { X_MaxW/2, Y_MaxW-45 }, mMess ) oFont := XbpFont():new():create("14.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) ***** Цикл определения такой длины строки, которая помещается в рамку ***** Массив отображаемых в рамке строк, включающий наименования и описательных шкал и их градаций ***** Из текстового буфера к отображаемому элементу массива добавляется по одному символу и определяется его длина в пикселях. ***** Если не хватает длины рамки - добавляется строка в массив. Отображение градации шкалы всегда начинается с новой строки. mZone = X_MaxW-850 // Ширина зоны отображения в пикселях с учетом полей слева и справа mMess := 'Приложение: ' // Массив отображаемых в рамке строк, включающий наименования и описательных шкал и их градаций mBuff = ALLTRIM(M_NameAppl) // Максимальная длина наименования класса, помещающегося в прямоугольнике, равна 90 символов FOR i=1 TO LEN(mBuff) aTxtPar = DC_GraQueryTextbox(mMess + SUBSTR(mBuff,i,1), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox(mMess + SUBSTR(mBuff,i,1)+" "+STR(aTxtPar[1])) IF aTxtPar[1] <= mZone mMess = mMess + SUBSTR(mBuff,i,1) // Полное наименование описательной шкалы посылается в буфер для отображения ELSE mMess = mMess + '...' // Полное наименование описательной шкалы посылается в буфер для отображения EXIT ENDIF NEXT GraStringAt( oPS, { X_MaxW/2, Y_MaxW-65 }, mMess ) *********************************************************************************************************************** *###################################################################################################################### *********************************************************************************************************************** ********* Начало рисования эллипса с кружочками классов и линиями связи: сходства-различия R0X = W_Wind * 0.70 * IF(mViewName=1, 1, 1.3) // Радиус элипса по X кружочков R0Y = H_Wind * 0.55 * IF(mViewName=1, 1, 1.3) // Радиус элипса по Y кружочков K0 = 360 / N_Recept // Количество градусов в секторе одного рецептора X := {} // Координаты X центров кружочков классов Y := {} // Координаты Y центров кружочков классов * Faza = -72 - K0 // Угол поворота системы кружочков классов вокруг центра эллипса Faza = -90 // Угол поворота системы кружочков классов вокруг центра эллипса FOR j=1 TO N_Recept AADD(X, X0 - R0X * COS(DTOR(Faza+(j-1)*K0))) AADD(Y, Y0 - R0Y * SIN(DTOR(Faza+(j-1)*K0))) NEXT ****** Рисование кружочков классов и линий связи между ними (брать из матрицы сходства) ****** Загрузить графический шрифт aFonts := XbpFont():new():list() // Все доступные шрифты oFont := aFonts[1] // Конкретный шрифт по номеру из списка (всего доступно 1681 графических шрифтов) GraSetFont(oPS , oFont) // установить шрифт ****** Атрибуты графического шрифта R0 = IF(mViewName=1, 30, 25) // Радиус кружочков с кодами классов RS = 15 // Радиус кружочка для указания силы связи aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_BOX ] := { RS, RS } // Размер поля вывода aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) *** Цикл по рецепторам *************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE GraNeuroView EXCLUSIVE NEW SELECT GraNeuroView ****** Присвоить значения отображаемым массивам aKodAtr := {} // Массив кодов признаков aNameAtr := {} // Массив наименований признаков DBGOTOP() IF SUBSTR(NAME_ATR,1,12) = 'SPECTRINTERV' aRGBAtr := {} // Массив цветов признаков, если спектр ENDIF DO WHILE .NOT. EOF() AADD(aKodAtr , Kod_atr) AADD(aNameAtr, DelZeroNameGr(Name_atr) ) mScName = NAME_ATR IF SUBSTR(mScName,1,12) = 'SPECTRINTERV' * SpectrInterv: 999/999-{123,123,123} * 123456789012 R G B mPosR1 = AT('{', mScName)+1 mPosR2 = mPosR1+2 mPosG1 = mPosR2+2 mPosG2 = mPosG1+2 mPosB1 = mPosG2+2 mPosB2 = mPosB1+2 mRed = VAL(SUBSTR(mScName, mPosR1, mPosR2-mPosR1+1)) mGreen = VAL(SUBSTR(mScName, mPosG1, mPosG2-mPosG1+1)) mBlue = VAL(SUBSTR(mScName, mPosB1, mPosB2-mPosB1+1)) * MsgBox(mScName+' '+STR(mRed)+','+STR(mGreen)+','+STR(mBlue)) fColor := GraMakeRGBColor({ mRed, mGreen, mBlue}) * SetPixel(hDC1, x, y, AutomationTranslateColor(fColor,.f.) ) * AADD(aRGBAtr, AutomationTranslateColor(fColor,.f.)) AADD(aRGBAtr, fColor) ENDIF DBSKIP(1) ENDDO DBGOTOP() DO WHILE .NOT. EOF() j = RECNO() ******* Сделать цвет заливки и линии, а также толщину линии, зависящими от величины и знака сходства-различия aAttr := Array( GRA_AA_COUNT ) // атрибуты области aAttr [ GRA_AA_COLOR ] := IF(Znach>0, BD_LIGHTYELLOW, BD_XBP_CYAN) aAttr [ GRA_AA_SYMBOL ] := GRA_SYM_DEFAULT graSetAttrArea( oPS, aAttr ) aAttr := Array( GRA_AL_COUNT ) // атрибуты линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := IF(Znach>0, GRA_CLR_RED, GRA_CLR_BLUE) aAttr [ GRA_AL_WIDTH ] := mKnorm * ABS(Znach) // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraLine(oPS, { X[j], Y[j] }, { X0, Y0 } ) // Нарисовать линию заданных толщины и цвета ****** Сделать надписи уровней сходства на линиях связи aAttr := Array( GRA_AA_COUNT ) // атрибуты области aAttr [ GRA_AA_COLOR ] := IF(Znach>0, BD_LIGHTYELLOW, BD_XBP_CYAN) aAttr [ GRA_AA_SYMBOL ] := GRA_SYM_DEFAULT graSetAttrArea( oPS, aAttr ) aAttr := Array( GRA_AL_COUNT ) // атрибуты линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := IF(Znach>0, GRA_CLR_RED, GRA_CLR_BLUE) aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) * GraArc( oPS, { (X[j]+X0)/2, (Y[j]+Y0)/2 }, RS, ,,, GRA_OUTLINEFILL ) * GraStringAt( oPS, { (X[j]+X0)/2, (Y[j]+Y0)/2 }, ALLTRIM(STR(Znach/mMaxZnach*100,15)) ) K = 0.3 IF X[j] <= X0 Xc = X[j] + K * ( X0 - X[j] ) ENDIF IF X[j] >= X0 Xc = X[j] - K * ( X[j] - X0 ) ENDIF IF Y[j] <= Y0 Yc = Y[j] + K * ( Y0 - Y[j] ) ENDIF IF Y[j] >= Y0 Yc = Y[j] - K * ( Y[j] - Y0 ) ENDIF GraArc( oPS, { Xc, Yc }, RS, ,,, GRA_OUTLINEFILL ) GraStringAt( oPS, { Xc, Yc }, ALLTRIM(STR(Znach/mMaxZnach*100,15)) ) DBSKIP(1) ENDDO ****** Рисование кружочков рецепторов с надписями Xb0 := {} // Координата Xb0 точки пересечения диагоналей прямоугольников с наименованиями классов Yb0 := {} // Координата Yb0 точки пересечения диагоналей прямоугольников с наименованиями классов Xb1 := {} // Координаты X1 прямоугольников с наименованиями классов Yb1 := {} // Координаты Y1 прямоугольников с наименованиями классов Xb2 := {} // Координаты X2 прямоугольников с наименованиями классов Yb2 := {} // Координаты Y2 прямоугольников с наименованиями классов Xb := 2*R0*1.618 // Ширина прямоугольника Yb := 2*R0 // Высота прямоугольника FOR j=1 TO N_Recept AADD(Xb0, X0 - ( R0X + R0*3.2 ) * COS(DTOR(Faza+(j-1)*K0))) AADD(Yb0, Y0 - ( R0Y + R0*2.5 ) * SIN(DTOR(Faza+(j-1)*K0))) AADD(Xb1, Xb0[j] - Xb/2 ) AADD(Yb1, Yb0[j] - Yb/2 ) AADD(Xb2, Xb0[j] + Xb/2 ) AADD(Yb2, Yb0[j] + Yb/2 ) NEXT FOR j=1 TO N_Recept // Цикл по рецепторам нейрона DBGOTO(j) mNameAtr = ALLTRIM(Name_Atr) ****** Инициализация графического шрифта oFont := XbpFont():new():create("22.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_BOX ] := { R0, R0 } // Размер поля вывода aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты ******* Сделать цвет заливки и линии, а также толщину линии, зависящими от величины и знака сходства-различия aAttrA := Array( GRA_AA_COUNT ) // атрибуты области aAttrA [ GRA_AA_COLOR ] := IF(Znach>0, BD_LIGHTYELLOW, BD_XBP_CYAN) aAttrA [ GRA_AA_SYMBOL ] := GRA_SYM_DEFAULT graSetAttrArea( oPS, aAttrA ) aAttrL := Array( GRA_AL_COUNT ) // атрибуты линии aAttrL [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttrL [ GRA_AL_COLOR ] := IF(Znach>0, GRA_CLR_RED, GRA_CLR_BLUE) * aAttrL [ GRA_AL_WIDTH ] := mKnorm * ABS(Znach) // Задать толщину линии aAttrL [ GRA_AL_WIDTH ] := 2 // Задать толщину линии graSetAttrLine( oPS, aAttrL ) GraArc( oPS, { X[j], Y[j] }, R0, ,,, GRA_OUTLINEFILL ) GraStringAt( oPS, { X[j], Y[j] }, ALLTRIM(STR(Kod_atr,15)) ) ** Сделать надписи наименований рецепторов IF mViewName = 1 aAttrA := Array( GRA_AA_COUNT ) // атрибуты области * aAttrA [ GRA_AA_COLOR ] := IF(Znach>0, BD_LIGHTYELLOW, BD_XBP_CYAN) aAttrA [ GRA_AA_COLOR ] := BD_WHITE aAttrA [ GRA_AA_SYMBOL] := GRA_SYM_DEFAULT graSetAttrArea( oPS, aAttrA ) aAttrL := Array( GRA_AL_COUNT ) // атрибуты линии aAttrL [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttrL [ GRA_AL_COLOR ] := IF(Znach>0, GRA_CLR_RED, GRA_CLR_BLUE) aAttrL [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttrL ) graBox( oPS, { Xb1[j], Yb1[j] }, { Xb2[j], Yb2[j] }, GRA_OUTLINEFILL, 10, 10 ) // прямоугольник очерчен, заполнен и закруглен * GraArc( oPS, { Xb0[j], Yb0[j] }, 2, ,,, GRA_OUTLINEFILL ) GraArc( oPS, { Xb1[j], Yb1[j] }, 2, ,,, GRA_OUTLINEFILL ) GraArc( oPS, { Xb2[j], Yb2[j] }, 2, ,,, GRA_OUTLINEFILL ) IF SUBSTR(aNameAtr[j],1,12) = 'SPECTRINTERV' GraSetColor( oPS, aRGBAtr[j] , aRGBAtr[j] ) // Цвет фона для текста - цвет цветового диапазона graBox( oPS, { Xb1[j]+1, Yb1[j]+1 }, { Xb2[j]-1, Yb2[j]-1 }, GRA_OUTLINEFILL, 10, 10 ) // прямоугольник очерчен, заполнен и закруглен ENDIF ***** Наименование рецептора внутри прямоугольника * oFont := aFonts[5] * GraSetFont(oPS , oFont) // установить шрифт * aAttrF := ARRAY( GRA_AS_COUNT ) * aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK * aAttrF [ GRA_AS_BOX ] := { ABS(Xb2[j]-Xb1[j]-2), ABS(Yb2[j]-Yb1[j])-2 } // Размер поля вывода * aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по центру относительно точки начала вывода * aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_TOP // Выравнивание символов по вертикали по средней линии относительно точки начала вывода * GraSetAttrString( oPS, aAttrF ) * **** Здесь сделать цикл по подстрокам наименования рецептора ** GraStringAt( oPS, { MIN(Xb1[j],Xb2[j])+3, MAX(Yb1[j],Yb2[j]-4) }, mNameAtr ) * NM = SUBSTR(mNameAtr,1, 90) // Максимальная длина наименования класса, помещающегося в прямоугольнике, равна 90 символов * SL = 15 // Длина строки в прямоугольнике в пикселях * SP = 9 // Межстрочный интервал в пикселях * L = 1+INT(LEN(NM)/SL) // Число строк в прямоугольнике * D = LEN(NM) - L * SL // Число символов в последней строке * FOR s=1 TO L // Цикл по строкам * GraStringAt( oPS, { MIN(Xb1[j],Xb2[j])+3, MAX(Yb1[j],Yb2[j]-4-(s-1)*SP) }, SUBSTR(NM,1+(s-1)*SL,SL) ) * NEXT ***** Наименование признака внутри прямоугольника NM = mNameAtr // Максимальная длина наименования признака, помещающегося в прямоугольнике, равна 90 символов SL = 15 // Длина строки в прямоугольнике в символах SP = 10 // Межстрочный интервал в пикселях L = 1+INT(LEN(NM)/SL) // Число строк в прямоугольнике oFont := XbpFont():new():create("14.Arial") GraSetFont( oPS ,oFont ) aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_BOX ] := { SL, SP } // Размер поля вывода в пикселях aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_TOP // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) **** Здесь сделать цикл по подстрокам наименования признака * GraStringAt( oPS, { MIN(Xb1[j],Xb2[j])+3, MAX(Yb1[j],Yb2[j]-4) }, aNameAtr[j] ) * aTxtPar = DC_GraQueryTextbox(aMess[s] + SUBSTR(mBuff1,j,1), oFont) // {101,16} Определяет длину и высоту текста в пикселях для НЕКОТОРЫХ шрифтов * D = LEN(NM) - L * SL // Число символов в последней строке * FOR s=1 TO L // Цикл по строкам * GraStringAt( oPS, { MIN(Xb1[j],Xb2[j])+3, MAX(Yb1[j],Yb2[j]-4-(s-1)*SP) }, SUBSTR(NM,1+(s-1)*SL,SL) ) * NEXT ***** Цикл определения такой длины строки, которая помещается в рамку ***** Массив отображаемых в рамке строк, включающий наименования и описательных шкал и их градаций ***** Из текстового буфера к отображаемому элементу массива добавляется по одному символу и определяется его длина в пикселях. ***** Если не хватает длины рамки - добавляется строка в массив. Отображение градации шкалы всегда начинается с новой строки. mZone = Xb-16 // Ширина зоны отображения в пикселях с учетом полей слева и справа aMess := {} // Массив отображаемых в рамке строк, включающий наименования и описательных шкал и их градаций AADD(aMess, L(" "));s=1 // 1-й элемент - 1-я строка mBuff = ALLTRIM(mNameAtr) // Максимальная длина наименования признака, помещающегося в прямоугольнике, равна 90 символов FOR i=1 TO LEN(mBuff) aTxtPar = DC_GraQueryTextbox(aMess[s] + SUBSTR(mBuff,i,1), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox(aMess[s] + SUBSTR(mBuff,i,1)+" "+STR(aTxtPar[1])) IF aTxtPar[1] <= mZone aMess[s] = aMess[s] + SUBSTR(mBuff,i,1) // Полное наименование описательной шкалы посылается в буфер для отображения ELSE IF s < 5 AADD(aMess, SUBSTR(mBuff,i,1)) s++ ELSE EXIT ENDIF ENDIF NEXT mInterval = SP // Межстрочный интервал в пикселях. 1 - строки пишутся без пропуска FOR s=1 TO LEN(aMess) GraStringAt( oPS, { MIN(Xb1[j],Xb2[j])+3, MAX(Yb1[j],Yb2[j]-4-(s-1)*mInterval) }, aMess[s] ) NEXT ENDIF NEXT ******* РИСОВАНИЕ НАДПИСЕЙ В ПРЯМОУГОЛЬНИКЕ КЛАССА (НЕЙРОНА) В ЦЕНТРЕ ********************************* oFont := XbpFont():new():create("12.Arial") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK // Задать цвет шрифта aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) ***** Цикл определения такой длины строки, которая помещается в рамку ***** Массив отображаемых в рамке строк, включающий наименования и описательных шкал и их градаций ***** Из текстового буфера к отображаемому элементу массива добавляется по одному символу и определяется его длина в пикселях. ***** Если не хватает длины рамки - добавляется строка в массив. Отображение градации шкалы всегда начинается с новой строки. mZone = 22 // Размер зоны отображения в символах aMess := {} // Массив отображаемых в рамке строк, включающий наименования и описательных шкал и их градаций AADD(aMess, L(" "));s=1 // 1-й элемент - 1-я строка mBuff1 = "["+ALLTRIM(STR(mKodClSc))+"] "+ALLTRIM(mNameCS) FOR j=1 TO LEN(mBuff1) * aTxtPar = DC_GraQueryTextbox(aMess[s] + SUBSTR(mBuff1,j,1), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов IF LEN(aMess[s] + SUBSTR(mBuff1,j,1)) <= mZone aMess[s] = aMess[s] + SUBSTR(mBuff1,j,1) // Полное наименование описательной шкалы посылается в буфер для отображения ELSE IF s < 4 AADD(aMess, SUBSTR(mBuff1,j,1)) s++ ELSE EXIT ENDIF ENDIF NEXT ***** Цикл определения такой длины строки, которая помещается в рамку AADD(aMess, L(" ")) s++ mBuff2 = "["+ALLTRIM(STR(mKodCls))+"] "+ALLTRIM(mNameGrCS) // Буфер. Из буфера добавляется по олному символу в отображаемый элемент массива FOR j=1 TO LEN(mBuff2) IF LEN(aMess[s] + SUBSTR(mBuff1,j,1)) <= mZone aMess[s] = aMess[s] + SUBSTR(mBuff2,j,1) // Полное наименование описательной шкалы посылается в буфер для отображения ELSE IF s < 8 AADD(aMess, SUBSTR(mBuff2,j,1)) s++ ELSE EXIT ENDIF ENDIF NEXT ****** Наименование прямоугольника для нейрона (класса) в центре mInterval = 17 // Межстрочный интервал в пикселях. 1 - строки пишутся без пропуска Wb = 200 // Ширина прямоугольника * Hb = 150 // Высота прямоугольника Hb = 10 + LEN(aMess) * ( mInterval + 1 ) // Высота прямоугольника aAttrA := Array( GRA_AA_COUNT ) // атрибуты области aAttrA [ GRA_AA_COLOR ] := BD_WHITE aAttrA [ GRA_AA_SYMBOL] := GRA_SYM_DEFAULT graSetAttrArea( oPS, aAttrA ) aAttrL := Array( GRA_AL_COUNT ) // атрибуты линии aAttrL [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttrL [ GRA_AL_COLOR ] := GRA_CLR_BLACK aAttrL [ GRA_AL_WIDTH ] := 2 // Задать толщину линии graSetAttrLine( oPS, aAttrL ) graBox( oPS, { X0-Wb/2, Y0-Hb/2 }, { X0+Wb/2, Y0+Hb/2 }, GRA_OUTLINEFILL, 20, 20 ) // прямоугольник очерчен, заполнен и закруглен *** Отображение наименования нейрона в центре ***** oFont := XbpFont():new():create("16.ArialBold") GraSetFont( oPS ,oFont ) aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты FOR s=1 TO LEN(aMess) GraStringAt( oPS, { X0-Wb/2+15, Y0+Hb/2-15-(s-1)*mInterval }, aMess[s] ) NEXT ****** Легенда ********************************* oFont := XbpFont():new():create("13.ArialBold") GraSetFont( oPS ,oFont ) aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты AxName = "Влияние рецепторов на актвацию/торможение нелокального нейрона, соотвествующего классу (система детерминации класса):" GraStringAt( oPS, { 20, LY-15 }, AxName ) AxName = "АКТИВИРУЩЕЕ влияние отображается линиями КРАСНОГО цвета, толщина линии (приведенная в кружочке в центре линии) отражает относительную силу влияния." GraStringAt( oPS, { 200, LY-35 }, AxName ) AxName = "ТОРМОЗЯЩЕЕ влияние отображается линиями СИНЕГО цвета, толщина линии (приведенная в кружочке в центре линии) отражает относительную силу влияния." GraStringAt( oPS, { 200, LY-55 }, AxName ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_DARKRED GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты **** Нарисовать сами линии **** mSxodstvo > 0 aAttr := Array( GRA_AL_COUNT ) // атрибуты линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := GRA_CLR_RED aAttr [ GRA_AL_WIDTH ] := 7 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraLine(oPS, { 23, LY-35 }, { 170, LY-35 } ) // Нарисовать линию заданных толщины и цвета **** mSxodstvo < 0 aAttr := Array( GRA_AL_COUNT ) // атрибуты линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := GRA_CLR_BLUE aAttr [ GRA_AL_WIDTH ] := 7 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraLine(oPS, { 23, LY-55 }, { 170, LY-55 } ) // Нарисовать линию заданных толщины и цвета ************************** Параметры формирования нейронов *************************** // mKodNeuro // Код нейрона для визуализации // PUBLIC aNeuro := {} // Коды нейронов (классов) надо вытаскивать из БД самому // PUBLIC mFltrLeftFlag44A := .F. // Есть фильтр или нет по фактору > 0 // Если фильтр есть, то по коду: mKodOpScLeft44A // PUBLIC mFltrRightFlag44A := .F. // Есть фильтр или нет по фактору < 0 // Если фильтр есть, то по коду: mKodOpScRight44A // PUBLIC mViewMax := 12 // кол-во рецепторов // PUBLIC mViewPorog := 0 // порог модуля * // PUBLIC mSort := 1 // 1 - по инф., 2 - по ABS // PUBLIC mViewName := 1 // 1 - с наим., 2 - только коды - это уже непосредственно при визуализации // *DC_ASave(M_CurrInf, "_NumbMod.arx") // mNumMod = DC_ARestore("_NumbMod.arx") // Номер модели ************************************************************************************** mPos = 1330 mInt = 13 AxName = "Форма создана: "+DTOC(DATE())+"-"+TIME() GraStringAt( oPS, { mPos, LY+mInt*3 }, AxName ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Opis_Sc EXCLUSIVE NEW IF mFltrLeftFlag44A SELECT Opis_Sc DBGOTO(mKodOpScLeft44A) mNameOpScLeft44A = SUBSTR("Установлен фильтр по фактору: ["+ALLTRIM(STR(mKodOpScLeft44A))+"] "+ALLTRIM(Name_OpSc),1,59) GraStringAt( oPS, { mPos, LY+mInt*2 }, mNameOpScLeft44A ) // Вывести ВСЕ параметры диаграммы ENDIF IF mFltrRightFlag44A SELECT Opis_Sc DBGOTO(mKodOpScRight44A) mNameOpScRight44A = SUBSTR("Установлен фильтр по фактору: ["+ALLTRIM(STR(mKodOpScRight44A))+"] "+ALLTRIM(Name_OpSc),1,59) GraStringAt( oPS, { mPos, LY+mInt*1 }, mNameOpScRight44A ) // Вывести ВСЕ параметры диаграммы ENDIF GraStringAt( oPS, { mPos, LY-mInt*1 }, "Сортировка рецепторов по "+IF(mSort=1,"", "по модулю ")+"информативности" ) // Вывести ВСЕ параметры диаграммы GraStringAt( oPS, { mPos, LY-mInt*2 }, "Отображается количество рецепторов не более: "+ALLTRIM(STR(mViewMax,19)) ) // Вывести ВСЕ параметры диаграммы GraStringAt( oPS, { mPos, LY-mInt*3 }, "Показаны связи с относительной силой влияния выше: "+ALLTRIM(STR(mViewPorog,19))+"%" ) // Вывести ВСЕ параметры диаграммы GraStringAt( oPS, { mPos, LY-mInt*4 }, "Визуализация нейрона с "+IF(mViewName=1,"кодами и наименованиями ", "кодами без наименований ")+"рецепторов" ) // Вывести ВСЕ параметры диаграммы CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций ********* Записать файл изображения с именем - порядковым номером в папке SemNetCls2d * DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения IF FILEDATE("NeuronsDiagr",16) = CTOD("//") DC_Impl(oScr) DIRMAKE("NeuronsDiagr") aMess := {} AADD(aMess, L('В папке текущего приложения: "'+UPPER(ALLTRIM(M_PathAppl))+'"')) AADD(aMess, L('не было директории "NeuronsDiagr" для графических диаграмм нейронов и она была создана!')) AADD(aMess, L('В эту папку записываются исходные изображения высокого качества (без масштабирования)')) LB_Warning(aMess, L('4.4.10.Графическое отображение нелокальных нейронов в системе "Эйдос"' )) oScr := DC_WaitOn('Немного подождите! Идет формирование изображения в памяти и его масштабирование',,,,,,,,,,,.F.) ENDIF IF mPar = 'Screen' DIRCHANGE(M_PathAppl+"\NeuronsDiagr\") // Перейти в папку NonlocalNeurons cFileName = "Neuron"+STRTRAN(STR(M_KodCls,4)," ","0")+Ar_Model[M_CurrInf]+".bmp" DC_Scrn2ImageFile( oStatic, cFileName ) DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения ENDIF ReTURN NIL ****************************************** **************************************************************************************************************************************** ******** Данный режим выполняет функцию, обратную универсальному программному интерфейсу с внешними базами данных 2.3.2.2(), ******** т.е. не вводит исходные данные в систему, а наоборот, формирует на основе исходных данных файлы: Inp_data.dbf и Inp_data.txt, ******** на основе которых в режиме 2.3.2.2() можно сформировать эту же модель (немного не доделано, т.е. не "вылизано") **************************************************************************************************************************************** FUNCTION F5_10() LOCAL GetList := {}, GetOptions, oProgressm, oDialogm Running(.T.) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF ApplChange("5.10()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Obi_zag EXCLUSIVE NEW;N_Obj = RECCOUNT() USE Class_Sc EXCLUSIVE NEW;N_ClSc = RECCOUNT() USE Gr_ClSc EXCLUSIVE NEW;N_GrCS = RECCOUNT() USE Opis_Sc EXCLUSIVE NEW;N_OpSc = RECCOUNT() USE Gr_OpSc EXCLUSIVE NEW;N_GrOS = RECCOUNT() **** Отображение стадии исполнения в кратком варианте *************************************************** nMax = N_ClSc + N_OpSc + N_GrCS + N_GrOS + N_Obj + N_ClSc + N_OpSc + N_Obj + 2*N_ClSc + 2*N_OpSc nTime = 0 @ 4,5 DCPROGRESS oProgressm SIZE 70,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 DCREAD GUI TITLE L('5.10. Исходные данные => Inp_data.dbf, Inp_name.txt') PARENT @oDialogm FIT EXIT oDialogm:show() DC_GetProgress(oProgressm,0,nMax) ********************************************************************************************************* aClass_Sc := {} SELECT Class_Sc DBGOTOP() DO WHILE .NOT. EOF() AADD(aClass_Sc, Name_ClSc) DC_GetProgress(oProgressm, ++nTime, nMax) DBSKIP(1) ENDDO aOpis_Sc := {} SELECT Opis_Sc DBGOTOP() DO WHILE .NOT. EOF() AADD(aOpis_Sc, Name_OpSc) DC_GetProgress(oProgressm, ++nTime, nMax) DBSKIP(1) ENDDO aNameGrCS := {} // Наименование градации классификационной шкалы aKodCSGr := {} // Код классификационной шкалы данной градации SELECT Gr_ClSc DBGOTOP() DO WHILE .NOT. EOF() mName = STRTRAN(ALLTRIM(Name_GrCS), " ", "_") mName = STRTRAN(ALLTRIM(mName), "-", "_") AADD(aNameGrCS, mName) AADD(aKodCSGr , Kod_ClSc) DC_GetProgress(oProgressm, ++nTime, nMax) DBSKIP(1) ENDDO *DC_DebugQout( aKodCSGr ) aNameGrOS := {} // Наименование градации описательной шкалы aKodOSGr := {} // Код описательной шкалы данной градации SELECT Gr_OpSc DBGOTOP() DO WHILE .NOT. EOF() mName = STRTRAN(ALLTRIM(Name_GrOS), " ", "_") mName = STRTRAN(ALLTRIM(mName), "-", "_") AADD(aNameGrOS, mName) AADD(aKodOSGr , Kod_OpSc) DC_GetProgress(oProgressm, ++nTime, nMax) DBSKIP(1) ENDDO *DC_DebugQout( aKodOSGr ) mMaxLenNameObj = 15 SELECT Obi_zag DBGOTOP() DO WHILE .NOT. EOF() mName = ALLTRIM(Name_Obj) mMaxLenNameObj = MAX(mMaxLenNameObj, LEN(mName)) DC_GetProgress(oProgressm, ++nTime, nMax) DBSKIP(1) ENDDO CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций aStructure := { { "Name_Obj" , "C",mMaxLenNameObj, 0} } // 1 FOR j=1 TO N_ClSc FieldName = "Cls"+ALLTRIM(STR(j,15)) AADD(aStructure, { FieldName , "C", 255, 0 }) DC_GetProgress(oProgressm, ++nTime, nMax) NEXT FOR j=1 TO N_OpSc FieldName = "Atr"+ALLTRIM(STR(N_ClSc+j,15)) AADD(aStructure, { FieldName , "C", 255, 0 }) DC_GetProgress(oProgressm, ++nTime, nMax) NEXT DbCreate( "Inp_data.dbf", aStructure ) ***** Формирование БД Inp_data.dbf CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Inp_data EXCLUSIVE NEW USE Obi_zag EXCLUSIVE NEW;N_Obj = RECCOUNT() USE Obi_Kcl EXCLUSIVE NEW USE Obi_Kpr EXCLUSIVE NEW USE Gr_ClSc EXCLUSIVE NEW;N_GrCS = RECCOUNT() USE Gr_OpSc EXCLUSIVE NEW;N_GrOS = RECCOUNT() SELECT Obi_zag DBGOTOP() DO WHILE .NOT. EOF() mKodObj = Kod_obj mNameObj = ALLTRIM(Name_obj) aKodGrCS := {} SELECT Obi_Kcl SET FILTER TO mKodObj = Kod_obj DBGOTOP() DO WHILE .NOT. EOF() FOR j=2 TO 5 mKodGrCS = FIELDGET(j) IF mKodGrCS > 0 AADD(aKodGrCS, FIELDGET(j)) ENDIF NEXT DBSKIP(1) ENDDO aKodGrOS := {} SELECT Obi_Kpr SET FILTER TO mKodObj = Kod_obj DBGOTOP() DO WHILE .NOT. EOF() FOR j=2 TO 8 mKodGrOS = FIELDGET(j) IF mKodGrOS > 0 AADD(aKodGrOS, FIELDGET(j)) ENDIF NEXT DBSKIP(1) ENDDO * DC_DebugQout( aKodCSGr, aKodGrCS ) * DC_DebugQout( aKodOSGr, aKodGrOS ) SELECT Inp_data APPEND BLANK REPLACE Name_Obj WITH mNameObj IF LEN(aKodGrCS) > 0 FOR j = 1 TO LEN(aKodGrCS) IF aKodGrCS[j] > 0 IF aKodGrCS[j] <= LEN(aKodCSGr) mKodClSc = aKodCSGr[aKodGrCS[j]] IF mKodClSc > 0 mFv = ALLTRIM(FIELDGET(1+mKodClSc)) FIELDPUT(1+mKodClSc, IF(LEN(mFv)=0, aNameGrCS[aKodGrCS[j]], mFv+', '+aNameGrCS[aKodGrCS[j]])) ENDIF ENDIF ENDIF NEXT ENDIF IF LEN(aKodGrOS) > 0 FOR j = 1 TO LEN(aKodGrOS) IF aKodGrOS[j] > 0 IF aKodGrOS[j] <= LEN(aKodOSGr) mKodOpSc = aKodOSGr[aKodGrOS[j]] IF mKodOpSc > 0 mFv = ALLTRIM(FIELDGET(1+N_ClSc+mKodOpSc)) FIELDPUT(1+N_ClSc+mKodOpSc, IF(LEN(mFv)=0, aNameGrOS[aKodGrOS[j]], mFv+', '+aNameGrOS[aKodGrOS[j]])) ENDIF ENDIF ENDIF NEXT ENDIF DC_GetProgress(oProgressm, ++nTime, nMax) SELECT Obi_zag DBSKIP(1) ENDDO **** Формирование Inp_name.txt CrLf = CHR(13)+CHR(10) // Конец строки (записи) mInpName = "" FOR mCls = 1 TO N_ClSc mInpName = mInpName + ALLTRIM(aClass_Sc[mCls]) + CrLf DC_GetProgress(oProgressm, ++nTime, nMax) NEXT FOR mAtr = 1 TO N_OpSc mInpName = mInpName + ALLTRIM(aOpis_Sc[mAtr]) + CrLf DC_GetProgress(oProgressm, ++nTime, nMax) NEXT StrFile(mInpName, "Inp_name.txt") DC_GetProgress(oProgressm,nMax,nMax) oDialogm:Destroy() ***** Попробовать преобразовать Inp_data.dbf и Inp_name.txt в Inp_data.xls CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Inp_data EXCLUSIVE NEW SELECT Inp_data aColumnNames := {} AADD(aColumnNames, "Наименование объекта обучающей выборки") FOR mCls = 1 TO N_ClSc AADD(aColumnNames, ALLTRIM(aClass_Sc[mCls])) NEXT FOR mAtr = 1 TO N_OpSc AADD(aColumnNames, ALLTRIM(aOpis_Sc[mAtr])) NEXT *DC_WorkArea2Excel() DC_WorkArea2Excel(,,,,,,,,, aColumnNames ) // Модифицированная функция Роджера *** Скопировать Inp_data.dbf и Inp_name.txt в папку Inp_data CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций Name_SS = "Inp_data.dbf" Name_DD = Disk_dir+"/AID_DATA/Inp_data/Inp_data.dbf" COPY FILE (Name_SS) TO (Name_DD) Name_SS = "Inp_name.txt" Name_DD = Disk_dir+"/AID_DATA/Inp_data/Inp_name.txt" COPY FILE (Name_SS) TO (Name_DD) *** Скопировать worksheet.xls в папку Inp_data и в папку текущего приложения Name_SS = Disk_dir+"/worksheet.xls" Name_DD = Disk_dir+"/AID_DATA/Inp_data/Inp_data.xls" COPY FILE (Name_SS) TO (Name_DD) IF FILE(Disk_dir+"/worksheet.xls") Name_SS = Disk_dir+"/worksheet.xls" Name_DD = "Inp_data.xls" COPY FILE (Name_SS) TO (Name_DD) ERASE(Name_SS) ENDIF *** Сформировать и записать файл параметров программного интерфейса: _2_3_2_2.arx для формирования исходной модели из созданных файлов Flag_zer = 1 // Считать нули и пробелы отсутствием данных? [1]-да, [2]-нет N_Chast = 1 // На сколько частей N разбивать обучающую или распознаваемую выборку (в зависимости от Regim) M_ClSc1 = 1+1 // Номер начального столбца диапазона классификационных шкал M_ClSc2 = 1+N_ClSc // Номер конечного столбца диапазона классификационных шкал M_OpSc1 = 1+N_ClSc+1 // Номер начального столбца диапазона описательных шкал M_OpSc2 = 1+N_ClSc+N_OpSc // Номер конечного столбца диапазона описательных шкал M_ObAnk = 3 // Создавать анкеты исходной выборки по строкам Inp_data-[1], по классам-[2], и 1-е, и 2-е [3] M_Interval = 1 // 1-равные интервалы, 2-адаптивные интервалы (с примерно равным количеством наблюдений, по Котельникову) N_SKGrCl = 30 N_SKGrPr = 30 K_N_ClSc = 1 K_N_OpSc = 1 K_N_GrClSc = N_GrCS K_N_GrOpSc = N_GrOS M_Scenario = .F. mGorizMin = 5 mGorizMax = 5 mGlubMin = 5 mGlubMax = 5 K_GradNClSc = 30 K_GradNOpSc = 30 M_ChastObi = .F. M_ChastRso = .F. N_ChastObi = 1 N_ChastRso = 1 M_XlsDbf = 3 mTxtCSField = 3 // Способ интерпретации значений текстовых полей - классификационных шкал файла исходных данных (слова) mTxtOSField = 3 // Способ интерпретации значений текстовых полей - описательных шкал файла исходных данных (слова) mTxtCSSep = "," // Разделитель элементов классификационных шкал, если mTxtCSField=3 mTxtOSSep = "," // Разделитель элементов описательных шкал, если mTxtOSField=3 * mScenario = 3 // Применить специальный способ интерпретации текстовых полей (старый вариант) mScenario = 1 // Не применять сценарный метод АСК-анализа mSpecInterprCls = .T. // Применить спец.интерпретацию текстовых полей классов mSpecInterprAtr = .T. // Применить спец.интерпретацию текстовых полей признаков mNameGrNumSc= 1 // Какие наименования ГРАДАЦИЙ числовых шкал использовать mClsAvr =.T. // .F. = модель без усреднения по классам mSortUnqCls = 1 // Выделять уникальные значения классов и сортировать, 1-да, 2-нет mLemmatCls = 2 // Проводить лемматизацию классов, 1-да, 2-нет mSortUnqGos = 1 // Выделять уникальные значения признаков и сортировать, 1-да, 2-нет mLemmatGos = 2 // Проводить лемматизацию признаков, 1-да, 2-нет // Сохранить файл с информацией о заданых параметрах программного интерфейса в текущей директории системы PRIVATE aSoftInt[40] aSoftInt[ 1] = 1 aSoftInt[ 2] = Flag_zer aSoftInt[ 3] = M_ClSc1 aSoftInt[ 4] = M_ClSc2 aSoftInt[ 5] = M_OpSc1 aSoftInt[ 6] = M_OpSc2 aSoftInt[ 7] = N_SKGrCl aSoftInt[ 8] = N_SKGrPr aSoftInt[ 9] = K_N_ClSc aSoftInt[10] = K_N_OpSc aSoftInt[11] = K_N_GrClSc aSoftInt[12] = K_N_GrOpSc aSoftInt[13] = M_ObAnk aSoftInt[14] = N_Chast aSoftInt[15] = M_Interval aSoftInt[16] = M_Scenario aSoftInt[17] = K_GradNClSc // Количество градаций в числовой классификационной шкале aSoftInt[18] = K_GradNOpSc // Количество градаций в числовой описательной шкале aSoftInt[19] = mGorizMin aSoftInt[20] = mGorizMax aSoftInt[21] = mGlubMin aSoftInt[22] = mGlubMax aSoftInt[23] = M_ChastObi aSoftInt[24] = M_ChastRso aSoftInt[25] = N_ChastObi aSoftInt[26] = N_ChastRso aSoftInt[27] = M_XlsDbf aSoftInt[28] = mTxtCSField aSoftInt[29] = mTxtOSField aSoftInt[30] = mTxtCSSep aSoftInt[31] = mTxtOSSep * aSoftInt[32] = mScenario // mScenario=1 Не применять сценарный метод АСК-анализа и спец.интерпретацию TXT-полей (старый вариант) aSoftInt[32] = mScenario // mScenario=1 Не применять сценарный метод АСК-анализа aSoftInt[33] = mSpecInterprCls // .T. - Применить спец.интерпретацию текстовых полей классов, .F. - не применять aSoftInt[34] = mSpecInterprAtr // .T. - Применить спец.интерпретацию текстовых полей признаков, .F. - не применять aSoftInt[35] = mNameGrNumSc // Какие наименования ГРАДАЦИЙ числовых шкал использовать aSoftInt[36] = mClsAvr // .F. = модель без усреднения по классам aSoftInt[37] = mSortUnqCls // Выделять уникальные значения классов и сортировать, 1-да, 2-нет aSoftInt[38] = IF(mSpecInterprCls,mLemmatCls,2) // Проводить лемматизацию классов, 1-да, 2-нет aSoftInt[39] = mSortUnqGos // Выделять уникальные значения признаков и сортировать, 1-да, 2-нет aSoftInt[40] = IF(mSpecInterprAtr,mLemmatGos,2) // Проводить лемматизацию признаков, 1-да, 2-нет DC_ASave(aSoftInt , "_2_3_2_2.arx") DC_ASave(aSoftInt , Disk_dir +"\_2_3_2_2.arx") *********** Сообщение об успешном оконачании работы aMess := {} AADD(aMess, L('Формирование базы данных "Inp_data.dbf" и файла "Inp_name.txt" на основе классификационных')) AADD(aMess, L('и описательных шкал и градаций и обучающей выборки текущего приложения завершено успешно! ')) AADD(aMess, L(' ')) AADD(aMess, L('Теперь в универсальном програмном интерфейсе с внешними базами данных (режим 2.3.2.2) ')) AADD(aMess, L('можно создать исходную модель на основе БД: "Inp_data.dbf" и файла наименований клас- ')) AADD(aMess, L('сификационных и описательных шкал "Inp_name.txt" при параметрах, заданных по умолчанию')) LB_Warning(aMess, L('(C) Универсальная когнитивная аналитическая система "Эйдос-Х++"')) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ********* Отображение стадии исполнения в упрощенном варианте *************************************** * oScr := DC_WaitOn('',,,,,,,,,,,.F.) * nMax = 5 * Mess = L('Расчет числа альтернативных и неальтернативных сочетаний классов' * @ 4,5 DCPROGRESS oProgressm SIZE 80,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 * DCREAD GUI TITLE Mess PARENT @oDialogm FIT EXIT * oDialogm:show() * nTime = 0 * DC_GetProgress(oProgressm,0,nMax) * FOR my=1 TO nMax * DC_GetProgress(oProgressm, ++nTime, nMax) * NEXT * DC_GetProgress(oProgressm,nMax,nMax) * oDialogm:Destroy() * DC_Impl(oScr) ****************************************************************************************************** FUNCTION ChangeBackground( oDlgBmp, Par ) LOCAL oBitmap STATIC snPointer := 0 *** При запуске программы подготовить для отображения фоны главного окна ****** aBitmaps := Directory(Disk_dir+'\Aid_data\BackGround2\*.jpg') *MsgBox(TIME()) HH = VAL(SUBSTR(TIME(),1,2)) // Часы MM = VAL(SUBSTR(TIME(),4,2)) // Минуты SS = VAL(SUBSTR(TIME(),7,2)) // Секунды mTime = HH*3600 + MM*60 + SS // Время, прошедшее с начала суток в секундах D = 86400 / LEN( aBitmaps ) // Величина интервала имен фонов с одинаковым индексом snPointer = 1 + INT( (mTime-1) / D ) // Индекс отображаемого фона *MsgBox(STR(snPointer)+STR(LEN(aBitmaps))) IF snPointer = 0 .OR. snPointer > LEN(aBitmaps) snPointer := 1 ENDIF *** Проверять демонстрируемое изображение фона на совпадение контрольной суммы, *** чтобы его невозможно было заменить использовать массив контрольных сумм. *** Массив контрольных сумм формировать и записывать после формирования и записи фонов. IF FILE("_CheckSum.arx") .AND. LEN(aBitmaps) > 0 aCheckSum = DC_ARestore("_CheckSum.arx") * DC_ASave(aCheckSum, "_CheckSum.arx") IF LEN(aBitmaps) = LEN(aCheckSum) IF snPointer <= LEN(aCheckSum) IF aCheckSum[snPointer] = FILECHECK(Disk_dir+'\Aid_data\BackGround2\'+aBitmaps[snPointer,1]) oBitmap := DC_GetBitmap(Disk_dir+'\Aid_data\BackGround2\'+aBitmaps[snPointer,1]) * IF Par = 1 MILLISEC(8000) * ENDIF *** Это все Роджер oDlgBmp:drawingArea:bitmap := oBitmap oDlgBmp:drawingArea:sizeRedraw := .t. oDlgBmp:drawingArea:setSize(oDlgBmp:drawingArea:currentSize()) oDlgBmp:drawingArea:configure() oDlgBmp:invalidateRect() ENDIF ENDIF ENDIF ENDIF RETURN nil *************************************************************************************** ******** 1.8. Задание градиентных фонов главного окна ******** Градиентные фоны главного окна задаются по умолчанию при инсталляции системы, ******** но могут быть изменены когда угодно сисадмином *************************************************************************************** FUNCTION F1_8() Running(.T.) *** Перед запуском: *** - удалить все jpg-файлы в папке с фонами *** - считать файл: data.ini, если он есть, и скорректировать путь на папку с фонами: Disk_dir+'\Aid_data\BackGround\' и запретить ее корректировку * DeleleGradFon() // Удалить все jpg-файлы в папке с фонами * oTimer:destroy() // Закрытие фона главного меню *********************************************** * Файл: data.ini (ANSI Windows) *********************************************** * Цвет_верха_начала_серии #2E005B * Цвет_низа_начала_серии #400000 * Цвет_верха_конца_серии #FF9B37 * Цвет_низа_конца_серии #D26900 * Количество_изображений 24 * Ширина_изображения 1800 * Высота_изображения 850 * Отразить_относительно_среднего: да * Имя_серии: grd * Папка: C:\Gradient * Разрешить_корректировку_пути_на_папку: нет *********************************************** *** Заменить путь на папку фонов IF .NOT. FILE("data.ini") RETURN nil ENDIF m1_8CurrSet = ConvToOemCP(FileStr("data.ini")) CrLf = CHR(13)+CHR(10) // Конец строки (записи) * MsgBox("Файл: data.ini: "+m1_8CurrSet) mCont = "Папка:" Pos1 = AT(mCont, m1_8CurrSet)+LEN(mCont)+1 // Позиция пути доступа к папке градиентных фонов главного окна mCont = "Разрешить_корректировку_пути_на_папку:" Pos2 = AT(mCont, m1_8CurrSet)-1 // Позиция пути доступа к папке градиентных фонов главного окна PathOld = SUBSTR(m1_8CurrSet, Pos1, Pos2-Pos1+1) // Старый путь доступа * MsgBox("Старый путь: "+PathOld) PathNew = Disk_dir+'\Aid_data\BackGround\'+CrLf // Новый путь доступа * MsgBox("Новый путь: "+PathNew) m1_8CurrSet = STRTRAN(m1_8CurrSet, PathOld, PathNew) * MsgBox(m1_8CurrSet) mCont1 = "Разрешить_корректировку_пути_на_папку: да" mCont2 = "Разрешить_корректировку_пути_на_папку: нет" m1_8CurrSet = STRTRAN(m1_8CurrSet, mCont1, mCont2) StrFile(ConvToAnsiCP(m1_8CurrSet), "data.ini") oTimer:destroy() // Закрытие фона главного меню ****** Сделать окно с отображением небольшого поясненения и кнопок: ****** Сброс градиентных фонов (вообще их не использовать) ****** Восстановить значения параметров по умолчанию ****** Создать новые градиентные фоны главного окна @ 0.0,0 DCGROUP oGroup1 CAPTION L('Что такое градиентные фоны главного окна') SIZE 55,11.7 @12.0,0 DCGROUP oGroup2 CAPTION L('Задайте нужный режим:' ) SIZE 55,2.7 s=1 @s,1 DCSAY L('Градиентные фоны главного окна улучшают дизайн системы и несут') PARENT oGroup1;s=s+0.8 @s,1 DCSAY L('некоторую смысловую нагрузку, т.к. меняются в течение суток от') PARENT oGroup1;s=s+0.8 @s,1 DCSAY L('первого до последнего через время, зависящее от их количества.') PARENT oGroup1;s=s+0.8 @s,1 DCSAY L('Кроме того фоны дают возможность персонализировать систему. ') PARENT oGroup1;s=s+0.8 s=s+0.7 @s,1 DCSAY L('С полуночи отображаются фоны, заданные в начале серии и ими же') PARENT oGroup1;s=s+0.8 @s,1 DCSAY L('при заданном параметре "Отразить относительно среднего" в это ') PARENT oGroup1;s=s+0.8 @s,1 DCSAY L('же время и заканчивается отображение. Фоны, сформированные по ') PARENT oGroup1;s=s+0.8 @s,1 DCSAY L('параметрам конца серии соответствуют дневному времени суток, ') PARENT oGroup1;s=s+0.8 @s,1 DCSAY L('в частностти средний фон соответствует полдню. ') PARENT oGroup1;s=s+0.8 s=s+0.7 @s,1 DCSAY L('Новые фоны, созданные в режиме: "Создать фоны" вступают в силу') PARENT oGroup1;s=s+0.8 @s,1 DCSAY L('со следующего запуска системы, как и опция:"Не применять фоны"') PARENT oGroup1;s=s+0.8 // .T. - внешняя программа запускается, а главная исполняется дальше, .F. - главная ждет окончания внешней программы * @1.0, 2 DCPUSHBUTTON CAPTION L('Создать фоны' ) SIZE 25, 1.1 PARENT oGroup2 ACTION {||RunShell("","_1_8.exe",.F.)} FONT "10.HelvBold" @1.0, 2 DCPUSHBUTTON CAPTION L('Создать фоны' ) SIZE 25, 1.1 PARENT oGroup2 ACTION {||Run1_8()} FONT "10.HelvBold" @1.0, 28 DCPUSHBUTTON CAPTION L('Не применять фоны') SIZE 25, 1.1 PARENT oGroup2 ACTION {||DeleleGradFon()} DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; FIT ; OPTIONS GetOptions ; MODAL ; TITLE L('1.8. Задание градиентных фонов главного окна') *DCREAD GUI TITLE L('Смена фона каждую секунду, минуту, час') PARENT @oDlgBmp OPTIONS GetOptions GradFonStart(2) // Организация смены фона главного окна Running(.F.) RETURN nil ******** Удалить все jpg-файлы в папке с фонами FUNCTION DeleleGradFon() *oTimer:destroy() // Закрытие фона главного меню aGradFon := Directory(Disk_dir+'\Aid_data\BackGround\*.jpg') IF LEN(aGradFon) > 0 FOR j=1 TO LEN(aGradFon) ERASE(Disk_dir+'\Aid_data\BackGround\'+aGradFon[j,1]) NEXT ENDIF IF FILE('_CheckSum.arx') ERASE('_CheckSum.arx') ENDIF RETURN nil ********************************************************************************************************* ******** Организация смены фона главного окна ********************************************************************************************************* FUNCTION GradFonStart(Par) PUBLIC oTimer, oDlgBmp // Градиентные фоны главного окна aBitmaps := Directory(Disk_dir+'\Aid_data\BackGround2\*.jpg') *HH = VAL(SUBSTR(TIME(),1,2)) // Часы *MM = VAL(SUBSTR(TIME(),4,2)) // Минуты *SS = VAL(SUBSTR(TIME(),7,2)) // Секунды *mTime = HH*3600 + MM*60 + SS // Время, прошедшее с начала суток в секундах *D = 86400 / LEN( aBitmaps ) // Величина интервала имен фонов с одинаковым индексом *snPointer = 1 + INT( (mTime-1) / D ) // Индекс отображаемого фона DCGETOPTIONS ; WINDOWHEIGHT H_MainWind ; WINDOWWIDTH W_MainWind *FullView( (Disk_dir+'\Aid_data\BackGround2\'+aBitmaps[snPointer,1]), "по центру", 0 ) *IF .NOT. FILE('_CheckSum.arx') * DeleleGradFon() *ENDIF *IF LEN(aBitmaps) = 0 * ERASE('_CheckSum.arx') *ENDIF * IF LEN(aBitmaps) > 0 .AND. FILE('_CheckSum.arx') oTimer := DC_SetTimerEvent():new(1000,{||ChangeBackground(@oDlgBmp, Par)}) // Смена фона через время, зависящее от числа фонов. Ед.изм. 0.01 секунды * ENDIF *DCREAD GUI TITLE L('Смена фона каждую секунду, минуту, час') PARENT @oDlgBmp OPTIONS GetOptions RETURN nil ********************************************************************************************************** FUNCTION RUN1_8() *RunShell("","_1_8.exe",.F.) *RUN("_1_8.exe") DeleleGradFon() *oTimer:destroy() // Закрытие фона главного меню LC_RunShell("_1_8.exe",114213396) GradFonStart() *** После запуска просчитать контрольные суммы всех файлов фонов и записать массив aCheckSum в виде файла: _CheckSum.arx *** а в функции ChangeBackground считать этот массив и показывать только фоны, для которых контрольная сумма совпадает aGradFon := Directory(Disk_dir+'\Aid_data\BackGround\*.jpg') aCheckSum := {} IF LEN(aGradFon) > 0 FOR j=1 TO LEN(aGradFon) AADD(aCheckSum, FILECHECK(Disk_dir+'\Aid_data\BackGround\'+aGradFon[j,1])) NEXT ENDIF ** Ожидание окончания формирования массива контрольных сумм. ** Это необходимо, чтобы контрольные суммы соответствовали файлам фонов DO WHILE LEN(aCheckSum) <> LEN(Directory(Disk_dir+'\Aid_data\BackGround\*.jpg')) ENDDO * aCheckSum = DC_ARestore("_CheckSum.arx") DC_ASave(aCheckSum, "_CheckSum.arx") RETURN nil ********************************************************************************************************** ****************************************************************************************************************** ******** Режим 5.11() обеспечивает управление системой "Эйдос" в реальном времени со стороны внешней программы ******** путем задания ею последовательности функций системы "Эйдос" для исполнения (по сути программы, написанной ******** на языке <Эйдос>) в специальной базе данных: "ExternalControl.dbf" и программного контроля их исполнения ****************************************************************************************************************** FUNCTION F5_11old() * есть в версии от 12_12_2016 и более ранних Running(.T.) Razrab() Running(.F.) RETURN NIL ************************************************************************************************** ******** Помощь по режиму 5.11 ************************************************************************************************** FUNCTION Help511() aHelp := {} AADD(aHelp, L('5.11. Тест по АСК-анализу и системе "Эйдос". Это тест по АСК-анализу и системе "Эйдос", включающий 400 вопросов, ')) AADD(aHelp, L('каждый с 1 верным и 3 ошибочными вариантами ответов. Тестирование занимает полную пару, т.е. примерно полтора часа.')) AADD(aHelp, L('Вопросы и варианты ответов представляются тестируемому в случайном порядке. По результатам тестирования тест ставит')) AADD(aHelp, L('оценку 2, 3, 4 или 5 в зависимости от того, в какой квартиль попадает суммарное количество верных ответов: 1-й, 2-й, 3-й')) AADD(aHelp, L('или 4-й. Скриншот последнего экрана теста с оценкой должен быть предоставлен ведущему преподавателю для учета при сдаче')) AADD(aHelp, L('зачета или экзамена. Результаты тестирования могут быть просмотрены в централизованной базе результатов тестирования,')) AADD(aHelp, L('находящейся в Эйдос-облаке, а также на карте мира. Перед началом тестирования нужно ввести фамилию, имя, отчество, ')) AADD(aHelp, L('№ группы и название вуза. ')) mHelpMax = -999;FOR h=1 TO LEN(aHelp);mHelpMax = MAX(mHelpMax, LEN(ALLTRIM(aHelp[h])));NEXT s=1;d=0.9;@0,0 DCGROUP oGroup1 CAPTION L(' ') SIZE mHelpMax-23, LEN(aHelp)*d+1.5 FOR h=1 TO LEN(aHelp);@s,2 DCSAY aHelp[h] SIZE 0 PARENT ogroup1;s=s+d;NEXT DCREAD GUI TO lExit FIT TITLE L('Помощь по режиму: 5.11. Тест по АСК-анализу и системе "Эйдос". (C) Система "ЭЙДОС-X++"') RETURN NIL ************************************************************************************************** ************************************************************************************************************************** ******** 5.11. Тест по АСК-анализу и системе "Эйдос". Это тест по АСК-анализу и системе "Эйдос", включающий 400 вопросов, ******** каждый с 1 верным и 3 ошибочными вариантами ответов. Тестирование занимает полную пару, т.е. примерно полтора часа. ******** Вопросы и варианты ответов представляются тестируемому в случайном порядке. По результатам тестирования тест ставит ******** оценку 2, 3, 4 или 5 в зависимости от того, в какой квартиль попадает суммарное количество верных ответов: 1-й, ******** 2-й, 3-й или 4-й. Скриншот последнего экрана теста с оценкой должен быть предоставлен ведущему преподавателю для ******** учета при сдаче зачета или экзамена. Результаты тестирования могут быть просмотрены в централизованной базе резуль- ******** татов тестирования, находящейся в Эйдос-облаке, а также на карте мира. ************************************************************************************************************************** FUNCTION F5_11() *** Проверка на наличие интернета и FTP доступа ******************************* oScr := DC_WaitOn('Идет проверка наличия интернета и FTP доступа к Эйдос-облаку. Немного подождите!!!',,,,,,,,,,,.F.) IF InternetGetConnectedState( @n, 0 ) == 0 DC_Impl(oScr) aMess := {} AADD(aMess, 'Нет соединения с Internet.') AADD(aMess, 'Тестирование и просмотр результатов невозможны.') LB_Warning(aMess, '(C°) Система "Эйдос-Х++"' ) RETURN NIL ENDIF PRIVATE cFtpServer := "94.25.18.114" // ftp-адрес моего сайта http://lc.kubagro.ru/ из любой сети: внешней или внутренней сети КубГАУ oFtp := FTPClient():new( cFtpServer, Ftp_User, Ftp_Passw ) // Соединение с моим сайтом и авторизация IF .NOT. oFtp:connect() // Есть соединение с моим сайтом и авторизация? DC_Impl(oScr) aMess := {} AADD(aMess, 'Нет FTP-соединения с сервером системы "Эйдос" (Эйдос-облаком). ') AADD(aMess, 'В этих условиях тестирование и просмотр результатов невозможны.') AADD(aMess, 'Но если дать точку доступа с телефона, то обычно все работает. ') LB_Warning(aMess, '(C°) Система "Эйдос-Х++"' ) RETURN NIL ENDIF DC_Impl(oScr) mPar = 1 @ 1, 1 DCGROUP oGroup1 CAPTION L('Задайте режим') SIZE 58, 6.5 @ 1, 2 DCRADIO mPar VALUE 1 PROMPT L('Пройти тестирование по АСК-анализу и системе "Эйдос"') PARENT oGroup1 @ 2, 2 DCRADIO mPar VALUE 2 PROMPT L('Табличный просмотр результатов тестирования в Эйдос-облаке') PARENT oGroup1 @ 3, 2 DCRADIO mPar VALUE 3 PROMPT L('Просмотр результатов тестирования на карте мира') PARENT oGroup1 @ 4.2, 4 DCPUSHBUTTON CAPTION L("Пояснение по режиму тестирования") SIZE 40, 1.7 ACTION {||Help511()} PARENT oGroup1 DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; OPTIONS GetOptions ; ADDBUTTONS; MODAL ; TITLE '5.11. Тест по АСК-анализу и системе "Эйдос"' IF lExit ** Button Ok ELSE RETURN NIL Running(.F.) ENDIF DO CASE CASE mPar=1 * LC_RunShell('_5_11py_testing.exe',484350439) * LC_RunShellAidosPy(717400306, '_5_11py_testing') // Мой вариант на Питоне в системе __AIDOS-PY.exe LC_RunShell("__AIDOS-PY.exe", 717400306, "_5_11py_testing") // Мой вариант на Питоне в системе __AIDOS-PY.exe CASE mPar=2 * LC_RunShell('_5_11py_results.exe',1222077762) * LC_RunShellAidosPy(717400306, '_5_11py_results') // Мой вариант на Питоне в системе __AIDOS-PY.exe LC_RunShell("__AIDOS-PY.exe", 717400306, "_5_11py_results") // Мой вариант на Питоне в системе __AIDOS-PY.exe CASE mPar=3 LC_RunUrl('http://lc.kubagro.ru/map_5_11.php') ENDCASE RETURN NIL ********************************************************************************************************************* ******** Режим 2.3.2.9. Разбиение TXT-файлов на файлы-абзацы обеспечивает: обнаружение в папке: ../AID_DATA/INP_DATA/ ******** TXT-файлов, загрузку этих файлов, нахождение в них абзацев, запись этих абзацев в виде TXT-файлов с именами ******** вида: "ID=#####, <ИМЯ TXT-ФАЙЛА>" из сквозного номера абзаца ID=##### и имени исходного TXT-файла, либо ******** в стандарте "http://kaggle.com/", когда "id, Class name" берутся непосредственно из текста самого файла ********************************************************************************************************************* FUNCTION F2_3_2_9() Running(.T.) mPar = 1 @ 1, 1 DCGROUP oGroup1 CAPTION L('Разбивать TXT-файлы на файлы-абзацы') SIZE 63, 3.5 @ 1, 2 DCRADIO mPar VALUE 1 PROMPT L('В папке обучающей выборки: "..AID_DATA/Inp_data/"') PARENT oGroup1 @ 2, 2 DCRADIO mPar VALUE 2 PROMPT L('В папке распознаваемой выборки: "..AID_DATA/Inp_rasp/"') PARENT oGroup1 mCod = 1 @ 5, 1 DCGROUP oGroup2 CAPTION L('Как кодировать имена файлов:') SIZE 63, 3.5 @ 1, 2 DCRADIO mCod VALUE 1 PROMPT L('В стандарте "Эйдос": в качестве имени класса брать имя файла') PARENT oGroup2 @ 2, 2 DCRADIO mCod VALUE 2 PROMPT L('В стандарте "http://kaggle.com/": "id, Class name" брать из текста файла') PARENT oGroup2 DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; OPTIONS GetOptions ; ADDBUTTONS; MODAL ; TITLE '2.3.2.9. Разбиение TXT-файлов на файлы-абзацы' IF lExit ** Button Ok ELSE RETURN NIL Running(.F.) ENDIF DO CASE CASE mPar = 1 DIRCHANGE(Disk_dir+"\AID_DATA\Inp_data\") // Перейти в папку Inp_data CASE mPar = 2 DIRCHANGE(Disk_dir+"\AID_DATA\Inp_rasp\") // Перейти в папку Inp_rasp ENDCASE mCountTxt = ADIR("*.TXT") // Кол-во TXT-файлов IF mCountTxt = 0 DO CASE CASE mPar = 1 LB_Warning(L('В папке: ')+Disk_dir+L('\AID_DATA\Inp_data\ нет TXT-файлов'), L('2.3.2.9. Разбиение TXT-файлов на файлы-абзацы')) CASE mPar = 2 LB_Warning(L('В папке: ')+Disk_dir+L('\AID_DATA\Inp_rasp\ нет TXT-файлов'), L('2.3.2.9. Разбиение TXT-файлов на файлы-абзацы')) ENDCASE ReTURN nil ENDIF PRIVATE aFileName[mCountTxt], aFileSize[mCountTxt] // Имена и размеры файлов ADIR("*.txt", aFileName, aFileSize) CrLf = CHR(13)+CHR(10) // Конец строки (записи) *** Преобразование имен файлов в кодировку OEM *oScrn := DC_WaitOn(L('Подсчет числа абзацев в файлах'),,,,,,,,,,,.F.) N_Paragraph = 0 FOR mFile=1 TO LEN(aFileName) // Цикл по TXT-файлам в дирректории Inp_data mLcBuf = ALLTRIM(FILESTR(aFileName[mFile])) // Загрузка файла mLcBuf = STRTRAN(mLcBuf, CrLf, CHR(13)) N_Paragraph = N_Paragraph + NUMTOKEN(mLcBuf, CHR(13)) NEXT *DC_Impl(oScrn) nMax = N_Paragraph+LEN(aFileName) Mess = L('2.3.2.9. Разбиение TXT-файлов на файлы-абзацы') @ 4,5 DCPROGRESS oProgress SIZE 70,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 DCREAD GUI TITLE Mess PARENT @oDialog FIT EXIT oDialog:show() nTime = 0 DC_GetProgress(oProgress,0,nMax) ********************************************************************************************************************************* IF mCod = 1 // Имена файлов кодировать в стандарте "Эйдос": "id, Class name" брать из номера и наименования файла mID = 0 FOR mFile=1 TO LEN(aFileName) // Цикл по TXT-файлам в дирректории Inp_data mLcBuf = ALLTRIM(FILESTR(aFileName[mFile])) // Загрузка файла mLcBuf = STRTRAN(mLcBuf, CrLf, CHR(13)) FOR ww=1 TO NUMTOKEN(mLcBuf, CHR(13)) // Цикл по абзацам mParagraph = TOKEN(mLcBuf, CHR(13), ww) STRFILE(mParagraph, STRTRAN(ALLTRIM(aFileName[mFile]),'.txt','')+'-'+STRTRAN(STR(++mID,9),' ','0')+'.txt') DC_GetProgress(oProgress, ++nTime, nMax) NEXT NEXT ENDIF ********************************************************************************************************************************* IF mCod = 2 // Имена файлов кодировать в стандарте "http://kaggle.com/": "id, Class name" брать из текста файла FOR mFile=1 TO LEN(aFileName) // Цикл по TXT-файлам в дирректории Inp_data mLcBuf = ALLTRIM(FILESTR(aFileName[mFile])) // Загрузка файла mLcBuf = STRTRAN(mLcBuf, CrLf, CHR(13)) FOR ww=1 TO NUMTOKEN(mLcBuf, CHR(13)) // Цикл по абзацам mParagraph = TOKEN(mLcBuf, CHR(13), ww) IF AT('id,text,label', mParagraph) = 0 // Исключить строку шапки, с наименованиями полей * mID = TOKEN(mParagraph,, 1) // Первый элемент абзаца - это id mID = STRTRAN(STR(VAL(TOKEN(mParagraph,, 1)),LEN(ALLTRIM(STR(N_Paragraph,15)))),' ','0') // Форматированный первый элемент абзаца - это id IF mPar = 2 STRFILE(mParagraph, ALLTRIM(mID)+'.txt') ELSE mClssName = ALLTRIM(TOKEN(mParagraph,, NUMTOKEN(mParagraph))) // Последний элемент абзаца - это класс (1 = "True", 0 = "False") ########## IF mClssName='1' mClssName = 'True' ELSE IF mClssName='0' mClssName = 'False' ELSE mClssName = 'Unknown' ENDIF ENDIF STRFILE(mParagraph, ALLTRIM(mID)+', '+mClssName+'.txt') ENDIF ENDIF DC_GetProgress(oProgress, ++nTime, nMax) NEXT NEXT ENDIF ********************************************************************************************************************************* FOR mFile=1 TO LEN(aFileName) // Цикл по TXT-файлам в дирректории Inp_data ERASE(aFileName[mFile]) DC_GetProgress(oProgress, ++nTime, nMax) NEXT *MsgBox('STOP') DC_GetProgress(oProgress,nMax,nMax) oDialog:Destroy() DIRCHANGE(Disk_dir) // Перейти в папку с системой aMess := {} DO CASE CASE mPar = 1 AADD(aMess, L('Результирующие файлы находятся в папке: ')+Disk_dir+'\AID_DATA\Inp_data\') CASE mPar = 2 AADD(aMess, L('Результирующие файлы находятся в папке: ')+Disk_dir+'\AID_DATA\Inp_rasp\') ENDCASE AADD(aMess, L('Исходные файлы удалены.')) LB_Warning(aMess, L('2.3.2.9. Разбиение TXT-файлов на файлы-абзацы')) Running(.F.) RETURN NIL ******************************************************************** ******** Помощь по режиму 5.11B() ********************************** ******************************************************************** FUNCTION Help511B() *SET TAG TO COMMAND DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы cFile = "_Struct_funct_Aidos-system.pdf" IF .NOT. FILE(cFile) Mess = L('В папке с исполнимым модулем системы нет файла: "#"') Mess = STRTRAN(Mess, "#", cFile) LB_Warning(Mess) ENDIF // Проверить контрольную сумму файла и если она не совпадает // выдать сообщение о том, что файл поврежден (чтобы было невозможно заменить графический файл) IF FILECHECK(cFile) = 13475490 * DC_PrintPreviewAcrobat( cFile, 'Система "Эйдос-Х++"' ) RunShell(cFile,"SumatraPDF-3.4.5-32.exe",.T.) ELSE Mess = L('Файл: "#" поврежден и не может быть отображен!') Mess = STRTRAN(Mess, "#", cFile) * Mess = STRTRAN(Mess, "#", ALLTRIM(STR(FILECHECK(cFile),19))) // Отображение контрольной суммы файлы LB_Warning(Mess) ENDIF DIRCHANGE(Disk_dir) IF ApplChange("") // Перейти в папку выбранного приложения или выйти из системы LB_Warning(L("Необходимо задать (выбрать) хотя бы одно текущее приложение !!!")) Running(.F.) RETURN NIL ENDIF RETURN nil ********************************************************** ******** Проверка, открыт файл или нет (от Роджера Доннея) ********************************************************** FUNCTION IsFileOpened( cFileName ) *#include "fileio.ch" LOCAL lStatus := .F. // Файл cFileName закрыт LOCAL nHandle := FOpen( cFileName, FO_READWRITE+FO_DENYWRITE ) IF nHandle <= 0 lStatus := .T. // Файл cFileName открыт или его нет ELSE FClose(nHandle) ENDIF RETURN lStatus ********************************************************************************************************* ******** 2.4. Просмотр эвентологических баз данных (баз событий), в которых исходные данные закодированы ******** с помощью классификационных и описательных шкал и градаций и представлены в форме кодов ******** событий, между которыми существуют причинно-следственные связи ********************************************************************************************************* FUNCTION F2_4() LOCAL GetList := {}, aPres, oBrowse, oToolBar, aColors, bColor, GetOptions, oEventsKO, bItems Running(.T.) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF mFlagErr = .F. IF ApplChange("2_4()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения mFlagErr = .T. ENDIF IF .NOT.FILE("EventsKO.dbf") aMess := {} AADD(aMess, L('База событий "EventsKO.dbf" отсутствует')) cTitle = L('2.4. Просмотр эвентологических баз данных (баз событий)') LB_Warning(aMess, cTitle) mFlagErr = .T. ELSE CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE EventsKO EXCLUSIVE NEW IF FIELDNAME(1) <> "NAME_OBJ" aMess := {} AADD(aMess, L('Формализация предметной области произведена не в режиме 2.3.2.2.')) cTitle = L('2.4. Просмотр эвентологических баз данных (баз событий)') LB_Warning(aMess, cTitle) mFlagErr = .T. ENDIF ENDIF IF mFlagErr ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF IF FILE(Disk_dir+"\_2_3_2_2.arx") aSoftInt = DC_ARestore(Disk_dir+"\_2_3_2_2.arx") Regim = aSoftInt[ 1] Flag_zer = aSoftInt[ 2] M_ClSc1 = aSoftInt[ 3] M_ClSc2 = aSoftInt[ 4] M_OpSc1 = aSoftInt[ 5] M_OpSc2 = aSoftInt[ 6] N_SKGrCl = aSoftInt[ 7] N_SKGrPr = aSoftInt[ 8] K_N_ClSc = aSoftInt[ 9] K_N_OpSc = aSoftInt[10] K_N_GrClSc = aSoftInt[11] K_N_GrOpSc = aSoftInt[12] M_ObAnk = aSoftInt[13] N_Chast = aSoftInt[14] M_Interval = aSoftInt[15] M_Scenario = aSoftInt[16] K_GradNClSc = aSoftInt[17] // Количество градаций в числовой классификационной шкале K_GradNOpSc = aSoftInt[18] // Количество градаций в числовой описательной шкале mGorizMin = aSoftInt[19] mGorizMax = aSoftInt[20] mGlubMin = aSoftInt[21] mGlubMax = aSoftInt[22] M_ChastObi = aSoftInt[23] M_ChastRso = aSoftInt[24] N_ChastObi = aSoftInt[25] N_ChastRso = aSoftInt[26] M_XlsDbf = aSoftInt[27] mTxtCSField = aSoftInt[28] // Способ интерпретации значений текстовых полей - классификационных шкал файла исходных данных mTxtOSField = aSoftInt[29] // Способ интерпретации значений текстовых полей - описательных шкал файла исходных данных mTxtCSSep = aSoftInt[30] mTxtOSSep = aSoftInt[31] * mScenario = aSoftInt[32] // mScenario=1 Не применять сценарный метод АСК-анализа и спец.интерпретацию TXT-полей (старый вариант) mScenario = aSoftInt[32] // mScenario=1 Не применять сценарный метод АСК-анализа mSpecInterprCls = aSoftInt[33] // .T. - Применить спец.интерпретацию текстовых полей классов, .F. - не применять mSpecInterprAtr = aSoftInt[34] // .T. - Применить спец.интерпретацию текстовых полей признаков, .F. - не применять mNameGrNumSc= aSoftInt[35] // Какие наименования ГРАДАЦИЙ числовых шкал использовать mClsAvr = aSoftInt[36] // .F. = модель без усреднения по классам mSortUnqCls = aSoftInt[37] // Выделять уникальные значения классов и сортировать, 1-да, 2-нет mLemmatCls = IF(mScenario=1,2,aSoftInt[38]) // Проводить лемматизацию классов, 1-да, 2-нет mSortUnqGos = aSoftInt[39] // Выделять уникальные значения признаков и сортировать, 1-да, 2-нет mLemmatGos = IF(mScenario=1,2,aSoftInt[40]) // Проводить лемматизацию классов, 1-да, 2-нет ENDIF * mScenario VALUE 1 PROMPT L('Не применять сценарный метод АСК-анализа и спец.интерпретацию TXT-полей' * mScenario VALUE 2 PROMPT L('Применить сценарный метод прогнозирования АСК-анализа' * mScenario VALUE 3 PROMPT L('Применить специальную интерпретацию текстовых полей "Inp_data"' (старый вариант) * mSpecInterprCls = .T. // Применять спец.интерпретацию текстовых полей классов * mSpecInterprAtr = .T. // Применять спец.интерпретацию текстовых полей признаков *IF mScenario = 3 // Старый вариант IF mSpecInterprCls .OR. mSpecInterprAtr aMess := {} AADD(aMess, L('Формализация предметной области произведена в режиме 2.3.2.2, т.е.')) AADD(aMess, L('Универсальном программном интерфейсе импорта данных в систему')) AADD(aMess, L('при опциях:",')) AADD(aMess, IF(mSpecInterprCls, 'П','Не п')+'рименять спец.интерпретацию текстовых полей классов') AADD(aMess, IF(mSpecInterprAtr, 'П','Не п')+'рименять спец.интерпретацию текстовых полей признаков') AADD(aMess, L('поэтому просмотр базы событий "EventsKO.dbf" невозможен !!!')) cTitle = L('2.4. Просмотр эвентологических баз данных (баз событий)') FOR j=1 TO LEN(aMess);aMess[j] = L(aMess[j]);NEXT LB_Warning(aMess, cTitle) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE EventsKO EXCLUSIVE NEW /* ----- Create browse ----- */ *SET TAG TO COMMAND *aInp_name = DC_ARestore("_Inp_name.arx") // Загрузка массива наименований шкал (колонок) из файла *DC_ASave(aInp_name, "_Inp_name.arx") // Запись массива наименований шкал (колонок) в виде файла *LB_Warning(aInp_name) ************************************ DIRCHANGE(M_ApplsPath+"Inp_data\") CrLf = CHR(13)+CHR(10) // Конец строки (абзаца) (CrLf) M_InpName = ALLTRIM(FILESTR('Inp_name.txt')) // Загрузка Inp_name.txt M_InpName = " " + CrLf + STRTRAN(M_InpName,CHR(26),"") + CrLf * LB_Warning(M_InpName) aInp_name := {} aColumnNames := {} FOR ff=1 TO NUMTOKEN(M_InpName,CrLf) AADD(aInp_name , SUBSTR(UPPER(ALLTRIM(TOKEN(M_InpName,CrLf,ff))),1,255)) // Ограничение длины наименования шкалы 255 символов AADD(aColumnNames, SUBSTR(UPPER(ALLTRIM(TOKEN(M_InpName,CrLf,ff))),1,255)) // Ограничение длины наименования шкалы 255 символов NEXT DC_ASave(aColumnNames, M_ApplsPath+"/Inp_data/_ColumnNames.arx") // Запись массива наименований шкал (колонок) в виде файла DC_ASave(aInp_name , M_ApplsPath+"/Inp_data/_Inp_name.arx") // Запись массива наименований шкал (колонок) в виде файла ************************************ *aMess := {} *FOR j=1 TO LEN(aInp_name) * AADD(aMess, ALLTRIM(STR(j))+'. '+aInp_name[j]) *NEXT *LB_Warning(aMess, L('2.4. Просмотр эвентологических баз данных (баз событий)') N_Col = LEN(aInp_name) // Число колонок в БД EventsKO PRIVATE aHeadName[N_Col], aDL[N_Col] aHeadName[1] = aInp_name[1] // 3. Заполнять строки заголовков целыми словами до тех пор, пока не превышена макс.ширина заголовка ****** ФОРМИРОВАНИЕ ЗАГОЛОВКОВ // Определение ширины заголовка в кол-ве символов DL = длина наиболее длинного слова AFILL(aDL, -99999999999) FOR j=1 TO N_Col M_NameCol = ALLTRIM(aInp_name[j]) * M_NameCol = STRTRAN(M_NameCol,'-','- ') // Чтобы были переносы в заголовке по тире * M_NameCol = STRTRAN(M_NameCol,'.','. ') // Чтобы были переносы в заголовке по точке * M_NameCol = STRTRAN(M_NameCol,';','; ') // Чтобы были переносы в заголовке по точке с запятой * M_NameCol = CHARONE(M_NameCol,' ') FOR w=1 TO NUMTOKEN(M_NameCol," ") // Разделитель между словами - пробел M_Word = UPPER(TOKEN(M_NameCol," ",w)) IF aDL[j] < LEN(M_Word) aDL[j] = LEN(M_Word) ENDIF NEXT NEXT Max_HeadLines = -999999999 FOR j=1 TO N_Col M_NameCol = ALLTRIM(aInp_name[j]) M_NameCol = STRTRAN(M_NameCol,'-','- ') // Чтобы были переносы в заголовке по тире * M_NameCol = STRTRAN(M_NameCol,'-','- ') // Чтобы были переносы в заголовке по тире * M_NameCol = STRTRAN(M_NameCol,'.','. ') // Чтобы были переносы в заголовке по точке * M_NameCol = STRTRAN(M_NameCol,';','; ') // Чтобы были переносы в заголовке по точке с запятой * M_NameCol = CHARONE(M_NameCol,' ') aHeadString := {} // Массив строк заголовка j-й колонки AADD(aHeadString, " ") AADD(aHeadString, ALLTRIM(STR(j,19))+". ") // Номер колонки *** Начало цикла по словам FOR w=1 TO NUMTOKEN(M_NameCol," ") // Разделитель между словами - пробел M_Word = UPPER(TOKEN(M_NameCol," ",w)) IF LEN(aHeadString[LEN(aHeadString)]+" "+M_Word) <= aDL[j] // Если после добавления слова к строке заголовка ее ширина меньше заданной, // то добавлять слово к этой же строке заголовка aHeadString[LEN(aHeadString)] = aHeadString[LEN(aHeadString)]+" "+M_Word ELSE // Если после добавления слова к строке заголовка ее ширина больше заданной, // то делать новую строку (";") и к ней добавлять слово AADD(aHeadString, ";"+M_Word) ENDIF NEXT // Переписать строки заголовка в массив наименований колонок aHeadName[j] = "" FOR s=1 TO LEN(aHeadString) aHeadName[j] = aHeadName[j] + aHeadString[s] NEXT Max_HeadLines = MAX(Max_HeadLines,LEN(aHeadString)) // Определение максимального количества строк в заголовке NEXT SELECT EventsKO ***** Определение максимальной длины номера записи mLenMax = LEN(ALLTRIM(STR(RECCOUNT()))) mLenMax = IF(mLenMax >= 5,mLenMax,5) ***** Определение максимальной длины наименования объекта выборки *INDEX ON LEN(ALLTRIM(Name_obj)) TO EventsKO *DBGOBOTTOM() *mNameObjMaxLen = LEN(ALLTRIM(Name_obj)) *SET ORDER TO *DBGOTOP() DCSETPARENT TO @ 5, 0 DCBROWSE oEventsKO ALIAS 'EventsKO' SIZE 132,22 ; PRESENTATION LC_BrowPres() ; // Только просмотр БД NOSOFTTRACK ; HEADLINES Max_HeadLines ; // Кол-во строк в заголовке (перенос строки - ";") SCOPE ; ITEMMARKED bItems DCSETPARENT oEventsKO DCBROWSECOL DATA {|| RECNO() } HEADER L("№") WIDTH mLenMax FOOTER ALLTRIM(STR(0)) DCBROWSECOL FIELD EventsKO->Name_obj HEADER L('Наименование;объекта') PARENT oEventsKO WIDTH 24 FOOTER ALLTRIM(STR(1)) // mNameObjMaxLen *** Подарок от Роджера FOR j=M_ClSc1 TO M_ClSc2 DCBROWSECOL DATA FieldAnchor(j,aDL[j],0) HEADER aHeadName[j] PARENT oEventsKO WIDTH aDL[j]+1 FONT "9.Courier" FOOTER ALLTRIM(STR(j)) COLOR {||{nil,aColor[100]}} NEXT FOR j=M_OpSc1 TO M_OpSc2 DCBROWSECOL DATA FieldAnchor(j,aDL[j],0) HEADER aHeadName[j] PARENT oEventsKO WIDTH aDL[j]+1 FONT "9.Courier" FOOTER ALLTRIM(STR(j)) NEXT DCGETOPTIONS SAYFONT '10.Helv Bold' TABSTOP AUTORESIZE cTitle = L('2.4. Просмотр эвентологических баз данных (баз событий). Текущая модель: "')+UPPER(Ar_Model[M_CurrInf])+'"' DCREAD GUI ; FIT ; OPTIONS GetOptions ; MODAL ; TITLE cTitle ; EVAL {|o|SetAppFocus(oEventsKO:GetColumn(1))} ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ******************************************************************************************* ******************************************************************************************* ***************************************************************************************************************************** ******** 4.4.11.Отображение: ******** - mOption='NeuroNet' - Парето-подмножеств нелокальной нейронной сети (аналогичен режиму 6.6 DOS-версии системы "Эйдос") ******** - mOption='IntCognMaps' - Интегральных когнитивных карт (аналогичен режиму 6.7 DOS-версии системы "Эйдос") ******** ЭКРАННАЯ ФОРМА ДЛЯ ДИАЛОГА: ******** Сортировать рецепторы по информативности (как в инф. портрете класса) или по модулю информативности ******** Отображать с наименованиями рецепторов или только с кодами ******** Отображать не более #### рецепторов ******** Отображать не более #### нейронов #################################### ******** Порог силы связи рецепторов ### ******** Задать модель: abs, per#, inf# ***************************************************************************************************************************** FUNCTION F4_4_11(mOption) LOCAL GetList := {}, aPres, oBrowse, oToolBar, aColors, bColor, GetOptions, cText PUBLIC aRecs:={}, multisel:=.T. // Нужно для выбора нейронов для визуализации Running(.T.) * LB_Warning(L("Этот режим сейчас в процессе доработки. Скоро будет!") * Running(.F.) * RETURN NIL IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF ApplChange("4.4.11()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения aMess := '' AADD(aMess, L('Необходимо сначала создать приложение в режиме 1.3, 2.3.2.2 или другом,')) AADD(aMess, L('создать модели в режиме 3.5 и уже после этого запускать данный режим !')) LB_Warning( aMess ) Running(.F.) ReTURN NIL ENDIF // Если файл параметров режима 4.4.11 есть, то скачать его и присвоить значения переменным // Если файл параметров режима 4.4.11 нет, то присвоить переменным значения по умолчанию, // сделать массив параметров и после корректровки в диалоге записать его в виде файла PUBLIC M_KodCls1, M_KodCls2, M_KodAtr1, M_KodAtr2, mViewMaxCls, mViewMaxRel, mViewMaxAtr, mViewPorogRel, mSort, mViewNameCls, mViewNameAtr IF FILE('_4_4_11.arx') aPar4411 = DC_ARestore("_4_4_11.arx") M_KodCls1 = aPar4411[ 1] // Начальный код класса (нейрона) M_KodCls2 = aPar4411[ 2] // Конечный код класса (нейрона) M_KodAtr1 = aPar4411[ 3] // Начальный код признака (рецептора) M_KodAtr2 = aPar4411[ 4] // Конечный код признака (рецептора) mViewMaxCls = aPar4411[ 5] // Отображать не более mViewMaxCls классов mViewMaxRel = aPar4411[ 6] // Отображать не более mViewMaxRel связей mViewMaxAtr = aPar4411[ 7] // Отображать не более mViewMaxAtr рецепторов mViewPorogRel = aPar4411[ 8] // Отображать связи с интенсивностью не менее mViewPorogRel mSort = aPar4411[ 9] // mSort=1 - сортировать по модулю информативности; mSort=2 - по информативности и знаку mViewNameCls = aPar4411[10] // .T. - рисовать наименования классов (нейронов) mViewNameAtr = aPar4411[11] // .T. - рисовать наименования признаков (рецепторов) ELSE PUBLIC aPar4411[11] CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW PUBLIC M_KodCls1, M_KodCls2 SELECT Classes DBGOTOP() ;M_KodCls1 = Kod_cls DBGOBOTTOM();M_KodCls2 = Kod_cls PUBLIC M_KodAtr1, M_KodAtr2 SELECT Attributes DBGOTOP() ;M_KodAtr1 = Kod_atr DBGOBOTTOM();M_KodAtr2 = Kod_atr mViewMaxCls = 16 mViewMaxRel = 1000 mViewMaxAtr = 16 mViewPorogRel = 0 mSort = 1 mViewNameCls = .T. mViewNameAtr = .T. // Сохранить файл с информацией о параметрах режима 4.4.11 в текущей директории системы и в папке приложения aPar4411[ 1] = M_KodCls1 // Начальный код класса (нейрона) aPar4411[ 2] = M_KodCls2 // Конечный код класса (нейрона) aPar4411[ 3] = M_KodAtr1 // Начальный код признака (рецептора) aPar4411[ 4] = M_KodAtr2 // Конечный код признака (рецептора) aPar4411[ 5] = mViewMaxCls // Отображать не более mViewMaxCls классов aPar4411[ 6] = mViewMaxRel // Отображать не более mViewMaxRel связей aPar4411[ 7] = mViewMaxAtr // Отображать не более mViewMaxAtr рецепторов aPar4411[ 8] = mViewPorogRel // Отображать связи с интенсивностью не менее mViewPorogRel aPar4411[ 9] = mSort // mSort=1 - сортировать по модулю информативности; mSort=2 - по информативности и знаку aPar4411[10] = mViewNameCls // .T. - рисовать наименования классов (нейронов) aPar4411[11] = mViewNameAtr // .T. - рисовать наименования признаков (рецепторов) * aPar4411 = DC_ARestore("_4_4_11.arx") DC_ASave(aPar4411 , "_4_4_11.arx") ENDIF ***** Проверка на наличие основных БД всех моделей и определение времени их создания. ***** Если оно не изменилось со времени предыдущего применения режима 4_2_1, то копировать txt=>dbf не надо Ar_Model := {"Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } Flag = .F. FOR z=1 TO LEN(Ar_Model) IF .NOT. FILE(Ar_Model[z]+'.txt') Mess = L('Модель: "#" отсутствует. Необходимо провести расчет моделей в режиме 3.5 !!!') Mess = STRTRAN(Mess, '#', Ar_Model[z]) LB_Warning( Mess ) Flag = .T. EXIT ENDIF NEXT FOR z=1 TO LEN(Ar_Model) IF .NOT. FILE(Ar_Model[z]+'.dbf') ConvTXTtoDBF() // Преобразование Abs, Prc#, Inf# из TXT в DBF * Mess = L('DBF-файл модели: "#" отсутствует. Необходимо сначала зайти в режим 5.5, а потом сюда !!!') * Mess = STRTRAN(Mess, '#', Ar_Model[z]) * LB_Warning( Mess ) * Flag = .T. * EXIT ENDIF NEXT IF Flag // Если какой-нибудь БД нет, то режим не запускать ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF mLenNameMax = CreateStructAll() // Создание файлов структур баз данных всех моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() // Количество классов (градаций классификационных шкал) USE Gr_OpSc EXCLUSIVE NEW;N_Gos = RECCOUNT() // Количество признаков (градаций описательных шкал) USE Opis_Sc EXCLUSIVE NEW * ########################################################################### // Открытие текстовых баз данных ******************************************** *DC_ASave(aInfStruct, "_InfStruct.arx") // Когда БД создается - записывать структуру, когда открывается - считывать aInfStruct := DC_ARestore("_InfStruct.arx") *DC_ASave(aStrEmpty, "_aStrEmpty.arx") // Записывать только после расчета Abs.txt, а при расчете остальных БД только считывать *DC_ASave(aColEmpty, "_aColEmpty.arx") aStrEmpty = DC_ARestore("_aStrEmpty.arx") aColEmpty = DC_ARestore("_aColEmpty.arx") ************************************************* ***** Формирование пустой записи N_Col = N_Cls+6 // Число полей CrLf = CHR(13)+CHR(10) // Конец строки (записи) Lc_buf = "" FOR j=1 TO N_Col * S = IF(j=2*INT(j/2),"#","X") // Для отладки S = " " // Для работы Lc_buf = Lc_buf + REPLICATE(S, aInfStruct[j,3]) NEXT Lc_buf = Lc_buf + CrLf PUBLIC Len_LcBuf := LEN(Lc_buf) ****** Открываем стат.базы и базы знаний (7 по частным критериям знаний) Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } PUBLIC nHandle[LEN(Ar_Model)] FOR z=1 TO LEN(Ar_Model) nHandle[z] := FOpen( Ar_Model[z]+".txt", FO_READWRITE ) // Открыть все текстовые базы данных ######################################## NEXT **** Рассчет массива начальных позиций полей в строке PUBLIC aPos[N_Col] aPos[1] = 1 FOR j=2 TO N_Col aPos[j] = aPos[j-1] + aInfStruct[j-1,3] NEXT * ########################################################################### ************************************************************* // Определить максимальную длину наименования: ОПИСАТЕЛЬНАЯ ШКАЛА-градация CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Gr_OpSc EXCLUSIVE NEW USE Opis_Sc EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW SELECT Gr_OpSc PUBLIC mLenMaxGOS := -9999999 DBGOTOP() DO WHILE .NOT. EOF() mLenMaxGOS = MAX(mLenMaxGOS, LEN(Name_GrOS)) DBSKIP(1) ENDDO SELECT Opis_Sc PUBLIC mLenMaxOS := -9999999 DBGOTOP() DO WHILE .NOT. EOF() mLenMaxOS = MAX(mLenMaxOS, LEN(Name_OpSc)) DBSKIP(1) ENDDO SELECT Attributes PUBLIC mLenMaxAtr := 33 DBGOTOP() DO WHILE .NOT. EOF() mLenMaxAtr = MAX(mLenMaxAtr, LEN(Name_atr)) DBSKIP(1) ENDDO // Сформировать пустую БД InfPortCls, как часть БД Attributes aStr := { { "Kod_atr" , "N", 15, 0 }, ; { "Name_atr" , "C", mLenMaxAtr, 0 }, ; { "Znach" , "N", 19, 7 }, ; { "Kod_OpSc" , "N", 15, 0 }, ; { "Fltr_Wind", "C", 1, 0 } } // Для фильтра "Вписать в окно" DbCreate( "InfPortCls" , aStr ) DbCreate( "InfPortClsPos", aStr ) DbCreate( "InfPortClsNeg", aStr ) DbCreate( "InfPortClsAbs", aStr ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW SELECT Classes mLenMaxCls = -99999 DBGOTOP() DO WHILE .NOT. EOF() mLenMaxCls = MAX(mLenMaxCls, LEN(ALLTRIM(NAME_CLS))) DBSKIP(1) ENDDO aStr := { { "KOD_ClS" , "N", 15 , 0 },; { "NAME_ClS", "C",mLenMaxCls, 0 },; { "tag" , "L", 2 , 0 } } DbCreate( 'ClassNeuro.dbf', aStr ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW USE ClassNeuro EXCLUSIVE NEW;ZAP SELECT Classes *SET FILTER TO Abs+Int_inf > 0 DBGOTOP() DO WHILE .NOT. EOF() mKodClS = KOD_ClS mNameClS = NAME_ClS SELECT ClassNeuro APPEND BLANK REPLACE KOD_ClS WITH mKodClS REPLACE NAME_ClS WITH mNameClS REPLACE tag WITH .F. SELECT Classes DBSKIP(1) ENDDO CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW USE ClassNeuro EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW USE Gr_OpSc EXCLUSIVE NEW USE Opis_Sc EXCLUSIVE NEW USE InfPortCls EXCLUSIVE NEW USE InfPortClsPos EXCLUSIVE NEW USE InfPortClsNeg EXCLUSIVE NEW USE InfPortClsAbs EXCLUSIVE NEW *PUBLIC M_KodCls1, M_KodCls2 *SELECT Classes *DBGOTOP() ;M_KodCls1 = Kod_cls *DBGOBOTTOM();M_KodCls2 = Kod_cls *PUBLIC M_KodAtr1, M_KodAtr2 *SELECT Attributes *DBGOTOP() ;M_KodAtr1 = Kod_atr *DBGOBOTTOM();M_KodAtr2 = Kod_atr /* ----- Create ToolBar ----- */ W = 132 // Ширина окна D = 1.5 // Отступ на линейки прокрутки и т.д. P1 = W / 2 // Конечная позиция левого окна P2 = P1 + D // Начальная позиция правого окна S=3 // Смещение вниз нижнего окна (число строк) ****** Сделать и вывести инф.портрет 1-го класса @0,0 DCGROUP oGroup1 SIZE W+2*D, 33.0+S @13+S, 1 DCSAY {|| MessIPC } OBJECT oSay1 SAYSIZE W FONT "12.Helv Bold" PARENT oGroup1 // Наименование класса и модели в SWOT @14+S, 1 DCSAY L("АКТИВИРУЮЩИЕ рецепторы и сила их влияния") SAYSIZE W/2 FONT "12.Helv Bold" COLOR GRA_CLR_RED PARENT oGroup1 // Наименование класса и модели в SWOT @14+S,P2 DCSAY L("ТОРМОЗЯЩИЕ рецепторы и сила их влияния") SAYSIZE W/2 FONT "12.Helv Bold" COLOR GRA_CLR_BLUE PARENT oGroup1 // Наименование класса и модели в SWOT SELECT ClassNeuro DBGOTOP() PUBLIC mFltrLeftFlag44B := .F. PUBLIC mFltrRightFlag44B := .F. FiltrLeft44B(.F.) FiltrRight44B(.F.) InfNeuroCls(6) ******** v Сортировать связи по интенсивности или по ее |модулю| ******** v Отображать наименования нейронов и рецепторов ******** v Отображать нейроны и рецепторы по установленным фильтрам ******** v Отображать нейроны и рецепторы c |инт.связи| больше ###.#% от макс. ******** v Отображать не более #### связей ******** v Отображать не более #### нейронов ******** v Отображать не более #### рецепторов ******** v Задать диапазон кодов отображаемых нейронов: ##### ##### ******** v Задать диапазон кодов отображаемых рецепторов: ##### ##### ******** v Отображать отмеченные в экранной форме нейроны ******** v Отображать отмеченные в экранной форме рецепторы ******** Задать модель: abs, per#, inf# H = 1.4 @ 27.3+S, 1 DCTOOLBAR oToolBar SIZE W/2, H PARENT oGroup1 DCADDBUTTON CAPTION L("ВКЛЮЧИТЬ фильтр по фактору") ; SIZE LEN(L("ВКЛЮЧИТЬ фильтр по фактору"))+5 ; ACTION {||FiltrLeft44B(.T.), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION L("ВЫКЛЮЧИТЬ фильтр по фактору") ; SIZE LEN(L("ВЫКЛЮЧИТЬ фильтр по фактору"))+5.5 ; ACTION {||FiltrLeft44B(.F.), DC_GetRefresh(GetList)}; PARENT oToolBar @ 27.3+S, W/2+D DCTOOLBAR oToolBar SIZE W/2, H PARENT oGroup1 DCADDBUTTON CAPTION L("ВКЛЮЧИТЬ фильтр по фактору") ; SIZE LEN(L("ВКЛЮЧИТЬ фильтр по фактору"))+5 ; ACTION {||FiltrRight44B(.T.), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION L("ВЫКЛЮЧИТЬ фильтр по фактору") ; SIZE LEN(L("ВЫКЛЮЧИТЬ фильтр по фактору"))+5.8 ; ACTION {||FiltrRight44B(.F.), DC_GetRefresh(GetList)}; PARENT oToolBar **** Управление под верхним окном @ 10.3+S, 1 DCTOOLBAR oToolBar SIZE 20, 2.0 PARENT oGroup1 DCADDBUTTON CAPTION L('Помощь') ; SIZE LEN(L("Помощь"))+7 ; ACTION {||Help44B(mOption), DC_GetRefresh(GetList)}; PARENT oToolBar @10.2+S, W/2+D-1.5 DCPUSHBUTTON CAPTION L('ClearSet') ; SIZE LEN(L("ClearSet"))+1, 2.0 ; ACTION {||ClearSet(), DC_GetRefresh(GetList)} ; PARENT oGroup1 ; TOOLTIP L('Сброс фильтров (парметров выборки)') @10.3+S, 14.7 DCSAY L("Максимальное количество отображаемых нейронов:") PARENT oGroup1 @10.3+S, 55.7 DCGET mViewMaxCls PICTURE "#######" COLOR "n/gb+" PARENT oGroup1 @11.3+S, 14.7 DCSAY L("Максимальное количество отображаемых связей:") PARENT oGroup1 @11.3+S, 55.7 DCGET mViewMaxRel PICTURE "#######" COLOR "n/gb+" PARENT oGroup1 ****** Справа A=D+10;B=A+35.5;C=B+9 @10.3+S, W/2+A DCSAY L("Диапазон кодов отображаемых нейронов:") PARENT oGroup1 @10.3+S, W/2+B DCGET M_KodCls1 PICTURE "#######" COLOR "n/gb+" PARENT oGroup1 @10.3+S, W/2+C DCGET M_KodCls2 PICTURE "#######" COLOR "n/gb+" PARENT oGroup1 @11.3+S, W/2+A DCSAY L("Диапазон кодов отображаемых рецепторов:") PARENT oGroup1 @11.3+S, W/2+B DCGET M_KodAtr1 PICTURE "#######" COLOR "n/gb+" PARENT oGroup1 @11.3+S, W/2+C DCGET M_KodAtr2 PICTURE "#######" COLOR "n/gb+" PARENT oGroup1 **** Управление под нижним окном @ 29.0+S, 1 DCTOOLBAR oToolBar SIZE W/2, 3.4 FONT "9.Helv Bold" PARENT oGroup1 IF mOption = 'NeuroNet' DCADDBUTTON CAPTION L("НейроСеть") ; SIZE LEN(L("НейроСеть"))+4 ; ACTION {||GraNeuroNet(M_KodCls1, M_KodCls2, M_KodAtr1, M_KodAtr2, mViewMaxCls, mViewMaxRel, mViewMaxAtr, mViewPorogRel, mSort, mViewNameCls, mViewNameAtr, mOption), DC_GetRefresh(GetList)}; PARENT oToolBar ELSE DCADDBUTTON CAPTION L("Когн.карта") ; SIZE LEN(L("Когн.карта"))+3 ; ACTION {||GraNeuroNet(M_KodCls1, M_KodCls2, M_KodAtr1, M_KodAtr2, mViewMaxCls, mViewMaxRel, mViewMaxAtr, mViewPorogRel, mSort, mViewNameCls, mViewNameAtr, mOption), DC_GetRefresh(GetList)}; PARENT oToolBar ENDIF *TEXT INTO cText *Нелокальная;нейронная;сеть *ENDTEXT *@29.0+S, 1 DCPUSHBUTTON CAPTION cText SIZE 13, 3.4 ; * ACTION {||GraNeuroNet(M_KodCls1, M_KodCls2, M_KodAtr1, M_KodAtr2, mViewMaxCls, mViewMaxRel, mViewMaxAtr, mViewPorogRel, mSort, mViewNameCls, mViewNameAtr), DC_GetRefresh(GetList)} ; * ALIGNCAPTION BS_MULTILINE @30.7+S, 14.7 DCSAY L("Максимальное количество отображаемых рецепторов:") PARENT oGroup1 @30.7+S, 55.7 DCGET mViewMaxAtr PICTURE "#######" COLOR "n/gb+" PARENT oGroup1 @31.7+S, 14.7 DCSAY L("Отображать связи с интенсивностью >= % от макс.:") PARENT oGroup1 @31.7+S, 55.7 DCGET mViewPorogRel PICTURE "###.###" COLOR "n/gb+" PARENT oGroup1 @29.0+S, W/2+D DCGROUP oGroup2 CAPTION L('Сортировать связи:') SIZE 31.0, 3.5 PARENT oGroup1 @ 1, 2 DCRADIO mSort VALUE 1 PROMPT L('по модулю информативности') PARENT oGroup2 @ 2, 2 DCRADIO mSort VALUE 2 PROMPT L('по информативности и знаку') PARENT oGroup2 @29.0+S, W/2+D+31.1 DCGROUP oGroup3 CAPTION L('Отображать наименования:') SIZE 32.9, 3.5 PARENT oGroup1 @ 1, 2 DCCHECKBOX mViewNameCls PROMPT L('нейронов' ) PARENT oGroup3 @ 2, 2 DCCHECKBOX mViewNameAtr PROMPT L('рецепторов') PARENT oGroup3 @ 29.0+S, 14.7 DCTOOLBAR oToolBar SIZE W/2-15, H PARENT oGroup1 DCADDBUTTON CAPTION Ar_Model[1] ; SIZE LEN(Ar_Model[1])+1.9 ; ACTION {||InfNeuroNet(1,M_KodCls1, M_KodCls2, M_KodAtr1, M_KodAtr2, mViewMaxCls, mViewMaxRel, mViewMaxAtr, mViewPorogRel, mSort, mViewNameCls, mViewNameAtr), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION Ar_Model[2] ; SIZE LEN(Ar_Model[2])+1 ; ACTION {||InfNeuroNet(2,M_KodCls1, M_KodCls2, M_KodAtr1, M_KodAtr2, mViewMaxCls, mViewMaxRel, mViewMaxAtr, mViewPorogRel, mSort, mViewNameCls, mViewNameAtr), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION Ar_Model[3] ; SIZE LEN(Ar_Model[3])+1 ; ACTION {||InfNeuroNet(3,M_KodCls1, M_KodCls2, M_KodAtr1, M_KodAtr2, mViewMaxCls, mViewMaxRel, mViewMaxAtr, mViewPorogRel, mSort, mViewNameCls, mViewNameAtr), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION Ar_Model[4] ; SIZE LEN(Ar_Model[4])+1 ; ACTION {||InfNeuroNet(4,M_KodCls1, M_KodCls2, M_KodAtr1, M_KodAtr2, mViewMaxCls, mViewMaxRel, mViewMaxAtr, mViewPorogRel, mSort, mViewNameCls, mViewNameAtr), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION Ar_Model[5] ; SIZE LEN(Ar_Model[5])+1 ; ACTION {||InfNeuroNet(5,M_KodCls1, M_KodCls2, M_KodAtr1, M_KodAtr2, mViewMaxCls, mViewMaxRel, mViewMaxAtr, mViewPorogRel, mSort, mViewNameCls, mViewNameAtr), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION Ar_Model[6] ; SIZE LEN(Ar_Model[6])+1 ; ACTION {||InfNeuroNet(6,M_KodCls1, M_KodCls2, M_KodAtr1, M_KodAtr2, mViewMaxCls, mViewMaxRel, mViewMaxAtr, mViewPorogRel, mSort, mViewNameCls, mViewNameAtr), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION Ar_Model[7] ; SIZE LEN(Ar_Model[7])+1 ; ACTION {||InfNeuroNet(7,M_KodCls1, M_KodCls2, M_KodAtr1, M_KodAtr2, mViewMaxCls, mViewMaxRel, mViewMaxAtr, mViewPorogRel, mSort, mViewNameCls, mViewNameAtr), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION Ar_Model[8] ; SIZE LEN(Ar_Model[8])+1 ; ACTION {||InfNeuroNet(8,M_KodCls1, M_KodCls2, M_KodAtr1, M_KodAtr2, mViewMaxCls, mViewMaxRel, mViewMaxAtr, mViewPorogRel, mSort, mViewNameCls, mViewNameAtr), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION Ar_Model[9] ; SIZE LEN(Ar_Model[9])+1 ; ACTION {||InfNeuroNet(9,M_KodCls1, M_KodCls2, M_KodAtr1, M_KodAtr2, mViewMaxCls, mViewMaxRel, mViewMaxAtr, mViewPorogRel, mSort, mViewNameCls, mViewNameAtr), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION Ar_Model[10] ; SIZE LEN(Ar_Model[10])+1 ; ACTION {||InfNeuroNet(10,M_KodCls1, M_KodCls2, M_KodAtr1, M_KodAtr2, mViewMaxCls, mViewMaxRel, mViewMaxAtr, mViewPorogRel, mSort, mViewNameCls, mViewNameAtr), DC_GetRefresh(GetList)}; PARENT oToolBar /* ----- Create browse Classes ----- */ IF mOption = 'NeuroNet' @ 1, 1 DCSAY L("Выбор нелокальных нейронов (классов) для визуализации в нейросети" ) SAYSIZE W-3.5 FONT "12.Helv Bold" PARENT oGroup1 ELSE @ 1, 1 DCSAY L("Выбор нелокальных нейронов (классов) для визуализации в когнитивной карте") SAYSIZE W-3.5 FONT "12.Helv Bold" PARENT oGroup1 ENDIF DC_LoadRdds() @ 2, 1 DCBROWSE oBrowse ALIAS 'ClassNeuro' SIZE W-0.5, 11 ; HEADLINES 1 ; // Кол-во строк в заголовке (перенос строки - ";") EDIT xbeBRW_ItemSelected MODE DCGUI_BROWSE_EDITDOWN; PRESENTATION LC_BrowPres() FIT PARENT oGroup1; COLOR {||IIF(2*INT(ClassNeuro->Kod_cls/2)==ClassNeuro->Kod_cls,nil,{nil,GraMakeRGBColor({230,252,213})})} // Вывод строки цветом RGB * ITEMSELECTED {|| Select_It(oBrowse,aRecs,multisel) } * DCBROWSECOL DATA {|| dc_getbitmap(iif(AScan(aRecs,recno())>0, iif(!multisel,BMP_RACHECKED,BMP_CHECKED), iif(!multisel,BMP_RAUNCHECKED,BMP_UNCHECKED))) } ; * HEADER L("Sel") PARENT oBrowse WIDTH 2 ; * TYPE XBPCOL_TYPE_BITMAP ; * PROTECT {|| .T.} ; * ALIGN XBPALIGN_HCENTER+XBPALIGN_VCENTER ; * EVAL {|oB| oB:dataArea:lbClick := {|a,b,o,w| iif( oBrowse:colPos=1, Select_It(oBrowse,aRecs,multisel),nil)}} DCBROWSECOL DATA {|x|x:=ClassNeuro->tag, ; IIF(x,BITMAP_CHECKBOX_CHECKED_S,BITMAP_CHECKBOX_UNCHECKED_S)} ; PARENT oBrowse HEADER L('Sel') WIDTH 1 ; TYPE XBPCOL_TYPE_BITMAP ; EVAL {|oB|oB:dataArea:lbClick := ; {|a,b,o|IIF(oBrowse:colPos=1, ; (ClassNeuro->(dbRLock()), ; ClassNeuro->tag:=!ClassNeuro->tag, ; ClassNeuro->(dbRUnlock()), ; oBrowse:refreshCurrent()),nil)}} DCGETOPTIONS AUTORESIZE DCBROWSECOL FIELD ClassNeuro->Kod_cls HEADER L("Код" ) PARENT oBrowse WIDTH 5 PROTECT {|| .T. } DCBROWSECOL FIELD ClassNeuro->Name_cls HEADER L("Наименование нелокального нейрона (класса)") PARENT oBrowse WIDTH 74.7 PROTECT {|| .T. } *DCBROWSECOL FIELD ClassNeuro->tag HEADER L("Выбрать" ) PARENT oBrowse WIDTH 3 /* ----- Create browse InfPortClsPos ----- */ PRIVATE bColorBlockPos:={|| iif(InfPortClsPos->Znach>0,{GRA_CLR_RED,nil},iif(InfPortClsPos->Znach=0,{GRA_CLR_BLACK,nil},{GRA_CLR_BLUE,nil})) } // Клиффорд PRIVATE bColorBlockNeg:={|| iif(InfPortClsNeg->Znach>0,{GRA_CLR_RED,nil},iif(InfPortClsNeg->Znach=0,{GRA_CLR_BLACK,nil},{GRA_CLR_BLUE,nil})) } // Клиффорд *@13+S, 1 DCSAY {|| MessIPC } OBJECT oSay1 SAYSIZE W FONT "12.Helv Bold") PARENT oGroup1 // Наименование класса и модели в SWOT *@14+S, 1 DCSAY L("АКТИВИРУЮЩИЕ рецепторы и сила их влияния") SAYSIZE W/2 FONT "12.Helv Bold" COLOR GRA_CLR_RED PARENT oGroup1 // Наименование класса и модели в SWOT *@14+S,P2 DCSAY L("ТОРМОЗЯЩИЕ рецепторы и сила их влияния") SAYSIZE W/2 FONT "12.Helv Bold" COLOR GRA_CLR_BLUE PARENT oGroup1 // Наименование класса и модели в SWOT @15+S, 1 DCBROWSE oBrowIpc1 ALIAS 'InfPortClsPos' SIZE W/2, 12; HEADLINES 2 ; // Кол-во строк в заголовке (перенос строки - ";") PRESENTATION aPres PARENT oGroup1 DCSETPARENT oBrowIpc1 DCBROWSECOL FIELD InfPortClsPos->KOD_atr HEADER L('Код') WIDTH 5; COLOR {||IIF(AT('SPECTRINTERV:',InfPortClsPos->NAME_atr)=0,nil,{nil,GraMakeRGBColor({VAL(SUBSTR(InfPortClsPos->NAME_atr, AT('{', InfPortClsPos->NAME_atr)+1, AT('{', InfPortClsPos->NAME_atr)+ 3-AT('{', InfPortClsPos->NAME_atr)+1+1)),VAL(SUBSTR(InfPortClsPos->NAME_atr, AT('{', InfPortClsPos->NAME_atr)+5, AT('{', InfPortClsPos->NAME_atr)+ 7-AT('{', InfPortClsPos->NAME_atr)+5+1)),VAL(SUBSTR(InfPortClsPos->NAME_atr, AT('{', InfPortClsPos->NAME_atr)+9, AT('{', InfPortClsPos->NAME_atr)+11-AT('{', InfPortClsPos->NAME_atr)+9+1))})})} // Вывод поля цветом RGB DCBROWSECOL FIELD InfPortClsPos->NAME_atr HEADER L('Наименование фактора;и его интервального значения') WIDTH 28 DCBROWSECOL DATA {|x|x:=InfPortClsPos->Znach,IIF(Empty(x),'',Str(x,11,3))} HEADER L("Сила;влияния") COLOR bColorBlockPos /* ----- Create browse InfPortClsNeg ----- */ DCSETPARENT TO @15+S,P2 DCBROWSE oBrowIpc2 ALIAS 'InfPortClsNeg' SIZE W/2, 12 ; HEADLINES 2 ; // Кол-во строк в заголовке (перенос строки - ";") PRESENTATION aPres PARENT oGroup1 DCSETPARENT oBrowIpc2 DCBROWSECOL FIELD InfPortClsNeg->KOD_atr HEADER L('Код') WIDTH 5; COLOR {||IIF(AT('SPECTRINTERV:',InfPortClsNeg->NAME_atr)=0,nil,{nil,GraMakeRGBColor({VAL(SUBSTR(InfPortClsNeg->NAME_atr, AT('{', InfPortClsNeg->NAME_atr)+1, AT('{', InfPortClsNeg->NAME_atr)+ 3-AT('{', InfPortClsNeg->NAME_atr)+1+1)),VAL(SUBSTR(InfPortClsNeg->NAME_atr, AT('{', InfPortClsNeg->NAME_atr)+5, AT('{', InfPortClsNeg->NAME_atr)+ 7-AT('{', InfPortClsNeg->NAME_atr)+5+1)),VAL(SUBSTR(InfPortClsNeg->NAME_atr, AT('{', InfPortClsNeg->NAME_atr)+9, AT('{', InfPortClsNeg->NAME_atr)+11-AT('{', InfPortClsNeg->NAME_atr)+9+1))})})} // Вывод поля цветом RGB DCBROWSECOL FIELD InfPortClsNeg->NAME_atr HEADER L('Наименование фактора;и его интервального значения') WIDTH 27 DCBROWSECOL DATA {|x|x:=InfPortClsNeg->Znach,IIF(Empty(x),'',Str(x,13,3))} HEADER L("Сила;влияния") COLOR bColorBlockNeg DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE IF mOption = 'NeuroNet' mTitle = L('4.4.11. Отображение Парето-подмножеств одного слоя нелокальной нейронной сети в системе "Эйдос"') ELSE mTitle = L('4.4.12. Отображение Парето-подмножеств одного слоя интегральной когнитивной карты в системе "Эйдос"') ENDIF DCREAD GUI ; TITLE mTitle ; // Надпись на окне графика FIT; MODAL; CLEAREVENTS *** Закрыть все текстовые БД ****** FOR z=1 TO LEN(Ar_Model) FClose( nHandle[z] ) // Закрытие текстовой базы данных ###################################### NEXT // Сохранить файл с информацией о параметрах режима 4.4.11 в текущей директории системы и в папке приложения aPar4411[ 1] = M_KodCls1 // Начальный код класса (нейрона) aPar4411[ 2] = M_KodCls2 // Конечный код класса (нейрона) aPar4411[ 3] = M_KodAtr1 // Начальный код признака (рецептора) aPar4411[ 4] = M_KodAtr2 // Конечный код признака (рецептора) aPar4411[ 5] = mViewMaxCls // Отображать не более mViewMaxCls классов aPar4411[ 6] = mViewMaxRel // Отображать не более mViewMaxRel связей aPar4411[ 7] = mViewMaxAtr // Отображать не более mViewMaxAtr рецепторов aPar4411[ 8] = mViewPorogRel // Отображать связи с интенсивностью не менее mViewPorogRel aPar4411[ 9] = mSort // mSort=1 - сортировать по модулю информативности; mSort=2 - по информативности и знаку aPar4411[10] = mViewNameCls // .T. - рисовать наименования классов (нейронов) aPar4411[11] = mViewNameAtr // .T. - рисовать наименования признаков (рецепторов) * aPar4411 = DC_ARestore("_4_4_11.arx") DC_ASave(aPar4411 , "_4_4_11.arx") ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** *** Записать массив в виде файла и при запуске 4.4.11 считывать его, если он есть, а иначе создавать *** может быть отмечать выбранные записи в базе данных * DC_DebugQout( aRecs ) Running(.F.) ReTURN(aRecs) ****** От Регана для выбора в БД STATIC PROCEDURE Select_It(oBrowse,aRecs,multisel) LOCAL p:=Ascan(aRecs, recno()) if p>0 ARemove(aRecs,p) else if !multisel ASize(aRecs,0) endif AAdd(aRecs, recno()) endif oBrowse:refreshAll() RETURN ********************************************************************************************************** FUNCTION ClearSet() // Сброс параметров фильтров PUBLIC aPar4411[11] CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW PUBLIC M_KodCls1, M_KodCls2 SELECT Classes DBGOTOP() ;M_KodCls1 = Kod_cls DBGOBOTTOM();M_KodCls2 = Kod_cls PUBLIC M_KodAtr1, M_KodAtr2 SELECT Attributes DBGOTOP() ;M_KodAtr1 = Kod_atr DBGOBOTTOM();M_KodAtr2 = Kod_atr mViewMaxCls = 16 mViewMaxRel = 1000 mViewMaxAtr = 16 mViewPorogRel = 0 mSort = 1 mViewNameCls = .T. mViewNameAtr = .T. // Сохранить файл с информацией о параметрах режима 4.4.11 в текущей директории системы и в папке приложения aPar4411[ 1] = M_KodCls1 // Начальный код класса (нейрона) aPar4411[ 2] = M_KodCls2 // Конечный код класса (нейрона) aPar4411[ 3] = M_KodAtr1 // Начальный код признака (рецептора) aPar4411[ 4] = M_KodAtr2 // Конечный код признака (рецептора) aPar4411[ 5] = mViewMaxCls // Отображать не более mViewMaxCls классов aPar4411[ 6] = mViewMaxRel // Отображать не более mViewMaxRel связей aPar4411[ 7] = mViewMaxAtr // Отображать не более mViewMaxAtr рецепторов aPar4411[ 8] = mViewPorogRel // Отображать связи с интенсивностью не менее mViewPorogRel aPar4411[ 9] = mSort // mSort=1 - сортировать по модулю информативности; mSort=2 - по информативности и знаку aPar4411[10] = mViewNameCls // .T. - рисовать наименования классов (нейронов) aPar4411[11] = mViewNameAtr // .T. - рисовать наименования признаков (рецепторов) * aPar4411 = DC_ARestore("_4_4_11.arx") DC_ASave(aPar4411 , "_4_4_11.arx") CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW USE ClassNeuro EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW USE Gr_OpSc EXCLUSIVE NEW USE Opis_Sc EXCLUSIVE NEW USE InfPortCls EXCLUSIVE NEW USE InfPortClsPos EXCLUSIVE NEW USE InfPortClsNeg EXCLUSIVE NEW USE InfPortClsAbs EXCLUSIVE NEW SELECT InfPortClsPos DBGOTOP() SELECT InfPortClsNeg DBGOTOP() SELECT ClassNeuro * SET FILTER TO Abs+Int_inf > 0 DBGOTOP() aMess := {} AADD(aMess, L('Параметры фильтров Парето-подмножества' )) IF mOption = 'NeuroNet' AADD(aMess, L('локальной нейросети сброшены в исходные!' )) ELSE AADD(aMess, L('интегральной когнитивной карты сброшены!' )) ENDIF LB_Warning( aMess, '(C) Система "Эйдос"' ) ReTURN nil ********************************************************************************************************** FUNCTION InfNeuroNet(M_CurrInf, M_KodCls1, M_KodCls2, M_KodAtr1, M_KodAtr2, mViewMaxCls, mViewMaxRel, mViewMaxAtr, mViewPorogRel, mSort, mViewNameCls, mViewNameAtr) aPar4411[ 1] = M_KodCls1 // Начальный код класса (нейрона) aPar4411[ 2] = M_KodCls2 // Конечный код класса (нейрона) aPar4411[ 3] = M_KodAtr1 // Начальный код признака (рецептора) aPar4411[ 4] = M_KodAtr2 // Конечный код признака (рецептора) aPar4411[ 5] = mViewMaxCls // Отображать не более mViewMaxCls классов aPar4411[ 6] = mViewMaxRel // Отображать не более mViewMaxRel связей aPar4411[ 7] = mViewMaxAtr // Отображать не более mViewMaxAtr рецепторов aPar4411[ 8] = mViewPorogRel // Отображать связи с интенсивностью не менее mViewPorogRel aPar4411[ 9] = mSort // mSort=1 - сортировать по модулю информативности; mSort=2 - по информативности и знаку aPar4411[10] = mViewNameCls // .T. - рисовать наименования классов (нейронов) aPar4411[11] = mViewNameAtr // .T. - рисовать наименования признаков (рецепторов) * aPar4411 = DC_ARestore("_4_4_11.arx") DC_ASave(aPar4411 , "_4_4_11.arx") DC_ASave(M_CurrInf, "_NumbMod.arx") * mNumMod = DC_ARestore("_NumbMod.arx") InfNeuroCls(M_CurrInf) // Подготовить БД для экранной формы текущего нейрона * F5_5(.F.) ReTURN nil ********************************************************************************************************** FUNCTION FiltrLeft44B(Flag44B) SELECT InfPortClsPos PUBLIC mKodOpScLeft44B := Kod_OpSc, mFltrLeftFlag44B := Flag44B IF Flag44B SET FILTER TO mKodOpScLeft44B = Kod_OpSc ELSE SET FILTER TO ENDIF ReTURN nil ******************************* FUNCTION FiltrRight44B(Flag44B) SELECT InfPortClsNeg PUBLIC mKodOpScRight44B := Kod_OpSc, mFltrRightFlag44B := Flag44B IF Flag44B SET FILTER TO mKodOpScRight44B = Kod_OpSc ELSE SET FILTER TO ENDIF ReTURN nil ************************************************************************************************** FUNCTION Help44B(mOption) aHelp := {} AADD(aHelp, L('АСК-анализ обеспечивает построение Парето-подмножеств интегральной когнитивной карты, которая представляет ')) AADD(aHelp, L('собой нелокальную нейронную сеть с указанием силы и направления влияния активирующих и тормозящих рецепторов ')) AADD(aHelp, L('в соответствии с статистическими и системно-когнитивными моделями, построенными непосредственно на основе ')) AADD(aHelp, L('эмпирических данных. Но в отличие от нейронной сети в когнитивной карте указано сходство нейронов (классов) ')) AADD(aHelp, L('по их системе детерминации (как в режиме 4.2.2. Кластерно-конструктивный анализ классов), а также и сходство ')) AADD(aHelp, L('рецепторов по их влиянию на моделируемый объект (как в режиме 4.3.2. Кластерно-конструктивный анализ признаков).')) AADD(aHelp, L('Классы при этом интерпретируются как нейроны, а значения факторов - как рецепторы. Количество информации, ')) AADD(aHelp, L('содержащееся в значениях фактора, рассматривается весовые коэффициенты, отражающие силу и направление влияния ')) AADD(aHelp, L('рецепторов на состояние нейрона. Таким образом, данный режим в наглядной и понятной форме отображает систему ')) AADD(aHelp, L('детерминации будущих состояний объекта управления значениями действующих на него факторов. Это предоставляет ')) AADD(aHelp, L('практически полную информацию для принятия решении об управляющем воздействии. ')) IF mOption = 'NeuroNet' mTitle = L('4.4.11. Отображение Парето-подмножеств нелокальной нейронной сети') ELSE mTitle = L('4.4.12. Отображение Парето-подмножеств интегральной когнитивной карты') ENDIF mHelpMax = -999;FOR h=1 TO LEN(aHelp);mHelpMax = MAX(mHelpMax, LEN(ALLTRIM(aHelp[h])));NEXT s=1;d=0.9;@0,0 DCGROUP oGroup1 CAPTION L(' ') SIZE mHelpMax-17, LEN(aHelp)*d+1.5 FOR h=1 TO LEN(aHelp);@s,2 DCSAY aHelp[h] SIZE 0 PARENT ogroup1;s=s+d;NEXT DCREAD GUI TO lExit FIT TITLE mTitle RETURN NIL ************************************************************************************************** ************************************************************************************************************************************************************ ******** Графическая визуализация нейронной сети или интегральной когнитивной карты с формированием изображения в памяти и с отображением с масштабированием ************************************************************************************************************************************************************ FUNCTION GraNeuroNet(M_KodCls1, M_KodCls2, M_KodAtr1, M_KodAtr2, mViewMaxCls, mViewMaxRel, mViewMaxAtr, mViewPorogRel, mSort, mViewNameCls, mViewNameAtr, mOption) LOCAL GetList := {}, oStatic LOCAL oPS, oDevice IF mOption = 'NeuroNet' mTitle = '4.4.11. Отображение Парето-подмножеств нелокальной нейронной сети в системе "Эйдос"' ELSE mTitle = '4.4.12. Отображение Парето-подмножеств интегральной когнитивной карты в системе "Эйдос"' ENDIF ** Проверка, существуют ли файлы матриц сходства классов и признаков IF mOption = 'IntCognMaps' PRIVATE Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } mFlagCls = .F. FOR j=1 TO LEN(Ar_Model) mName = "SxodCls"+Ar_Model[j]+'.DBF' IF .NOT. FILE(mName) mFlagCls = .T. EXIT ENDIF NEXT mFlagAtr =.F. FOR j=1 TO LEN(Ar_Model) mName = "SxodAtr"+Ar_Model[j]+'.DBF' IF .NOT. FILE(mName) mFlagAtr = .T. ENDIF NEXT aMess := {} AADD(aMess, L('Перед запуском режима 4.4.12 необходимо предварительно')) IF mFlagCls .AND. .NOT. mFlagAtr AADD(aMess, L('расчитать матрицу сходства классов в режиме 4.2.2.1.!!')) ENDIF IF mFlagAtr .AND. .NOT. mFlagCls AADD(aMess, L('расчитать матрицу сходства признаков в режиме 4.3.2.1.!!')) ENDIF IF mFlagCls .AND. mFlagAtr AADD(aMess, L('выполнить режимы 4.2.2.1 и 4.3.2.1 с параметрами по умолчанию!')) ENDIF IF mFlagCls .OR. mFlagAtr LB_Warning(aMess, mTitle) IF ApplChange("") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения ReTURN NIL ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW USE ClassNeuro EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW USE Gr_OpSc EXCLUSIVE NEW USE Opis_Sc EXCLUSIVE NEW USE InfPortCls EXCLUSIVE NEW USE InfPortClsPos EXCLUSIVE NEW USE InfPortClsNeg EXCLUSIVE NEW USE InfPortClsAbs EXCLUSIVE NEW SELECT InfPortClsPos DBGOTOP() SELECT InfPortClsNeg DBGOTOP() SELECT ClassNeuro * SET FILTER TO Abs+Int_inf > 0 DBGOTOP() RETURN NIL ENDIF ENDIF * DC_DebugQout( aRecs ) // Данные о выбранных нейронах передаются, но не отображаются на экранной форме SELECT ClassNeuro mRecnoGN = RECNO() aPar4411[ 1] = M_KodCls1 // Начальный код класса (нейрона) aPar4411[ 2] = M_KodCls2 // Конечный код класса (нейрона) aPar4411[ 3] = M_KodAtr1 // Начальный код признака (рецептора) aPar4411[ 4] = M_KodAtr2 // Конечный код признака (рецептора) aPar4411[ 5] = mViewMaxCls // Отображать не более mViewMaxCls классов aPar4411[ 6] = mViewMaxRel // Отображать не более mViewMaxRel связей aPar4411[ 7] = mViewMaxAtr // Отображать не более mViewMaxAtr рецепторов aPar4411[ 8] = mViewPorogRel // Отображать связи с интенсивностью не менее mViewPorogRel aPar4411[ 9] = mSort // mSort=1 - сортировать по модулю информативности; mSort=2 - по информативности и знаку aPar4411[10] = mViewNameCls // .T. - рисовать наименования классов (нейронов) aPar4411[11] = mViewNameAtr // .T. - рисовать наименования признаков (рецепторов) * aPar4411 = DC_ARestore("_4_4_11.arx") DC_ASave(aPar4411 , "_4_4_11.arx") nXSize = 1800 nYSize = 900 // Create new bitmap with given size oPS := XBPPRESSPACE() :new() :Create() oBMP := XBPBITMAP() :New() :Create() * oBMP:Make( nXSize, nYSize, nPlanes, nBits ) oBMP:Make( nXSize, nYSize ) oBMP:presSpace( oPS ) // here your GRA* Code **** Закрасить фон прямоугольника *************** * GraSetColor( oPS, GRA_CLR_WHITE, GRA_CLR_WHITE ) GraSetColor( oPS, BD_LIGHTGREY, BD_LIGHTGREY ) GraBox( oPS, { 0, 0 }, { nXSize, nYSize }, GRA_FILL ) *####################################################################################################### PUBLIC X_MaxW := nXSize, Y_MaxW := nYSize // Размер графического окна в пикселях LC_NeuroNet( oPS, oStatic, M_CurrInf, mOption, 'File' ) // Графическая функция <<<===############## *####################################################################################################### *My image original, my image scaled DC_Impl(oScrn) DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения IF mOption = 'NeuroNet' IF FILEDATE("NeuroNetDiagr",16) = CTOD("//") DIRMAKE("NeuroNetDiagr") aMess := {} AADD(aMess, L('В папке текущего приложения: "'+UPPER(ALLTRIM(M_PathAppl))+'"')) AADD(aMess, L('не было директории "NeuroNetDiagr" для графических диаграмм нейронных сетей и она была создана!')) AADD(aMess, L('В эту папку записываются исходные изображения высокого качества (без масштабирования).')) LB_Warning(aMess, L('4.4.11.Графическое отображение нелокальных нейросетей в системе "Эйдос"' )) ENDIF DIRCHANGE(M_PathAppl+"\NeuroNetDiagr\") // Перейти в папку NeuroNetDiagr cFileName = "NeuroNet"+STRTRAN(STR(1+ADIR("*.jpg"),4)," ","0")+Ar_Model[M_CurrInf]+".jpg" ELSE IF FILEDATE("IntCognMaps",16) = CTOD("//") DIRMAKE("IntCognMaps") aMess := {} AADD(aMess, L('В папке текущего приложения: "'+UPPER(ALLTRIM(M_PathAppl))+'"')) AADD(aMess, L('не было директории "IntCognMaps" для интегральных когнитивных карт и она была создана!')) AADD(aMess, L('В эту папку записываются исходные изображения высокого качества (без масштабирования).')) LB_Warning(aMess, L('4.4.12.Графическое отображение интегральных когнитивных карт в системе "Эйдос"' )) ENDIF DIRCHANGE(M_PathAppl+"\IntCognMaps\") // Перейти в папку IntCognMaps cFileName = "IntCognMap"+STRTRAN(STR(1+ADIR("*.jpg"),4)," ","0")+Ar_Model[M_CurrInf]+".jpg" ENDIF ****** Запись полноразмерного графического файла в папку: M_PathAppl+"\IntCognMaps\" ERASE(cFileName) oBMP:SaveFile(cFileName,XBPBMP_FORMAT_JPG) IF nWidth > 1800 FullView( cFileName, "по верху", 65 ) // Визуализация полноразмерного файла на мониторе высокого разрешения ELSE ****** Формирование с помощью bmp2bmp() и отображение масштабированного изображения aNewSize := {nWidth,nHeight-29} // Новый размер изображения (еще немного уменьшается, чтобы не рисовать по панели задач) oBMP:loadFile(cFileName) // Загрузка полноразмерного изображения oRet := BMP2BMP(oBMP,aNewSize) // Масштабирование изображения cFileNameScale = SUBSTR(cFileName,1,AT(".jpg",cFileName)-1)+"_scaled.jpg" ERASE(cFileNameScale) oRet:saveFile(cFileNameScale,XBPBMP_FORMAT_JPG) // Запись масштабированного графического файла в в папку приложения для визуализации FullView( cFileNameScale, "по верху", 0 ) // Визуализация масштабированного графического файла на мониторе ограниченного разрешения ENDIF DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения IF ApplChange("") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения ReTURN NIL ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW USE ClassNeuro EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW USE Gr_OpSc EXCLUSIVE NEW USE Opis_Sc EXCLUSIVE NEW USE InfPortCls EXCLUSIVE NEW USE InfPortClsPos EXCLUSIVE NEW USE InfPortClsNeg EXCLUSIVE NEW USE InfPortClsAbs EXCLUSIVE NEW SELECT InfPortClsPos DBGOTOP() SELECT InfPortClsNeg DBGOTOP() SELECT ClassNeuro * SET FILTER TO Abs+Int_inf > 0 DBGOTO(mRecnoGN) ReTURN NIL ************************************************* ********* Графическая визуализация нейронной сети ********* или интегральной когнитивной карты ************************************************* *FUNCTION GraNeuroNetOld(M_KodCls1, M_KodCls2, M_KodAtr1, M_KodAtr2, mViewMaxCls, mViewMaxRel, mViewMaxAtr, mViewPorogRel, mSort, mViewNameCls, mViewNameAtr, mOption) * LOCAL GetList := {}, oStatic * LOCAL oPS, oDevice * IF mOption = 'NeuroNet' * mTitle = '4.4.11. Отображение Парето-подмножеств нелокальной нейронной сети в системе "Эйдос"' * ELSE * mTitle = '4.4.12. Отображение Парето-подмножеств интегральной когнитивной карты в системе "Эйдос"' * ENDIF * ** Проверка, существуют ли файлы матриц сходства классов и признаков * IF mOption = 'IntCognMaps' * PRIVATE Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } * mFlagCls = .F. * FOR j=1 TO LEN(Ar_Model) * mName = "SxodCls"+Ar_Model[j]+'.DBF' * IF .NOT. FILE(mName) * mFlagCls = .T. * EXIT * ENDIF * NEXT * mFlagAtr =.F. * FOR j=1 TO LEN(Ar_Model) * mName = "SxodAtr"+Ar_Model[j]+'.DBF' * IF .NOT. FILE(mName) * mFlagAtr = .T. * ENDIF * NEXT * aMess := {} * AADD(aMess, L('Перед запуском режима 4.4.12 необходимо предварительно')) * IF mFlagCls .AND. .NOT. mFlagAtr * AADD(aMess, L('расчитать матрицу сходства классов в режиме 4.2.2.1.!!')) * ENDIF * IF mFlagAtr .AND. .NOT. mFlagCls * AADD(aMess, L('расчитать матрицу сходства признаков в режиме 4.3.2.1.!!')) * ENDIF * IF mFlagCls .AND. mFlagAtr * AADD(aMess, L('выполнить режимы 4.2.2.1 и 4.3.2.1 с параметрами по умолчанию!')) * ENDIF * IF mFlagCls .OR. mFlagAtr * LB_Warning(aMess, mTitle) * IF ApplChange("") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения * ReTURN NIL * ENDIF * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * USE Classes EXCLUSIVE NEW * USE ClassNeuro EXCLUSIVE NEW * USE Attributes EXCLUSIVE NEW * USE Gr_OpSc EXCLUSIVE NEW * USE Opis_Sc EXCLUSIVE NEW * USE InfPortCls EXCLUSIVE NEW * USE InfPortClsPos EXCLUSIVE NEW * USE InfPortClsNeg EXCLUSIVE NEW * USE InfPortClsAbs EXCLUSIVE NEW * SELECT InfPortClsPos * DBGOTOP() * SELECT InfPortClsNeg * DBGOTOP() * SELECT ClassNeuro ** SET FILTER TO Abs+Int_inf > 0 * DBGOTOP() * RETURN NIL * ENDIF * ENDIF ** DC_DebugQout( aRecs ) // Данные о выбранных нейронах передаются, но не отображаются на экранной форме * SELECT ClassNeuro * mRecnoGN = RECNO() * aPar4411[ 1] = M_KodCls1 // Начальный код класса (нейрона) * aPar4411[ 2] = M_KodCls2 // Конечный код класса (нейрона) * aPar4411[ 3] = M_KodAtr1 // Начальный код признака (рецептора) * aPar4411[ 4] = M_KodAtr2 // Конечный код признака (рецептора) * aPar4411[ 5] = mViewMaxCls // Отображать не более mViewMaxCls классов * aPar4411[ 6] = mViewMaxRel // Отображать не более mViewMaxRel связей * aPar4411[ 7] = mViewMaxAtr // Отображать не более mViewMaxAtr рецепторов * aPar4411[ 8] = mViewPorogRel // Отображать связи с интенсивностью не менее mViewPorogRel * aPar4411[ 9] = mSort // mSort=1 - сортировать по модулю информативности; mSort=2 - по информативности и знаку * aPar4411[10] = mViewNameCls // .T. - рисовать наименования классов (нейронов) * aPar4411[11] = mViewNameAtr // .T. - рисовать наименования признаков (рецепторов) ** aPar4411 = DC_ARestore("_4_4_11.arx") * DC_ASave(aPar4411 , "_4_4_11.arx") ******* Узнать разрешение экрана и не показывать изображений большой размерности **************** *nWidth := AppDeskTop():currentSize()[1] // current screen size width in pixels *nHeight := AppDeskTop():currentSize()[2] // current screen size height in pixels *mFlag = .F. *IF nWidth < 1800 * aMess := {} * AADD(aMess, L("Для правильного отображения графической формы")) * AADD(aMess, L("необходимо разрешение экрана 1800 pix по горизонтали,")) * AADD(aMess, L("а фактически установлено: ")+ALLTRIM(STR(nWidth))+" pix") * LB_Warning(aMess ) * mFlag = .T. *ENDIF *IF nHeight < 850 * aMess := {} * AADD(aMess, L("Для правильного отображения графической формы")) * AADD(aMess, L("необходимо разрешение экрана 850 pix по вертикали,")) * AADD(aMess, L("а фактически установлено: ")+ALLTRIM(STR(nHeight))+" pix") * LB_Warning(aMess ) * mFlag = .T. *ENDIF *IF mFlag * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * USE Classes EXCLUSIVE NEW * USE ClassNeuro EXCLUSIVE NEW * USE Attributes EXCLUSIVE NEW * USE Gr_OpSc EXCLUSIVE NEW * USE Opis_Sc EXCLUSIVE NEW * USE InfPortCls EXCLUSIVE NEW * USE InfPortClsPos EXCLUSIVE NEW * USE InfPortClsNeg EXCLUSIVE NEW * USE InfPortClsAbs EXCLUSIVE NEW * SELECT InfPortClsPos * DBGOTOP() * SELECT InfPortClsNeg * DBGOTOP() * SELECT ClassNeuro ** SET FILTER TO Abs+Int_inf > 0 * DBGOTO(mRecnoGN) * Running(.F.) * RETURN NIL *ENDIF ************************************************************************************************* * SELECT ClassNeuro * mRecnoGN = RECNO() * PUBLIC X_MaxW := 1800, Y_MaxW := 900 // Размер графического окна в пикселях * mKodNeuro = Kod_Cls * STRFILE(STR(mKodNeuro,15), "_KodNeuro.txt") // Записать mKodNeuro и потом там, где надо загружать его * @ 2,1 DCSTATIC TYPE XBPSTATIC_TYPE_RECESSEDBOX SIZE X_MaxW, Y_MaxW PIXEL; // Размер окна для отображения графика в пикселях (от Тома) * OBJECT oStatic; * EVAL {|| _PresSpace44B( oStatic, M_CurrInf, mOption ) } * IF mOption = 'NeuroNet' * mTitle = '4.4.11. Отображение Парето-подмножеств нелокальной нейронной сети в системе "Эйдос"' * ELSE * mTitle = '4.4.12. Отображение Парето-подмножеств интегральной когнитивной карты в системе "Эйдос"' * ENDIF * DCREAD GUI ; * TITLE mTitle ; // Надпись на окне графика * FIT; * MODAL * IF ApplChange("") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения * ReTURN NIL * ENDIF * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * USE Classes EXCLUSIVE NEW * USE ClassNeuro EXCLUSIVE NEW * USE Attributes EXCLUSIVE NEW * USE Gr_OpSc EXCLUSIVE NEW * USE Opis_Sc EXCLUSIVE NEW * USE InfPortCls EXCLUSIVE NEW * USE InfPortClsPos EXCLUSIVE NEW * USE InfPortClsNeg EXCLUSIVE NEW * USE InfPortClsAbs EXCLUSIVE NEW * SELECT InfPortClsPos * DBGOTOP() * SELECT InfPortClsNeg * DBGOTOP() * SELECT ClassNeuro ** SET FILTER TO Abs+Int_inf > 0 * DBGOTO(mRecnoGN) *RETURN NIL ************************************************* *FUNCTION _PresSpace44B( oStatic, M_CurrInf, mOption ) * LOCAL oPS, oDevice * mKodNeuro = VAL(FILESTR("_KodNeuro.txt")) // Код нейрона для визуализации * oPS := XbpPresSpace():new() // Create a PS * oDevice := oStatic:winDevice() // Get the device context * oPS:create( oDevice ) // Link device context to PS * oPS:SetViewPort( { 0, 0, X_MaxW, Y_MaxW } ) * oStatic:paint := {|mp1,mp2,obj| mp1 := LC_NeuroNet( oPS, oStatic, M_CurrInf, mOption, 'Screen' ) } *RETURN NIL ********************************************************************** ****** Визуализация Парето-подмножества нелокальной нейросети ****** или интегральной когнитивной карты ********************************************************************** STATIC FUNCTION LC_NeuroNet( oPS, oStatic, M_CurrInf, mOption, mPar ) IF mOption = 'NeuroNet' mTitle = 'Подготовка визуализации Парето-подмножества нелокальной нейросети' ELSE mTitle = 'Подготовка визуализации Парето-подмножества интегральной когнитивной карты' ENDIF PUBLIC oScrn := DC_WaitOn(mTitle,,,,,,,,,,,.F.) // Если файл параметров режима 4.4.11 есть, то скачать его и присвоить значения переменным aPar4411 = DC_ARestore("_4_4_11.arx") * DC_ASave(aPar4411 , "_4_4_11.arx") M_KodCls1 = aPar4411[ 1] // Начальный код класса (нейрона) M_KodCls2 = aPar4411[ 2] // Конечный код класса (нейрона) M_KodAtr1 = aPar4411[ 3] // Начальный код признака (рецептора) M_KodAtr2 = aPar4411[ 4] // Конечный код признака (рецептора) mViewMaxCls = aPar4411[ 5] // Отображать не более mViewMaxCls классов mViewMaxRel = aPar4411[ 6] // Отображать не более mViewMaxRel связей mViewMaxAtr = aPar4411[ 7] // Отображать не более mViewMaxAtr рецепторов mViewPorogRel = aPar4411[ 8] // Отображать связи с интенсивностью не менее mViewPorogRel mSort = aPar4411[ 9] // mSort=1 - сортировать по модулю информативности; mSort=2 - по информативности и знаку mViewNameCls = aPar4411[10] // .T. - рисовать наименования классов (нейронов) mViewNameAtr = aPar4411[11] // .T. - рисовать наименования признаков (рецепторов) * DC_ASave(M_CurrInf, "_NumbMod.arx") M_CurrInf = DC_ARestore("_NumbMod.arx") // Для какой модели создана БД нейросети ****** 1. Сформировать БД кодов рецепторов, нейронов и информативностей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW ******** Массивы кодов и наименований классов A_KodCls := {} A_NameCls := {} mMaxLenCls = -99999 SELECT Classes DBGOTOP() DO WHILE .NOT. EOF() mNameCls = ALLTRIM(Name_cls) AADD(A_KodCls , Kod_cls) AADD(A_NameCls, mNameCls) mMaxLenCls = MAX(mMaxLenCls, LEN(mNameCls)) DBSKIP(1) ENDDO ******** Массивы кодов и наименований признаков A_KodAtr := {} A_NameAtr := {} mMaxLenAtr = -99999 SELECT Attributes DBGOTOP() DO WHILE .NOT. EOF() mNameAtr = ALLTRIM(Name_atr) AADD(A_KodAtr , Kod_atr) AADD(A_NameAtr, Name_atr) mMaxLenAtr = MAX(mMaxLenAtr, LEN(mNameAtr)) DBSKIP(1) ENDDO ****** 1.1. Создаем файл структуры БД ******* ***** Создаем БД синаптических связей ********************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций aStr := { { "N_relat" , "N", 15, 0 },; // Кол-во связей { "N_recept" , "N", 15, 0 },; // Кол-во РАЗНЫХ признаков (рецепторов) { "N_neuron" , "N", 15, 0 },; // Кол-во РАЗНЫХ классов (нейронов) { "Kod_atr" , "N", 15, 0 },; // Код первичного признака (рецептора) { "Name_atr" , "C", mMaxLenAtr, 0 },; // Наименование первичного признака (рецептора) { "Kod_cls" , "N", 15, 0 },; // Код класса (нейрона) { "Name_cls" , "C", mMaxLenCls, 0 },; // Наименование класса (нейрона) { "Inf" , "N", 15, 7 },; // Весовой коэффициент { "Abs_Inf" , "N", 19, 7 },; // Модуль весового коэффициента { "Perc_Inf" , "N", 15, 7 },; // Модуль весового коэффициента в % от Abs_Inf { "Sum_Mod_VK" , "N", 19, 7 },; // Сумма модулей весового коэффициента { "PercSModVK" , "N", 19, 7 },; // Сумма модулей весового коэффициента в процентах от максимального по БД { "XR" , "N", 15, 0 },; // Координата Х рецептора { "YR" , "N", 15, 0 },; // Координата Y рецептора (для инт.когн.карт) { "XN" , "N", 15, 0 },; // Координата Х нейрона { "YN" , "N", 15, 0 } } // Координата Y нейрона (для инт.когн.карт) DbCreate( 'NeuroRel.dbf' , aStr ) DbCreate( 'NeuroRelAll.dbf', aStr ) **** АЛГОРИТМ ********************************************************************************* * 1. Сформировать БД кодов рецепторов, нейронов и информативностей * Занести в БД информативности и коды и наименования рецепторов и нейронов * 2. Рассортировать БД по убыванию МОДУЛЯ информативности или информативности со знаком * 3. Двигаться вниз по БД и считать кол-во РАЗНЫХ рецепторов и РАЗНЫХ нейронов * 4. Удалить все записи, не удовлетворяющие ограничениям (DELETE FOR; PACK) * 5. Выйти на отображение Парето-подмножества нейронной сети или интегральной когнитивной карты *********************************************************************************************** * 1. Сформировать БД кодов рецепторов, нейронов и информативностей * Занести в БД информативности и коды и наименования рецепторов и нейронов Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } mModel = Ar_Model[M_CurrInf] // Сделать, чтобы использовалась модель, заданная в экранной форме <################### CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Attributes EXCLUSIVE NEW;N_Atr = RECCOUNT() USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE NeuroRel EXCLUSIVE NEW // БД с ограничениями, введенными в диалоге USE (mModel) EXCLUSIVE NEW // БД модели: "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" FactMaxInf = 0 // Фактическая максимальная интенсивность связи, которая принимается за 100% (найти в БД mModel) FOR i=1 TO N_Atr FOR j=1 TO N_Cls SELECT(mModel) DBGOTO(i) M_Inf = FIELDGET(2+j) Fn = FIELDNAME(2+j) FactMaxInf = MAX(FactMaxInf, ABS(M_Inf)) // Фактическая максимальная интенсивность связи, которая принимается за 100% M_KodAtr = Kod_pr M_KodCls = VAL(SUBSTR(Fn,4,5)) mPosAtr = ASCAN(A_KodAtr, M_KodAtr) mPosCls = ASCAN(A_KodCls, M_KodCls) IF mPosAtr * mPosCls > 0 SELECT NeuroRel APPEND BLANK REPLACE Kod_atr WITH M_KodAtr REPLACE Name_atr WITH DelZeroNameGr(A_NameAtr[M_KodAtr]) REPLACE Kod_cls WITH M_KodCls REPLACE Name_cls WITH DelZeroNameGr(A_NameCls[M_KodCls]) REPLACE Inf WITH M_Inf REPLACE Abs_inf WITH ABS(M_Inf) ENDIF NEXT NEXT * 2. Рассортировать БД по убыванию МОДУЛЯ информативности или информативности со знаком SELECT NeuroRel IF mSort = 1 // по модулю информативности INDEX ON STR(99999999.9999999-Abs_Inf,19, 7) TO Neur_Rel ENDIF IF mSort = 2 // по информативности и знаку INDEX ON STR(99999999.9999999- Inf,19, 7) TO Neur_Rel ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE NeuroRelAll EXCLUSIVE NEW // БД без сокращений, ПОЛНАЯ USE NeuroRel INDEX Neur_Rel EXCLUSIVE NEW SELECT NeuroRel SET ORDER TO 1 * 3. Двигаться вниз по БД и считать кол-во РАЗНЫХ рецепторов и РАЗНЫХ нейронов A_KodAtr := {} // Массив кодов признаков A_KodCls := {} // Массив кодов классов DBGOTOP() DO WHILE .NOT. EOF() ******* Занесение информации по РЕЦЕПТОРАМ mKodAtr = Kod_atr mPos = ASCAN(A_KodAtr, mKodAtr) // Если кода признака еще нет в массиве IF mPos = 0 // Кодируем признаки AADD(A_KodAtr, mKodAtr) mPos = ASCAN(A_KodAtr, mKodAtr) // Если кода признака еще нет в массиве ENDIF REPLACE N_recept WITH mPos REPLACE Perc_inf WITH Abs_inf / FactMaxInf * 100 ******* Занесение информации по НЕЙРОНАМ mKodCls = Kod_cls mPos = ASCAN(A_KodCls, mKodCls) // Если кода класса еще нет в массиве IF mPos = 0 // Кодируем классы AADD(A_KodCls, mKodCls) mPos = ASCAN(A_KodCls, mKodCls) // Если кода признака еще нет в массиве ENDIF REPLACE N_neuron WITH mPos DBSKIP(1) ENDDO ****** Дорасчет остальных полей БД NeuroRel Num_pp = 0 SumAbsInf = 0 FactMaxInf = 0 // Легче посчитать еще раз, чем тащить через файлы DBGOTOP() DO WHILE .NOT. EOF() REPLACE N_relat WITH ++Num_pp // Номер связи SumAbsInf = SumAbsInf + Abs_inf // Модуль интенсивности связи нарастающим итогом REPLACE Sum_Mod_VK WITH SumAbsInf FactMaxInf = MAX(FactMaxInf, Abs_inf) // Фактическая максимальная интенсивность связи, которая принимается за 100% DBSKIP(1) ENDDO ************ Расчет Парето-диаграммы в процентах * { "Sum_Mod_VK" , "N", 15, 7 },; // Сумма модулей весового коэффициента * { "PercSModVK" , "N", 15, 7 },; // Сумма модулей весового коэффициента в процентах от максимального по БД DBGOBOTTOM() SummaAbsInf = Sum_Mod_VK // 100% DBGOTOP() DO WHILE .NOT. EOF() REPLACE PercSModVK WITH Sum_Mod_VK / SummaAbsInf * 100 DBSKIP(1) ENDDO ****** Копирование БД NeuroRel => NeuroRelAll SELECT NeuroRel DBGOTOP() DO WHILE .NOT. EOF() aR := {} FOR j=1 TO FCOUNT() AADD(aR, FIELDGET(j)) NEXT SELECT NeuroRelAll APPEND BLANK FOR j=1 TO LEN(aR) FIELDPUT(j, aR[j]) NEXT SELECT NeuroRel DBSKIP(1) ENDDO * 4. Удалить все записи, не удовлетворяющие ограничениям (снчала все DELETE FOR, потом один PACK) * M_KodCls1 // Начальный код класса (нейрона) * M_KodCls2 // Конечный код класса (нейрона) * M_KodAtr1 // Начальный код признака (рецептора) * M_KodAtr2 // Конечный код признака (рецептора) * mViewMaxCls // Отображать не более mViewMaxCls классов * mViewMaxRel // Отображать не более mViewMaxRel связей * mViewMaxAtr // Отображать не более mViewMaxAtr рецепторов * mViewPorogRel // Отображать связи с интенсивностью не менее mViewPorogRel * mSort // mSort=1 - сортировать по модулю информативности; mSort=2 - по информативности и знаку * mViewNameCls // .T. - рисовать наименования классов (нейронов) * mViewNameAtr // .T. - рисовать наименования признаков (рецепторов) *aStr := { { "N_relat" , "N", 15, 0 },; // Кол-во связей * { "N_recept" , "N", 15, 0 },; // Кол-во РАЗНЫХ признаков (рецепторов) * { "N_neuron" , "N", 15, 0 },; // Кол-во РАЗНЫХ классов (нейронов) * { "Kod_atr" , "N", 15, 0 },; // Код первичного признака (рецептора) * { "Name_atr" , "C", mMaxLenAtr, 0 },; // Наименование первичного признака (рецептора) * { "Kod_cls" , "N", 15, 0 },; // Код класса (нейрона) * { "Name_cls" , "C", mMaxLenCls, 0 },; // Наименование класса (нейрона) * { "Inf" , "N", 15, 7 },; // Весовой коэффициент * { "Abs_Inf" , "N", 15, 7 },; // Модуль весового коэффициента * { "Perc_Inf" , "N", 15, 7 },; // Модуль весового коэффициента в % от Abs_Inf * { "Sum_Mod_VK" , "N", 15, 7 },; // Сумма модулей весового коэффициента * { "PercSModVK" , "N", 15, 7 },; // Сумма модулей весового коэффициента в процентах от максимального по БД * { "XR" , "N", 15, 0 },; // Координата Х рецептора * { "YR" , "N", 15, 0 },; // Координата Y рецептора (для инт.когн.карт) * { "XN" , "N", 15, 0 },; // Координата Х нейрона * { "YN" , "N", 15, 0 } } // Координата Y нейрона (для инт.когн.карт) SELECT NeuroRel *DELETE FOR Abs_Inf/FactMaxInf*100 < mViewPorogRel // Отображать связи с интенсивностью не менее mViewPorogRel *DELETE FOR Kod_cls < M_KodCls1 // Начальный код класса (нейрона) *DELETE FOR Kod_cls > M_KodCls2 // Конечный код класса (нейрона) *DELETE FOR Kod_atr < M_KodAtr1 // Начальный код признака (рецептора) *DELETE FOR Kod_atr > M_KodAtr2 // Конечный код признака (рецептора) *DELETE FOR N_neuron < mViewMaxCls // Отображать не более mViewMaxCls разных классов *DELETE FOR N_recept < mViewMaxAtr // Отображать не более mViewMaxAtr разных рецепторов *DELETE FOR N_relat < mViewMaxRel // Отображать не более mViewMaxRel связей *PACK SELECT NeuroRel DBGOTOP() DO WHILE .NOT. EOF() IF Abs_Inf/FactMaxInf*100 >= mViewPorogRel // Отображать связи с интенсивностью не менее mViewPorogRel ELSE DELETE ENDIF IF M_KodCls1 <= Kod_cls .AND. Kod_cls <= M_KodCls2 // Начальный код класса (нейрона) ELSE DELETE ENDIF IF M_KodAtr1 <= Kod_atr .AND. Kod_atr <= M_KodAtr2 // Начальный код признака (рецептора) ELSE DELETE ENDIF IF N_neuron > mViewMaxCls // Отображать не более mViewMaxCls разных классов DELETE ENDIF IF N_recept > mViewMaxAtr // Отображать не более mViewMaxAtr разных рецепторов DELETE ENDIF IF N_relat > mViewMaxRel // Отображать не более mViewMaxRel связей DELETE ENDIF DBSKIP(1) ENDDO PACK * 2. Рассортировать БД по убыванию МОДУЛЯ информативности или информативности со знаком SELECT NeuroRel IF mSort = 1 // по модулю информативности INDEX ON STR(99999999.9999999-Abs_Inf,19, 7) TO Neur_Rel ENDIF IF mSort = 2 // по информативности и знаку INDEX ON STR(99999999.9999999- Inf,19, 7) TO Neur_Rel ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE NeuroRelAll EXCLUSIVE NEW // БД без сокращений, ПОЛНАЯ USE NeuroRel INDEX Neur_Rel EXCLUSIVE NEW SELECT NeuroRel SET ORDER TO 1 * 3. Двигаться вниз по БД и считать кол-во РАЗНЫХ рецепторов и РАЗНЫХ нейронов A_KodAtr := {} // Массив кодов признаков A_KodCls := {} // Массив кодов классов DBGOTOP() DO WHILE .NOT. EOF() ******* Занесение информации по РЕЦЕПТОРАМ mKodAtr = Kod_atr mPos = ASCAN(A_KodAtr, mKodAtr) // Если кода признака еще нет в массиве IF mPos = 0 // Кодируем признаки AADD(A_KodAtr, mKodAtr) mPos = ASCAN(A_KodAtr, mKodAtr) // Если кода признака еще нет в массиве ENDIF REPLACE N_recept WITH mPos REPLACE Perc_inf WITH Abs_inf / FactMaxInf * 100 ******* Занесение информации по НЕЙРОНАМ mKodCls = Kod_cls mPos = ASCAN(A_KodCls, mKodCls) // Если кода класса еще нет в массиве IF mPos = 0 // Кодируем классы AADD(A_KodCls, mKodCls) mPos = ASCAN(A_KodCls, mKodCls) // Если кода признака еще нет в массиве ENDIF REPLACE N_neuron WITH mPos DBSKIP(1) ENDDO ****** Дорасчет остальных полей БД NeuroRel Num_pp = 0 SumAbsInf = 0 FactMaxInf = 0 // Легче посчитать еще раз, чем тащить через файлы DBGOTOP() DO WHILE .NOT. EOF() REPLACE N_relat WITH ++Num_pp // Номер связи SumAbsInf = SumAbsInf + Abs_inf // Модуль интенсивности связи нарастающим итогом REPLACE Sum_Mod_VK WITH SumAbsInf FactMaxInf = MAX(FactMaxInf, Abs_inf) // Фактическая максимальная интенсивность связи, которая принимается за 100% DBSKIP(1) ENDDO ************ Расчет Парето-диаграммы в процентах * { "Sum_Mod_VK" , "N", 15, 7 },; // Сумма модулей весового коэффициента * { "PercSModVK" , "N", 15, 7 },; // Сумма модулей весового коэффициента в процентах от максимального по БД DBGOBOTTOM() SummaAbsInf = Sum_Mod_VK // 100% DBGOTOP() DO WHILE .NOT. EOF() REPLACE PercSModVK WITH Sum_Mod_VK / SummaAbsInf * 100 DBSKIP(1) ENDDO ****** Найти реальное количество разных классов и разных признаков после срабатывания ограничений на БД SELECT NeuroRel DBGOTOP() DO WHILE .NOT. EOF() mKodAtr = Kod_atr mPos = ASCAN(A_KodAtr, mKodAtr) // Если кода признака еще нет в массиве IF mPos = 0 // Кодируем признаки AADD(A_KodAtr, mKodAtr) ENDIF mKodCls = Kod_cls mPos = ASCAN(A_KodCls, mKodCls) // Если кода класса еще нет в массиве IF mPos = 0 // Кодируем классы AADD(A_KodCls, mKodCls) ENDIF DBSKIP(1) ENDDO N_Cls = LEN(A_KodCls) // Количество разных классов N_Atr = LEN(A_KodAtr) // Количество разных признаков * 5. Выйти на отображение Парето-подмножества нейронной сети и инт.когнитивных карт ** РАССЧИТАТЬ И ВСТАВИТЬ КООРДИНАТЫ РЕЦЕПТОРОВ И НЕЙРОНОВ В БД IF mOption = 'IntCognMaps' W_Wind = X_MaxW / 2 // Полуширина окна для самого графика H_Wind = Y_MaxW / 4.7 // Полувысота окна для самого графика LX := 70 // Зона слева и справа от области графика LY := 72 // Зона над областью графика для наименования и под областью графика для легенды X0n := W_Wind // Начало координат для эллипса нейронов по оси X Y0n := Y_MaxW - H_Wind // Начало координат для эллипса нейронов по оси Y X0r := W_Wind // Начало координат для эллипса рецепторов по оси X Y0r := H_Wind // Начало координат для эллипса рецепторов по оси Y ********* Начало рисования эллипса с кружочками классов и линиями связи: сходства-различия R0X = W_Wind * 0.70 // Радиус элипса по X кружочков R0Y = H_Wind * 0.40 // Радиус элипса по Y кружочков K0n = 360 / N_Cls // Количество градусов в секторе одного класса K0r = 360 / N_Atr // Количество градусов в секторе одного признака aKn := {} // Код класса aXn := {} // Координаты X центров кружочков классов aYn := {} // Координаты Y центров кружочков классов aKr := {} // Код признака aXr := {} // Координаты X центров кружочков признаков aYr := {} // Координаты Y центров кружочков признаков * Faza = 0 - K0 // Угол поворота системы кружочков классов вокруг центра эллипса FazaN = 222.4969097651422 - K0n // Угол поворота системы кружочков классов вокруг центра эллипса (чтобы были видны линии связи между нейронами и рецепторами) FazaR = 222.4969097651422 - K0r // Угол поворота системы кружочков классов вокруг центра эллипса (чтобы были видны линии связи между нейронами и рецепторами) R0 = 25 // Радиус кружочков с кодами классов RS = 12 // Радиус кружочка для указания силы связи SELECT NeuroRel DBGOTOP() DO WHILE .NOT. EOF() *** нейроны mXn = X0n - R0X * COS(DTOR(FazaN+(N_neuron-1)*K0n)) mYn = Y0n - R0Y * SIN(DTOR(FazaN+(N_neuron-1)*K0n)) AADD(aKn, N_neuron) AADD(aXn, mXn) AADD(aYn, mYn) REPLACE XN WITH mXn // Координаты X центров нейронов REPLACE YN WITH mYn // Координата Y центров нейронов *** рецепторы mXr = X0r - R0X * COS(DTOR(FazaR+(N_recept-1)*K0r)) mYr = Y0r - R0Y * SIN(DTOR(FazaR+(N_recept-1)*K0r)) AADD(aKr, N_recept) AADD(aXr, mXr) AADD(aYr, mYr) REPLACE XR WITH mXr // Координаты X центров рецепторов REPLACE YR WITH mYr // Координата Y центров рецепторов DBSKIP(1) ENDDO ENDIF IF mOption = 'NeuroNet' W_Wind = X_MaxW / 2 // Полуширина окна для самого графика H_Wind = Y_MaxW / 2 // Полувысота окна для самого графика LX := 70 // Зона слева и справа от области графика LY := 72 // Зона над областью графика для наименования и под областью графика для легенды X0 := W_Wind // Начало координат для эллипса по оси X Y0 := H_Wind // Начало координат для эллипса по оси Y *** Расчитать параметры отображения R0X = W_Wind-2*LX // Радиус элипса по X R0Y = H_Wind-2*LY // Радиус элипса по Y DXN = 2*R0X / N_Cls // Смещение между центрами нейронов по X DXR = 2*R0X / N_Atr // Смещение между центрами рецепторов по X R0 = 25 // Радиус кружочков с кодами классов и длина прямоугольника для вывода наименования класса или признака RS = 12 // Радиус кружочка для указания силы связи YN = Y0 + R0Y - R0 // Координата линейки Y нейронов YR = Y0 - R0Y + R0 // Координата линейки Y рецепторов XN_min = 99999999 XN_max = -99999999 XR_min = 99999999 XR_max = -99999999 DBGOTOP() DO WHILE .NOT. EOF() REPLACE XR WITH X0 - R0X + (N_recept-1)*DXR // Координаты X центров рецепторов REPLACE XN WITH X0 - R0X + (N_neuron-1)*DXN // Координаты X центров нейронов REPLACE YR WITH Y0 - R0Y + R0 // Координата линейки Y рецепторов REPLACE YN WITH Y0 + R0Y - R0 // Координата линейки Y нейронов XN_min = MIN(XN_min, XN) XN_max = MAX(XN_max, XN) XR_min = MIN(XR_min, XR) XR_max = MAX(XR_max, XR) DBSKIP(1) ENDDO ******* ОТЦЕНТРОВАТЬ КООРДИНАТЫ РЕЦЕПТОРОВ И НЕЙРОНОВ В БД XR_left = 25 + X0 - (XR_max-XR_min)/2 XN_left = 25 + X0 - (XN_max-XN_min)/2 DBGOTOP() DO WHILE .NOT. EOF() REPLACE XR WITH XR_left + (N_recept-1)*DXR // Координаты X центров рецепторов REPLACE XN WITH XN_left + (N_neuron-1)*DXN // Координаты X центров нейронов DBSKIP(1) ENDDO ENDIF ********* ВЫВОД ГРАФИЧЕСКОЙ ДИАГРАММЫ ************************************ SELECT NeuroRel ****** ЗАГОЛОВОК *** Определение наиболее сильной по модулю связи для нормировки толщины линии mMaxPix = 7 // Максимальная по модулю сила связи в pix для нормировки силы связи на изображении mKnorm = mMaxPix / FactMaxInf // Коэффициент нормировки и преобразования силы связи из bit в pix () W_Wind = X_MaxW / 2 // Полуширина окна для самого графика H_Wind = Y_MaxW / 2 // Полувысота окна для самого графика LY := 70 // Зона над областью графика для наименования и под областью графика для легенды X0 := W_Wind // Начало координат для эллипса по оси X Y0 := H_Wind // Начало координат для эллипса по оси Y ***** Закрасить фон прямоугольника *************** ***** Закрасить фон прямоугольника *************** GraSetColor( oPS, aColor[98] , aColor[98] ) // Номер цвета в соответствии с _AidosColor.prg GraBox( oPS, { X0-W_Wind, Y0-H_Wind }, { X0+W_Wind, Y0+H_Wind }, GRA_FILL ) GraSetColor( oPS, aColor[222] , aColor[222] ) ***** Нарисовать рамку изображения и отделить место для легенды ******************* aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты * ****** Начало координат в центре рисунка * GraArc ( oPS, { X0, Y0 }, 1 ) // Начало координат * GraArc ( oPS, { X0, Y0 }, 2 ) // Начало координат * GraArc ( oPS, { X0, Y0 }, 3 ) // Начало координат GraLine( oPS, {X0-W_Wind+1, Y0-H_Wind+1}, {X0-W_Wind+1, Y0+H_Wind-1} ) // Нарисовать границу рамки изображения слева GraLine( oPS, {X0+W_Wind-1, Y0-H_Wind+1}, {X0+W_Wind-1, Y0+H_Wind-1} ) // Нарисовать границу рамки изображения справа GraLine( oPS, {X0-W_Wind+1, Y0-H_Wind+1}, {X0+W_Wind-1, Y0-H_Wind+1} ) // Нарисовать границу рамки изображения внизу параллельно оси X GraLine( oPS, {X0-W_Wind+1, Y0+H_Wind-1}, {X0+W_Wind-1, Y0+H_Wind-1} ) // Нарисовать границу рамки изображения вверху параллельно оси X GraLine( oPS, {X0-W_Wind+1, Y0-H_Wind+LY}, {X0+W_Wind-1, Y0-H_Wind+LY} ) // Нарисовать границу рамки легенды на уровне LY параллельно оси X *********************************************************************************************************************** *###################################################################################################################### *********************************************************************************************************************** **** Написать заголовок диаграммы * DC_ASave(M_CurrInf, "_NumbMod.arx") mNumMod = DC_ARestore("_NumbMod.arx") oFont := XbpFont():new():create("22.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты IF mOption = 'NeuroNet' mTitle = 'ПАРЕТО-ПОДМНОЖЕСТВО НЕЛОКАЛЬНОЙ НЕЙРОННОЙ СЕТИ В МОДЕЛИ: "'+UPPER(Ar_Model[mNumMod])+'"' ELSE mTitle = 'ПАРЕТО-ПОДМНОЖЕСТВО НЕЛОКАЛЬНОЙ ИНТЕГРАЛЬНОЙ КОГНИТИВНОЙ КАРТЫ В МОДЕЛИ: "'+UPPER(Ar_Model[mNumMod])+'"' ENDIF GraStringAt( oPS, { X_MaxW/2, Y_MaxW-20 }, mTitle ) oFont := XbpFont():new():create("20.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты // Посчитать сумму силы Inf отображаемых связей и ВСЕХ связей и вывести % отображаемых в конечном итоге // после удаления ниже порога и больше макс.числа рецепотров и нейронов <####################### SELECT NeuroRelAll;DBGOBOTTOM();mSUM_MOD_VK1 = SUM_MOD_VK SELECT NeuroRel ;DBGOBOTTOM();mSUM_MOD_VK2 = SUM_MOD_VK GraStringAt( oPS, { X_MaxW/2, Y_MaxW-48 }, 'Отображено: '+ALLTRIM(STR(mSUM_MOD_VK2/mSUM_MOD_VK1*100,7,2))+'% наиболее значимых синаптических связей' ) IF LEN(ALLTRIM(M_NameAppl)) < 70 GraStringAt( oPS, { X_MaxW/2, Y_MaxW-76 }, "Приложение: "+'"'+ALLTRIM(M_NameAppl)+'"' ) ELSE GraStringAt( oPS, { X_MaxW/2, Y_MaxW-76 }, '"'+ALLTRIM(M_NameAppl)+'"' ) ENDIF ***** Надписи oFont := XbpFont():new():create("12.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты mString = "{#, $} =>" mString = STRTRAN(mString,"#",ALLTRIM(STR(M_KodCls1,15))) mString = STRTRAN(mString,"$",ALLTRIM(STR(M_KodCls2,15))) GraStringAt( oPS, { 20, YN+20 }, 'Нейроны:' ) GraStringAt( oPS, { 20, YN-05 }, mString ) mString = "{#, $} =>" mString = STRTRAN(mString,"#",ALLTRIM(STR(M_KodAtr1,15))) mString = STRTRAN(mString,"$",ALLTRIM(STR(M_KodAtr2,15))) GraStringAt( oPS, { 20, YR-10 }, 'Рецепторы:' ) GraStringAt( oPS, { 20, YR-35 }, mString ) ****** Легенда ********************************* oFont := XbpFont():new():create("13.Arial Bold") GraSetFont( oPS ,oFont ) aAttr := ARRAY( GRA_AS_COUNT ) aAttr [ GRA_AS_COLOR ] := GRA_CLR_BLACK * aAttr [ GRA_AS_BOX ] := { X_MaxW-2*LX, LY } // Размер поля вывода в пикселях aAttr [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttr [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttr ) // Установить символьные атрибуты AxName = "Связи между рецепторами и нейронами. Цвет линии обозначает знак связи ('+','-'), а толщина линии - силу связи:" GraStringAt( oPS, { 20, LY-15 }, AxName ) AxName = "АКТИВИРУЮЩАЯ связь между рецептором и нейроном отображается КРАСНЫМ цветом" GraStringAt( oPS, { 200, LY-35 }, AxName ) AxName = "ТОРМОЗЯЩАЯ связь между рецептором и нейроном отображается СИНИМ цветом" GraStringAt( oPS, { 200, LY-55 }, AxName ) IF mOption = 'IntCognMaps' ******* Эллипс с фоном для нейронов aAttrL := Array( GRA_AL_COUNT ) // атрибуты линии aAttrL [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttrL [ GRA_AL_COLOR ] := aColor[157] aAttrL [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttrL ) aAttr := Array( GRA_AA_COUNT ) // атрибуты области aAttr [ GRA_AA_COLOR ] := aColor[100] aAttr [ GRA_AA_SYMBOL ] := GRA_SYM_DEFAULT graSetAttrArea( oPS, aAttr ) GraArc( oPS, {X0n, Y0n}, 1, {R0X, 0, 0, R0Y}, ,, GRA_OUTLINEFILL ) ******* Эллипс с фоном для рецепторов aAttrL := Array( GRA_AL_COUNT ) // атрибуты линии aAttrL [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttrL [ GRA_AL_COLOR ] := aColor[11] aAttrL [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttrL ) aAttr := Array( GRA_AA_COUNT ) // атрибуты области aAttr [ GRA_AA_COLOR ] := aColor[20] aAttr [ GRA_AA_SYMBOL ] := GRA_SYM_DEFAULT graSetAttrArea( oPS, aAttr ) GraArc( oPS, {X0r, Y0r}, 1, {R0X, 0, 0, R0Y}, ,, GRA_OUTLINEFILL ) ENDIF **** Параметры фильтров oFont := XbpFont():new():create("10.ArialBold") GraSetFont( oPS ,oFont ) aAttr := ARRAY( GRA_AS_COUNT ) aAttr [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttr [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttr [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttr ) // Установить символьные атрибуты * M_KodCls1 // Начальный код класса (нейрона) * M_KodCls2 // Конечный код класса (нейрона) * M_KodAtr1 // Начальный код признака (рецептора) * M_KodAtr2 // Конечный код признака (рецептора) * mViewMaxCls // Отображать не более mViewMaxCls классов * mViewMaxRel // Отображать не более mViewMaxRel связей * mViewMaxAtr // Отображать не более mViewMaxAtr рецепторов * mViewPorogRel // Отображать связи с интенсивностью не менее mViewPorogRel * mSort // mSort=1 - сортировать по модулю информативности; mSort=2 - по информативности и знаку * mViewNameCls // .T. - рисовать наименования классов (нейронов) * mViewNameAtr // .T. - рисовать наименования признаков (рецепторов) GraLine(oPS, { X0+70, LY }, { X0+70, LY-69 } ) // Нарисовать линию заданных толщины и цвета s=X0+120;d=14 GraStringAt( oPS, { s, LY-10-0*d }, 'Коды нач.и кон.нейронов: ');GraStringAt( oPS, { s+200, LY-10-0*d },ALLTRIM(STR(M_KodCls1))+'-'+ALLTRIM(STR(M_KodCls2)) ) GraStringAt( oPS, { s, LY-10-1*d }, 'Коды нач.и кон.рецепторов: ');GraStringAt( oPS, { s+200, LY-10-1*d },ALLTRIM(STR(M_KodAtr1))+'-'+ALLTRIM(STR(M_KodAtr2)) ) GraStringAt( oPS, { s, LY-10-2*d }, 'Отображать не более: '+ALLTRIM(STR(mViewMaxCls))+' нейронов' ) GraStringAt( oPS, { s, LY-10-3*d }, 'Отображать не более: '+ALLTRIM(STR(mViewMaxAtr))+' рецепторов' ) GraLine(oPS, { X0+420, LY }, { X0+420, LY-69 } ) // Нарисовать линию заданных толщины и цвета s=X0+470;d=14 GraStringAt( oPS, { s, LY-10-0*d }, 'Отображать не более: '+ALLTRIM(STR(mViewMaxRel))+' связей' ) GraStringAt( oPS, { s, LY-10-1*d }, 'Отображать связи с интенс.более: '+ALLTRIM(STR(mViewPorogRel,8,3))+'% от факт.макс.' ) GraStringAt( oPS, { s, LY-10-2*d }, 'Сортировка связей по '+IF(mSort=1,'модулю информативности','информативности и знаку') ) GraStringAt( oPS, { s, LY-10-3*d }, "Дата и время создания формы: "+DTOC(DATE())+'-'+TIME() ) **** Нарисовать сами линии **** mSxodstvo > 0 aAttr := Array( GRA_AL_COUNT ) // атрибуты линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := GRA_CLR_RED aAttr [ GRA_AL_WIDTH ] := 7 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraLine(oPS, { 23, LY-35 }, { 170, LY-35 } ) // Нарисовать линию заданных толщины и цвета **** mSxodstvo < 0 aAttr := Array( GRA_AL_COUNT ) // атрибуты линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := GRA_CLR_BLUE aAttr [ GRA_AL_WIDTH ] := 7 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraLine(oPS, { 23, LY-55 }, { 170, LY-55 } ) // Нарисовать линию заданных толщины и цвета ****************************************************** ********* Рисование линий связи нужных толщины и цвета ****************************************************** R0 = 25 // Радиус кружочков с кодами классов и длина прямоугольника для вывода наименования класса или признака RS = 12 // Радиус кружочка для указания силы связи ****** Загрузить графический шрифт для надписей силы связи oFont := XbpFont():new():create("10.Arial") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_BOX ] := { RS*1.2, RS*1.2 } // Размер поля вывода aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) SELECT NeuroRel DBGOTOP() DO WHILE .NOT. EOF() IF Inf <> 0 aAttrL := Array( GRA_AL_COUNT ) // атрибуты линии aAttrL [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttrL [ GRA_AL_COLOR ] := IF(Inf > 0, GRA_CLR_RED, GRA_CLR_BLUE) aAttrL [ GRA_AL_WIDTH ] := Abs_Inf * mKnorm // Задать толщину линии graSetAttrLine( oPS, aAttrL ) GraLine(oPS, { XR, YR }, { XN, YN } ) // Нарисовать линию заданных толщины и цвета IF mOption = 'NeuroNet' ****** Сделать надписи уровней сходства на линиях связи aAttrF := Array( GRA_AA_COUNT ) // атрибуты области Для рисунков кружков по центрам линий связи aAttrF [ GRA_AA_COLOR ] := IF(Inf > 0, BD_LIGHTYELLOW, BD_XBP_CYAN) aAttrF [ GRA_AA_SYMBOL ] := GRA_SYM_DEFAULT graSetAttrArea( oPS, aAttrF ) aAttrL := Array( GRA_AL_COUNT ) // атрибуты линии aAttrL [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttrL [ GRA_AL_COLOR ] := IF(Inf > 0, GRA_CLR_RED, GRA_CLR_BLUE) aAttrL [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttrL ) GraArc( oPS, { (XR+XN)/2, (YR+YN)/2 }, RS, ,,, GRA_OUTLINEFILL ) GraStringAt( oPS, { (XR+XN)/2, (YR+YN)/2 }, ALLTRIM(STR(ROUND(Perc_Inf,0),15)) ) // В % от факт.максимальной <############# ENDIF ENDIF DBSKIP(1) ENDDO IF mOption = 'NeuroNet' **************************************************** ****** Рисование надписей признаков **************** **************************************************** ****** Загрузить графический шрифт oFont := XbpFont():new():create("10.Arial") GraSetFont(oPS , oFont) // установить шрифт ****** Атрибуты графического шрифта aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_BOX ] := { RS, RS } // Размер поля вывода aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) *** Цикл по рецепторам *************** SELECT NeuroRel DBGOTOP() IF SUBSTR(Name_atr,1,12) = 'SPECTRINTERV' aRGBAtr := {} // Массив цветов признаков, если спектр DBGOTOP() DO WHILE .NOT. EOF() mScName = ALLTRIM(Name_atr) * IF SUBSTR(mScName,1,12) = 'SPECTRINTERV' // <<<===######### Почему-то у рецепторов неверные цвета фонов * SpectrInterv: 999/999-{123,123,123} * 123456789012 R G B mPosR1 = AT('{', mScName)+1 mPosR2 = mPosR1+2 mPosG1 = mPosR2+2 mPosG2 = mPosG1+2 mPosB1 = mPosG2+2 mPosB2 = mPosB1+2 * MsgBox(mScName+' R='+ALLTRIM(STR(mPosR1))+','+ALLTRIM(STR(mPosR2))+', G='+ALLTRIM(STR(mPosG1))+','+ALLTRIM(STR(mPosG2))+', B='+ALLTRIM(STR(mPosB1))+','+ALLTRIM(STR(mPosB2))) mRed = VAL(SUBSTR(mScName, mPosR1, mPosR2-mPosR1+1)) mGreen = VAL(SUBSTR(mScName, mPosG1, mPosG2-mPosG1+1)) mBlue = VAL(SUBSTR(mScName, mPosB1, mPosB2-mPosB1+1)) * MsgBox(mScName+' '+STR(mRed)+','+STR(mGreen)+','+STR(mBlue)) * GraMakeRGBColor({VAL(SUBSTR(InfPortClsPos->NAME_atr, AT('{', InfPortClsPos->NAME_atr)+1, AT('{', InfPortClsPos->NAME_atr)+ 3-AT('{', InfPortClsPos->NAME_atr)+1+1)),VAL(SUBSTR(InfPortClsPos->NAME_atr, AT('{', InfPortClsPos->NAME_atr)+5, AT('{', InfPortClsPos->NAME_atr)+ 7-AT('{', InfPortClsPos->NAME_atr)+5+1)),VAL(SUBSTR(InfPortClsPos->NAME_atr, AT('{', InfPortClsPos->NAME_atr)+9, AT('{', InfPortClsPos->NAME_atr)+11-AT('{', InfPortClsPos->NAME_atr)+9+1))})})} // Вывод поля цветом RGB fColor := GraMakeRGBColor({ mRed, mGreen, mBlue}) * SetPixel(hDC1, x, y, AutomationTranslateColor(fColor,.f.) ) * AADD(aRGBAtr, AutomationTranslateColor(fColor,.f.)) AADD(aRGBAtr, fColor) * ENDIF DBSKIP(2) // У каждой связи два конца: нейрон и рецептор ENDDO ENDIF ** Сделать надписи наименований рецепторов (признаков) Xb := 2.2*R0*1.618 // Ширина прямоугольника Yb := 2.2*R0 // Высота прямоугольника Prc := 0.8 IF mViewNameAtr // .T. - рисовать наименования признаков (рецепторов) aNameAtr := {} // Массив уже нарисованных наименований признаков j = 0 DBGOTOP() DO WHILE .NOT. EOF() IF ASCAN(aNameAtr, Name_atr) = 0 // исключение повторных рисований наименований признаков AADD(aNameAtr, DelZeroNameGr(Name_atr)) aAttrA := Array( GRA_AA_COUNT ) // атрибуты области aAttrA [ GRA_AA_COLOR ] := BD_WHITE aAttrA [ GRA_AA_SYMBOL] := GRA_SYM_DEFAULT graSetAttrArea( oPS, aAttrA ) aAttrL := Array( GRA_AL_COUNT ) // атрибуты линии aAttrL [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttrL [ GRA_AL_COLOR ] := GRA_CLR_BLUE aAttrL [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttrL ) GraBox( oPS, { XR - Xb/2, YR - Yb - Prc*R0 }, { XR + Xb/2, YR - Prc*R0 }, GRA_OUTLINEFILL, 10, 10 ) // прямоугольник очерчен, заполнен и закруглен GraArc( oPS, { XR - Xb/2, YR - Yb - Prc*R0 }, 2, ,,, GRA_OUTLINEFILL ) GraArc( oPS, { XR + Xb/2, YR - Prc*R0 }, 2, ,,, GRA_OUTLINEFILL ) IF SUBSTR(Name_atr,1,12) = 'SPECTRINTERV' * SPECTRINTERV:-1/35-{255,063,063} * j++ * mPos1 = AT('-',Name_atr) * mPos2 = AT('/',Name_atr) * j = VAL(SUBSTR(Name_atr, mPos1+1, mPos2-mPos1)) * MsgBox(STR(j)) * MsgBox(Name_atr) * SpectrInterv: 999/999-{123,123,123} * 123456789012 R G B mPosR1 = AT('{', Name_atr)+1 mPosR2 = mPosR1+2 mPosG1 = mPosR2+2 mPosG2 = mPosG1+2 mPosB1 = mPosG2+2 mPosB2 = mPosB1+2 * MsgBox(mScName+' R='+ALLTRIM(STR(mPosR1))+','+ALLTRIM(STR(mPosR2))+', G='+ALLTRIM(STR(mPosG1))+','+ALLTRIM(STR(mPosG2))+', B='+ALLTRIM(STR(mPosB1))+','+ALLTRIM(STR(mPosB2))) mRed = VAL(SUBSTR(Name_atr, mPosR1, mPosR2-mPosR1+1)) mGreen = VAL(SUBSTR(Name_atr, mPosG1, mPosG2-mPosG1+1)) mBlue = VAL(SUBSTR(Name_atr, mPosB1, mPosB2-mPosB1+1)) * MsgBox(mScName+' '+STR(mRed)+','+STR(mGreen)+','+STR(mBlue)) * GraMakeRGBColor({VAL(SUBSTR(InfPortClsPos->NAME_atr, AT('{', InfPortClsPos->NAME_atr)+1, AT('{', InfPortClsPos->NAME_atr)+ 3-AT('{', InfPortClsPos->NAME_atr)+1+1)),VAL(SUBSTR(InfPortClsPos->NAME_atr, AT('{', InfPortClsPos->NAME_atr)+5, AT('{', InfPortClsPos->NAME_atr)+ 7-AT('{', InfPortClsPos->NAME_atr)+5+1)),VAL(SUBSTR(InfPortClsPos->NAME_atr, AT('{', InfPortClsPos->NAME_atr)+9, AT('{', InfPortClsPos->NAME_atr)+11-AT('{', InfPortClsPos->NAME_atr)+9+1))})})} // Вывод поля цветом RGB fColor := GraMakeRGBColor({ mRed, mGreen, mBlue}) * GraSetColor( oPS, aRGBAtr[j] , aRGBAtr[j] ) // Цвет фона для текста - цвет цветового диапазона // <<<===############### Неверно выводится цвет фона GraSetColor( oPS, fColor , fColor ) // Цвет фона для текста - цвет цветового диапазона // <<<===############### Неверно выводится цвет фона GraBox( oPS, { XR - Xb/2 + 1, YR - Yb - Prc*R0 + 1 }, { XR + Xb/2 - 1, YR - Prc*R0 - 1 }, GRA_OUTLINEFILL, 10, 10 ) // прямоугольник очерчен, заполнен и закруглен ENDIF ***** Наименование признака внутри прямоугольника NM = Name_atr // Максимальная длина наименования признака, помещающегося в прямоугольнике, равна 90 символов SL = 15 // Длина строки в прямоугольнике в символах SP = 10 // Межстрочный интервал в пикселях L = 1+INT(LEN(NM)/SL) // Число строк в прямоугольнике oFont := XbpFont():new():create("14.Arial") GraSetFont( oPS ,oFont ) aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_BOX ] := { SL, SP } // Размер поля вывода в пикселях aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_TOP // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) ***** Цикл определения такой длины строки, которая помещается в рамку ***** Массив отображаемых в рамке строк, включающий наименования и описательных шкал и их градаций ***** Из текстового буфера к отображаемому элементу массива добавляется по одному символу и определяется его длина в пикселях. ***** Если не хватает длины рамки - добавляется строка в массив. Отображение градации шкалы всегда начинается с новой строки. mZone = Xb-16 // Ширина зоны отображения в пикселях с учетом полей слева и справа aMess := {} // Массив отображаемых в рамке строк, включающий наименования и описательных шкал и их градаций AADD(aMess, L(" "));s=1 // 1-й элемент - 1-я строка mBuff = ALLTRIM(Name_atr) // Максимальная длина наименования признака, помещающегося в прямоугольнике, равна 90 символов FOR i=1 TO LEN(mBuff) aTxtPar = DC_GraQueryTextbox(aMess[s] + SUBSTR(mBuff,i,1), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox(aMess[s] + SUBSTR(mBuff,i,1)+" "+STR(aTxtPar[1])) IF aTxtPar[1] <= mZone aMess[s] = aMess[s] + SUBSTR(mBuff,i,1) // Полное наименование описательной шкалы посылается в буфер для отображения ELSE IF s < 5 AADD(aMess, SUBSTR(mBuff,i,1)) s++ ELSE EXIT ENDIF ENDIF NEXT mInterval = SP // Межстрочный интервал в пикселях. 1 - строки пишутся без пропуска FOR s=1 TO LEN(aMess) GraStringAt( oPS, { XR-Xb/2+3, YR-Prc*R0-4-(s-1)*mInterval }, aMess[s] ) NEXT ENDIF DBSKIP(1) ENDDO ENDIF ********* Сделать надписи наименований классов (нейронов) IF mViewNameCls // .T. - рисовать наименования классов (нейронов) aNameCls := {} // Массив уже нарисованных наименований классов DBGOTOP() DO WHILE .NOT. EOF() IF ASCAN(aNameCls, Name_cls) = 0 // исключение повторных рисований наименований классов AADD(aNameCls, DelZeroNameGr(Name_cls)) aAttrA := Array( GRA_AA_COUNT ) // атрибуты области aAttrA [ GRA_AA_COLOR ] := BD_WHITE aAttrA [ GRA_AA_SYMBOL] := GRA_SYM_DEFAULT graSetAttrArea( oPS, aAttrA ) aAttrL := Array( GRA_AL_COUNT ) // атрибуты линии aAttrL [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttrL [ GRA_AL_COLOR ] := GRA_CLR_BLUE aAttrL [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttrL ) GraBox( oPS, { XN - Xb/2, YN + Yb + Prc*R0 }, { XN + Xb/2, YN + Prc*R0 }, GRA_OUTLINEFILL, 10, 10 ) // прямоугольник очерчен, заполнен и закруглен GraArc( oPS, { XN - Xb/2, YN + Yb + Prc*R0 }, 2, ,,, GRA_OUTLINEFILL ) GraArc( oPS, { XN + Xb/2, YN + Prc*R0 }, 2, ,,, GRA_OUTLINEFILL ) ***** Наименование признака внутри прямоугольника NM = Name_cls // Максимальная длина наименования признака, помещающегося в прямоугольнике, равна 90 символов SL = 15 // Длина строки в прямоугольнике в символах SP = 10 // Межстрочный интервал в пикселях L = 1+INT(LEN(NM)/SL) // Число строк в прямоугольнике oFont := XbpFont():new():create("14.Arial") GraSetFont( oPS ,oFont ) aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_BOX ] := { SL, SP } // Размер поля вывода в пикселях aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_TOP // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) ***** Цикл определения такой длины строки, которая помещается в рамку ***** Массив отображаемых в рамке строк, включающий наименования и описательных шкал и их градаций ***** Из текстового буфера к отображаемому элементу массива добавляется по одному символу и определяется его длина в пикселях. ***** Если не хватает длины рамки - добавляется строка в массив. Отображение градации шкалы всегда начинается с новой строки. mZone = Xb-16 // Ширина зоны отображения в пикселях с учетом полей слева и справа aMess := {} // Массив отображаемых в рамке строк, включающий наименования и описательных шкал и их градаций AADD(aMess, L(" "));s=1 // 1-й элемент - 1-я строка mBuff = ALLTRIM(Name_cls) // Максимальная длина наименования признака, помещающегося в прямоугольнике, равна 90 символов FOR i=1 TO LEN(mBuff) aTxtPar = DC_GraQueryTextbox(aMess[s] + SUBSTR(mBuff,i,1), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox(aMess[s] + SUBSTR(mBuff,i,1)+" "+STR(aTxtPar[1])) IF aTxtPar[1] <= mZone aMess[s] = aMess[s] + SUBSTR(mBuff,i,1) // Полное наименование описательной шкалы посылается в буфер для отображения ELSE IF s < 5 AADD(aMess, SUBSTR(mBuff,i,1)) s++ ELSE EXIT ENDIF ENDIF NEXT mInterval = SP // Межстрочный интервал в пикселях. 1 - строки пишутся без пропуска FOR s=1 TO LEN(aMess) GraStringAt( oPS, { XN-Xb/2+3, YN+Prc*R0+Yb-4-(s-1)*mInterval }, aMess[s] ) NEXT ENDIF DBSKIP(1) ENDDO ENDIF ENDIF ******************************************** ** Линии связи между классами и классам ** Линии связи между признаками и признаками ******************************************** IF mOption = 'IntCognMaps' ********* Нарисовать линии связи между классами M_SxodCls = "SxodCls" +Ar_Model[mNumMod] USE (M_SxodCls) EXCLUSIVE NEW // Для рисования 2d семантической сети классов SELECT (M_SxodCls) *** Полный перебор всех сочетаний классов конструкта D = 7 // Максимальная толщина отображаемых линий *** Поиск минимального и максимального значений толщины линии mSxodMin = +99999999999 mSxodMax = -99999999999 FOR i=1 TO LEN(A_KodCls) // Цикл по классам конструкта DBGOTO(A_KodCls[i]) FOR j=i+1 TO LEN(A_KodCls) // Цикл по классам конструкта mSxodstvo = FIELDGET(3+A_KodCls[j]) IF ABS(mSxodstvo) >= mViewPorogRel // Отображать связи с интенсивностью не менее mViewPorogRel mSxodMin = MIN(mSxodMin, mSxodstvo) mSxodMax = MAX(mSxodMax, mSxodstvo) ENDIF NEXT NEXT K = D / MAX(ABS(mSxodMax), ABS(mSxodMin)) // Масштабный коэффициент * MsgBox(STR(mSxodMax)+STR(mSxodMin)+STR(K)) FOR i=1 TO LEN(A_KodCls) // Цикл по классам конструкта DBGOTO(A_KodCls[i]) FOR j=i+1 TO LEN(A_KodCls) // Цикл по классам конструкта mSxodstvo = FIELDGET(3+A_KodCls[j]) IF ABS(mSxodstvo) >= mViewPorogRel // Отображать связи с интенсивностью не менее mViewPorogRel ******* Сделать цвет заливки и линии, а также толщину линии, зависящими от величины и знака сходства-различия aAttr := Array( GRA_AL_COUNT ) // атрибуты линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := IF(mSxodstvo > 0, aColor[160], aColor[107] ) aAttr [ GRA_AL_WIDTH ] := ABS(mSxodstvo) * K // Задать толщину линии graSetAttrLine( oPS, aAttr ) mPosKni = ASCAN(aKn, i) mPosKnj = ASCAN(aKn, j) GraLine(oPS, { aXn[mPosKni], aYn[mPosKni] }, { aXn[mPosKnj], aYn[mPosKnj] } ) // Нарисовать линию заданных толщины и цвета ############## ENDIF NEXT NEXT CLOSE (M_SxodCls) ********* Нарисовать линии связи между признаками M_SxodAtr = "SxodAtr" +Ar_Model[mNumMod] USE (M_SxodAtr) EXCLUSIVE NEW // Для рисования 2d семантической сети классов SELECT (M_SxodAtr) *** Полный перебор всех сочетаний признаков конструкта D = 7 // Максимальная толщина отображаемых линий *** Поиск минимального и максимального значений толщины линии mSxodMin = +99999999999 mSxodMax = -99999999999 FOR i=1 TO LEN(A_KodAtr) // Цикл по классам конструкта DBGOTO(A_KodAtr[i]) FOR j=i+1 TO LEN(A_KodAtr) // Цикл по классам конструкта mSxodstvo = FIELDGET(3+A_KodAtr[j]) IF ABS(mSxodstvo) >= mViewPorogRel // Отображать связи с интенсивностью не менее mViewPorogRel mSxodMin = MIN(mSxodMin, mSxodstvo) mSxodMax = MAX(mSxodMax, mSxodstvo) ENDIF NEXT NEXT K = D / MAX(ABS(mSxodMax), ABS(mSxodMin)) // Масштабный коэффициент * MsgBox(STR(mSxodMax)+STR(mSxodMin)+STR(K)) FOR i=1 TO LEN(A_KodAtr) // Цикл по классам конструкта DBGOTO(A_KodAtr[i]) FOR j=i+1 TO LEN(A_KodAtr) // Цикл по классам конструкта mSxodstvo = FIELDGET(3+A_KodAtr[j]) IF ABS(mSxodstvo) >= mViewPorogRel // Отображать связи с интенсивностью не менее mViewPorogRel ******* Сделать цвет заливки и линии, а также толщину линии, зависящими от величины и знака сходства-различия aAttr := Array( GRA_AL_COUNT ) // атрибуты линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := IF(mSxodstvo > 0, aColor[160], aColor[107] ) aAttr [ GRA_AL_WIDTH ] := ABS(mSxodstvo) * K // Задать толщину линии graSetAttrLine( oPS, aAttr ) mPosKri = ASCAN(aKr, i) mPosKrj = ASCAN(aKr, j) GraLine(oPS, { aXr[mPosKri], aYr[mPosKri] }, { aXr[mPosKrj], aYr[mPosKrj] } ) // Нарисовать линию заданных толщины и цвета ############## ENDIF NEXT NEXT CLOSE (M_SxodAtr) ENDIF ******* Рисование кружков признаков и классов oFont := XbpFont():new():create("20.Arial") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_BOX ] := { RS*1.2, RS*1.2 } // Размер поля вывода aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) aAttrL := Array( GRA_AL_COUNT ) // атрибуты линии aAttrL [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttrL [ GRA_AL_COLOR ] := BD_DARKBLUE aAttrL [ GRA_AL_WIDTH ] := 2 // Задать толщину линии graSetAttrLine( oPS, aAttrL ) aAttrF := Array( GRA_AA_COUNT ) // атрибуты области Для рисунков кружков по центрам линий связи aAttrF [ GRA_AA_COLOR ] := BD_XBP_CYAN aAttrF [ GRA_AA_SYMBOL ] := GRA_SYM_DEFAULT graSetAttrArea( oPS, aAttrF ) SELECT NeuroRel DBGOTOP() DO WHILE .NOT. EOF() aAttrF [ GRA_AA_COLOR ] := BD_XBP_CYAN graSetAttrArea( oPS, aAttrF ) GraArc( oPS, { XR, YR }, 18, ,,, GRA_OUTLINEFILL ) GraStringAt( oPS, { XR, YR }, ALLTRIM(STR(Kod_atr,15)) ) aAttrF [ GRA_AA_COLOR ] := BD_LIGHTYELLOW graSetAttrArea( oPS, aAttrF ) GraArc( oPS, { XN, YN }, 18, ,,, GRA_OUTLINEFILL ) GraStringAt( oPS, { XN, YN }, ALLTRIM(STR(Kod_cls,15)) ) DBSKIP(1) ENDDO ********* Записать файл изображения с именем - порядковым номером в папке SemNetCls2d DC_Impl(oScrn) IF mPar = 'Screen' DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения IF mOption = 'NeuroNet' IF FILEDATE("NeuroNetDiagr",16) = CTOD("//") DIRMAKE("NeuroNetDiagr") aMess := {} AADD(aMess, L('В папке текущего приложения: "#" не было директории "NeuroNetDiagr"')) AADD(aMess, L('для графических диаграмм нейронных сетей и она была создана!')) aMess[1] = STRTRAN(aMess[1], "#", UPPER(ALLTRIM(M_PathAppl))) LB_Warning(aMess, L('4.4.11.Графическое отображение нелокальных нейросетей в системе "Эйдос"' )) ENDIF DIRCHANGE(M_PathAppl+"\NeuroNetDiagr\") // Перейти в папку NeuroNetDiagr cFileName = "NeuroNet"+STRTRAN(STR(1+ADIR("*.bmp"),4)," ","0")+Ar_Model[M_CurrInf]+".bmp" ELSE IF FILEDATE("IntCognMaps",16) = CTOD("//") DIRMAKE("IntCognMaps") aMess := {} AADD(aMess, L('В папке текущего приложения: "#" не было директории "IntCognMaps"')) AADD(aMess, L('для графических диаграмм нейронных сетей и она была создана!')) aMess[1] = STRTRAN(aMess[1], "#", UPPER(ALLTRIM(M_PathAppl))) LB_Warning(aMess, L('4.4.12.Графическое отображение интегральных когнитивных карт в системе "Эйдос"' )) ENDIF DIRCHANGE(M_PathAppl+"\IntCognMaps\") // Перейти в папку IntCognMaps cFileName = "IntCognMap"+STRTRAN(STR(1+ADIR("*.bmp"),4)," ","0")+Ar_Model[M_CurrInf]+".bmp" ENDIF DC_Scrn2ImageFile( oStatic, cFileName ) ENDIF // Сохранить файл с информацией о параметрах режима 4.4.11, 4.4.12 в текущей директории системы и в папке приложения aPar4411[ 1] = M_KodCls1 // Начальный код класса (нейрона) aPar4411[ 2] = M_KodCls2 // Конечный код класса (нейрона) aPar4411[ 3] = M_KodAtr1 // Начальный код признака (рецептора) aPar4411[ 4] = M_KodAtr2 // Конечный код признака (рецептора) aPar4411[ 5] = mViewMaxCls // Отображать не более mViewMaxCls классов aPar4411[ 6] = mViewMaxRel // Отображать не более mViewMaxRel связей aPar4411[ 7] = mViewMaxAtr // Отображать не более mViewMaxAtr рецепторов aPar4411[ 8] = mViewPorogRel // Отображать связи с интенсивностью не менее mViewPorogRel aPar4411[ 9] = mSort // mSort=1 - сортировать по модулю информативности; mSort=2 - по информативности и знаку aPar4411[10] = mViewNameCls // .T. - рисовать наименования классов (нейронов) aPar4411[11] = mViewNameAtr // .T. - рисовать наименования признаков (рецепторов) * aPar4411 = DC_ARestore("_4_4_11.arx") DC_ASave(aPar4411 , "_4_4_11.arx") ReTURN NIL ****************************************** **************************************************************************************************************************************************** ******* Режим представляет собой ПРОГРАММНЫЙ ИНТЕРФЕЙС ФОРМАЛИЗАЦИИ ПРЕДМЕТНОЙ ОБЛАСТИ И ИМПОРТА ДАННЫХ В СИСТЕМУ "ЭЙДОС-Х". ******* Данный программный интерфейс обеспечивает автоматическое формирование классификационных и описательных шкал и градаций и обучающей выборки ******* на основе XLS, XLSX или DBF-файла с исходными данными стандарта, описанного в Help режима стандарта, представляющего собой ТРАНСПОНИРОВАННЫЙ ******* файл стандарта режима 2.3.2.2. Кроме того он обеспечивает автоматический ввод распознаваемой выборки из внешней базы данных ******* Все сделать точно как в режиме 1.5.3 DOS-версии. Обрабатывать шкалы соответственно указанному типу данных шкалы: как текстовые или числовые **************************************************************************************************************************************************** FUNCTION F2_3_2_3() LOCAL Getlist := {}, oProgress, oDialog PUBLIC Time_progress, Wsego, lOk := .T., Sec_1, GetOptions Running(.T.) ********************************************** * LB_Warning(L('Данный режим на реконструкции') * RETURN NIL ********************************************** IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF ** Файл параметров работы интерфейса. Здесь для того, чтобы не зависило от приложения IF FILE(Disk_dir+"\_2_3_2_3.arx") // Файл параметров aParInt = DC_ARestore(Disk_dir+"\_2_3_2_3.arx") ELSE PRIVATE aParInt[10] AFILL(aParInt, 1) aParInt[ 7] = 3 aParInt[ 8] = 3 DC_ASave(aParInt, Disk_dir+"\_2_3_2_3.arx") DC_ASave(aParInt, "_2_3_2_3.arx") ENDIF ********************************************************************************************************************** // Диалог задания параметров работы интерфейса D = 46 // Ширина окна группы @ 1, 0 DCGROUP oGroup1 CAPTION L('Задайте параметры работы программного интерфейса:') SIZE 97,25.5 @ 1, 2 DCGROUP oGroup2 CAPTION L('Задайте тип файла исходных данных: "Inp_data":' ) SIZE D, 4.5 PARENT oGroup1 @ 1, 2 DCRADIO aParInt[1] VALUE 1 PROMPT L('XLS - MS Excel-2003' ) PARENT oGroup2 @ 2, 2 DCRADIO aParInt[1] VALUE 2 PROMPT L('XLSX- MS Excel-2007 (2010 и более поздние)') PARENT oGroup2 @ 3, 2 DCRADIO aParInt[1] VALUE 3 PROMPT L('DBF - DBASE IV (DBF/NTX)' ) PARENT oGroup2 @ 1,D+3 DCGROUP oGroup3 CAPTION L('Считать нули и пробелы отсутствием данных?') SIZE D, 4.5 PARENT oGroup1 @ 1, 2 DCRADIO aParInt[2] VALUE 1 PROMPT L('Да' ) PARENT oGroup3 @ 2, 2 DCRADIO aParInt[2] VALUE 2 PROMPT L('Нет') PARENT oGroup3 @ 1,D-12.25 DCPUSHBUTTON CAPTION L('Help') SIZE 10.1,2.8 PARENT oGroup3 ACTION {||Help2323()} FONT '10.Helv Bold' @ 6.0, 2 DCGROUP oGroup4 CAPTION L('Шкалы и градации в файле: "Inp_data.xls" (xlsx, dbf)') SIZE 93,9.5 PARENT oGroup1 @ 1.1, 2 DCSAY L('Задайте номер ПЕРВОЙ строки с классификационными шкалами (заголовок не нумеруется):' ) PARENT oGroup4 @ 1.0,79 DCSAY L(" ") GET aParInt[3] PICTURE "########" PARENT oGroup4 @ 2.1, 2 DCSAY L('Задайте номер ПОСЛЕДНЕЙ строки с классификационными шкалами (заголовок не нумеруется):') PARENT oGroup4 @ 2.0,79 DCSAY L(" ") GET aParInt[4] PICTURE "########" PARENT oGroup4 @ 4.1, 2 DCSAY L('Задайте номер ПЕРВОЙ строки с описательными шкалами (заголовок не нумеруется):' ) PARENT oGroup4 @ 4.0,79 DCSAY L(" ") GET aParInt[5] PICTURE "########" PARENT oGroup4 @ 5.1, 2 DCSAY L('Задайте номер ПОСЛЕДНЕЙ строки с описательными шкалами (заголовок не нумеруется):' ) PARENT oGroup4 @ 5.0,79 DCSAY L(" ") GET aParInt[6] PICTURE "########" PARENT oGroup4 @ 7.1, 2 DCSAY L('Задайте число градаций в числовой классификационной шкале:' ) PARENT oGroup4 @ 7.0,79 DCSAY L(" ") GET aParInt[7] PICTURE "########" PARENT oGroup4 @ 8.1, 2 DCSAY L('Задайте число градаций в числовой описательной шкале:' ) PARENT oGroup4 @ 8.0,79 DCSAY L(" ") GET aParInt[8] PICTURE "########" PARENT oGroup4 mNameGrNumSc = 1 D = 50;h = 0.25 @16.0, 2 DCGROUP oGroup5 CAPTION L('Какие наименования ГРАДАЦИЙ числовых шкал использовать:') SIZE 93, 4.5 PARENT oGroup1 @ 1 , 2 DCRADIO aParInt[10] VALUE 1 PROMPT L('Только интервальные числовые значения' ) PARENT oGroup5 SIZE 0 @ 1+h, D DCSAY L('("1/3-{59.000, 178.667}")') PARENT oGroup5 SIZE 0 @ 2 , 2 DCRADIO aParInt[10] VALUE 2 PROMPT L('Только наименования интервальных числовых значений' ) PARENT oGroup5 SIZE 0 @ 2+h, D DCSAY L('("Минимальное")') PARENT oGroup5 SIZE 0 @ 3 , 2 DCRADIO aParInt[10] VALUE 3 PROMPT L('И интервальные числовые значения, и их наименования' ) PARENT oGroup5 SIZE 0 @ 3+h, D DCSAY L('("Минимальное: 1/3-{59.000, 178.667}")') PARENT oGroup5 SIZE 0 @21,2 DCGROUP oGroup6 CAPTION L('Что формировать:') SIZE 93,3.5 PARENT oGroup1 @ 1,2 DCRADIO aParInt[9] VALUE 1 PROMPT L('Классификационные и описательные шкалы и градации и обучающую выборку') PARENT oGroup6 @ 2,2 DCRADIO aParInt[9] VALUE 2 PROMPT L('Только распознаваемую выборку в ранее созданной модели' ) PARENT oGroup6 DCREAD GUI ; TO lExit ; FIT ; OPTIONS GetOptions ; ADDBUTTONS; MODAL ; TITLE L('2.3.2.3. Импорт данных из транспонированных внешних баз данных') ********************************************************************************************************************** ******************************************************************** IF lExit ** Button Ok ELSE ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ******************************************************************** DC_ASave(aParInt, "_2_3_2_3.arx") // Запись заданых параметров ************************************************************************************************************* * aParInt[1] = 1 // XLS - MS Excel-2003 * aParInt[1] = 2 // XLSX- MS Excel-2007 (2010 и более поздние) * aParInt[1] = 3 // DBF - DBASE IV (DBF/NTX) * aParInt[2] = 1 // Считать нули и пробелы отсутствием данных * aParInt[2] = 2 // Не считать нули и пробелы отсутствием данных * aParInt[3] = номер ПЕРВОЙ строки с классификационными шкалами * aParInt[4] = номер ПОСЛЕДНЕЙ строки с классификационными шкалами * aParInt[5] = номер ПЕРВОЙ строки с описательными шкалами * aParInt[6] = номер ПОСЛЕДНЕЙ строки с описательными шкалами * aParInt[7] = число градаций в классификационной шкале * aParInt[8] = число градаций в описательной шкале * aParInt[9] = 1 // Формировать классификационные и описательные шкалы и градации и обучающую выборку * aParInt[9] = 2 // Формировать только распознаваемую выборку * aParInt[10]= 1 // Наменования ГРАДАЦИЙ числовых шкал - Только интервальные числовые значения * aParInt[10]= 2 // Наменования ГРАДАЦИЙ числовых шкал - Только наименования интервальных числовых значений * aParInt[10]= 3 // Наменования ГРАДАЦИЙ числовых шкал - И интервальные числовые значения, и их наименования ************************************************************************************************************* mNumClSc1 = aParInt[3] // Номер первой классификационной шкалы mNumClSc2 = aParInt[4] // Номер последней классификационной шкалы mNumOpSc1 = aParInt[5] // Номер первой описательной шкалы mNumOpSc2 = aParInt[6] // Номер последней описательной шкалы mNClSc = mNumClSc2 - mNumClSc1 + 1 // Кол-во классификационных шкал mNOpSc = mNumOpSc2 - mNumOpSc1 + 1 // Кол-во описательных шкал IF aParInt[9] = 1 // Формировать классификационные и описательные шкалы и градации и обучающую выборку ********** Создание нового пустого приложения ************************************ PUBLIC cExcelFile := 'Inp_data' PUBLIC cDbaseFile := cExcelFile // Создать новое пустое приложение * aSave_adds := DC_DataSave() // Сохранение вычислительной среды (открытые и текущие БД и индексы) DIRCHANGE(Disk_dir) ***** Создать новое пустое приложение или открыть ранее созданное в режиме 1.3 mNewAppl = ADD_ZAPPL('Приложение, созданное путем ввода даных из БД Inp_data.xls в режиме 2.3.2.3(). Это название надо скорректировать в режиме 1.3') // Создать основные БД нового приложения ********************************************** DIRCHANGE(mNewAppl) // Перейти в папку с БД новой модели и создать БД формализации предметной области: GenDbfClSc(.F.) // Классификационные шкалы GenDbfGrClSc(.F.) // Градации классификационных шкал GenDbfClass(.F.) // Классификационные шкалы и градации GenDbfOpSc(.F.) // Описательные шкалы GenDbfGrOpSc(.F.) // Градации описательных шкал GenDbfAttr(.F.) // Описательные шкалы и градации GenDbfObiZag() // Заголовки объектов обучающей выборки GenDbfObiKcl() // Коды классов объектов обучающей выборки GenDbfObiKpr() // Коды признаков объектов обучающей выборки GenDbfRsoZag() // Заголовки объектов распознаваемой выборки GenDbfRsoKcl() // Коды классов объектов распознаваемой выборки GenDbfRsoKpr() // Коды признаков объектов распознаваемой выборки *************************************************************************************** DC_ASave(aParInt, Disk_dir+"\_2_3_2_3.arx") // Запись файла параметров DC_ASave(aParInt, mNewAppl+"\_2_3_2_3.arx") ******** Скачивание xls - файла и преобразование его в dbf ************************************************************** ** XLS - имя файла базы исходных данных: Inp_data.XLS **************************** IF aParInt[1] = 1 // Определить, есть ли файлы в папке: AID_DATA/Inp_data DIRCHANGE(Disk_dir+"/AID_DATA/Inp_data/") IF .NOT. FILE("Inp_data.xls") Mess = L('В папке:')+' '+M_ApplsPath+L('\Inp_data\ должен быть файл: "Inp_data.xls"') LB_Warning(Mess) Help2323() // Пояснение о назначении режима ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF Flag_InpRasp = .T. IF .NOT. FILE("Inp_rasp.xls") Flag_InpRasp = .F. ENDIF DIRCHANGE(Disk_dir) // Скопировать в новое приложение файл: Inp_data.xls Name_SS = Disk_dir+"/AID_DATA/Inp_data/Inp_data.xls" Name_DD = mNewAppl +"/Inp_data.xls" COPY FILE (Name_SS) TO (Name_DD) *** ПРЕОБРАЗОВАНИЕ EXCEL-ФАЙЛА Inp_data.xls в БД: Inp_data.dbf *** и файл наименований классификационных и описательных шкал: Inp_name.txt cExcelFile = cExcelFile + '.xls' mFlag = LC_Excel2WorkArea( cExcelFile, mNewAppl ) IF .NOT. mFlag LB_Warning(L('Исправьте файл исходных данных !'), L('2.3.2.3. Импорт данных из транспонированных внешних баз данных' )) Help2323() // Пояснение о назначении режима ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF *** Убрать 1-ю строку в файле наименований классификационных и описательных шкал: Inp_name.txt * DC_ASave(aInp_name, "_Inp_name.arx") // Запись массива наименований шкал (колонок) в виде файла aInp_name = DC_ARestore("_Inp_name.arx") // Загрузка массива наименований шкал (колонок) из файла CrLf = CHR(13)+CHR(10) // Конец строки (абзаца) (CrLf) mInp_name = "" FOR j=3 TO LEN(aInp_name) mInp_name = mInp_name + aInp_name[j] + CrLf NEXT StrFile( mInp_name, mNewAppl +"/Inp_name.txt") // Добавить путь на папку Inp_data ENDIF ** XLSX - имя файла базы исходных данных: Inp_data.XLSX ************************** IF aParInt[1] = 2 // Определить, есть ли файлы в папке: AID_DATA/Inp_data DIRCHANGE(Disk_dir+"/AID_DATA/Inp_data/") IF .NOT. FILE("Inp_data.xlsx") Mess = L('В папке: '+Disk_dir+'\AID_DATA\Inp_data\'+' должен быть файл: "Inp_data.xlsx"') LB_Warning(Mess) Help2323() // Пояснение о назначении режима ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF Flag_InpRasp = .T. IF .NOT. FILE("Inp_rasp.xlsx") Flag_InpRasp = .F. ENDIF DIRCHANGE(Disk_dir) // Скопировать в новое приложение файл: Inp_data.xlsx Name_SS = Disk_dir+"/AID_DATA/Inp_data/Inp_data.xlsx" Name_DD = mNewAppl +"/Inp_data.xlsx" COPY FILE (Name_SS) TO (Name_DD) *** ПРЕОБРАЗОВАНИЕ EXCEL-ФАЙЛА Inp_data.xlsx в БД: Inp_data.dbf *** и файл наименований классификационных и описательных шкал: Inp_name.txt cExcelFile = cExcelFile + '.xlsx' mFlag = LC_Excel2WorkArea( cExcelFile, mNewAppl ) IF .NOT. mFlag LB_Warning(L('Исправьте файл исходных данных !'), L('2.3.2.3. Импорт данных из транспонированных внешних баз данных' )) Help2323() // Пояснение о назначении режима ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF *** Убрать 1-ю строку в файле наименований классификационных и описательных шкал: Inp_name.txt * DC_ASave(aInp_name, "_Inp_name.arx") // Запись массива наименований шкал (колонок) в виде файла aInp_name = DC_ARestore("_Inp_name.arx") // Загрузка массива наименований шкал (колонок) из файла CrLf = CHR(13)+CHR(10) // Конец строки (абзаца) (CrLf) mInp_name = "" FOR j=3 TO LEN(aInp_name) mInp_name = mInp_name + aInp_name[j] + CrLf NEXT StrFile( mInp_name, mNewAppl +"/Inp_name.txt") // Добавить путь на папку Inp_data ENDIF ** DBF - имя файла базы исходных данных: Inp_data.DBF ************************** IF aParInt[1] = 3 // Определить, есть ли файлы в папке: AID_DATA/Inp_data Flag_err = .F. DIRCHANGE(Disk_dir+"/AID_DATA/Inp_data/") IF .NOT. FILE("Inp_data.dbf") Mess = L('В папке:')+' '+Disk_dir+L('\AID_DATA\Inp_data\ должен быть файл: "Inp_data.dbf"') Flag_err = .T. ENDIF IF .NOT. FILE("Inp_name.txt") Mess = L('В папке:')+' '+Disk_dir+L('\AID_DATA\Inp_data\ должен быть файл: "Inp_name.txt"') Flag_err = .T. ENDIF IF Flag_err Mess = STRTRAN(Mess, "#", Disk_dir+"/AID_DATA/Inp_data/") LB_Warning(Mess) Help2323() // Пояснение о назначении режима ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF Flag_InpRasp = .T. IF .NOT. FILE("Inp_rasp.dbf") Flag_InpRasp = .F. ENDIF DIRCHANGE(Disk_dir) // Скопировать в новое приложение файл: Inp_data.dbf и Inp_name.txt Name_SS = Disk_dir+"/AID_DATA/Inp_data/Inp_data.dbf" Name_DD = mNewAppl +"/Inp_data.dbf" COPY FILE (Name_SS) TO (Name_DD) Name_SS = Disk_dir+"/AID_DATA/Inp_data/Inp_name.txt" Name_DD = mNewAppl +"/Inp_name.txt" COPY FILE (Name_SS) TO (Name_DD) ENDIF ******** Определение параметров файла ################################################################################################################## DIRCHANGE(mNewAppl) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Inp_data EXCLUSIVE NEW N_Obj = FCOUNT()-2 N_Rec = RECCOUNT() ************************* Проверки корректности параметров перобразования * mNumClSc1 = aParInt[3] // Номер первой классификационной шкалы * mNumClSc2 = aParInt[4] // Номер последней классификационной шкалы * mNumOpSc1 = aParInt[5] // Номер первой описательной шкалы * mNumOpSc2 = aParInt[6] // Номер последней описательной шкалы * mNClSc = mNumClSc2 - mNumClSc1 + 1 // Кол-во классификационных шкал * mNOpSc = mNumOpSc2 - mNumOpSc1 + 1 // Кол-во описательных шкал mFlagErr = .F. IF mNumClSc2 < mNumClSc1 LB_Warning(L("Номер последней классификационной шкалы должен быть не меньше номера первой!"),L('2.3.2.3. Импорт данных из транспонированных внешних баз данных')) mFlagErr = .T. ENDIF IF mNumOpSc2 < mNumOpSc1 LB_Warning(L("Номер последней описательной шкалы должен быть не меньше номера первой!"),L('2.3.2.3. Импорт данных из транспонированных внешних баз данных')) mFlagErr = .T. ENDIF IF RECCOUNT() < mNumClSc1 LB_Warning(L("Номер первой классификационной шкалы не должен быть больше числа записей в базе исходных данных!"),L('2.3.2.3. Импорт данных из транспонированных внешних баз данных')) mFlagErr = .T. ENDIF IF RECCOUNT() < mNumClSc2 LB_Warning(L("Номер последней классификационной шкалы не должен быть больше числа записей в базе исходных данных!"),L('2.3.2.3. Импорт данных из транспонированных внешних баз данных')) mFlagErr = .T. ENDIF IF RECCOUNT() < mNumOpSc1 LB_Warning(L("Номер первой описательной шкалы не должен быть больше числа записей в базе исходных данных!"),L('2.3.2.3. Импорт данных из транспонированных внешних баз данных')) mFlagErr = .T. ENDIF IF RECCOUNT() < mNumOpSc2 LB_Warning(L("Номер последней описательной шкалы не должен быть больше числа записей в базе исходных данных!"),L('2.3.2.3. Импорт данных из транспонированных внешних баз данных')) mFlagErr = .T. ENDIF IF mNClSc = 0 LB_Warning(L("Необходимо задать хотя бы одну классификационную шкалу!"),L('2.3.2.3. Импорт данных из транспонированных внешних баз данных')) mFlagErr = .T. ENDIF IF mNOpSc = 0 LB_Warning(L("Необходимо задать хотя бы одну описательную шкалу!"),L('2.3.2.3. Импорт данных из транспонированных внешних баз данных')) mFlagErr = .T. ENDIF ****** Теперь в режиме 2.3.2.3 в БД Inp_data.dbf допустимы только текстовые поля, а в числовые преобразовывать их по необходимости, если тип данных "N" SELECT Inp_data DO WHILE .NOT. EOF() .AND. .NOT. mFlagErr // Цикл по строкам классов БД Inp_data FOR jj = 3 TO FCOUNT() IF VALTYPE(FIELDGET(jj)) <> "C" // Не текстовое значение aMess := {} AADD(aMess, L('У объектов обучающей выборки есть нетекстовые показатели, что')) AADD(aMess, L('недопустимо. Исправьте файл исходных данных: "Inp_data.xls"')) LB_Warning(aMess,L('2.3.2.3. Импорт данных из транспонированных внешних баз данных')) mFlagErr = .T. ENDIF IF mFlagErr EXIT ENDIF NEXT DBSKIP(1) ENDDO IF mFlagErr ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF *MsgBox('STOP') ************************************************************** ***** Формирование класс.и опис.шкал и градаций и обуч.выборки *************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Inp_data EXCLUSIVE NEW N_Obj = FCOUNT()-2 // Число объектов обучающей выборки N_Rec = RECCOUNT() // Число шкал в объекте обучающей выборки *** Организация отображения стадии исполнения <===############################## НЕ СООТВЕТСТВУЕТ ВРЕМЯ И ДЛИНА ПРОГРЕСС-БАР nMax = N_Rec +(aParInt[4]-aParInt[3]+1)+(aParInt[6]-aParInt[5]+1) +N_Obj+; ((aParInt[4]-aParInt[3]+1)+(aParInt[6]-aParInt[5]+1))*N_Obj Mess = L('2.3.2.3. Импорт данных из внешних баз данных') @ 4,5 DCPROGRESS oProgress SIZE 75,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 DCREAD GUI TITLE Mess PARENT @oDialog FIT EXIT oDialog:show() nTime = 0 DC_GetProgress(oProgress,0,nMax) ******* Поиск Min и Max ДЛЯ ВСЕХ числовых класс.и опис.шкалах и создание БД EventsKO.dbf PRIVATE aMinSH[N_Rec], aMaxSH[N_Rec], aNameGrChrSc[N_Rec] // Тоже формировать и потом использовать AFILL(aMinSH, +999999999) AFILL(aMaxSH, -999999999) mMaxlenNameSc = 35 aNameScale := {} // Массив наименований шкал aTypeScale := {} // Массив типов данных в шкалах SELECT Inp_data *SET FILTER TO SUBSTR(ALLTRIM(FIELDNAME(1)),1,12) = 'SPECTRINTERV' // Если файл Inp_data содержит результаты спектрального анализа, то N_SpectrInterv > 0 ** 123456789012 *COUNT TO N_SpectrInterv *SET FILTER TO *** Диапазон классификационных шкал FOR ff = aParInt[3] TO aParInt[4] // Цикл по строкам классов БД Inp_data DBGOTO(ff) mNameScale = ALLTRIM(FIELDGET(1)) mTypeScale = ALLTRIM(FIELDGET(2)) AADD(aNameScale, mNameScale) AADD(aTypeScale, mTypeScale) mMaxlenNameSc = MAX(mMaxlenNameSc, LEN(mNameScale)) // ############################################# преобразовывать типы данных IF FIELDGET(2) = "N" // ЧИСЛОВАЯ ШКАЛА DO CASE CASE aParInt[2] = 1 // Считать нули и пробелы отсутствием данных = 1 FOR cc=3 TO FCOUNT() Fv = VAL(FIELDGET(cc)) // Обработать числа с десятичной точкой и запятой ################ IF Fv <> 0 aMinSH[ff] = MIN(aMinSH[ff], Fv) aMaxSH[ff] = MAX(aMaxSH[ff], Fv) ENDIF NEXT CASE aParInt[2] = 2 // Не считать нули и пробелы отсутствием данных = 2 FOR cc=3 TO FCOUNT() Fv = VAL(FIELDGET(cc)) // Обработать числа с десятичной точкой и запятой ################ aMinSH[ff] = MIN(aMinSH[ff], Fv) aMaxSH[ff] = MAX(aMaxSH[ff], Fv) NEXT ENDCASE ENDIF IF FIELDGET(2) = "C" // ТЕКСТОВАЯ ШКАЛА * ************ Уникальные значения градаций текстовой шкалы * aNameGrChrSc := {} * FOR j=3 TO FCOUNT() * mFv = FIELDGET(j) * Fv = IF(VALTYPE(mFv)="N", ALLTRIM(STR(mFv)), ALLTRIM(mFv)) * IF ASCAN(aNameGrChrSc, Fv) = 0 * AADD (aNameGrChrSc, Fv ) * ENDIF * NEXT * ASORT(aNameGrChrSc) * N_Grad = LEN(aNameGrChrSc) * aNameGrChrSc[ff] = aGrTxtScale // Присвоить элементу одного массива значение другого массива в целом, а если не выйдет - использовать memo ENDIF DC_GetProgress(oProgress, ++nTime, nMax) NEXT *DC_DebugQout( aNameGrChrSc ) *MsgBox('STOP') *** Диапазон описательных шкал FOR ff = aParInt[5] TO aParInt[6] // Цикл по строкам признаков БД Inp_data DBGOTO(ff) mNameScale = ALLTRIM(FIELDGET(1)) mTypeScale = ALLTRIM(FIELDGET(2)) AADD(aNameScale, mNameScale) AADD(aTypeScale, mTypeScale) mMaxlenNameSc = MAX(mMaxlenNameSc, LEN(mNameScale)) IF FIELDGET(2) = "N" // ЧИСЛОВАЯ ШКАЛА DO CASE CASE aParInt[2] = 1 // Считать нули и пробелы отсутствием данных = 1 FOR cc=3 TO FCOUNT() Fv = VAL(FIELDGET(cc)) IF Fv <> 0 aMinSH[ff] = MIN(aMinSH[ff], Fv) aMaxSH[ff] = MAX(aMaxSH[ff], Fv) * MsgBox('Строка='+ALLTRIM(STR(ff))+', Текстовое значение поля='+FIELDGET(cc)+', Числовое значение поля='+STR(VAL(FIELDGET(cc)))) ENDIF NEXT CASE aParInt[2] = 2 // Не считать нули и пробелы отсутствием данных = 2 FOR cc=3 TO FCOUNT() Fv = VAL(FIELDGET(cc)) aMinSH[ff] = MIN(aMinSH[ff], Fv) aMaxSH[ff] = MAX(aMaxSH[ff], Fv) * MsgBox('Строка='+ALLTRIM(STR(ff))+', Текстовое значение поля='+FIELDGET(cc)+', Числовое значение поля='+STR(VAL(FIELDGET(cc)))) NEXT ENDCASE ENDIF IF FIELDGET(2) = "C" // ТЕКСТОВАЯ ШКАЛА * ************ Уникальные значения градаций текстовой шкалы * aNameGrChrSc := {} * FOR j=3 TO FCOUNT() * mFv = FIELDGET(j) * Fv = IF(VALTYPE(mFv)="N", ALLTRIM(STR(mFv)), ALLTRIM(mFv)) * IF ASCAN(aNameGrChrSc, Fv) = 0 * AADD (aNameGrChrSc, Fv ) * ENDIF * NEXT * ASORT(aNameGrChrSc) * N_Grad = LEN(aNameGrChrSc) * aNameGrChrSc[ff] = aGrTxtScale // Наверное надо использовать Memo, как в Image.dbf ENDIF DC_GetProgress(oProgress, ++nTime, nMax) NEXT *DC_DebugQout( aMinSH ) *DC_DebugQout( aMaxSH ) DC_ASave(aMinSH, "_MinSH2323.arx") // Запись минимальных и максимальных значений числовых шкал DC_ASave(aMaxSH, "_MaxSH2323.arx") ***** Создать БД EventsKO.dbf CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Inp_data EXCLUSIVE NEW;N_Obj = FCOUNT()-2 ***** Создать БД: "EventsKO.dbf" ********* CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций cFileName := "EventsKO.dbf" // База событий для обучающей выборки aStructure := { { "ScaleName", "C", 35, 0 },; // Наименование шкалы { "Data_Type", "C", 1, 0 } } // Тип данных в шкале: N - числовой, С - символьный FOR j=1 TO N_Obj mFieldName = "Obj"+ALLTRIM(STR(j)) AADD(aStructure, { mFieldName, "C", 15, 0 } ) NEXT DbCreate( cFileName, aStructure ) ****************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Inp_data EXCLUSIVE NEW USE EventsKO EXCLUSIVE NEW;ZAP USE Class_Sc EXCLUSIVE NEW;ZAP USE Gr_ClSc EXCLUSIVE NEW;ZAP USE Classes EXCLUSIVE NEW;ZAP USE Opis_Sc EXCLUSIVE NEW;ZAP USE Gr_OpSc EXCLUSIVE NEW;ZAP USE Attributes EXCLUSIVE NEW;ZAP USE Obi_Zag EXCLUSIVE NEW;ZAP USE Obi_Kcl EXCLUSIVE NEW;ZAP USE Obi_Kpr EXCLUSIVE NEW;ZAP SELECT EventsKO FOR j = 1 TO LEN(aNameScale) APPEND BLANK REPLACE ScaleName WITH aNameScale[j] // Наименование шкалы REPLACE Data_Type WITH aTypeScale[j] // Тип данных в шкале: N - числовой, С - символьный NEXT ************************************************************************************************************* * aParInt[1] = 1 // XLS - MS Excel-2003 * aParInt[1] = 2 // XLSX- MS Excel-2007 (2010 и более поздние) * aParInt[1] = 3 // DBF - DBASE IV (DBF/NTX) * aParInt[2] = 1 // Считать нули и пробелы отсутствием данных * aParInt[2] = 2 // Не считать нули и пробелы отсутствием данных * aParInt[3] = номер ПЕРВОЙ строки с классификационными шкалами * aParInt[4] = номер ПОСЛЕДНЕЙ строки с классификационными шкалами * aParInt[5] = номер ПЕРВОЙ строки с описательными шкалами * aParInt[6] = номер ПОСЛЕДНЕЙ строки с описательными шкалами * aParInt[7] = число градаций в классификационной шкале * aParInt[8] = число градаций в описательной шкале * aParInt[9] = 1 // Формировать классификационные и описательные шкалы и градации и обучающую выборку * aParInt[9] = 2 // Формировать только распознаваемую выборку * aParInt[10]= 1 // Наменования ГРАДАЦИЙ числовых шкал - Только интервальные числовые значения * aParInt[10]= 2 // Наменования ГРАДАЦИЙ числовых шкал - Только наименования интервальных числовых значений * aParInt[10]= 3 // Наменования ГРАДАЦИЙ числовых шкал - И интервальные числовые значения, и их наименования ************************************************************************************************************* ******** Формирование класс.шкал и градаций **************************** <===################################ aNameCls := {} // Массив наименований классов M_KodClSc = 0 M_KodGrCS = 0 FOR ff = aParInt[3] TO aParInt[4] // Цикл по строкам классов БД Inp_data SELECT Inp_data DBGOTO(ff) M_NameSH = ALLTRIM(FIELDGET(1)) IF FIELDGET(2) = "N" // ЧИСЛОВАЯ ШКАЛА Delta = (aMaxSH[ff]-aMinSH[ff])/aParInt[7] IF Delta > 0 SELECT Class_Sc APPEND BLANK REPLACE Kod_ClSc WITH ++M_KodClSc REPLACE Name_ClSc WITH M_NameSH aNameGrNumSc = NameGrNumSc(aParInt[7]) FOR gr=1 TO aParInt[7] SELECT Gr_ClSc APPEND BLANK F_MinGR = aMinSH[ff]+(gr-1)*Delta // Границы интервала градации F_MaxGR = aMinSH[ff]+(gr )*Delta // Какие наименования ГРАДАЦИЙ числовых шкал использовать DO CASE CASE aParInt[10] = 1 // Только интервальные числовые значения M_NameGr = ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(aParInt[7],19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" CASE aParInt[10] = 2 // Только наименования интервальных числовых значений M_NameGr = aNameGrNumSc[gr] CASE aParInt[10] = 3 // И интервальные числовые значения, и их наименования M_NameGr = aNameGrNumSc[gr]+": "+; ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(aParInt[7],19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" ENDCASE REPLACE Kod_ClSc WITH M_KodClSc REPLACE Kod_GrCS WITH ++M_KodGrCS REPLACE Name_GrCS WITH M_NameGr // Сформировать БД Classes M_Name = M_NameSH + "-" + M_NameGr M_Name = DelZeroNameGr(M_Name) AADD(aNameCls, M_Name) // Массив наименований классов SELECT Classes // Имя БЗ брать из переменной APPEND BLANK REPLACE Kod_cls WITH M_KodGrCS REPLACE Name_cls WITH M_Name REPLACE Kod_ClSc WITH M_KodClSc // Код класс.шкалы REPLACE N_ChrClSc WITH LEN(ALLTRIM(M_NameSH)) // Кол-во символов в наим.класс.шкалы REPLACE Min_GrInt WITH F_MinGR // Минимальная граница интервала REPLACE Max_GrInt WITH F_MaxGR // Максимальная граница интервала REPLACE Avr_GrInt WITH F_MinGR+(F_MaxGR-F_MinGR)/2 // Среднее значение интервала NEXT ENDIF ELSE // ТЕКСТОВАЯ ШКАЛА ************ Уникальные значения градаций текстовой шкалы aNameGrChrSc := {} FOR j=3 TO FCOUNT() mFv = FIELDGET(j) Fv = IF(VALTYPE(mFv)="N", ALLTRIM(STR(mFv)), ALLTRIM(mFv)) IF LEN(Fv) > 0 // Если имя класса состоит из одних пробелов, то не создавать такого класса IF ASCAN(aNameGrChrSc, Fv) = 0 AADD (aNameGrChrSc, Fv ) ENDIF ENDIF NEXT * // Что-то как-то не так сортирует, наверное из-за того, что русский язык ############ * DC_DebugQout( aNameGrChrSc ) * FOR j=1 TO LEN(aNameGrChrSc) * aNameGrChrSc[j] = ConvToAnsiCP(aNameGrChrSc[j]) * NEXT * ASORT(aNameGrChrSc) // Теперь сортирует правильно, но не ищет и не кодирует обуч.выборку * FOR j=1 TO LEN(aNameGrChrSc) * aNameGrChrSc[j] = ConvToOemCP(aNameGrChrSc[j]) * NEXT * DC_DebugQout( aNameGrChrSc ) N_Grad = LEN(aNameGrChrSc) IF N_Grad > 1 SELECT Class_Sc APPEND BLANK REPLACE Kod_ClSc WITH ++M_KodClSc REPLACE Name_ClSc WITH M_NameSH FOR gr=1 TO N_Grad // Здесь делать для текстовых шкал SELECT Gr_ClSc APPEND BLANK // Какие наименования ГРАДАЦИЙ числовых шкал использовать DO CASE CASE aParInt[10] = 1 // Только интервальные значения M_NameGr = ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(N_Grad))+"-{"+; aNameGrChrSc[gr]+"}" CASE aParInt[10] = 2 // Только наименования интервальных числовых значений M_NameGr = aNameGrChrSc[gr] CASE aParInt[10] = 3 // И интервальные значения, и их наименования M_NameGr = ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(N_Grad))+"-{"+; aNameGrChrSc[gr]+"}" ENDCASE REPLACE Kod_ClSc WITH M_KodClSc REPLACE Kod_GrCS WITH ++M_KodGrCS REPLACE Name_GrCS WITH M_NameGr // Сформировать БД Classes M_Name = M_NameSH + "-" + M_NameGr M_Name = DelZeroNameGr(M_Name) * MsgBox(M_Name) AADD(aNameCls, M_Name) // Массив наименований классов SELECT Classes // Имя БЗ брать из переменной APPEND BLANK REPLACE Kod_cls WITH M_KodGrCS REPLACE Name_cls WITH M_Name REPLACE Kod_ClSc WITH M_KodClSc // Код класс.шкалы REPLACE N_ChrClSc WITH LEN(ALLTRIM(M_NameSH)) // Кол-во символов в наим.класс.шкалы NEXT ENDIF ENDIF DC_GetProgress(oProgress, ++nTime, nMax) NEXT *MsgBox('STOP') ************************************************************************************************************* * aParInt[1] = 1 // XLS - MS Excel-2003 * aParInt[1] = 2 // XLSX- MS Excel-2007 (2010 и более поздние) * aParInt[1] = 3 // DBF - DBASE IV (DBF/NTX) * aParInt[2] = 1 // Считать нули и пробелы отсутствием данных * aParInt[2] = 2 // Не считать нули и пробелы отсутствием данных * aParInt[3] = номер ПЕРВОЙ строки с классификационными шкалами * aParInt[4] = номер ПОСЛЕДНЕЙ строки с классификационными шкалами * aParInt[5] = номер ПЕРВОЙ строки с описательными шкалами * aParInt[6] = номер ПОСЛЕДНЕЙ строки с описательными шкалами * aParInt[7] = число градаций в классификационной шкале * aParInt[8] = число градаций в описательной шкале * aParInt[9] = 1 // Формировать классификационные и описательные шкалы и градации и обучающую выборку * aParInt[9] = 2 // Формировать только распознаваемую выборку * aParInt[10]= 1 // Наменования ГРАДАЦИЙ числовых шкал - Только интервальные числовые значения * aParInt[10]= 2 // Наменования ГРАДАЦИЙ числовых шкал - Только наименования интервальных числовых значений * aParInt[10]= 3 // Наменования ГРАДАЦИЙ числовых шкал - И интервальные числовые значения, и их наименования ************************************************************************************************************* ******** Формирование описательных шкал и градаций *********************** aNameAtr := {} // Массив наименований признаков M_KodOpSc = 0 M_KodGrOS = 0 FOR ff = aParInt[5] TO aParInt[6] // Цикл по строкам признаков БД Inp_data SELECT Inp_data DBGOTO(ff) M_NameSH = ALLTRIM(FIELDGET(1)) IF FIELDGET(2) = "N" // ЧИСЛОВАЯ ШКАЛА * SpectrInterv: 999/999-{123,123,123} * 123456789012 R G B IF SUBSTR(M_NameSH,1,12) <> 'SPECTRINTERV' // Если не спектральный анализ изображений Delta = (aMaxSH[ff]-aMinSH[ff])/aParInt[8] IF Delta > 0 SELECT Opis_Sc APPEND BLANK REPLACE Kod_OpSc WITH ++M_KodOpSc REPLACE Name_OpSc WITH M_NameSH aNameGrNumSc = NameGrNumSc(aParInt[8]) // Это функция, возвражающее расшифровку наименований градаций FOR gr=1 TO aParInt[8] SELECT Gr_OpSc APPEND BLANK F_MinGR = aMinSH[ff]+(gr-1)*Delta F_MaxGR = aMinSH[ff]+(gr )*Delta // Какие наименования ГРАДАЦИЙ числовых шкал использовать DO CASE CASE aParInt[10] = 1 // Только интервальные числовые значения M_NameGr = ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(aParInt[8],19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" CASE aParInt[10] = 2 // Только наименования интервальных числовых значений M_NameGr = aNameGrNumSc[gr] CASE aParInt[10] = 3 // И интервальные числовые значения, и их наименования M_NameGr = aNameGrNumSc[gr]+": "+; ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(aParInt[8],19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" ENDCASE REPLACE Kod_OpSc WITH M_KodOpSc REPLACE Kod_GrOS WITH ++M_KodGrOS REPLACE Name_GrOS WITH M_NameGr // Сформировать БД Attributes M_Name = M_NameSH + "-" + M_NameGr M_Name = DelZeroNameGr(M_Name) AADD(aNameAtr, M_Name) // Массив наименований признаков SELECT Attributes // Имя БЗ брать из переменной APPEND BLANK REPLACE Kod_atr WITH M_KodGrOS REPLACE Name_atr WITH M_Name REPLACE Kod_OpSc WITH M_KodOpSc // Код класс.шкалы REPLACE N_ChrOpSc WITH LEN(ALLTRIM(M_NameSH)) // Кол-во символов в наим.опис.шкалы REPLACE Min_GrInt WITH F_MinGR // Минимальная граница интервала REPLACE Max_GrInt WITH F_MaxGR // Максимальная граница интервала REPLACE Avr_GrInt WITH F_MinGR+(F_MaxGR-F_MinGR)/2 // Среднее значение интервала NEXT ENDIF ENDIF // ************************************ IF SUBSTR(M_NameSH,1,12) = 'SPECTRINTERV' // Если спектральный анализ изображений // ************************************ SELECT Opis_Sc APPEND BLANK REPLACE Kod_OpSc WITH ++M_KodOpSc REPLACE Name_OpSc WITH 'SPECTRINTERV: ' SELECT Inp_data DO WHILE .NOT. EOF() .AND. SUBSTR(ALLTRIM(FIELDGET(1)),1,12) = 'SPECTRINTERV' * SpectrInterv: 999/999-{123,123,123} * 123456789012345 R G B * 123456789012345678901 * 10 21 * 12345678901234567890123456789012345 * 10 20 30 35 M_Name = ALLTRIM(FIELDGET(1)) mPos = AT(":",M_Name) M_NameGr = SUBSTR(M_Name,mPos+2,LEN(M_Name)-14) * MsgBox(M_NameGr) SELECT Gr_OpSc APPEND BLANK REPLACE Kod_OpSc WITH M_KodOpSc REPLACE Kod_GrOS WITH ++M_KodGrOS REPLACE Name_GrOS WITH DelZeroNameGr(M_NameGr) M_Name = DelZeroNameGr(M_Name) AADD(aNameAtr, M_Name) // Массив наименований признаков SELECT Attributes // Имя БЗ брать из переменной APPEND BLANK REPLACE Kod_atr WITH M_KodGrOS REPLACE Name_atr WITH M_Name REPLACE Kod_OpSc WITH M_KodOpSc // Код класс.шкалы REPLACE N_ChrOpSc WITH mPos // Кол-во символов в наим.опис.шкалы SELECT Inp_data DBSKIP(1) ff++ ENDDO DBGOTO(ff) ENDIF ELSE // ТЕКСТОВАЯ ШКАЛА ************ Уникальные значения градаций текстовой шкалы aNameGrChrSc := {} FOR j=3 TO FCOUNT() mFv = FIELDGET(j) Fv = IF(VALTYPE(mFv)="N", ALLTRIM(STR(mFv)), ALLTRIM(mFv)) IF ASCAN(aNameGrChrSc, Fv) = 0 AADD (aNameGrChrSc, Fv ) ENDIF NEXT * // Что-то как-то не так сортирует, наверное из-за того, что русский язык ############ * DC_DebugQout( aNameGrChrSc ) * FOR j=1 TO LEN(aNameGrChrSc) * aNameGrChrSc[j] = ConvToAnsiCP(aNameGrChrSc[j]) * NEXT * ASORT(aNameGrChrSc) // Тепероь сортирует правильно, но не ищет и не кодирует обуч.выборку * FOR j=1 TO LEN(aNameGrChrSc) * aNameGrChrSc[j] = ConvToOemCP(aNameGrChrSc[j]) * NEXT * DC_DebugQout( aNameGrChrSc ) N_Grad = LEN(aNameGrChrSc) IF N_Grad > 1 SELECT Opis_Sc APPEND BLANK REPLACE Kod_OpSc WITH ++M_KodOpSc REPLACE Name_OpSc WITH M_NameSH FOR gr=1 TO N_Grad // Здесь делать для текстовых шкал SELECT Gr_OpSc APPEND BLANK // Какие наименования ГРАДАЦИЙ числовых шкал использовать DO CASE CASE aParInt[10] = 1 // Только интервальные значения M_NameGr = ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(N_Grad))+"-{"+; aNameGrChrSc[gr]+"}" CASE aParInt[10] = 2 // Только наименования интервальных числовых значений M_NameGr = aNameGrChrSc[gr] CASE aParInt[10] = 3 // И интервальные значения, и их наименования M_NameGr = ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(N_Grad))+"-{"+; aNameGrChrSc[gr]+"}" ENDCASE REPLACE Kod_OpSc WITH M_KodOpSc REPLACE Kod_GrOS WITH ++M_KodGrOS REPLACE Name_GrOS WITH DelZeroNameGr(M_NameGr) // Сформировать БД Attributes M_Name = M_NameSH + "-" + M_NameGr M_Name = DelZeroNameGr(M_Name) AADD(aNameAtr, M_Name) // Массив наименований классов SELECT Attributes // Имя БЗ брать из переменной APPEND BLANK REPLACE Kod_atr WITH M_KodGrOS REPLACE Name_atr WITH M_Name REPLACE Kod_OpSc WITH M_KodOpSc // Код класс.шкалы REPLACE N_ChrOpSc WITH LEN(ALLTRIM(M_NameSH)) // Кол-во символов в наим.класс.шкалы NEXT ENDIF ENDIF DC_GetProgress(oProgress, ++nTime, nMax) NEXT *MsgBox('STOP') ************************************************************************************************************* * aParInt[1] = 1 // XLS - MS Excel-2003 * aParInt[1] = 2 // XLSX- MS Excel-2007 (2010 и более поздние) * aParInt[1] = 3 // DBF - DBASE IV (DBF/NTX) * aParInt[2] = 1 // Считать нули и пробелы отсутствием данных * aParInt[2] = 2 // Не считать нули и пробелы отсутствием данных * aParInt[3] = номер ПЕРВОЙ строки с классификационными шкалами * aParInt[4] = номер ПОСЛЕДНЕЙ строки с классификационными шкалами * aParInt[5] = номер ПЕРВОЙ строки с описательными шкалами * aParInt[6] = номер ПОСЛЕДНЕЙ строки с описательными шкалами * aParInt[7] = число градаций в классификационной шкале * aParInt[8] = число градаций в описательной шкале * aParInt[9] = 1 // Формировать классификационные и описательные шкалы и градации и обучающую выборку * aParInt[9] = 2 // Формировать только распознаваемую выборку * aParInt[10]= 1 // Наменования ГРАДАЦИЙ числовых шкал - Только интервальные числовые значения * aParInt[10]= 2 // Наменования ГРАДАЦИЙ числовых шкал - Только наименования интервальных числовых значений * aParInt[10]= 3 // Наменования ГРАДАЦИЙ числовых шкал - И интервальные числовые значения, и их наименования ************************************************************************************************************* **** Генерация базы событий и обучающей выборки SELECT Inp_data ********* Загрузить файл Inp_name.txt и сформировать массив: A_FNRus M_InpName = ALLTRIM(FILESTR('Inp_name.txt')) // Загрузка Inp_name.txt CrLf = CHR(13)+CHR(10) // Конец строки (абзаца) (CrLf) *M_InpName = " " + CrLf + STRTRAN(M_InpName,CHR(26),"") + CrLf *LB_Warning(M_InpName) A_FNRus := {} FOR ff=1 TO NUMTOKEN(M_InpName, CrLf) AADD(A_FNRus, TOKEN(M_InpName, CrLf, ff)) NEXT IF LEN(A_FNRus) <> N_Obj aMess := {} AADD(aMess, L('В "Inp_name.txt" должно быть столько же колонок с данными, сколько объектов обучающей выборки в "Inp_data.xls"')) AADD(aMess, L('Фактически же в "Inp_name.txt" (#) строк, а в "Inp_data.dbf" ($) объектов обучающей выборки"')) AADD(aMess, L('Возможно нет наименований некоторых колонок в файле исходных данных: "Inp_data.xls"')) aMess[2] = STRTRAN(aMess[2],"#", ALLTRIM(STR(LEN(A_FNRus),9))) aMess[2] = STRTRAN(aMess[2],"$", ALLTRIM(STR(N_Obj,9))) LB_Warning(aMess) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF M_KodIst = 0 FOR mObj = 1 TO N_Obj // ЦИКЛ ПО ОБЪЕКТАМ ОБУЧАЮЩЕЙ ВЫБОРКИ ************************ aKodCls := {} // Массив кодов классов текущего объекта aKodAtr := {} // Массив кодов признаков текущего объекта aRecCls := {} // Массив номеров записей для кодов классов текущего объекта aRecAtr := {} // Массив номеров записей для кодов признаков текущего объекта SELECT Inp_data M_NameIst = ALLTRIM(A_FNRus[mObj]) // Брать из Inp_name.txt FOR ff = aParInt[3] TO aParInt[4] // Цикл по строкам классов БД Inp_data SELECT Inp_data DBGOTO(ff) M_NameSH = ALLTRIM(FIELDGET(1)) IF FIELDGET(2) = "N" // ЧИСЛОВАЯ ШКАЛА Delta = (aMaxSH[ff]-aMinSH[ff])/aParInt[7] IF Delta > 0 Fv = VAL(FIELDGET(2+mObj)) aNameGrNumSc = NameGrNumSc(aParInt[7]) // Массив наименований градаций числовых шкал FOR gr=1 TO aParInt[7] F_MinGR = aMinSH[ff]+(gr-1)*Delta F_MaxGR = aMinSH[ff]+(gr )*Delta IF F_MinGR <= Fv .AND. Fv <= F_MaxGR // Какие наименования ГРАДАЦИЙ числовых шкал использовать DO CASE CASE aParInt[10] = 1 // Только интервальные числовые значения M_NameGr = ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(aParInt[7],19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" CASE aParInt[10] = 2 // Только наименования интервальных числовых значений M_NameGr = aNameGrNumSc[gr] CASE aParInt[10] = 3 // И интервальные числовые значения, и их наименования M_NameGr = aNameGrNumSc[gr]+": "+; ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(aParInt[7],19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" ENDCASE M_Name = M_NameSH + "-" + M_NameGr M_KodCls = ASCAN(aNameCls, M_Name) IF M_KodCls > 0 AADD(aKodCls, M_KodCls) AADD(aRecCls, ff) ENDIF EXIT // Исключить повторное кодирование того же значения в следующем интервале ENDIF NEXT ENDIF ELSE // ТЕКСТОВАЯ ШКАЛА ################################################################## ************ Уникальные значения градаций текстовой шкалы aNameGrChrSc := {} FOR j=3 TO FCOUNT() mFv = FIELDGET(j) Fv = IF(VALTYPE(mFv)="N", ALLTRIM(STR(mFv)), ALLTRIM(mFv)) IF LEN(Fv) > 0 IF ASCAN(aNameGrChrSc, Fv) = 0 AADD (aNameGrChrSc, Fv ) ENDIF ENDIF NEXT * // Что-то как-то не так сортирует, наверное из-за того, что русский язык ############ * DC_DebugQout( aNameGrChrSc ) * FOR j=1 TO LEN(aNameGrChrSc) * aNameGrChrSc[j] = ConvToAnsiCP(aNameGrChrSc[j]) * NEXT * ASORT(aNameGrChrSc) // Тепероь сортирует правильно, но не ищет и не кодирует обуч.выборку * FOR j=1 TO LEN(aNameGrChrSc) * aNameGrChrSc[j] = ConvToOemCP(aNameGrChrSc[j]) * NEXT * DC_DebugQout( aNameGrChrSc ) N_Grad = LEN(aNameGrChrSc) IF N_Grad > 1 Fv = ALLTRIM(FIELDGET(2+mObj)) gr = ASCAN(aNameGrChrSc, Fv) * MsgBox(Fv+str(gr)) IF LEN(Fv) > 0 IF gr > 0 // Какие наименования ГРАДАЦИЙ числовых шкал использовать DO CASE CASE aParInt[10] = 1 // Только интервальные значения M_NameGr = ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(N_Grad))+"-{"+; aNameGrChrSc[gr]+"}" CASE aParInt[10] = 2 // Только наименования интервальных числовых значений M_NameGr = aNameGrChrSc[gr] CASE aParInt[10] = 3 // И интервальные значения, и их наименования M_NameGr = ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(N_Grad))+"-{"+; aNameGrChrSc[gr]+"}" ENDCASE M_Name = M_NameSH + "-" + M_NameGr M_KodCls = ASCAN(aNameCls, M_Name) * MsgBox(M_Name) * LB_Warning(aKodCls, '(C°) Система "Эйдос-Х++"') IF M_KodCls > 0 AADD(aKodCls, M_KodCls) AADD(aRecCls, ff) ENDIF ENDIF ENDIF ENDIF ENDIF DC_GetProgress(oProgress, ++nTime, nMax) NEXT FOR ff = aParInt[5] TO aParInt[6] // Цикл по строкам признаков БД Inp_data SELECT Inp_data DBGOTO(ff) M_NameSH = ALLTRIM(FIELDGET(1)) IF FIELDGET(2) = "N" // ЧИСЛОВАЯ ШКАЛА // ************************************ IF SUBSTR(M_NameSH,1,12) <> 'SPECTRINTERV' // Если не спектральный анализ изображений ЭТО ДЕЛАТЬ ТОЛЬКО ПО ПРИЗНАКАМ ############### // ************************************ Delta = (aMaxSH[ff]-aMinSH[ff])/aParInt[8] IF Delta > 0 Fv = VAL(FIELDGET(2+mObj)) aNameGrNumSc = NameGrNumSc(aParInt[8]) // Массив наименований градаций числовых шкал FOR gr=1 TO aParInt[7] F_MinGR = aMinSH[ff]+(gr-1)*Delta F_MaxGR = aMinSH[ff]+(gr )*Delta IF F_MinGR <= Fv .AND. Fv <= F_MaxGR // Неверный тип данных // Какие наименования ГРАДАЦИЙ числовых шкал использовать DO CASE CASE aParInt[10] = 1 // Только интервальные числовые значения M_NameGr = ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(aParInt[7],19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" CASE aParInt[10] = 2 // Только наименования интервальных числовых значений M_NameGr = aNameGrNumSc[gr] CASE aParInt[10] = 3 // И интервальные числовые значения, и их наименования M_NameGr = aNameGrNumSc[gr]+": "+; ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(aParInt[7],19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" ENDCASE M_Name = M_NameSH + "-" + M_NameGr M_KodAtr = ASCAN(aNameAtr, M_Name) IF M_KodAtr > 0 AADD(aKodAtr, M_KodAtr) AADD(aRecAtr, ff) ENDIF EXIT // Исключить повторное кодирование того же значения в следующем интервале ENDIF NEXT ENDIF ENDIF // ************************************ IF SUBSTR(M_NameSH,1,12) = 'SPECTRINTERV' // Если спектральный анализ изображений // ************************************ // Сформировать такие описания объектов обучающей выборки, которые дают частотное распределение в ABS, как в Inp_data.dbf * 10 DO WHILE .NOT. EOF() .AND. SUBSTR(ALLTRIM(FIELDGET(1)),1,12) = 'SPECTRINTERV' M_Name = ALLTRIM(FIELDGET(1)) Fv = ROUND(VAL(FIELDGET(2+mObj)) * 10,0) // В цикле сделать столько кодов каждого цвета, сколько его доля в изображении в % * 10 M_KodAtr = ASCAN(aNameAtr, M_Name) IF M_KodAtr > 0 FOR j=1 TO Fv AADD(aKodAtr, M_KodAtr) AADD(aRecAtr, ff) NEXT ENDIF DBSKIP(1) ff++ ENDDO DBGOTO(ff) ENDIF ELSE // ТЕКСТОВАЯ ШКАЛА ################################################################## ************ Уникальные значения градаций текстовой шкалы aNameGrChrSc := {} FOR j=3 TO FCOUNT() mFv = FIELDGET(j) Fv = IF(VALTYPE(mFv)="N", ALLTRIM(STR(mFv)), ALLTRIM(mFv)) IF ASCAN(aNameGrChrSc, Fv) = 0 AADD (aNameGrChrSc, Fv ) ENDIF NEXT * // Что-то как-то не так сортирует, наверное из-за того, что русский язык ############ * DC_DebugQout( aNameGrChrSc ) * FOR j=1 TO LEN(aNameGrChrSc) * aNameGrChrSc[j] = ConvToAnsiCP(aNameGrChrSc[j]) * NEXT * ASORT(aNameGrChrSc) // Тепероь сортирует правильно, но не ищет и не кодирует обуч.выборку * FOR j=1 TO LEN(aNameGrChrSc) * aNameGrChrSc[j] = ConvToOemCP(aNameGrChrSc[j]) * NEXT * DC_DebugQout( aNameGrChrSc ) N_Grad = LEN(aNameGrChrSc) * DC_DebugQout(N_Grad, aNameGrChrSc ) IF N_Grad > 1 Fv = ALLTRIM(FIELDGET(2+mObj)) gr = ASCAN(aNameGrChrSc, Fv) * MsgBox(Fv+str(gr)) IF gr > 0 // Какие наименования ГРАДАЦИЙ текстовых шкал использовать DO CASE CASE aParInt[10] = 1 // Только интервальные значения M_NameGr = ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(N_Grad))+"-{"+; aNameGrChrSc[gr]+"}" CASE aParInt[10] = 2 // Только наименования интервальных числовых значений M_NameGr = aNameGrChrSc[gr] CASE aParInt[10] = 3 // И интервальные значения, и их наименования M_NameGr = ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(N_Grad))+"-{"+; aNameGrChrSc[gr]+"}" ENDCASE M_Name = M_NameSH + "-" + M_NameGr M_KodAtr = ASCAN(aNameAtr, M_Name) IF M_KodAtr > 0 AADD(aKodAtr, M_KodAtr) AADD(aRecAtr, ff) ENDIF ENDIF ENDIF ENDIF DC_GetProgress(oProgress, ++nTime, nMax) NEXT ****** Запись базы событий EventsKO.dbf SELECT EventsKO FOR ff = 1 TO LEN(aRecCls) // Цикл по строкам классов БД Inp_data DBGOTO(aRecCls[ff]) FIELDPUT(2+mObj, ALLTRIM(STR(aKodCls[ff]))) NEXT FOR ff = 1 TO LEN(aRecAtr) // Цикл по строкам признаков БД Inp_data DBGOTO(aRecAtr[ff]) FIELDPUT(2+mObj, ALLTRIM(STR(aKodAtr[ff]))) NEXT ****** Запись обучающей выборки SELECT Obi_Zag APPEND BLANK REPLACE Kod_obj WITH mObj REPLACE Name_obj WITH M_NameIst REPLACE Date WITH DTOC(DATE()) REPLACE Time WITH TIME() *** Занести массив кодов классов в БД ObI_Kcl * LB_Warning(aKodCls, '(C°) Система "Эйдос-Х++"') SELECT Obi_Kcl APPEND BLANK REPLACE Kod_Obj WITH mObj IF LEN(aKodCls) > 0 k=1 FOR j=1 TO LEN(aKodCls) IF k <= 4 FIELDPUT(1+k++,aKodCls[j]) ELSE k=1 APPEND BLANK REPLACE Kod_Obj WITH mObj FIELDPUT(1+k++,aKodCls[j]) ENDIF NEXT ENDIF *** Занести массив кодов признаков в БД ObI_Kpr SELECT Obi_Kpr APPEND BLANK REPLACE Kod_Obj WITH mObj IF LEN(aKodAtr) > 0 k=1 FOR j=1 TO LEN(aKodAtr) IF k <= 7 FIELDPUT(1+k++,aKodAtr[j]) ELSE k=1 APPEND BLANK REPLACE Kod_Obj WITH mObj FIELDPUT(1+k++,aKodAtr[j]) ENDIF NEXT ENDIF DC_GetProgress(oProgress, ++nTime, nMax) NEXT // Конец цикла по объектам обучающей выборки ***************************************** ****** Запись всех массивов, необходимых для работы режима формирования распознаваемой выборки DC_ASave(aParInt, "_2_3_2_3.arx") DC_ASave(aNameScale, "_aNmSc2323.arx") DC_ASave(aNameCls, "_NameCls2323.arx") DC_ASave(aNameAtr, "_NameAtr2323.arx") DC_ASave(aMinSH, "_MinSH2323.arx") DC_ASave(aMaxSH, "_MaxSH2323.arx") DC_ASave(A_FNRus, "_FNRus2323.arx") aInp_name := {} FOR j=1 TO LEN(A_FNRus) AADD(aInp_name, A_FNRus[j]) NEXT *aInp_name = DC_ARestore("_Inp_name.arx") // Загрузка массива наименований колонок из файла DC_ASave(aInp_name, "_Inp_name.arx") // Запись массива наименований колонок в виде файла *MsgBox('STOP') DC_GetProgress(oProgress,nMax,nMax) oDialog:Destroy() ************************************************************************ DC_ASave(aParInt, Disk_dir+"\_2_3_2_3.arx") // Запись файла параметров DC_ASave(aParInt, mNewAppl+"\_2_3_2_3.arx") DC_ASave(aParInt, Disk_dir+'\AID_DATA\Inp_data\_2_3_2_3.arx') // Информация о типе используемого API для интеллектуальных облачных Эйдос-приложений, чтобы при их загрузке сразу запускать нужный API StrFile('API_type=2.3.2.3.', Disk_dir+'\AID_DATA\Inp_data\API_type.txt') ************************************************************************ Mess = L(" ПРОЦЕСС ФОРМАЛИЗАЦИИ ПРЕДМЕТНОЙ ОБЛАСТИ ЗАВЕРШЕН УСПЕШНО !!! ") LB_Warning(Mess,L('2.3.2.3. Импорт данных из транспонированных внешних баз данных')) *aInp_name = DC_ARestore("_Inp_name.arx") // Загрузка массива наименований шкал (колонок) из файла DC_ASave(aInp_name, "_Inp_name.arx") // Запись массива наименований шкал (колонок) в виде файла ENDIF // Конец режима: aParInt[9] = 1 // Формировать классификационные и описательные шкалы и градации и обучающую выборку **************************************************************************************************************************** IF aParInt[9] = 2 // Формировать только распознаваемую выборку // ######################################################### DC_ASave(aParInt, Disk_dir+"\_2_3_2_3.arx") // Запись файла параметров DC_ASave(aParInt, M_PathAppl+"\_2_3_2_3.arx") ******** Скачивание xls - файла и преобразование его в dbf ************************************************************** ** XLS - имя файла базы исходных данных: Inp_rasp.XLS **************************** IF aParInt[1] = 1 // Определить, есть ли файлы в папке: AID_DATA/Inp_data DIRCHANGE(Disk_dir+"/AID_DATA/Inp_data/") * MsgBox(Disk_dir+"/AID_DATA/Inp_data/") IF .NOT. FILE("Inp_rasp.xls") Mess = L('В папке:')+' '+Disk_dir+L('\AID_DATA\Inp_data\ должен быть файл: "Inp_rasp.xls"') LB_Warning(Mess) Help2323() // Пояснение о назначении режима ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF DIRCHANGE(Disk_dir) // Скопировать в новое приложение файл: Inp_rasp.xls Name_SS = Disk_dir+"/AID_DATA/Inp_data/Inp_rasp.xls" Name_DD = M_PathAppl +"/Inp_rasp.xls" COPY FILE (Name_SS) TO (Name_DD) *** ПРЕОБРАЗОВАНИЕ EXCEL-ФАЙЛА Inp_data.xls в БД: Inp_rasp.dbf *** и файл наименований классификационных и описательных шкал: Inp_name.txt cExcelFile = 'Inp_rasp.xls' mFlag = LC_Excel2WorkArea( cExcelFile, M_PathAppl ) IF .NOT. mFlag LB_Warning(L('Исправьте файл исходных данных !'), L('2.3.2.3. Импорт данных из транспонированных внешних баз данных' )) Help2323() // Пояснение о назначении режима ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ENDIF ** XLSX - имя файла базы исходных данных: Inp_rasp.XLSX ************************** IF aParInt[1] = 2 // Определить, есть ли файлы в папке: AID_DATA/Inp_data DIRCHANGE(Disk_dir+"/AID_DATA/Inp_data/") IF .NOT. FILE("Inp_rasp.xlsx") Mess = L('В папке:')+' '+Disk_dir+L('\AID_DATA\Inp_data\ должен быть файл: "Inp_rasp.xlsx"') // <<<===############ НЕ ОБНАРУЖИВАЕТСЯ LB_Warning(Mess) Help2323() // Пояснение о назначении режима ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF DIRCHANGE(Disk_dir) // Скопировать в новое приложение файл: Inp_rasp.xlsx Name_SS = Disk_dir+"/AID_DATA/Inp_data/Inp_rasp.xlsx" Name_DD = M_PathAppl +"/Inp_rasp.xlsx" COPY FILE (Name_SS) TO (Name_DD) *** ПРЕОБРАЗОВАНИЕ EXCEL-ФАЙЛА Inp_rasp.xlsx в БД: Inp_rasp.dbf *** и файл наименований классификационных и описательных шкал: Inp_name.txt cExcelFile = 'Inp_rasp.xlsx' mFlag = LC_Excel2WorkArea( cExcelFile, M_PathAppl ) IF .NOT. mFlag LB_Warning(L('Исправьте файл исходных данных !'), L('2.3.2.3. Импорт данных из транспонированных внешних баз данных' )) Help2323() // Пояснение о назначении режима ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ENDIF ** DBF - имя файла базы исходных данных: Inp_rasp.dbf ************************** IF aParInt[1] = 3 // Определить, есть ли файлы в папке: AID_DATA/Inp_data Flag_err = .F. DIRCHANGE(Disk_dir+"/AID_DATA/Inp_data/") IF .NOT. FILE("Inp_rasp.dbf") Mess = L('В папке:')+' '+Disk_dir+L('\AID_DATA\Inp_data\ должен быть файл: "Inp_rasp.dbf"') Flag_err = .T. ENDIF IF .NOT. FILE("Inp_name.txt") Mess = L('В папке:')+' '+Disk_dir+L('\AID_DATA\Inp_data\ должен быть файл: "Inp_name.txt"') Flag_err = .T. ENDIF IF Flag_err LB_Warning(Mess) Help2323() // Пояснение о назначении режима ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF // Скопировать в новое приложение файл: Inp_rasp.dbf Name_SS = Disk_dir+"/AID_DATA/Inp_data/Inp_rasp.dbf" Name_DD = M_PathAppl +"/Inp_rasp.dbf" COPY FILE (Name_SS) TO (Name_DD) Name_SS = Disk_dir+"/AID_DATA/Inp_data/Inp_name.txt" Name_DD = M_PathAppl +"/Inp_name.txt" COPY FILE (Name_SS) TO (Name_DD) ENDIF DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения ******* Загрузить все массивы, необходимые для работы режима формирования распознаваемой выборки IF FILE("_2_3_2_3.arx") .AND.; FILE("EventsKO.dbf") .AND.; FILE("_aNmSc2323.arx") .AND.; FILE("_NameCls2323.arx") .AND.; FILE("_NameAtr2323.arx") .AND.; FILE("_MinSH2323.arx") .AND.; FILE("_MaxSH2323.arx") .AND.; FILE("_FNRus2323.arx") aParInt = DC_ARestore("_2_3_2_3.arx") aNameScale = DC_ARestore("_aNmSc2323.arx") aNameCls = DC_ARestore("_NameCls2323.arx") aNameAtr = DC_ARestore("_NameAtr2323.arx") aMinSH = DC_ARestore("_MinSH2323.arx") aMaxSH = DC_ARestore("_MaxSH2323.arx") A_FNRus = DC_ARestore("_FNRus2323.arx") ELSE aMess := {} AADD(aMess, L("Нет классификационных и описательных шкал и градаций и обучающей выборки.")) AADD(aMess, L("Необходимо их создать перед формированием распознаваемой выборки.")) LB_Warning(aMess, L('2.3.2.3. Импорт данных из транспонированных внешних баз данных')) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF *************************************************************************************************** DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения ******** Определение параметров файла ################################################################################################################## CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Inp_rasp EXCLUSIVE NEW // Нет БД N_Rec = RECCOUNT() N_Obj = FCOUNT()-2 ************************* Проверки корректности параметров перобразования * mNumClSc1 = aParInt[3] // Номер первой классификационной шкалы * mNumClSc2 = aParInt[4] // Номер последней классификационной шкалы * mNumOpSc1 = aParInt[5] // Номер первой описательной шкалы * mNumOpSc2 = aParInt[6] // Номер последней описательной шкалы * mNClSc = mNumClSc2 - mNumClSc1 + 1 // Кол-во классификационных шкал * mNOpSc = mNumOpSc2 - mNumOpSc1 + 1 // Кол-во описательных шкал mFlagErr = .F. IF mNumClSc2 < mNumClSc1 LB_Warning(L("Номер последней классификационной шкалы должен быть не меньше номера первой!"),L('2.3.2.3. Импорт данных из транспонированных внешних баз данных')) mFlagErr = .T. ENDIF IF mNumOpSc2 < mNumOpSc1 LB_Warning(L("Номер последней описательной шкалы должен быть не меньше номера первой!"),L('2.3.2.3. Импорт данных из транспонированных внешних баз данных')) mFlagErr = .T. ENDIF IF RECCOUNT() < mNumClSc1 LB_Warning(L("Номер первой классификационной шкалы не должен быть больше числа записей в базе исходных данных!"),L('2.3.2.3. Импорт данных из транспонированных внешних баз данных')) mFlagErr = .T. ENDIF IF RECCOUNT() < mNumClSc2 LB_Warning(L("Номер последней классификационной шкалы не должен быть больше числа записей в базе исходных данных!"),L('2.3.2.3. Импорт данных из транспонированных внешних баз данных')) mFlagErr = .T. ENDIF IF RECCOUNT() < mNumOpSc1 LB_Warning(L("Номер первой описательной шкалы не должен быть больше числа записей в базе исходных данных!"),L('2.3.2.3. Импорт данных из транспонированных внешних баз данных')) mFlagErr = .T. ENDIF IF RECCOUNT() < mNumOpSc2 LB_Warning(L("Номер последней описательной шкалы не должен быть больше числа записей в базе исходных данных!"),L('2.3.2.3. Импорт данных из транспонированных внешних баз данных')) mFlagErr = .T. ENDIF IF mNClSc = 0 LB_Warning(L("Необходимо задать хотя бы одну классификационную шкалу!"),L('2.3.2.3. Импорт данных из транспонированных внешних баз данных')) mFlagErr = .T. ENDIF IF mNOpSc = 0 LB_Warning(L("Необходимо задать хотя бы одну описательную шкалу!"),L('2.3.2.3. Импорт данных из транспонированных внешних баз данных')) mFlagErr = .T. ENDIF ******* Теперь в режиме 2.3.2.3 в БД Inp_data.dbf допустимы только текстовые поля, а в числовые преобразовывать их по необходимости, если тип данных "N" SELECT Inp_rasp DO WHILE .NOT. EOF() .AND. .NOT. mFlagErr // Цикл по строкам классов БД Inp_data FOR jj = 3 TO FCOUNT() IF VALTYPE(FIELDGET(jj)) <> "C" // Не текстовое значение aMess := {} AADD(aMess, L('У объектов обучающей выборки есть нетекстовые показатели, что')) AADD(aMess, L('недопустимо. Исправьте файл исходных данных: "Inp_data.xls"')) LB_Warning(aMess,L('2.3.2.3. Импорт данных из транспонированных внешних баз данных')) mFlagErr = .T. ENDIF IF mFlagErr EXIT ENDIF NEXT DBSKIP(1) ENDDO IF mFlagErr ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF *************************************************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE EventsKO EXCLUSIVE NEW N_Rec = RECCOUNT() N_Obj = FCOUNT()-2 COPY STRUCTURE TO EventsKR.dbf // База событий для распознаваемой выборки CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Inp_rasp EXCLUSIVE NEW USE EventsKR EXCLUSIVE NEW USE Class_Sc EXCLUSIVE NEW USE Gr_ClSc EXCLUSIVE NEW USE Classes EXCLUSIVE NEW USE Opis_Sc EXCLUSIVE NEW USE Gr_OpSc EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW USE Rso_Zag EXCLUSIVE NEW;ZAP USE Rso_Kcl EXCLUSIVE NEW;ZAP USE Rso_Kpr EXCLUSIVE NEW;ZAP SELECT EventsKR FOR j = 1 TO N_Rec APPEND BLANK REPLACE ScaleName WITH aNameScale[j] NEXT ************************************************************************************************************* * aParInt[1] = 1 // XLS - MS Excel-2003 * aParInt[1] = 2 // XLSX- MS Excel-2007 (2010 и более поздние) * aParInt[1] = 3 // DBF - DBASE IV (DBF/NTX) * aParInt[2] = 1 // Считать нули и пробелы отсутствием данных * aParInt[2] = 2 // Не считать нули и пробелы отсутствием данных * aParInt[3] = номер ПЕРВОЙ строки с классификационными шкалами * aParInt[4] = номер ПОСЛЕДНЕЙ строки с классификационными шкалами * aParInt[5] = номер ПЕРВОЙ строки с описательными шкалами * aParInt[6] = номер ПОСЛЕДНЕЙ строки с описательными шкалами * aParInt[7] = число градаций в классификационной шкале * aParInt[8] = число градаций в описательной шкале * aParInt[9] = 1 // Формировать классификационные и описательные шкалы и градации и обучающую выборку * aParInt[9] = 2 // Формировать только распознаваемую выборку * aParInt[10]= 1 // Наменования ГРАДАЦИЙ числовых шкал - Только интервальные числовые значения * aParInt[10]= 2 // Наменования ГРАДАЦИЙ числовых шкал - Только наименования интервальных числовых значений * aParInt[10]= 3 // Наменования ГРАДАЦИЙ числовых шкал - И интервальные числовые значения, и их наименования ************************************************************************************************************* **** Генерация базы событий и распознаваемой выборки (ВСЕ СДЕЛАТЬ ТАКЖЕ, КАК В ОБУЧАЮЩЕЙ ВЫБОРКЕ) ################################################## SELECT Inp_rasp N_Obj = FCOUNT()-2 ********* Загрузить файл Inp_name.txt и сформировать массив: A_FNRus M_InpName = ALLTRIM(FILESTR('Inp_name.txt')) // Загрузка Inp_name.txt CrLf = CHR(13)+CHR(10) // Конец строки (абзаца) (CrLf) *M_InpName = " " + CrLf + STRTRAN(M_InpName,CHR(26),"") + CrLf *LB_Warning(M_InpName) A_FNRus := {} FOR ff=1 TO NUMTOKEN(M_InpName,CrLf) AADD(A_FNRus, TOKEN(M_InpName,CrLf,ff)) NEXT IF LEN(A_FNRus) <> N_Obj aMess := {} AADD(aMess, L('В "Inp_name.txt" должно быть столько же строк, сколько объектов распознаваемой выборки в "Inp_rasp"')) AADD(aMess, L('Фактически же в "Inp_name.txt" (#) строк, а в "Inp_rasp" ($) объектов распознаваемой выборки"')) AADD(aMess, L('Возможно нет наименований некоторых колонок в файле исходных данных: "Inp_rasp", или, может быть,')) AADD(aMess, L('надо выполнить формализацию предметной области в режиме 2.3.2.3 и синтез модели в режиме 3.5.')) aMess[2] = STRTRAN(aMess[2],"#", ALLTRIM(STR(LEN(A_FNRus),9))) aMess[2] = STRTRAN(aMess[2],"$", ALLTRIM(STR(N_Obj,9))) LB_Warning(Mess) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF *** Организация отображения стадии исполнения nMax = N_Obj+((aParInt[4]-aParInt[3]+1)+(aParInt[6]-aParInt[5]+1))*N_Obj Mess = L('2.3.2.3. Ввод распознаваемой выборки из транспонированных внешних баз данных') @ 4,5 DCPROGRESS oProgress SIZE 80,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 DCREAD GUI TITLE Mess PARENT @oDialog FIT EXIT oDialog:show() nTime = 0 DC_GetProgress(oProgress,0,nMax) M_KodIst = 0 FOR mObj = 1 TO N_Obj // ЦИКЛ ПО ОБЪЕКТАМ распознаваемой ВЫБОРКИ ************************ aKodCls := {} // Массив кодов классов текущего объекта aKodAtr := {} // Массив кодов признаков текущего объекта aRecCls := {} // Массив номеров записей для кодов классов текущего объекта aRecAtr := {} // Массив номеров записей для кодов признаков текущего объекта SELECT Inp_rasp M_NameIst = ALLTRIM(A_FNRus[mObj]) // Брать из Inp_name.txt FOR ff = aParInt[3] TO aParInt[4] // Цикл по строкам классов БД Inp_rasp IF FIELDGET(2) = "N" // ЧИСЛОВАЯ ШКАЛА Delta = (aMaxSH[ff]-aMinSH[ff])/aParInt[7] IF Delta > 0 SELECT Inp_rasp DBGOTO(ff) M_NameSH = ALLTRIM(FIELDGET(1)) Fv = VAL(FIELDGET(2+mObj)) aNameGrNumSc = NameGrNumSc(aParInt[7]) // Массив наименований градаций числовых шкал FOR gr=1 TO aParInt[7] F_MinGR = aMinSH[ff]+(gr-1)*Delta F_MaxGR = aMinSH[ff]+(gr )*Delta IF F_MinGR <= Fv .AND. Fv <= F_MaxGR // Какие наименования ГРАДАЦИЙ числовых шкал использовать DO CASE CASE aParInt[10] = 1 // Только интервальные числовые значения M_NameGr = ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(aParInt[7],19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" CASE aParInt[10] = 2 // Только наименования интервальных числовых значений M_NameGr = aNameGrNumSc[gr] CASE aParInt[10] = 3 // И интервальные числовые значения, и их наименования M_NameGr = aNameGrNumSc[gr]+": "+; ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(aParInt[7],19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" ENDCASE M_Name = M_NameSH + "-" + M_NameGr M_KodCls = ASCAN(aNameCls, M_Name) IF M_KodCls > 0 AADD(aKodCls, M_KodCls) AADD(aRecCls, ff) ENDIF EXIT // Исключить повторное кодирование того же значения в следующем интервале ENDIF NEXT ENDIF ENDIF IF FIELDGET(2) <> "N" // ТЕКСТОВАЯ ШКАЛА ################################################################## SELECT Inp_rasp DBGOTO(ff) M_NameSH = ALLTRIM(FIELDGET(1)) ************ Уникальные значения градаций текстовой шкалы aNameGrChrSc := {} FOR j=3 TO FCOUNT() mFv = FIELDGET(j) Fv = IF(VALTYPE(mFv)="N", ALLTRIM(STR(mFv)), ALLTRIM(mFv)) IF ASCAN(aNameGrChrSc, Fv) = 0 AADD (aNameGrChrSc, Fv ) ENDIF NEXT ASORT(aNameGrChrSc) N_Grad = LEN(aNameGrChrSc) * DC_DebugQout( aNameGrChrSc ) IF N_Grad > 1 Fv = ALLTRIM(FIELDGET(2+mObj)) gr = ASCAN(aNameGrChrSc, Fv) * MsgBox(Fv+str(gr)) IF gr > 0 // Какие наименования ГРАДАЦИЙ текстовых шкал использовать DO CASE CASE aParInt[10] = 1 // Только интервальные значения M_NameGr = ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(N_Grad))+"-{"+; aNameGrChrSc[gr]+"}" CASE aParInt[10] = 2 // Только наименования интервальных числовых значений M_NameGr = aNameGrChrSc[gr] CASE aParInt[10] = 3 // И интервальные значения, и их наименования M_NameGr = ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(N_Grad))+"-{"+; aNameGrChrSc[gr]+"}" ENDCASE M_Name = M_NameSH + "-" + M_NameGr M_KodCls = ASCAN(aNameCls, M_Name) IF M_KodCls > 0 AADD(aKodCls, M_KodCls) AADD(aRecCls, ff) ENDIF ENDIF ENDIF ENDIF DC_GetProgress(oProgress, ++nTime, nMax) NEXT FOR ff = aParInt[5] TO aParInt[6] // Цикл по строкам признаков БД Inp_rasp IF FIELDGET(2) = "N" // ЧИСЛОВАЯ ШКАЛА Delta = (aMaxSH[ff]-aMinSH[ff])/aParInt[8] IF Delta > 0 SELECT Inp_rasp DBGOTO(ff) M_NameSH = ALLTRIM(FIELDGET(1)) Fv = VAL(FIELDGET(2+mObj)) aNameGrNumSc = NameGrNumSc(aParInt[8]) // Массив наименований градаций числовых шкал FOR gr=1 TO aParInt[7] F_MinGR = aMinSH[ff]+(gr-1)*Delta F_MaxGR = aMinSH[ff]+(gr )*Delta IF F_MinGR <= Fv .AND. Fv <= F_MaxGR // Нерверный тип данных // Какие наименования ГРАДАЦИЙ числовых шкал использовать DO CASE CASE aParInt[10] = 1 // Только интервальные числовые значения M_NameGr = ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(aParInt[7],19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" CASE aParInt[10] = 2 // Только наименования интервальных числовых значений M_NameGr = aNameGrNumSc[gr] CASE aParInt[10] = 3 // И интервальные числовые значения, и их наименования M_NameGr = aNameGrNumSc[gr]+": "+; ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(aParInt[7],19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" ENDCASE M_Name = M_NameSH + "-" + M_NameGr M_KodAtr = ASCAN(aNameAtr, M_Name) IF M_KodAtr > 0 AADD(aKodAtr, M_KodAtr) AADD(aRecAtr, ff) ENDIF EXIT // Исключить повторное кодирование того же значения в следующем интервале ENDIF NEXT ENDIF ENDIF IF FIELDGET(2) <> "N" // ТЕКСТОВАЯ ШКАЛА ################################################################## SELECT Inp_rasp DBGOTO(ff) M_NameSH = ALLTRIM(FIELDGET(1)) ************ Уникальные значения градаций текстовой шкалы aNameGrChrSc := {} FOR j=3 TO FCOUNT() mFv = FIELDGET(j) Fv = IF(VALTYPE(mFv)="N", ALLTRIM(STR(mFv)), ALLTRIM(mFv)) IF ASCAN(aNameGrChrSc, Fv) = 0 AADD (aNameGrChrSc, Fv ) ENDIF NEXT ASORT(aNameGrChrSc) N_Grad = LEN(aNameGrChrSc) * DC_DebugQout( aNameGrChrSc ) IF N_Grad > 1 Fv = ALLTRIM(FIELDGET(2+mObj)) gr = ASCAN(aNameGrChrSc, Fv) IF gr > 0 // Какие наименования ГРАДАЦИЙ текстовых шкал использовать DO CASE CASE aParInt[10] = 1 // Только интервальные значения M_NameGr = ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(N_Grad))+"-{"+; aNameGrChrSc[gr]+"}" CASE aParInt[10] = 2 // Только наименования интервальных числовых значений M_NameGr = aNameGrChrSc[gr] CASE aParInt[10] = 3 // И интервальные значения, и их наименования M_NameGr = ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(N_Grad))+"-{"+; aNameGrChrSc[gr]+"}" ENDCASE M_Name = M_NameSH + "-" + M_NameGr M_KodAtr = ASCAN(aNameAtr, M_Name) IF M_KodAtr > 0 AADD(aKodAtr, M_KodAtr) AADD(aRecAtr, ff) ENDIF ENDIF ENDIF ENDIF DC_GetProgress(oProgress, ++nTime, nMax) NEXT ****** Запись базы событий EventsKR.dbf SELECT EventsKR FOR ff = 1 TO LEN(aRecCls) // Цикл по строкам классов БД Inp_rasp DBGOTO(aRecCls[ff]) FIELDPUT(2+mObj, ALLTRIM(STR(aKodCls[ff]))) NEXT FOR ff = 1 TO LEN(aRecAtr) // Цикл по строкам признаков БД Inp_rasp DBGOTO(aRecAtr[ff]) FIELDPUT(2+mObj, ALLTRIM(STR(aKodAtr[ff]))) NEXT ****** Запись распознаваемой выборки SELECT Rso_Zag APPEND BLANK REPLACE Kod_obj WITH mObj REPLACE Name_obj WITH M_NameIst REPLACE Date WITH DTOC(DATE()) REPLACE Time WITH TIME() *** Занести массив кодов классов в БД Rso_Kcl SELECT Rso_Kcl APPEND BLANK REPLACE Kod_Obj WITH mObj IF LEN(aKodCls) > 0 k=1 FOR j=1 TO LEN(aKodCls) IF k <= 4 FIELDPUT(1+k++,aKodCls[j]) ELSE k=1 APPEND BLANK REPLACE Kod_Obj WITH mObj FIELDPUT(1+k++,aKodCls[j]) ENDIF NEXT ENDIF *** Занести массив кодов признаков в БД Rso_Kpr SELECT Rso_Kpr APPEND BLANK REPLACE Kod_Obj WITH mObj IF LEN(aKodAtr) > 0 k=1 FOR j=1 TO LEN(aKodAtr) IF k <= 7 FIELDPUT(1+k++,aKodAtr[j]) ELSE k=1 APPEND BLANK REPLACE Kod_Obj WITH mObj FIELDPUT(1+k++,aKodAtr[j]) ENDIF NEXT ENDIF DC_GetProgress(oProgress, ++nTime, nMax) NEXT // Конец цикла по объектам распознаваемой выборки ***************************************** *MsgBox('STOP') DC_GetProgress(oProgress,nMax,nMax) oDialog:Destroy() Mess = L(" ПРОЦЕСС СОЗДАНИЯ РАСПОЗНАВАЕМОЙ ВЫБОРКИ ЗАВЕРШЕН УСПЕШНО !!! ") LB_Warning(Mess,L('2.3.2.3. Импорт данных из транспонированных внешних баз данных')) ENDIF // Конец режима: aParInt[9] = 2 // Формировать только распознаваемую выборку ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) ReTURN NIL ****************************************** * nMax = RECCOUNT() * Mess = L('2.2. Копирование описательной шкалы со всеми градациями') * @ 4,5 DCPROGRESS oProgress SIZE 70,1.1 MAXCOUNT nMax COLOR GRA_CLR_BLUE PERCENT EVERY 100 * DCREAD GUI TITLE Mess PARENT @oDialog FIT EXIT * oDialog:show() * nTime = 0 * DC_GetProgress(oProgress,0,nMax) * FOR r=1 TO nMax * DBGOTO(r) * IF M_KodOS_Old = Kod_OpSc * a := {} * FOR j=1 TO FCOUNT() * AADD(a, FIELDGET(j)) * NEXT * APPEND BLANK * FOR j=1 TO LEN(a) * FIELDPUT(j, a[j]) * NEXT * REPLACE Kod_OpSc WITH M_KodOS_New * ENDIF * DC_GetProgress(oProgress, ++nTime, nMax) * NEXT * DC_GetProgress(oProgress,nMax,nMax) * oDialog:Destroy() *********************************************************************************************************************************************** FUNCTION Help2323() @0,0 DCGROUP oGroup1 CAPTION L(' ') SIZE 90.5, 27.0 s=1 d=0.8 @s,2 DCSAY L('Данный режим обеспечивает импорт данных из внешних баз данных "Inp_data.xls", "Inp_data.xlsx"' ) PARENT ogroup1 FONT '9.Helv Bold' SIZE 0;s=s+d @s,2 DCSAY L('или "Inp_data.dbf" + "Inp_name.txt" в систему "Эйдос-X++" и формализацию предметной области, ' ) PARENT ogroup1 FONT '9.Helv Bold' SIZE 0;s=s+d @s,2 DCSAY L('т.е. создание классификационных и описательных шкал и градаций и обучающей выборки (см.6.4.).' ) PARENT ogroup1 FONT '9.Helv Bold' SIZE 0;s=s+1.5*d @s,2 DCSAY L('ФОРМАТ ФАЙЛА ИСХОДНЫХ ДАННЫХ: ') PARENT oGroup1 ;s=s+d @s,2 DCSAY L('=============================================== ') PARENT oGroup1 ;s=s+d @s,2 DCSAY L('В строках с 1-й по N-ю этого файла файла содержится информация о классификационных шкалах и градациях, ') PARENT oGroup1 ;s=s+d @s,2 DCSAY L('а в строках с N+1-й по последнюю - об описательных шкалах и градациях. ') PARENT oGroup1 ;s=s+1.5*d @s,2 DCSAY L('При нумерации строк XLS-файла исходных данных строка заголовка не нумеруется. Все строки и колонки файла') PARENT oGroup1 ;s=s+d @s,2 DCSAY L('исходных данных должны быть текстового типа. Для преобразования ячеек к текстовому типу надо в Excel ') PARENT oGroup1 ;s=s+d @s,2 DCSAY L('заменить во всех числах десятичную запятую на десятичную точку и присвоить ячейкам текстовый тип данных.') PARENT oGroup1 ;s=s+1.5*d @s,2 DCSAY L('1-й столбец этого файла должен быть текстового типа и содержать информацию о наименованиях шкал. ') PARENT oGroup1 ;s=s+d @s,2 DCSAY L('Длина этих наименований должна быть минимальной, достаточной для понимания, т.к. используется в много- ') PARENT oGroup1 ;s=s+d @s,2 DCSAY L('численных текстовых и графических выходных формах ') PARENT oGroup1 ;s=s+d @s,2 DCSAY L('2-й столбец содержит информацию о типе данных классификационной или описательной шкалы: ') PARENT oGroup1 ;s=s+d @s,2 DCSAY L('- "N" шкала числового типа (значения в колонках будут преобразовываться из текстового типа в числовой);') PARENT oGroup1 ;s=s+d @s,2 DCSAY L('- "C" шкала текстового типа (значения в колонках обрабатываться как текстовые). ') PARENT oGroup1 ;s=s+d @s,2 DCSAY L('Столбцы со 3-го по последний содержат информацию об объектах обучающей выборки. ') PARENT oGroup1 ;s=s+d @s,2 DCSAY L('=============================================== ') PARENT oGroup1 ;s=s+1.5*d @s,2 DCSAY L('Таким образом данный файл является транспонированным файлом стандарта, используемого режима 2.3.2.2(). ') PARENT oGroup1 ;s=s+1.5*d @s,2 DCSAY L('Если задана опция формирования классификационных и описательных шкал и градаций и обучающей выборки, то ') PARENT oGroup1 ;s=s+d @s,2 DCSAY L('система автоматически находит минимальное и максимальное значения в каждой числовой шкале и формирует ') PARENT oGroup1 ;s=s+d @s,2 DCSAY L('заданное в диалоге количество равных интервалов. Градациями текстовых шкал являются уникальные значения.') PARENT oGroup1 ;s=s+d @s,2 DCSAY L('С использованием этой информации генерируется обучающая выборка, в которой каждому столбцу XLS-файла ') PARENT oGroup1 ;s=s+d @s,2 DCSAY L('исходных данных, начиная со второго, соответствует один объект обучающей выборки. ') PARENT oGroup1 ;s=s+1.5*d @s,2 DCSAY L('Если задана опция формирования только распознаваемой выборки, то с использованием ранее сформированных ') PARENT oGroup1 ;s=s+d @s,2 DCSAY L('классификационных и описательных шкал и градаций на основе файла с именем: "Inp_rasp.xls" формируется ') PARENT oGroup1 ;s=s+d @s,2 DCSAY L('распознаваемая выборка. Файл "Inp_rasp.xls" должен иметь такую же структуру, как "Inp_rasp.xls", в том ') PARENT oGroup1 ;s=s+d @s,2 DCSAY L('числе в "Inp_rasp.xls" должен быть те же диапазоны строк калассифкационных и описательных шкал, что и ') PARENT oGroup1 ;s=s+d @s,2 DCSAY L('в файле "Inp_data.xls". ') PARENT oGroup1 ;s=s+2*d @s,0 DCGROUP oGroup2 CAPTION L('Принцип организации таблицы исходных данных:') SIZE 90.5, 7.6 **** Если файл существует изображения и его контрольная сумма совпадает, то он отображается cFile = Disk_dir+"\Help2323.jpg" // Сделать соответствующий файл IF FILE(cFile) IF FILECHECK(cFile) = 5612195 @20,12 DCSTATIC TYPE XBPSTATIC_TYPE_BITMAP CAPTION cFile SIZE 610,120 PIXEL PARENT oGroup2 ELSE Mess = L('Графический файл: "#" поврежден и не может быть отображен!') Mess = STRTRAN(Mess, "#", cFile) * Mess = STRTRAN(Mess, "#", ALLTRIM(STR(FILECHECK(cFile),19))) // Отображение контрольной суммы файлы LB_Warning(Mess) ENDIF ENDIF DCREAD GUI FIT ADDBUTTONS TITLE L('Help режима: "2.3.2.3. Импорт данных из транспонированных внешних баз данных"') ReTURN nil *********************************************************************************************************************************************** *********************************************************************************************************** ******** '2.3.2.7 Транспонирование файлов исходных данных. Данный режим обеспечивает транспонирование ******** заданной подматрицы или всей базы данных Inp_data.xls и ее запись в виде файла Inp_transp.xls' *********************************************************************************************************** FUNCTION F2_3_2_7() LOCAL Getlist := {}, oProgress, oDialog PUBLIC Time_progress, Wsego, lOk := .T., Sec_1, GetOptions Running(.T.) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF ** Файл параметров работы интерфейса. Здесь для того, чтобы не зависило от приложения ****************************************************************************************************** * aParInt[1] = 1 // XLS - MS Excel-2003 * aParInt[1] = 2 // XLSX- MS Excel-2007 (2010 и более поздние) * aParInt[2] = 1 // Транспонировать весь файл: "Inp_data.xls" * aParInt[2] = 2 // Транспонировать подматрицу файла "Inp_data.xls" * aParInt[3] = номер ПЕРВОЙ строки подматрицы * aParInt[4] = номер ПОСЛЕДНЕЙ строки подматрицы * aParInt[5] = номер ПЕРВОГО столбца подматрицы * aParInt[6] = номер ПОСЛЕДНЕГО столбца подматрицы ****************************************************************************************************** IF FILE(Disk_dir+"\_2_3_2_7.arx") // Файл параметров aParInt = DC_ARestore(Disk_dir+"\_2_3_2_7.arx") ELSE PRIVATE aParInt[6] AFILL(aParInt, 1) aParInt[3] = 1 aParInt[4] = RECCOUNT() aParInt[5] = 1 aParInt[6] = FCOUNT() DC_ASave(aParInt, Disk_dir+"\_2_3_2_7.arx") ENDIF ********************************************************************************************************************** // Диалог задания параметров работы интерфейса @ 1,2 DCGROUP oGroup1 CAPTION L('Задайте тип файла исходных данных: "Inp_data":' ) SIZE 83,3.5 @ 1,2 DCRADIO aParInt[1] VALUE 1 PROMPT L('XLS - MS Excel-2003' ) PARENT oGroup1 @ 2,2 DCRADIO aParInt[1] VALUE 2 PROMPT L('XLSX- MS Excel-2007 (2010 и более поздние)') PARENT oGroup1 @ 1,70.6 DCPUSHBUTTON CAPTION L('Help') SIZE 10.2, 1.8 PARENT oGroup1 ACTION {||Help2327()} FONT '10.Helv Bold' DCREAD GUI ; TO lExit ; FIT ; OPTIONS GetOptions ; ADDBUTTONS; MODAL ; TITLE L('2.3.2.7. Транспонирование файлов исходных данных') ********************************************************************************************************************** ******************************************************************** IF lExit ** Button Ok ELSE ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW Running(.F.) RETURN NIL ENDIF ******************************************************************** ****************************************************************************************************** * aParInt[1] = 1 // XLS - MS Excel-2003 * aParInt[1] = 2 // XLSX- MS Excel-2007 (2010 и более поздние) * aParInt[2] = 1 // Транспонировать весь файл: "Inp_data.xls" * aParInt[2] = 2 // Транспонировать подматрицу файла "Inp_data.xls" * aParInt[3] = номер ПЕРВОЙ строки подматрицы * aParInt[4] = номер ПОСЛЕДНЕЙ строки подматрицы * aParInt[5] = номер ПЕРВОГО столбца подматрицы * aParInt[6] = номер ПОСЛЕДНЕГО столбца подматрицы ****************************************************************************************************** DIRCHANGE(Disk_dir) *************************************************************************************** DC_ASave(aParInt, Disk_dir+"\_2_3_2_7.arx") // Запись файла параметров ******** Загрузка файла исходных данных Inp_data.xls IF aParInt[1] = 1 // Определить, есть ли файлы в папке: AID_DATA/Inp_data DIRCHANGE(M_ApplsPath+"\Inp_data") IF .NOT. FILE("Inp_data.xls") Mess = L('В папке: '+M_ApplsPath+'\Inp_data\ должен быть файл: "Inp_data.xls"') LB_Warning(Mess) Help2327() // Пояснение о назначении режима ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF DIRCHANGE(Disk_dir) // Скопировать в новое приложение файл: Inp_data.xls Name_SS = M_ApplsPath+"\Inp_data\Inp_data.xls" * Name_DD = M_PathAppl +"\Inp_data.xls" * COPY FILE (Name_SS) TO (Name_DD) *** ПРЕОБРАЗОВАНИЕ EXCEL-ФАЙЛА Inp_data.xls в БД: Inp_data.dbf *** и файл наименований классификационных и описательных шкал: Inp_name.txt cExcelFile = 'Inp_data.xls' mFlag = LC_Excel2WorkArea( cExcelFile, M_ApplsPath+"\Inp_data" ) IF .NOT. mFlag LB_Warning(L('Исправьте файл исходных данных !'), L('2.3.2.7. Транспонирование файлов исходных данных' )) Help2327() // Пояснение о назначении режима ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ENDIF ** XLSX - имя файла базы исходных данных: Inp_data.XLSX ************************** IF aParInt[1] = 2 // Определить, есть ли файлы в папке: AID_DATA\Inp_data DIRCHANGE(M_ApplsPath+"\Inp_data\") IF .NOT. FILE("Inp_data.xlsx") Mess = L('В папке: ')+M_ApplsPath+L('\Inp_data\ должен быть файл: "Inp_data.xlsx"') LB_Warning(Mess) Help2327() // Пояснение о назначении режима ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF DIRCHANGE(Disk_dir) // Скопировать в новое приложение файл: Inp_data.xlsx Name_SS = M_ApplsPath+"\Inp_data\Inp_data.xlsx" * Name_DD = M_PathAppl +"\Inp_data.xlsx" * COPY FILE (Name_SS) TO (Name_DD) *** ПРЕОБРАЗОВАНИЕ EXCEL-ФАЙЛА Inp_data.xlsx в БД: Inp_data.dbf *** и файл наименований классификационных и описательных шкал: Inp_name.txt cExcelFile = 'Inp_data.xlsx' mFlag = LC_Excel2WorkArea( cExcelFile, M_ApplsPath+"\Inp_data" ) IF .NOT. mFlag LB_Warning(L('Исправьте файл исходных данных !'), L('2.3.2.7. Транспонирование файлов исходных данных' )) Help2327() // Пояснение о назначении режима ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ENDIF ******** Определение параметров файла ################################################################################################################## ****************************************************************************************************** * aParInt[1] = 1 // XLS - MS Excel-2003 * aParInt[1] = 2 // XLSX- MS Excel-2007 (2010 и более поздние) * aParInt[2] = 1 // Транспонировать весь файл: "Inp_data.xls" * aParInt[2] = 2 // Транспонировать подматрицу файла "Inp_data.xls" * aParInt[3] = номер ПЕРВОЙ строки подматрицы * aParInt[4] = номер ПОСЛЕДНЕЙ строки подматрицы * aParInt[5] = номер ПЕРВОГО столбца подматрицы * aParInt[6] = номер ПОСЛЕДНЕГО столбца подматрицы ****************************************************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Inp_data EXCLUSIVE NEW N_Rec = RECCOUNT() N_Col = FCOUNT() aParInt[3] = 1 aParInt[4] = N_Rec aParInt[5] = 1 aParInt[6] = N_Col ************************* Проверки корректности параметров перобразования *DC_DebugQout( aParInt ) *MsgBox('STOP') nMax = N_Rec + N_Rec*N_Col + (N_Col-1) + N_Rec*(N_Col-1) Mess = L('2.3.2.7. Транспонирование файлов исходных данных') @ 4,5 DCPROGRESS oProgress SIZE 70,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 DCREAD GUI TITLE Mess PARENT @oDialog FIT EXIT oDialog:show() nTime = 0 DC_GetProgress(oProgress,0,nMax) ****** Сформировать массив наименований колонок исходной матрицы mFlagErr = .F. ****** Загрузить файл Inp_nameAll.txt и сформировать массив: A_ColName M_InpName = ALLTRIM(FILESTR('Inp_nameAll.txt')) // Загрузка Inp_nameAll.txt CrLf = CHR(13)+CHR(10) // Конец строки (абзаца) (CrLf) M_InpName = " " + CrLf + STRTRAN(M_InpName,CHR(26),"") + CrLf *LB_Warning(M_InpName) A_ColName := {} mMaxLenCol = 15 FOR ff=2 TO NUMTOKEN(M_InpName,CrLf) mName = ALLTRIM(TOKEN(M_InpName,CrLf,ff)) AADD(A_ColName, mName) // Ограничение длины наименования шкалы 255 символов mMaxLenCol = MAX(mMaxLenCol, LEN(mName)) NEXT IF LEN(A_ColName) <> N_Col aMess := {} AADD(aMess, L('Строк в "Inp_nameAll.txt" должно быть столько же, сколько колонок в "Inp_data.dbf!"')) AADD(aMess, L('Фактически же в "Inp_nameAll.txt" (#) строк, а в "Inp_data.dbf" ($) колонок"')) aMess[2] = STRTRAN(aMess[2],"#", ALLTRIM(STR(LEN(A_ColName),9))) aMess[2] = STRTRAN(aMess[2],"$", ALLTRIM(STR(N_Col,9))) LB_Warning(aMess) mFlagErr = .T. ENDIF ******** Сформировать массив наименований строк исходной матрицы, включая наименование первой колонки SELECT Inp_data A_RecName := {} AADD(A_RecName, A_ColName[1]) mMaxLenRec = LEN(ALLTRIM(A_ColName[1])) FOR mRec = 1 TO N_Rec DBGOTO(mRec) Fv = FIELDGET(1) IF VALTYPE(Fv) = "N" Fv = STR(Fv,FIELDSIZE(1),FIELDDECI(1)) ENDIF AADD(A_RecName, ALLTRIM(Fv)) mMaxLenRec = MAX(mMaxLenRec, LEN(Fv)) DC_GetProgress(oProgress, ++nTime, nMax) // nMax = N_Rec NEXT IF mFlagErr ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF *** Определить максимальную длину значения поля mMaxLenCol = LEN(L('Col_names')) FOR mRec = 1 TO N_Rec DBGOTO(mRec) FOR mCol = 1 TO N_Col Fv = FIELDGET(mCol) IF VALTYPE(Fv) = "N" Fv = STR(Fv,FIELDSIZE(mCol),FIELDDECI(mCol)) ENDIF mMaxLenCol = MAX(mMaxLenCol, LEN(ALLTRIM(Fv))) DC_GetProgress(oProgress, ++nTime, nMax) // nMax = N_Rec + N_Rec*N_Col NEXT NEXT ****** Создаем файл структуры БД для транспонированной матрицы aStructure := { { "Col_names", "C", mMaxLenCol, 0} } FOR j=1 TO N_Rec FieldName = "F"+ALLTRIM(STR(j,7)) AADD(aStructure, { FieldName , "C", mMaxLenCol, 0 }) NEXT DbCreate( "Out_transp.dbf", aStructure ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Inp_data EXCLUSIVE NEW USE Out_transp EXCLUSIVE NEW ***** ТРАНСПОНИРОВАНИЕ *************** ****** Наименования колонок исходной матрицы, а теперь строк SELECT Out_transp FOR mCol = 2 TO N_Col APPEND BLANK FIELDPUT(1, A_ColName[mCol]) DC_GetProgress(oProgress, ++nTime, nMax) // nMax = N_Rec + N_Rec*N_Col + (N_Col-1) NEXT FOR mRec = 1 TO N_Rec SELECT Inp_data DBGOTO(mRec) Ar := {} FOR mCol = 1 TO N_Col Fv = FIELDGET(mCol) IF VALTYPE(Fv) = "N" Fv = STR(Fv,FIELDSIZE(mCol),FIELDDECI(mCol)) ENDIF AADD(Ar, ALLTRIM(Fv)) NEXT SELECT Out_transp FOR mCol = 2 TO N_Col DBGOTO(mCol-1) FIELDPUT(1+mRec, Ar[mCol]) DC_GetProgress(oProgress, ++nTime, nMax) // nMax = N_Rec + N_Rec*N_Col + (N_Col-1) + N_Rec*(N_Col-1) NEXT NEXT *MsgBox('STOP') DC_GetProgress(oProgress,nMax,nMax) oDialog:Destroy() ***** Записать транспонированный файл в виде Excel-файла CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Out_transp EXCLUSIVE NEW SELECT Out_transp *aFields := {} aColumnNames := {} FOR j=1 TO FCOUNT() * AADD(aFields, FIELDNAME(j)) AADD(aColumnNames, A_RecName[j]) NEXT *DC_WorkArea2Excel( cExcelFile, nOrientation, lDisplayAlerts, ; * lVisible, aFields, lAutoFit, cDateFormat, aFieldEvals, ; * cPassword, aColumnNames ) cExcelFile = M_ApplsPath+"\Inp_data\Out_transp.xls" DC_DbGoTop() DC_WorkArea2Excel( cExcelFile ,,,,,,,,,,, aColumnNames ) aMess := {} AADD(aMess, L('Транспонирование файла исходных данных "Inp_data.xls" завершено успешно!')) AADD(aMess, L('Результат находится в файле: '+M_ApplsPath+"\Inp_data\Out_transp.xls")) LB_Warning(aMess,L('2.3.2.7. Транспонирование файлов исходных данных')) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) ReTURN nil *********************************************************************************************************************************************** ******** Помощь по режиму: 2.3.2.7. Транспонирование файлов исходных данных. Данный режим обеспечивает транспонирование ******** базы данных Inp_data.xls и ее запись в виде файла Inp_transp.xls' *********************************************************************************************************************************************** FUNCTION Help2327() @0,0 DCGROUP oGroup1 CAPTION L(' ') SIZE 85.0, 9.5 s=1 d=1 @s,2 DCSAY L('2.3.2.7. Транспонирование файлов исходных данных ') PARENT ogroup1 FONT '9.Helv Bold' SIZE 0;s=s+2*d @s,2 DCSAY L('Данный режим обеспечивает транспонирование базы данных:'+M_ApplsPath+'\Inp_data\'+'"Inp_data.xls" ') PARENT oGroup1 ;s=s+d @s,2 DCSAY L('и ее запись в виде файла:'+M_ApplsPath+'\Inp_data\'+'"Inp_transp.xls" ') PARENT oGroup1 ;s=s+2*d @s,2 DCSAY L('Первая строка и первый столбец в транспонируемой матрице ОБЯЗАТЕЛЬНО должны быть текстового типа, ') PARENT oGroup1 ;s=s+d @s,2 DCSAY L('и желательно, чтобы и все остальные данные также были текстового типа. Если же они будут числового') PARENT oGroup1 ;s=s+d @s,2 DCSAY L('типа, то в процессе транспонирования будут преобразованы к текстовому типу. ') PARENT oGroup1 ;s=s+2*d DCREAD GUI FIT ADDBUTTONS TITLE L('Режим: "2.3.2.7. Транспонирование файлов исходных данных"') ReTURN nil *********************************************************************************************************************************************** **************************************************************************** ******** Подготовка массива наименования ГРАДАЦИЙ числовых шкал использовать **************************************************************************** FUNCTION NameGrNumSc(mNGrSc) aNameGrNumSc := {} DO CASE CASE mNGrSc = 1 AADD(aNameGrNumSc, "") CASE mNGrSc = 2 AADD(aNameGrNumSc, L("Малое")) AADD(aNameGrNumSc, L("Большое")) CASE mNGrSc = 3 AADD(aNameGrNumSc, L("Малое")) AADD(aNameGrNumSc, L("Среднее")) AADD(aNameGrNumSc, L("Большое")) CASE mNGrSc = 4 AADD(aNameGrNumSc, L("Очень малое")) AADD(aNameGrNumSc, L("Малое")) AADD(aNameGrNumSc, L("Большое")) AADD(aNameGrNumSc, L("Очень большое")) CASE mNGrSc = 5 AADD(aNameGrNumSc, L("Очень малое")) AADD(aNameGrNumSc, L("Малое")) AADD(aNameGrNumSc, L("Среднее")) AADD(aNameGrNumSc, L("Большое")) AADD(aNameGrNumSc, L("Очень большое")) CASE mNGrSc = 6 AADD(aNameGrNumSc, L("Самое малое")) AADD(aNameGrNumSc, L("Очень малое")) AADD(aNameGrNumSc, L("Малое")) AADD(aNameGrNumSc, L("Большое")) AADD(aNameGrNumSc, L("Очень большое")) AADD(aNameGrNumSc, L("Самое большое")) CASE mNGrSc = 7 AADD(aNameGrNumSc, L("Самое малое")) AADD(aNameGrNumSc, L("Очень малое")) AADD(aNameGrNumSc, L("Малое")) AADD(aNameGrNumSc, L("Среднее")) AADD(aNameGrNumSc, L("Большое")) AADD(aNameGrNumSc, L("Очень большое")) AADD(aNameGrNumSc, L("Самое большое")) CASE mNGrSc = 8 AADD(aNameGrNumSc, L("Самое малое")) AADD(aNameGrNumSc, L("Очень малое")) AADD(aNameGrNumSc, L("Малое")) AADD(aNameGrNumSc, L("Меньше среднего")) AADD(aNameGrNumSc, L("Больше среднего")) AADD(aNameGrNumSc, L("Большое")) AADD(aNameGrNumSc, L("Очень большое")) AADD(aNameGrNumSc, L("Самое большое")) CASE mNGrSc = 9 AADD(aNameGrNumSc, L("Самое малое")) AADD(aNameGrNumSc, L("Очень малое")) AADD(aNameGrNumSc, L("Малое")) AADD(aNameGrNumSc, L("Меньше среднего")) AADD(aNameGrNumSc, L("Среднее")) AADD(aNameGrNumSc, L("Больше среднего")) AADD(aNameGrNumSc, L("Большое")) AADD(aNameGrNumSc, L("Очень большое")) AADD(aNameGrNumSc, L("Самое большое")) OTHERWISE FOR g=1 TO mNGrSc AADD(aNameGrNumSc, ALLTRIM(STR(g))+"-е из "+ALLTRIM(STR(mNGrSc))) NEXT ENDCASE ReTURN(aNameGrNumSc) *********************************************************************************************************************************************** ****************************************************************************************************************** ******** 2.3.2.8. Объединение нескольких файлов исходных данных в один ******** Данный режим обеспечивает объединение нескольких одинаковых по структуре баз данных с именами вида: ******** "Input####.xls", где: "####" - номер файла вида: 0001,0002,...,9999, в один файл с именем: "Add_data.xls" ****************************************************************************************************************** FUNCTION F2_3_2_8() LOCAL Getlist := {}, oProgress, oDialog PUBLIC Time_progress, Wsego, lOk := .T., Sec_1, GetOptions Running(.T.) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF ** Файл параметров работы интерфейса. Здесь для того, чтобы не зависило от приложения ****************************************************************************************************** * aParInt[1] = 1 // DBF - файл базы данных * aParInt[1] = 2 // XLS - MS Excel-2003 * aParInt[1] = 3 // XLSX- MS Excel-2007 (2010 и более поздние) ****************************************************************************************************** IF FILE(Disk_dir+"\_2_3_2_8.arx") // Файл параметров aParInt = DC_ARestore(Disk_dir+"\_2_3_2_8.arx") ELSE PRIVATE aParInt[1] AFILL(aParInt, 1) DC_ASave(aParInt, Disk_dir+"\_2_3_2_8.arx") ENDIF ********************************************************************************************************************** // Диалог задания параметров работы интерфейса cExcelFile = M_ApplsPath+"\Inp_data\Input###" @ 1,2 DCGROUP oGroup1 CAPTION L('Задайте тип файлов исходных данных: ')+cExcelFile+'"' SIZE 83,4.5 @ 1,2 DCRADIO aParInt[1] VALUE 1 PROMPT L('DBF - файл базы данных' ) PARENT oGroup1 @ 2,2 DCRADIO aParInt[1] VALUE 2 PROMPT L('XLS - MS Excel-2003' ) PARENT oGroup1 @ 3,2 DCRADIO aParInt[1] VALUE 3 PROMPT L('XLSX- MS Excel-2007 (2010 и более поздние)') PARENT oGroup1 @ 1,70.6 DCPUSHBUTTON CAPTION L('Help') SIZE 10.2, 1.8 PARENT oGroup1 ACTION {||Help2328()} FONT '10.Helv Bold' DCREAD GUI ; TO lExit ; FIT ; OPTIONS GetOptions ; ADDBUTTONS; MODAL ; TITLE L('2.3.2.8. Объединение нескольких файлов исходных данных в один') ********************************************************************************************************************** ******************************************************************** IF lExit ** Button Ok ELSE ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ******************************************************************** ****************************************************************************************************** * aParInt[1] = 1 // DBF - файл базы данных * aParInt[1] = 2 // XLS - MS Excel-2003 * aParInt[1] = 3 // XLSX- MS Excel-2007 (2010 и более поздние) ****************************************************************************************************** DIRCHANGE(M_ApplsPath+"\Inp_data\") *************************************************************************************** DC_ASave(aParInt, Disk_dir+"\_2_3_2_8.arx") // Запись файла параметров **** Рекогносцировка DO CASE CASE aParInt[1] = 1 // DBF - файл базы данных mExt = ".dbf" CASE aParInt[1] = 2 // XLS - MS Excel-2003 mExt = ".xls" CASE aParInt[1] = 3 // XLSX- MS Excel-2007 (2010 и более поздние) mExt = ".xlsx" ENDCASE cExcelFile = "Input*"+mExt N_InpFiles = ADIR(cExcelFile) IF N_InpFiles = 0 aMess := {} AADD(aMess, L('В папке: '+M_ApplsPath+"\Inp_data\")) AADD(aMess, L('нет файлов исходных данных вида: "Input####"')+mExt) AADD(aMess, L('где: "###" - номер файла вида: 0001,0002, ..., 9999')) LB_Warning(aMess, L('2.3.2.8. Объединение нескольких файлов исходных данных в один')) Help2328() // Пояснение о назначении режима ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF PRIVATE aFileName[N_InpFiles] ADIR(cExcelFile, aFileName) // Имена ВСЕХ файлов исходных данных в папке "Inp_data" ******** Если файлы исходных данных dbf-типа, то создать массив наименований полей IF aParInt[1] = 1 // DBF - файл базы данных mFileName = SUBSTR(aFileName[1],1,LEN(aFileName[1])-4) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mFileName) EXCLUSIVE NEW aColumnNames := {} FOR j=1 TO FCOUNT() AADD(aColumnNames, FIELDNAME(j)) NEXT DC_ASave(aColumnNames, "_ColumnNames.arx") // Запись массива наименований шкал (колонок) в виде файла ENDIF ******** Если файлы исходных данных xls или xlsx типа, то преобразовать их в dbf-файлы IF aParInt[1] > 1 // XLS, XLSX FOR ff=1 TO N_InpFiles cExcelFile = aFileName[ff] mFlag = LC_Excel2WorkArea( cExcelFile, M_ApplsPath+'\Inp_data\' ) IF .NOT. mFlag LB_Warning(L('Исправьте файл исходных данных: ')+cExcelFile, L('2.3.2.8. Объединение нескольких файлов исходных данных в один' )) Help2327() // Пояснение о назначении режима ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF NEXT ENDIF *MsgBox('STOP') ****************************************************************************************************** * aParInt[1] = 1 // DBF - файл базы данных * aParInt[1] = 2 // XLS - MS Excel-2003 * aParInt[1] = 3 // XLSX- MS Excel-2007 (2010 и более поздние) ****************************************************************************************************** ***** Само объединение теперь уже ранее имевшихся или созданных dbf-файлов ************* cExcelFile = "Input*.dbf" N_InpFiles = ADIR(cExcelFile) PRIVATE aFileNameDBF[N_InpFiles] ADIR(cExcelFile, aFileNameDBF) // Имена ВСЕХ dbf-файлов исходных данных в папке "Inp_data" CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций mFileName = SUBSTR(aFileNameDBF[1],1,LEN(aFileNameDBF[1])-4) USE (mFileName) EXCLUSIVE NEW aStruInpdata := DbStruct() COPY STRUCTURE TO Inp_data.dbf CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Inp_data EXCLUSIVE NEW;ZAP // Отладка *DC_DebugQout( aStruInpdata ) * DC_GuiABrowse( aStruInpdata, nil,nil,nil,nil, 'Структура: "Inp_data.dbf"' ) *MsgBox(STR(aStruInpdata[1,3])) * Структура подмассива для определения поля * * Элемент No. Значение Константа в Dbstruct.ch *---------------------------------------------------------- * 1 Имя поля DBS_NAME * 2 Тип поля DBS_TYPE * 3 Длина поля DBS_LEN * 4 Десятичные разряды DBS_DEC ****** Для сообщения о несовпадении структуры aConst := {} AADD(aConst, 'Имя поля') AADD(aConst, 'Тип поля') AADD(aConst, 'Длина поля') AADD(aConst, 'Десятичные разряды') *aStr := { { "KOD_OpSc" , "N", 15, 0 }, ; * { "NAME_OpSc" , "C",mLenMax, 0 }, ; * { "KodGr_min" , "N", 15, 0 }, ; // Минимальный код градаций описательной шкалы * { "KodGr_max" , "N", 15, 0 } } // Максимальный код градаций описательной шкалы *DbCreate( 'Opis_ScKD.dbf', aStr ) nMax = N_InpFiles Mess = L('2.3.2.8. Объединение нескольких файлов исходных данных в один') @ 4,5 DCPROGRESS oProgress SIZE 70,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 DCREAD GUI TITLE Mess PARENT @oDialog FIT EXIT oDialog:show() nTime = 0 DC_GetProgress(oProgress,0,nMax) *** Проверять совпадение структуры файлов исходных данных и Inp_data, и если структура не совпадает, то сообщить об этом и не объединять. aColumnNames = DC_ARestore("_ColumnNames.arx") // Восстановление массива наименований колонок в виде файла FOR ff=1 TO N_InpFiles CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Inp_data EXCLUSIVE NEW mFileName = SUBSTR(aFileNameDBF[ff],1,LEN(aFileNameDBF[ff])-4) USE (mFileName) EXCLUSIVE NEW SELECT (mFileName) aStruInput := DbStruct() Flag_Str = .F. IF LEN(aStruInpData) <> LEN(aStruInput) Flag_Str = .T. aMess := {} AADD(aMess, L('Объединение файлов исходных данных:"')+' '+aFileName[1]+'" - "'+aFileName[N_InpFiles]+'"') AADD(aMess, L('прервано на файле:"')+' '+aFileName[ff]+' '+L('"из-за того, что у него другое количество полей')) AADD(aMess, L('чем у объединенной базы: "Inp_data.dbf", структура которой берется из 1-го файла данных:')) AADD(aMess, L('в базе данных: "Inp_data.dbf"')+' '+ALLTRIM(STR(LEN(aStruInpData)))+' '+L('полей, а в:"')+' '+aFileName[ff]+'" - '+ALLTRIM(STR(LEN(aStruInput)))+' '+L('полей')) ENDIF IF .NOT. Flag_Str FOR i=1 TO LEN(aStruInput) FOR j=1 TO 4 IF aStruInpdata[i,j] <> aStruInput[i,j] Flag_Str = .T. aMess := {} AADD(aMess, L('Объединение файлов исходных данных: "')+aFileName[1]+'" - "'+aFileName[N_InpFiles]+'"') AADD(aMess, L('прервано на файле: "')+aFileName[ff]+' '+L('"из-за того, что в поле:"')+' '+aColumnNames[i]+'"') AADD(aMess, L('у него не совпадает параметр:"')+' '+aConst[j]+' '+L('"с объединенной базой: "Inp_data.dbf"')) AADD(aMess, L('структура которой берется из 1-го файла исходных данных: "')+aFileName[1]+'"') * AADD(aMess, L('В базе данных: "Inp_data.dbf" параметр: "')+aConst[j]+L('" имеет значение: "')+ALLTRIM(STR(aStruInpData[i,j]))+'",') * AADD(aMess, L('а в файле исходных данных: "')+aFileName[ff]+'" - "'+ALLTRIM(STR(aStruInput[i,j]))+'"') EXIT ENDIF NEXT NEXT ENDIF IF Flag_Str LB_Warning(aMess,L('2.3.2.8. Объединение нескольких файлов исходных данных в один')) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) ReTURN nil ENDIF DBGOTOP() DO WHILE .NOT. EOF() Ar := {} FOR j=1 TO FCOUNT() AADD(Ar, FIELDGET(j)) NEXT SELECT Inp_data APPEND BLANK FOR j=1 TO LEN(Ar) FIELDPUT(j, Ar[j]) NEXT SELECT (mFileName) DBSKIP(1) ENDDO DC_GetProgress(oProgress, ++nTime, nMax) NEXT *MsgBox('STOP') DC_GetProgress(oProgress,nMax,nMax) oDialog:Destroy() ***** Записать объединенного файла dbf-файла в виде Excel-файла *DC_WorkArea2Excel( cExcelFile, nOrientation, lDisplayAlerts, ; * lVisible, aFields, lAutoFit, cDateFormat, aFieldEvals, ; * cPassword, aColumnNames ) *DC_ASave(aColumnNames, "_ColumnNames.arx") // Запись массива наименований колонок в виде файла aColumnNames = DC_ARestore("_ColumnNames.arx") // Восстановление массива наименований колонок в виде файла CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Inp_data EXCLUSIVE NEW SELECT Inp_data DC_DbGoTop() cExcelFile = M_ApplsPath+"\Inp_data\Inp_data.xls" DC_WorkArea2Excel( cExcelFile ,,,,,,,,,,, aColumnNames ) aMess := {} AADD(aMess, L('Объединение файлов исходных данных: ')+aFileName[1]+' - '+aFileName[N_InpFiles]+L(' завершено успешно!')) AADD(aMess, L('Результат находится в файлах:')) AADD(aMess, M_ApplsPath+"\Inp_data\Inp_data.dbf") AADD(aMess, M_ApplsPath+"\Inp_data\Inp_data.xls") LB_Warning(aMess,L('2.3.2.8. Объединение нескольких файлов исходных данных в один')) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) ReTURN nil *********************************************************************************************************************************************** ******** Помощь по режиму: 2.3.2.8. Объединение нескольких файлов исходных данных в один ******** Данный режим обеспечивает объединение нескольких одинаковых по структуре баз данных с именами вида: ******** "Input####.xls", где: "####" - номер файла вида: 0001,0002,...,9999, в один файл с именем: "Inp_data.xls" *********************************************************************************************************************************************** FUNCTION Help2328() @0,0 DCGROUP oGroup1 CAPTION L(' ') SIZE 87.5, 10.5 s=1 d=1 @s,2 DCSAY L('2.3.2.7. Объединение нескольких файлов исходных данных в один' ) PARENT ogroup1 FONT '9.Helv Bold' SIZE 0;s=s+1.5*d @s,2 DCSAY L('Данный режим обеспечивает объединение нескольких одинаковых по структуре баз данных с именами вида:') PARENT oGroup1 ;s=s+d @s,2 DCSAY L('"Input####.dbf", "Input####.xls" или "Input####.xlsx", где: "####" - номер файла вида: 0001 - 9999 ') PARENT oGroup1 ;s=s+d @s,2 DCSAY L('в один файл с именем: "Inp_data.dbf" и один файл с именем: "Inp_data.xls". ') PARENT oGroup1 ;s=s+1.5*d @s,2 DCSAY L('Все файлы исходных данных должны находиться в папке: '+M_ApplsPath+"\Inp_data\" ) PARENT oGroup1 ;s=s+1.5*d @s,2 DCSAY L('Максимальное количество строк в файле "Inp_data.xls" ограничено установленной версией MS Excel. ') PARENT oGroup1 ;s=s+d @s,2 DCSAY L('Максимальное количество строк в файле "Inp_data.dbf" ограничено только размером этого файла: до 2Гб') PARENT oGroup1 ;s=s+d DCREAD GUI FIT ADDBUTTONS TITLE L('Режим: "2.3.2.8. Объединение нескольких файлов исходных данных в один"') ReTURN nil *********************************************************************************************************************************************** **************************************** ******** Копировать INF#.TXT => INF#.DBF **************************************** FUNCTION COPY_TXT_DBF() ***** Проверка наличия основных БД всех моделей. Ar_Model := {"Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } Flag = .F. FOR z=1 TO LEN(Ar_Model) IF .NOT. FILE(Ar_Model[z]+'.txt') Mess = L('Модель: "#" отсутствует. Необходимо провести расчет моделей в режиме 3.5 !!!') Mess = STRTRAN(Mess, '#', Ar_Model[z]) LB_Warning( Mess, L('5.5. Просмотр основных БД всех моделей' )) Flag = .T. EXIT ENDIF NEXT IF Flag // Если какой-нибудь БД нет, то режим не запускать ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF mLenNameMax = CreateStructAll() // Создание файлов структур баз данных всех моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() // Количество классов (градаций классификационных шкал) USE Attributes EXCLUSIVE NEW;N_Gos = RECCOUNT() // Количество признаков (градаций описательных шкал) USE Gr_OpSc EXCLUSIVE NEW;N_Gos = RECCOUNT() // Количество признаков (градаций описательных шкал) USE Opis_Sc EXCLUSIVE NEW PRIVATE aInfTime[LEN(Ar_Model)] // Время создания основных баз данных моделей: Abs, Prc#, Inf# FOR z=1 TO LEN(Ar_Model) aInfTime[z] = FileTime(Ar_Model[z]+'.txt') NEXT DC_ASave(aInfTime, "_InfTime.arx") // Сформировать и записать массив времен создания основных баз данных моделей, если его не было *aInfTime = DC_ARestore("_InfTime.arx") ***** Копирование основных БД всех моделей из txt в dbf формат с числом полей до 2035 IF N_Cls > 2035 LB_Warning(L("Будут показаны только первые 2035 колонок"), L('5.5. Просмотр основных БД всех моделей' )) ENDIF * ########################################################################### // Открытие текстовых баз данных ******************************************** *** Создание баз данных в dbf-формате с найденной максимальной длиной наименования шкалы + строки и столбцы, как в Inf# GenDbfAbsOld(mLenNameMax) GenDbfPrcOld(mLenNameMax) GenDbfInfOld(mLenNameMax) *DC_ASave(aInfStruct, "_InfStruct.arx") // Когда БД создается - записывать структуру, когда открывается - считывать aInfStruct = DC_ARestore("_InfStruct.arx") *DC_ASave(aStrEmpty, "_aStrEmpty.arx") // Записывать только после расчета Abs.txt, а при расчете остальных БД только считывать *DC_ASave(aColEmpty, "_aColEmpty.arx") aStrEmpty = DC_ARestore("_aStrEmpty.arx") aColEmpty = DC_ARestore("_aColEmpty.arx") ************************************************* ***** Формирование пустой записи N_Col = N_Cls+6 // Число полей CrLf = CHR(13)+CHR(10) // Конец строки (записи) Lc_buf = "" FOR j=1 TO N_Col * S = IF(j=2*INT(j/2),"#","X") // Для отладки S = " " // Для работы Lc_buf = Lc_buf + REPLICATE(S, aInfStruct[j,3]) NEXT Lc_buf = Lc_buf + CrLf PUBLIC Len_LcBuf := LEN(Lc_buf) ****** Создаем стат.базы и базы знаний (7 по частным критериям знаний) Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } PUBLIC nHandle[LEN(Ar_Model)] FOR z=1 TO LEN(Ar_Model) nHandle[z] := FOpen( Ar_Model[z]+".txt", FO_READWRITE ) // Открыть все текстовые базы данных ######################################## NEXT **** Рассчет массива начальных позиций полей в строке PUBLIC aPos[N_Col] aPos[1] = 1 FOR j=2 TO N_Col aPos[j] = aPos[j-1] + aInfStruct[j-1,3] NEXT * ########################################################################### ***** Открытие основных БД.dbf всех моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() // Количество классов (градаций классификационных шкал) FOR z=1 TO LEN(Ar_Model) M_Inf = Ar_Model[z] USE (M_Inf) EXCLUSIVE NEW NEXT ***************************** nMax = N_Gos + 4 + ( N_Gos + 3 ) * 9 Mess = L('Копирование основных баз данных моделей: Abs, Prc#, Inf#: txt => dbf') @ 4,5 DCPROGRESS oProgr SIZE 80,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 DCREAD GUI TITLE Mess PARENT @oDial FIT EXIT oDial:show() nTime = 0 DC_GetProgress(oProgr,0,nMax) ***************************** *** Копирование БД.txt => БД.dbf ************** (но не более 2035 полей классов) mNCls = IF(N_Cls<=2035,N_Cls,2035) FOR z=1 TO LEN(Ar_Model) M_Inf = Ar_Model[z] SELECT(M_Inf) FOR i=1 TO N_Gos * IF aStrEmpty[i] DBGOTO(i) Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], i, 1 ));FIELDPUT(1, Fv) Fv = LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], i, 2 ) ;FIELDPUT(2, Fv) FOR j=1 TO mNCls * IF aColEmpty[j] Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], i, 2+j ));FIELDPUT(2+j, Fv) * ENDIF NEXT FOR j=1 TO 3 Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], i, mNCls+2+j ));FIELDPUT(mNCls+2+j, Fv) NEXT * ENDIF DC_GetProgress(oProgr, ++nTime, nMax) NEXT FOR i=1 TO 4 DBGOTO(N_Gos+i) Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], N_Gos+i, 1 ));FIELDPUT(1, Fv) Fv = LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], N_Gos+i, 2 ) ;FIELDPUT(2, Fv) FOR j=1 TO mNCls * IF aColEmpty[j] Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], N_Gos+i, 2+j ));FIELDPUT(2+j, Fv) * ENDIF NEXT FOR j=1 TO 3 Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], N_Gos+i, mNCls+2+j ));FIELDPUT(mNCls+2+j, Fv) NEXT DC_GetProgress(oProgr, ++nTime, nMax) NEXT NEXT DC_GetProgress(oProgr,nMax,nMax) oDial:Destroy() ***** Открытие основных БД.dbf всех моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() // Количество классов (градаций классификационных шкал) Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } FOR z=1 TO LEN(Ar_Model) M_Inf = Ar_Model[z] USE (M_Inf) EXCLUSIVE NEW NEXT CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций FOR z=1 TO LEN(nHandle) FClose( nHandle[z] ) // Закрытие всех txt баз данных ###################################### NEXT RETURN NIL *********************************************************************************************************************************************** ******* Графика Роджера. Операции с графикой на основе манипулирования массивами. Определение характеристик пикселей. *********************************************************************************************************************************************** *STATIC snHdll *FUNCTION Main() FUNCTION DC_Graph() LOCAL GetList[0], GetOptions, oSay, hDC1, hDC2, oStatic1, oStatic2, aPixel cFileName = 'colors.bmp' IF .NOT.FILE(cFileName) Mess = L('В текущей папке нет файла: "')+ cFileName+'"' LB_Warning(Mess, L("Экспериментальная графика Роджера" )) RETURN NIL ENDIF PUBLIC mMouseOnOff := .F. @ 0,0 DCSTATIC TYPE XBPSTATIC_TYPE_BITMAP ; CAPTION L("colors.jpg") ; OBJECT oStatic1 ; PREEVAL {|o|o:autoSize := .t.} ; EVAL {|o|hDC1 := GetWindowDC(o:getHWnd()), ; o:motion := {|a,b,o|ShowColor( hDC1, a, oSay, o )}, ; aPixel := Array(o:caption:xSize,o:caption:ySize)} @ 0,250 DCSTATIC TYPE XBPSTATIC_TYPE_BITMAP; CAPTION L("colors.jpg") ; PREEVAL {|o|o:autoSize := .t.} ; OBJECT oStatic2 ; EVAL {|o|hDC2 := GetWindowDC(o:getHWnd())} *-------- DC H = 20 // Высота кнопки W = 80 // Ширина кнопки D = 3 // Расстояние между кнопками @ 50,0 DCSAY L(' ') SAYSIZE 350,20 FONT '10.Lucida Console' OBJECT oSay @ 100,0 DCPUSHBUTTON CAPTION L('Clear Image' ) SIZE 100,20 ACTION {||ClearImage(hDC2,aPixel)} @ DCGUI_ROW, DCGUI_COL + D DCPUSHBUTTON CAPTION L('Transfer Image') SIZE W,H ACTION {||TransferImage(hDC1,hDC2,aPixel)} @ DCGUI_ROW, DCGUI_COL + D DCPUSHBUTTON CAPTION L('Flip Image' ) SIZE W,H ACTION {||FlipImage(hDC1,hDC2,aPixel)} @ DCGUI_ROW, DCGUI_COL + D DCPUSHBUTTON CAPTION L('Rotate Image' ) SIZE W,H ACTION {||RotateImage(hDC1,hDC2,aPixel)} @ DCGUI_ROW, DCGUI_COL + D DCPUSHBUTTON CAPTION L('Load Array' ) SIZE W,H ACTION {||LoadArray(hDC1,aPixel)} *-------- LC @ DCGUI_ROW, DCGUI_COL + D DCPUSHBUTTON CAPTION L('Спектр' ) SIZE W,H ACTION {||SpectrumSpiral(hDC2,aPixel)} @ DCGUI_ROW, DCGUI_COL + D DCPUSHBUTTON CAPTION L('Контур' ) SIZE W,H ACTION {||OutLine(hDC1,hDC2,aPixel)} @ DCGUI_ROW, DCGUI_COL + D DCPUSHBUTTON CAPTION L('Рамка' ) SIZE W,H ACTION {||Trimming(hDC1,hDC2,aPixel)} @ DCGUI_ROW, DCGUI_COL + D DCPUSHBUTTON CAPTION L('Яркость +' ) SIZE W,H ACTION {||LightImage(hDC1,hDC2,aPixel)} @ DCGUI_ROW, DCGUI_COL + D DCPUSHBUTTON CAPTION L('Яркость -' ) SIZE W,H ACTION {||DarkImage(hDC1,hDC2,aPixel)} @ DCGUI_ROW, DCGUI_COL + D DCPUSHBUTTON CAPTION L('Контраст +' ) SIZE W,H ACTION {||ContrastH(hDC1,hDC2,aPixel)} @ DCGUI_ROW, DCGUI_COL + D DCPUSHBUTTON CAPTION L('Контраст -' ) SIZE W,H ACTION {||ContrastL(hDC1,hDC2,aPixel)} @ DCGUI_ROW, DCGUI_COL + D DCPUSHBUTTON CAPTION L('Mouse On/Off' ) SIZE W,H ACTION {||MouseOnOff(hDC1,hDC2,aPixel)} DCGETOPTIONS PIXEL DCREAD GUI FIT TITLE L('Pixel Test') OPTIONS GetOptions ; EVAL {||ClearImage(hDC2,aPixel)} RETURN nil ****************************************************** * --------- FUNCTION ContrastH( hDC1, hDC2, aPixel ) // Увеличить контрастность LOCAL i, j, nColor, lEmptyArray := aPixel[1,1] == nil, ; nXSize := Len(aPixel), nYSize := Len(aPixel[1]) LOCAL hMemoryDC := CreateMemoryDC( hDC1, nXSize, nYSize ) // Для ускорения работы GetPixel() примерно в 50 раз D = 5 // Шаг изменения яркости при одном нажатии nColorB := GraMakeRGBColor({ 0, 0, 0}) // 33554431. От черного до белого 256*256*256 = 16777216 = 2 ^ 24 цветов nColorW := GraMakeRGBColor({255,255,255}) // 16777216. White = 16777216, Black = 33554431 *MsgBox(STR(nColorW)+STR(nColorB)) FOR i := 0 TO nXSize-1 FOR j := 0 TO nYSize-1 IF lEmptyArray nColor = GetPixel(hMemoryDC,i,j) ELSE nColor = aPixel[i+1,j+1] ENDIF nColor = AutomationTranslateColor(nColor, .t.) IF GraIsRGBColor(nColor) aRGB = GraGetRGBIntensity(nColor) nColorP = GraMakeRGBColor(aRGB) nColorN = nColorW + ( nColorB - nColorW ) / 2 // Нейтральный цвет (середина по яркости) * MsgBox(STR(nColorP)+STR(nColorN)) IF nColorP < nColorN // Светлый сделать темнее aRGB[1] = IF(aRGB[1]-D > 0, aRGB[1]-D, 0 ) aRGB[2] = IF(aRGB[2]-D > 0, aRGB[2]-D, 0 ) aRGB[3] = IF(aRGB[3]-D > 0, aRGB[3]-D, 0 ) ENDIF IF nColorP > nColorN // Темный сделать светлее aRGB[1] = IF(aRGB[1]+D < 255, aRGB[1]+D, 255 ) aRGB[2] = IF(aRGB[2]+D < 255, aRGB[2]+D, 255 ) aRGB[3] = IF(aRGB[3]+D < 255, aRGB[3]+D, 255 ) ENDIF aPixel[i+1,j+1] := AutomationTranslateColor(GraMakeRGBColor(aRGB),.f.) SetPixel(hDC2,i,j,aPixel[i+1,j+1]) ENDIF NEXT NEXT RETURN nil * --------- FUNCTION ContrastL( hDC1, hDC2, aPixel ) // Уменьшить контрастность LOCAL i, j, nColor, lEmptyArray := aPixel[1,1] == nil, ; nXSize := Len(aPixel), nYSize := Len(aPixel[1]) LOCAL hMemoryDC := CreateMemoryDC( hDC1, nXSize, nYSize ) // Для ускорения работы GetPixel() примерно в 50 раз D = 5 // Шаг изменения яркости при одном нажатии nColorB := GraMakeRGBColor({ 0, 0, 0}) // 33554431. От черного до белого 256*256*256 = 16777216 = 2 ^ 24 цветов nColorW := GraMakeRGBColor({255,255,255}) // 16777216. White = 16777216, Black = 33554431 *MsgBox(STR(nColorW)+STR(nColorB)) FOR i := 0 TO nXSize-1 FOR j := 0 TO nYSize-1 IF lEmptyArray nColor = GetPixel(hMemoryDC,i,j) ELSE nColor = aPixel[i+1,j+1] ENDIF nColor = AutomationTranslateColor(nColor, .t.) IF GraIsRGBColor(nColor) aRGB = GraGetRGBIntensity(nColor) nColorP = GraMakeRGBColor(aRGB) nColorN = nColorW + ( nColorB - nColorW ) / 2 // Нейтральный цвет (середина по яркости) * MsgBox(STR(nColorP)+STR(nColorN)) IF nColorP < nColorN // Светлый сделать еще светлее aRGB[1] = IF(aRGB[1]+D < 255, aRGB[1]+D, 255 ) aRGB[2] = IF(aRGB[2]+D < 255, aRGB[2]+D, 255 ) aRGB[3] = IF(aRGB[3]+D < 255, aRGB[3]+D, 255 ) ENDIF IF nColorP > nColorN // Темный сделать еще темнее aRGB[1] = IF(aRGB[1]-D > 0, aRGB[1]-D, 0 ) aRGB[2] = IF(aRGB[2]-D > 0, aRGB[2]-D, 0 ) aRGB[3] = IF(aRGB[3]-D > 0, aRGB[3]-D, 0 ) ENDIF aPixel[i+1,j+1] := AutomationTranslateColor(GraMakeRGBColor(aRGB),.f.) SetPixel(hDC2,i,j,aPixel[i+1,j+1]) ENDIF NEXT NEXT RETURN nil * --------- FUNCTION DarkImage( hDC1, hDC2, aPixel ) LOCAL i, j, nColor, lEmptyArray := aPixel[1,1] == nil, ; nXSize := Len(aPixel), nYSize := Len(aPixel[1]) LOCAL hMemoryDC := CreateMemoryDC( hDC1, nXSize, nYSize ) // Для ускорения работы GetPixel() примерно в 50 раз D = 10 // Шаг изменения яркости при одном нажатии FOR i := 0 TO nXSize-1 FOR j := 0 TO nYSize-1 IF lEmptyArray nColor = GetPixel(hMemoryDC,i,j) ELSE nColor = aPixel[i+1,j+1] ENDIF nColor = AutomationTranslateColor(nColor, .t.) IF GraIsRGBColor(nColor) aRGB = GraGetRGBIntensity(nColor) aRGB[1] = IF(aRGB[1]-D > 0, aRGB[1]-D, 0 ) aRGB[2] = IF(aRGB[2]-D > 0, aRGB[2]-D, 0 ) aRGB[3] = IF(aRGB[3]-D > 0, aRGB[3]-D, 0 ) aPixel[i+1,j+1] := AutomationTranslateColor(GraMakeRGBColor(aRGB),.f.) SetPixel(hDC2,i,j,aPixel[i+1,j+1]) ENDIF NEXT NEXT RETURN nil * --------- FUNCTION LightImage( hDC1, hDC2, aPixel ) LOCAL i, j, nColor, lEmptyArray := aPixel[1,1] == nil, ; nXSize := Len(aPixel), nYSize := Len(aPixel[1]) LOCAL hMemoryDC := CreateMemoryDC( hDC1, nXSize, nYSize ) // Для ускорения работы GetPixel() примерно в 50 раз D = 10 // Шаг изменения яркости при одном нажатии FOR i := 0 TO nXSize-1 FOR j := 0 TO nYSize-1 IF lEmptyArray nColor = GetPixel(hMemoryDC,i,j) ELSE nColor = aPixel[i+1,j+1] ENDIF nColor = AutomationTranslateColor(nColor, .t.) // .t. - Из COM в RGB * DC_DebugQout(nColor) IF GraIsRGBColor(nColor) aRGB = GraGetRGBIntensity(nColor) * DC_DebugQout(nColor, aRGB[1], aRGB[2], aRGB[3] ) aRGB[1] = IF(aRGB[1]+D < 255, aRGB[1]+D, 255 ) aRGB[2] = IF(aRGB[2]+D < 255, aRGB[2]+D, 255 ) aRGB[3] = IF(aRGB[3]+D < 255, aRGB[3]+D, 255 ) aPixel[i+1,j+1] := AutomationTranslateColor(GraMakeRGBColor(aRGB),.f.) // .f. - Из RGB в COM SetPixel(hDC2,i,j,aPixel[i+1,j+1]) ENDIF NEXT NEXT RETURN nil * --------- *FUNCTION LoadArray( hDC1, aPixel ) *LOCAL i, j, oScrn, nXSize := Len(aPixel), nYSize := Len(aPixel[1]) *LOCAL hMemoryDC := CreateMemoryDC( hDC1, nXSize, nYSize ) // Для ускорения работы GetPixel() примерно в 50 раз *IF !aPixel[1,1] == nil * DCMSGBOX 'Array is already loaded!' * RETURN nil *ENDIF *oScrn := DC_WaitOn('',,,,,,,,,,,.F.) *FOR i := 1 TO nXSize * FOR j := 1 TO nYSize * aPixel[i,j] := GetPixel(hMemoryDC,i-1,j-1) * NEXT *NEXT *DC_Impl(oScrn) *RETURN(aPixel) * --------- FUNCTION ClearImage( hDC2, aPixel ) LOCAL i, j, nXSize := Len(aPixel), nYSize := Len(aPixel[1]) LOCAL nColor := AutomationTranslateColor(GraMakeRGBColor({255,255,255}),.f.) LOCAL hMemoryDC := CreateMemoryDC( hDC2, nXSize, nYSize ) // Для ускорения работы GetPixel() примерно в 50 раз FOR i := 0 TO nXSize FOR j := 0 TO nYSize SetPixel(hMemoryDC,i,j,nColor) NEXT NEXT RETURN nil * ---------- FUNCTION ClearImage1( hDC1, aPixel ) LOCAL i, j, nXSize := Len(aPixel), nYSize := Len(aPixel[1]) LOCAL nColor := AutomationTranslateColor(GraMakeRGBColor({255,255,255}),.f.) FOR i := 0 TO nXSize FOR j := 0 TO nYSize SetPixel(hDC1,i,j,nColor) NEXT NEXT RETURN nil * ---------- FUNCTION TransferImage( hDC1, hDC2, aPixel ) LOCAL i, j, nColor, lEmptyArray := aPixel[1,1] == nil, ; nXSize := Len(aPixel), nYSize := Len(aPixel[1]) LOCAL hMemoryDC := CreateMemoryDC( hDC1, nXSize, nYSize ) // Для ускорения работы GetPixel() и SetPixel() примерно в 50 раз FOR i := 0 TO nXSize-1 FOR j := 0 TO nYSize-1 IF lEmptyArray SetPixel(hDC2,i,j,GetPixel(hMemoryDC,i,j)) ELSE SetPixel(hDC2,i,j,aPixel[i+1,j+1]) ENDIF NEXT NEXT RETURN nil * ---------- FUNCTION FlipImage( hDC1, hDC2, aPixel ) LOCAL i, j, lEmptyArray := aPixel[1,1] == nil, ; nXSize := Len(aPixel), nYSize := Len(aPixel[1]) LOCAL hMemoryDC := CreateMemoryDC( hDC1, nXSize, nYSize ) // Для ускорения работы GetPixel() примерно в 50 раз FOR i := 0 TO nXSize-1 FOR j := 0 TO nYSize-1 IF lEmptyArray SetPixel(hDC2,j,i,GetPixel(hMemoryDC,j,nXSize-i)) ELSE SetPixel(hDC2,j,i,aPixel[i+1,j+1]) ENDIF NEXT NEXT RETURN nil * ---------- FUNCTION RotateImage( hDC1, hDC2, aPixel ) LOCAL i, j, lEmptyArray := aPixel[1,1] == nil, ; nXSize := Len(aPixel), nYSize := Len(aPixel[1]) LOCAL hMemoryDC := CreateMemoryDC( hDC1, nXSize, nYSize ) // Для ускорения работы GetPixel() примерно в 50 раз FOR i := 0 TO nXSize-1 FOR j := 0 TO nYSize-1 IF lEmptyArray SetPixel(hDC2,i,j,GetPixel(hMemoryDC,j,nXSize-i)) ELSE SetPixel(hDC2,i,j,aPixel[j+1,nXSize-i]) ENDIF NEXT NEXT RETURN nil * --------- *PROC appsys ; RETURN * --------- FUNCTION MouseOnOff(hDC1,hDC2,aPixel) // Включить/выключить рисование мышкой mMouseOnOff = IF(mMouseOnOff, .F., .T.) RETURN nil * --------- STATIC FUNCTION ShowColor( hDC, aCoords, oSay, oStatic ) LOCAL nColor aCoords[2] := oStatic:currentSize()[2] - aCoords[2] nColor := GetPixel(hDC, aCoords[1], aCoords[2]) ***** RGB-Color (Роджер) *oSay:SetCaption(L('Color: ') + DC_Array2String(GraGetRGBIntensity(AutomationTranslateColor(nColor,.T.))) + ' Coords: ' + DC_Array2String(aCoords)) ***** nColor+RGB oSay:SetCaption(L('Col=') + ALLTRIM(STR(nColor)) + ' RGB' + DC_Array2String(GraGetRGBIntensity(AutomationTranslateColor(nColor,.T.))) + ' X,Y' + DC_Array2String(aCoords)) ***** Истинно-черный, а не отсутствие цвета: nColor=16843009, RGB{1,1,1} *oSay:SetCaption(L('Col=') + ALLTRIM(IF(nColor>0,STR(nColor),STR(GraMakeRGBColor({1,1,1})))) + ' RGB' + DC_Array2String(GraGetRGBIntensity(AutomationTranslateColor(nColor,.T.))) + ' X,Y' + DC_Array2String(aCoords)) IF mMouseOnOff nColorMouse := AutomationTranslateColor(GraMakeRGBColor({255,0,0}),.f.) SetPixel(hDC,aCoords[1],aCoords[2], nColorMouse ) ENDIF RETURN nil * -------- FUNCTION OutLine(hDC1, hDC2, aPixel ) // Нарисовать внешний контур LOCAL i, j, nXSize := Len(aPixel), nYSize := Len(aPixel[1]) LOCAL hMemoryDC := CreateMemoryDC( hDC1, nXSize, nYSize ) // Для ускорения работы GetPixel() примерно в 50 раз *** Нарисовать контур изображения символа *** Еще можно двигаться по 2 диагоналям *** Еще можно учитывать значения всех 8 пикселей прилегающих к данному (или всех, прилегающих к этим 8 и т.д.) *** Еще можно рисовать контур только для R, только G, или только B fColor := AutomationTranslateColor(GraMakeRGBColor({255,0,0}),.f.) LB_Warning(L('Это устаревший вариант. См. режим "Оконтуривание" в подсистеме 4.8!'),L('4.8. Геокогнитивная подсистема "Эйдос"')) FOR x = 1 TO nXSize mPixOld = GetPixel(hMemoryDC, x-1, 0) FOR y = 1 TO nYSize mPixNew = IF(aPixel[1,1]==nil, GetPixel(hMemoryDC,x-1,y-1), aPixel[x,y] ) IF mPixOld <> mPixNew mPixOld = mPixNew SetPixel(hDC2, x-1, y-1, fColor) ENDIF NEXT NEXT FOR y = 1 TO nYSize mPixOld = GetPixel(hMemoryDC, 0, y-1) FOR x = 1 TO nXSize mPixNew = IF(aPixel[1,1]==nil, GetPixel(hMemoryDC,x-1,y-1), aPixel[x,y] ) IF mPixOld <> mPixNew mPixOld = mPixNew SetPixel(hDC2, x-1, y-1, fColor) ENDIF NEXT NEXT * cFileName = ConvToAnsiCP("Спектр в форме спирали.bmp") * DC_Scrn2ImageFile( oStatic, cFileName ) RETURN nil * -------- FUNCTION SpectrumSpiral( hDC2, aPixel ) LOCAL i, j, nXSize := Len(aPixel), nYSize := Len(aPixel[1]) PUBLIC X_MaxW := nXSize, Y_MaxW := nYSize // Размер графического окна для изображения в пикселях (чтобы помещалось на ультрабук) *** Расчет позиций центров изображений в стилях "Контур" и "Витраж" mRadiusMax = X_MaxW / 4 Ax = X_MaxW / ( 2 * mRadiusMax ) Ay = Y_MaxW / ( 2 * mRadiusMax ) X0L = X_MaxW / 2 // Для левого изображения Y0L = Y_MaxW / 2 X0R = X_MaxW / 2 // Для правого изображения Y0R = Y_MaxW / 2 ****** Гармонические последовательности цветов Column = 0 Ax = 0.05 Ay = 0.05 Kx = 1 Ky = 1 FOR n = 0 TO 360*30 STEP 0.1 ma := 127.5 mb := 127.5 mc := 127.5 mU := 0 mV := 120 mW := 240 mColor = n R := INT( ma * (1 + COS( ( mColor + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( mColor + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( mColor + mW ) * GradRad ) ) ) fColor := GraMakeRGBColor({ R, G, B }) ***** Закрасить фон прямоугольника *************** * GraSetColor( hDC2, fColor, fColor ) fColor := AutomationTranslateColor(GraMakeRGBColor({R,G,B}),.f.) Column = Column + 1 X1 := X0R + Ax * Column * COS((Column-1) * GradRad ) * Kx Y1 := Y0R + Ay * Column * SIN((Column-1) * GradRad ) * Ky * GraArc( oPS, { X1, Y1 }, RS, ,,, GRA_OUTLINEFILL ) IF X0R - X_MaxW / 2 <= X1 .AND. X1 <= X0R + X_MaxW / 2 IF Y0R - Y_MaxW / 2 <= Y1 .AND. Y1 <= Y0R + Y_MaxW / 2 SetPixel(hDC2, X1, Y1, fColor) ENDIF ENDIF NEXT * cFileName = ConvToAnsiCP("Спектр в форме спирали.bmp") * DC_Scrn2ImageFile( oStatic, cFileName ) RETURN nil * ---------- ************************************************************************************** ******** Нарисовать границы минимальной достаточной области для изображения + 1 пиксел ************************************************************************************** FUNCTION Trimming(hDC1, hDC2, aPixel) LOCAL i, j, nXSize := Len(aPixel), nYSize := Len(aPixel[1]) LOCAL hMemoryDC := CreateMemoryDC( hDC1, nXSize, nYSize ) // Для ускорения работы GetPixel() примерно в 50 раз fColor := AutomationTranslateColor(GraMakeRGBColor({255,0,0}),.f.) *** Определить координаты левой границы области отображения X1 X1 = +9999999 FOR x = 1 TO nXSize mPixOld = IF(aPixel[1,1]==nil, GetPixel(hMemoryDC,x-1,0), aPixel[x,1] ) FOR y = 1 TO nYSize mPixNew = IF(aPixel[1,1]==nil, GetPixel(hMemoryDC,x-1,y-1), aPixel[x,y] ) * MsgBox("x="+STR(x)+", y="+STR(y)+", mPix="+STR(mPix)) IF mPixNew <> mPixOld X1 = MIN(X1,x) * GraMarker ( oPS, { x-1, y-1 } ) SetPixel(hDC2, x-1, y-1, fColor) EXIT ENDIF NEXT NEXT *** Определить координаты правой границы области отображения X2 X2 = -9999999 FOR x = nXSize TO 1 STEP -1 mPixOld = IF(aPixel[1,1]==nil, GetPixel(hMemoryDC,x-1,0), aPixel[x,1] ) FOR y = 1 TO nYSize mPixNew = IF(aPixel[1,1]==nil, GetPixel(hMemoryDC,x-1,y-1), aPixel[x,y] ) IF mPixNew <> mPixOld X2 = MAX(X2,x) * GraMarker ( oPS, { x-1, y-1 } ) SetPixel(hDC2, x-1, y-1, fColor) EXIT ENDIF NEXT NEXT *** Определить координаты верхней границы области отображения Y1 Y1 = +9999999 FOR y = 1 TO nYSize mPixOld = IF(aPixel[1,1]==nil, GetPixel(hMemoryDC,1,y-1), aPixel[1,y] ) FOR x = 1 TO nXSize mPixNew = IF(aPixel[1,1]==nil, GetPixel(hMemoryDC,x-1,y-1), aPixel[x,y] ) IF mPixNew <> mPixOld Y1 = MIN(Y1,y) * GraMarker ( oPS, { x-1, y-1 } ) SetPixel(hDC2, x-1, y-1, fColor) EXIT ENDIF NEXT NEXT *** Определить координаты нижней границы области отображения Y2 Y2 = -9999999 FOR y = nYSize TO 1 STEP -1 mPixOld = IF(aPixel[1,1]==nil, GetPixel(hMemoryDC,1,y-1), aPixel[1,y] ) FOR x = 1 TO nXSize mPixNew = IF(aPixel[1,1]==nil, GetPixel(hMemoryDC,x-1,y-1), aPixel[x,y] ) IF mPixNew <> mPixOld Y2 = MAX(Y2,y) * GraMarker ( oPS, { x-1, y-1 } ) SetPixel(hDC2, x-1, y-1, fColor) EXIT ENDIF NEXT NEXT *** Нарисовать прямоугольник области отображения символов с синими границами IF X1 <> +9999999 .AND. X2 <> -9999999 .AND. Y1 <> +9999999 .AND. Y2 <> -9999999 * GraSetColor( oPS, GRA_CLR_RED, GRA_CLR_RED ) * GraBox( oPS, { X1, Y1 }, { X2, Y2 }, GRA_OUTLINE ) * GraSetColor( oPS, GRA_CLR_BLACK, GRA_CLR_BLACK ) * cFileName = "All_images.bmp" * ERASE( cFileName );DC_Scrn2ImageFile( oStatic, cFileName ) // Стереть старый файл и записать новый * MsgBox("{X1="+ALLTRIM(STR(X1))+", Y1="+ALLTRIM(STR(Y1))+"}, {X2="+ALLTRIM(STR(X2))+", Y2="+ALLTRIM(STR(Y2))+"}") fColor := AutomationTranslateColor(GraMakeRGBColor({0,0,255}),.f.) FOR x=X1 TO X2 SetPixel(hDC2, x-1, Y1-1, fColor) NEXT FOR x=X1 TO X2 SetPixel(hDC2, x-1, Y2-1, fColor) NEXT FOR y=Y1 TO Y2 SetPixel(hDC2, X1-1, y-1, fColor) NEXT FOR y=Y1 TO Y2 SetPixel(hDC2, X2-1, y-1, fColor) NEXT ENDIF PRIVATE aXY[4] aXY[1] = X1 aXY[2] = Y1 aXY[3] = X2 aXY[4] = Y2 RETURN(aXY) * ---------- *********************************************************************************************************************************************** *********************************************************************************************************************************************** ******** 4.1.6. Назначения объектов на классы (задача о назначениях) Функционально-стоимостной анализ в управлении персоналом ******** 4.1.6.1. Задание ограничений на ресурсы по классам, Razrab(). ******** 4.1.6.2. Ввод затрат на объекты, Razrab(). ******** 4.1.6.3. Назначения объектов на классы (LC-алгоритм), Razrab(). ******** 4.1.6.4. Сравнение эффективности LC и RND алгоритмов, Razrab(). *********************************************************************************************************************************************** ******** 4.1.6.1. Задание ограничений на ресурсы по классам ******** В данном режиме мы можем ввести и скорректировать ограничения на ресурсы по классам *********************************************************************************************************************************************** FUNCTION F4_1_6_1() LOCAL Getlist := {}, oProgress, oDialog PUBLIC Time_progress, Wsego, lOk := .T., Sec_1, GetOptions Running(.T.) IF ApplChange("4.1.6.1()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ********* Проверки на существование необходимых БД FlagError = .F. IF .NOT. FILE("Abs.txt") // БД абс.частот LB_Warning(L("Проведите рассчет матрицы абсолютных частот Abs.txt в режиме 3.1 или 3.5!")) FlagError = .T. ENDIF IF .NOT. FILE("Prc1.txt") .OR.; // БД процентных распределений .NOT. FILE("Prc2.txt") LB_Warning(L("Проведите рассчет матриц условных и безусловных процентных распределений Prc1 и Prc2 в режиме 3.2 или 3.5 !")) FlagError = .T. ENDIF IF .NOT. FILE("Inf1.txt") // БЗ-1 LB_Warning(L("Проведите рассчет баз знаний Inf1 - Inf7 в режиме 3.3 или 3.5!")) FlagError = .T. ENDIF IF FILE("_RaspInf.arx") // Файл с информацией о том, в какой модели было проведено распознавание M_RaspInf = DC_ARestore("_RaspInf.arx") Ar_Model := {"Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } IF M_CurrInf <> M_RaspInf Mess = L("Результаты распознавания получены в модели модели: #, отличающейся от текущей: $") Mess = STRTRAN(Mess, "#", Ar_Model[M_RaspInf]) Mess = STRTRAN(Mess, "$", Ar_Model[M_CurrInf]) LB_Warning(Mess, L("4.1.6.1. Задача о назначениях. Задание ограничений на ресурсы по классам")) ENDIF ELSE aMess := {} AADD(aMess, L("Перед заданием ограничений на ресурсы по классам")) AADD(aMess, L("Необходимо выполнить режим 3.5 или 4.1.2 !!!")) LB_Warning(aMess, L("4.1.6.1. Задача о назначениях. Задание ограничений на ресурсы по классам")) FlagError = .T. ENDIF IF FlagError ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ***** Если нет БД ресурсов классов, то создать ее CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций IF .NOT. FILE("Klas_res.dbf") CrDBRes4161() ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Klas_res EXCLUSIVE NEW SELECT Klas_res DBGOTOP() ********* Открытие окна для просмотра и корректировки БД ресурсов /* ----- Create ToolBar ----- */ @ 31.5, 1 DCTOOLBAR oToolBar SIZE 150, 1.5 K=2.3 mMess = L('Помощь') DCADDBUTTON CAPTION mMess ; SIZE 5+K+LEN(mMess) ; ACTION {||Help4161(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Помощь по режиму 4.1.6.1') mMess = L('Заново сформировать базу ресурсов') DCADDBUTTON CAPTION mMess ; SIZE K+LEN(mMess) ; ACTION {||CrDBRes4161(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Помощь по режиму 4.1.6.1') mMess = L('Сформировать значения ресурсов автоматически') DCADDBUTTON CAPTION mMess ; SIZE K+LEN(mMess) ; ACTION {||AutoDB4161(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Помощь по режиму 4.1.6.1') mMess = L('Записать базу ресурсов в виде Excel-файла') DCADDBUTTON CAPTION mMess ; SIZE K+LEN(mMess) ; ACTION {||ExcelDB4161(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Помощь по режиму 4.1.6.1') aColors := { {GRA_CLR_WHITE,GRA_CLR_DARKRED },; {GRA_CLR_WHITE,GRA_CLR_DARKBLUE },; {GRA_CLR_BLACK,GRA_CLR_DARKGREEN} } aPres := ; { { XBP_PP_COL_HA_FGCLR, GRA_CLR_WHITE },; // Header FG Color { XBP_PP_COL_HA_BGCLR, GRA_CLR_DARKGRAY },; // Header BG Color { XBP_PP_COL_FA_FGCLR, GRA_CLR_YELLOW },; // Footer FG Color { XBP_PP_COL_FA_BGCLR, GRA_CLR_DARKGRAY },; // Footer BG Color { XBP_PP_COL_DA_ROWSEPARATOR, XBPCOL_SEP_DOTTED },; // Row Sep { XBP_PP_COL_DA_COLSEPARATOR, XBPCOL_SEP_DOTTED },; // Col Sep { XBP_PP_COL_HA_ALIGNMENT, XBPALIGN_LEFT },; // Header alignment (способ выравнивания наименований колонок) { XBP_PP_COL_DA_ROWHEIGHT, 22 },; // Row Height { XBP_PP_COL_DA_CELLHEIGHT, 22 } } // Cell Height /* ----- Create browse ----- */ @ 1, 0 DCBROWSE oBrowse ALIAS 'Klas_res' SIZE 150,30 ; EDIT xbeBRW_ItemSelected MODE DCGUI_BROWSE_EDITDOWN ; HEADLINES 4 ; // Кол-во строк в заголовке PRESENTATION aPres ; DCBROWSECOL FIELD Klas_res->Kod HEADER L("Код;класса" ) PARENT oBrowse WIDTH 5 PROTECT {|| .T. } // 1 Код класса DCBROWSECOL FIELD Klas_res->Name HEADER L("Наименование;класса" ) PARENT oBrowse WIDTH 30 PROTECT {|| .T. } // 2 Наименование класса DCBROWSECOL FIELD Klas_res->Resource HEADER L("Начальный;ресурс;класса" ) PARENT oBrowse WIDTH 7 FONT "10.Arial Bold" // 3 Начальный ресурс класса DCBROWSECOL FIELD Klas_res->OstatokRes HEADER L("Остаток;ресурса;класса" ) PARENT oBrowse WIDTH 6 PROTECT {|| .T. } // 4 Остаток ресурса класса DCBROWSECOL FIELD Klas_res->Kol_Obj HEADER L("Количество;объектов,;назначенных;на класс") PARENT oBrowse WIDTH 6 PROTECT {|| .T. } // 5 Количество объектов, назначенных на класс DCBROWSECOL FIELD Klas_res->Sum_UrSxod HEADER L("Суммарное;сходство;назначенных;объектов" ) PARENT oBrowse WIDTH 6 PROTECT {|| .T. } // 6 Суммарное сходство назначенных объектов DCBROWSECOL FIELD Klas_res->Sum_Zatrat HEADER L("Суммарные;затраты на;назначенные;объекты" ) PARENT oBrowse WIDTH 6 PROTECT {|| .T. } // 7 Суммарные затраты на назначенные объекты DCBROWSECOL FIELD Klas_res->Svz_UdSxod HEADER L("Средневз-;вешенное;удельное;сходство" ) PARENT oBrowse WIDTH 6 PROTECT {|| .T. } // 8 Средневзвешенное удельное сходство DCBROWSECOL FIELD Klas_res->Avr_UrSxod HEADER L("Средний;на объект;уровень;сходства" ) PARENT oBrowse WIDTH 6 PROTECT {|| .T. } // 9 Средний на объект уровень сходства DCBROWSECOL FIELD Klas_res->Avr_Zatrat HEADER L("Средние;на объект;затраты" ) PARENT oBrowse WIDTH 6 PROTECT {|| .T. } // 10 Средние на объект затраты DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; OPTIONS GetOptions ; MODAL ; TITLE L('4.1.6.1. Задача о назначениях. Задание ограничений на ресурсы по классам') ; FIT ; CLEAREVENTS ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN nil ************************************************************************************************** ******** Помощь по режиму 4.1.6.1 ************************************************************************************************** FUNCTION Help4161() aHelp := {} AADD(aHelp, L('Режим: "4.1.6. РАЦИОНАЛЬНОЕ НАЗНАЧЕНИЕ ОБЪЕКТОВ НА КЛАССЫ (ЗАДАЧА О РАНЦЕ). ЗАДАНИЕ ОГРАНИЧЕНИЙ НА РЕСУРСЫ ПО КЛАССАМ". ')) AADD(aHelp, L(' ')) AADD(aHelp, L('В данном режиме мы можем ввести и скорректировать ресурсы по классам, которые являются ограничениями при назначении объектов ')) AADD(aHelp, L('на классы и уменьшаются при назначении каждого объекта на величину затрат, заданную для данного объекта в режиме 4.1.6.2. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Значения ресурсов по каждому классу можно корректировать вручную, а можно сформировать расчетным путем по всем классам сразу. ')) AADD(aHelp, L('Во втором случае необходимо выбрать один из вариантов и задать его параметры: ')) AADD(aHelp, L('1. Значение ресурсов классов вычисляется методом линейной интерполяции значений ресурсов начального и конечного классов. ')) AADD(aHelp, L('2. Классы имеют одинаковый ресурс, вычисляемый как сумма ресурсов по всем классам, деленная на число классов. ')) AADD(aHelp, L('3. Классы имеют одинаковый ресурс, значение которого просто задается непосредственно в диалоге. ')) AADD(aHelp, L('4. Классы имеют случайные значения ресурсов, подчиняющиеся равномерному распределению с заданным средним значением. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Ссылки на работы в этой области: ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Луценко Е.В. Решение обобщенной задачи о назначениях в системно-когнитивном анализе / Е.В. Луценко, В.Е. Коржаков ')) AADD(aHelp, L('// Политематический сетевой электронный научный журнал Кубанского государственного аграрного университета (Научный журнал ')) AADD(aHelp, L('КубГАУ) [Электронный ресурс]. - Краснодар: КубГАУ, 2009. - №07(051). С. 83 - 108. - Шифр Информрегистра: 0420900012\0070, ')) AADD(aHelp, L('IDA [article ID]: 0510907004. - Режим доступа: http://ej.kubagro.ru/2009/07/pdf/04.pdf, 1,625 у.п.л. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Луценко Е.В., Коржаков В.Е., Ермоленко В.В. Интеллектуальные системы в контроллинге и менеджменте средних и малых фирм: ')) AADD(aHelp, L('Под науч. ред. д.э.н., проф. Е.В.Луценко. Монография (научное издание). - Майкоп: АГУ. 2011. - 392 с. ')) AADD(aHelp, L('- Режим доступа: http://lc.kubagro.ru/aidos/aidos11_LKE/index.htm ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Луценко Е.В. Автоматизированный системно-когнитивный анализ как метод комплексного решения проблемы управления персоналом с ')) AADD(aHelp, L('применением функционально-стоимостного анализа / Е.В. Луценко, В.Е. Коржаков // Политематический сетевой электронный научный ')) AADD(aHelp, L('журнал Кубанского государственного аграрного университета (Научный журнал КубГАУ) [Электронный ресурс]. - Краснодар: КубГАУ, 2014.')) AADD(aHelp, L('- №02(096). С. 1 - 16. - IDA [article ID]: 0961402001. - Режим доступа: http://ej.kubagro.ru/2014/02/pdf/01.pdf, 1 у.п.л. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Луценко Е.В. Управление персоналом с применением функционально-стоимостного и системно-когнитивного анализа / Е.В. Луценко, ')) AADD(aHelp, L('В.Е. Коржаков // Политематический сетевой электронный научный журнал Кубанского государственного аграрного университета (Научный ')) AADD(aHelp, L('журнал КубГАУ) [Электронный ресурс]. - Краснодар: КубГАУ, 2014. - №04(098). С. 1009 - 1041. - IDA [article ID]: 0981404075. ')) AADD(aHelp, L('- Режим доступа: http://ej.kubagro.ru/2014/04/pdf/75.pdf, 2,062 у.п.л. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Луценко Е.В. Интеллектуальное управление качеством систем путем решения обобщенной задачи о назначениях с применением АСК-анализа ')) AADD(aHelp, L('и системы <Эйдос-Х++> / Е.В. Луценко // Политематический сетевой электронный научный журнал Кубанского государственного аграрного ')) AADD(aHelp, L('университета (Научный журнал КубГАУ) [Электронный ресурс]. - Краснодар: КубГАУ, 2015. - №05(109). С. 1 - 51. - IDA [article ID]: ')) AADD(aHelp, L('1091505001. - Режим доступа: http://ej.kubagro.ru/2015/05/pdf/01.pdf, 3,188 у.п.л. ')) mHelpMax = -999;FOR h=1 TO LEN(aHelp);mHelpMax = MAX(mHelpMax, LEN(ALLTRIM(aHelp[h])));NEXT s=1;d=0.9;@0,0 DCGROUP oGroup1 CAPTION L(' ') SIZE mHelpMax-15, LEN(aHelp)*d+1.5 FOR h=1 TO LEN(aHelp);@s,2 DCSAY aHelp[h] SIZE 0 PARENT ogroup1;s=s+d;NEXT DCREAD GUI TO lExit FIT TITLE L('Помощь по режиму: "4.1.6. Рациональное назначение объектов на классы". (C) Система "ЭЙДОС-X++"') RETURN NIL ************************************************************************************************** ******************************************************************************************* ******** Автоматически сформировать значения ресурсов расчетным путем по всем классам сразу ******************************************************************************************* FUNCTION AutoDB4161() LOCAL GetList := {}, aPres, oBrowse, oToolBar, aColors, bColor, GetOptions LOCAL oBrowse1, oBrowse2, oBrowse3 IF FILE("_AutoDB4161.arx") aAutoDB4161 = DC_ARestore("_AutoDB4161.arx") mMetod = aAutoDB4161[1] // Метод формирования ресурсов классов (1,2,3,4) mRes1 = aAutoDB4161[2] // Ресурс начального класса mRes2 = aAutoDB4161[3] // Ресурс конечного класса mSumRes = aAutoDB4161[4] // Суммарный ресурс всех классов mZnaRes = aAutoDB4161[5] // Значение ресурса класса mResAvr = aAutoDB4161[6] // Среднее значение ресурса ELSE mMetod = 3 // Метод формирования ресурсов классов (1,2,3,4) mRes1 = 100 // Ресурс начального класса mRes2 = 10 // Ресурс конечного класса mSumRes = 1000 // Суммарный ресурс всех классов mZnaRes = 100 // Значение ресурса класса mResAvr = 100 // Среднее значение ресурса PRIVATE aAutoDB4161[6] aAutoDB4161[1] = mMetod // Метод формирования ресурсов классов (1,2,3,4) aAutoDB4161[2] = mRes1 // Ресурс начального класса aAutoDB4161[3] = mRes2 // Ресурс конечного класса aAutoDB4161[4] = mSumRes // Суммарный ресурс всех классов aAutoDB4161[5] = mZnaRes // Значение ресурса класса aAutoDB4161[6] = mResAvr // Среднее значение ресурса ENDIF *1. Значение ресурсов классов вычисляется методом линейной интерполяции значений ресурсов начального и конечного классов. *2. Классы имеют одинаковый ресурс, вычисляемый как сумма ресурсов по всем классам, деленная на число классов. *3. Классы имеют одинаковый ресурс, значение которого просто задается непосредственно в диалоге. *4. Классы имеют случайные значения ресурсов, подчиняющиеся равномерному распределению с заданным средним значением. mLen = 75.0 @ 1, 1 DCGROUP oGroup1 CAPTION L('Задайте метод формирования ресурсов классов:') SIZE mLen, 5.5 @ 1, 1 DCRADIO mMetod VALUE 1 PROMPT L('Метод линейной интерполяции значений ресурсов начального и конечного классов' ) PARENT oGroup1 @ 2, 1 DCRADIO mMetod VALUE 2 PROMPT L('Значение ресурса класса вычисляется как сумма ресурсов, деленная на число классов' ) PARENT oGroup1 @ 3, 1 DCRADIO mMetod VALUE 3 PROMPT L('Значение ресурса для всех классов одинаково и задается в диалоге' ) PARENT oGroup1 @ 4, 1 DCRADIO mMetod VALUE 4 PROMPT L('Классы имеют случайные значения ресурсов, подчиняющиеся равномерному распределению') PARENT oGroup1 @ 1,mLen+2 DCGROUP oGroup2 CAPTION L('Задайте параметры:') SIZE 35.0, 5.5 mPos = 15.50 mS1 = 0.25 mS2 = 0.10 @ 1+mS1, 2 DCSAY L("Рес.нач.класса:") PARENT oGroup2 EDITPROTECT {|| .NOT.mMetod=1 } HIDE {|| .NOT.mMetod=1 } @ 1+mS2, mPos DCGET mRes1 PARENT oGroup2 PICTURE "#######.#######" EDITPROTECT {|| .NOT.mMetod=1 } HIDE {|| .NOT.mMetod=1 } @ 2+mS1, 2 DCSAY L("Рес.кон.класса:") PARENT oGroup2 EDITPROTECT {|| .NOT.mMetod=1 } HIDE {|| .NOT.mMetod=1 } @ 2+mS2, mPos DCGET mRes2 PARENT oGroup2 PICTURE "#######.#######" EDITPROTECT {|| .NOT.mMetod=1 } HIDE {|| .NOT.mMetod=1 } @ 2+mS1, 2 DCSAY L("Суммарный рес.:") PARENT oGroup2 EDITPROTECT {|| .NOT.mMetod=2 } HIDE {|| .NOT.mMetod=2 } @ 2+mS2, mPos DCGET mSumRes PARENT oGroup2 PICTURE "#######.#######" EDITPROTECT {|| .NOT.mMetod=2 } HIDE {|| .NOT.mMetod=2 } @ 3+mS1, 2 DCSAY L("Значен.ресурса:") PARENT oGroup2 EDITPROTECT {|| .NOT.mMetod=3 } HIDE {|| .NOT.mMetod=3 } @ 3+mS2, mPos DCGET mZnaRes PARENT oGroup2 PICTURE "#######.#######" EDITPROTECT {|| .NOT.mMetod=3 } HIDE {|| .NOT.mMetod=3 } @ 4+mS1, 2 DCSAY L("Сред.знач.рес.:") PARENT oGroup2 EDITPROTECT {|| .NOT.mMetod=4 } HIDE {|| .NOT.mMetod=4 } @ 4+mS2, mPos DCGET mResAvr PARENT oGroup2 PICTURE "#######.#######" EDITPROTECT {|| .NOT.mMetod=4 } HIDE {|| .NOT.mMetod=4 } DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; ADDBUTTONS; OPTIONS GetOptions ; MODAL ; TITLE L('4.1.6. Задача о назначениях. Задание ограничений на ресурсы по классам') ******************************************************************** IF lExit ** Button Ok ELSE RETURN NIL ENDIF ******************************************************************** *** Записать заданные параметры в виде файла, чтобы можно было загрузить их и отобразить в диаграмме aAutoDB4161[1] = mMetod // Метод формирования ресурсов классов (1,2,3,4) aAutoDB4161[2] = mRes1 // Ресурс начального класса aAutoDB4161[3] = mRes2 // Ресурс конечного класса aAutoDB4161[4] = mSumRes // Суммарный ресурс всех классов aAutoDB4161[5] = mZnaRes // Значение ресурса класса aAutoDB4161[6] = mResAvr // Среднее значение ресурса * aAutoDB4161 = DC_ARestore("_AutoDB4161.arx") DC_ASave(aAutoDB4161, "_AutoDB4161.arx") mSummaRes = 0 CrDBRes4161() *************************************************************************************************** IF mMetod = 1 // Метод линейной интерполяции значений ресурсов начального и конечного классов ***** Заполнение БД ресурсов начальными данными CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Klas_res EXCLUSIVE NEW;N_Cls = RECCOUNT() SELECT Klas_res nMax = N_Cls Mess = L('4.1.6. Задача о назначениях. Заполнение базы ресурсов классов начальными данными') @ 4,5 DCPROGRESS oProgress SIZE 70,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 DCREAD GUI TITLE Mess PARENT @oDialog FIT EXIT oDialog:show() nTime = 0 DC_GetProgress(oProgress,0,nMax) DBGOTOP() mX1 = Kod DBGOBOTTOM() mX2 = Kod DBGOTOP() DO WHILE .NOT. EOF() mZnaRes = mRes1+(Kod-mX1)/(mX2-mX1)*(mRes2-mRes1) mSummaRes = mSummaRes + mZnaRes REPLACE Resource WITH mZnaRes DC_GetProgress(oProgress, ++nTime, nMax) DBSKIP(1) ENDDO DBGOTOP() ENDIF *************************************************************************************************** IF mMetod = 2 // Значение ресурса класса вычисляется как сумма ресурсов, деленная на число классов ***** Заполнение БД ресурсов начальными данными CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Klas_res EXCLUSIVE NEW;N_Cls = RECCOUNT() SELECT Klas_res nMax = N_Cls Mess = L('4.1.6. Задача о назначениях. Заполнение базы ресурсов классов начальными данными') @ 4,5 DCPROGRESS oProgress SIZE 70,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 DCREAD GUI TITLE Mess PARENT @oDialog FIT EXIT oDialog:show() nTime = 0 DC_GetProgress(oProgress,0,nMax) DBGOTOP() DO WHILE .NOT. EOF() mZnaRes = mSumRes/N_Cls mSummaRes = mSummaRes + mZnaRes REPLACE Resource WITH mZnaRes DC_GetProgress(oProgress, ++nTime, nMax) DBSKIP(1) ENDDO DBGOTOP() ENDIF *************************************************************************************************** IF mMetod = 3 // Значение ресурса для всех классов одинаково и задается в диалоге ***** Заполнение БД ресурсов начальными данными CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Klas_res EXCLUSIVE NEW;N_Cls = RECCOUNT() SELECT Klas_res nMax = N_Cls Mess = L('4.1.6. Задача о назначениях. Заполнение базы ресурсов классов начальными данными') @ 4,5 DCPROGRESS oProgress SIZE 70,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 DCREAD GUI TITLE Mess PARENT @oDialog FIT EXIT oDialog:show() nTime = 0 DC_GetProgress(oProgress,0,nMax) DBGOTOP() DO WHILE .NOT. EOF() mSummaRes = mSummaRes + mZnaRes REPLACE Resource WITH mZnaRes DC_GetProgress(oProgress, ++nTime, nMax) DBSKIP(1) ENDDO DBGOTOP() ENDIF *************************************************************************************************** IF mMetod = 4 // Классы имеют случайные значения ресурсов, подчиняющиеся равномерному распределению ***** Заполнение БД ресурсов начальными данными CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Klas_res EXCLUSIVE NEW;N_Cls = RECCOUNT() SELECT Klas_res nMax = N_Cls Mess = L('4.1.6. Задача о назначениях. Заполнение базы ресурсов классов начальными данными') @ 4,5 DCPROGRESS oProgress SIZE 70,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 DCREAD GUI TITLE Mess PARENT @oDialog FIT EXIT oDialog:show() nTime = 0 DC_GetProgress(oProgress,0,nMax) DBGOTOP() DO WHILE .NOT. EOF() mZnaRes = 2*mResAvr*(RANDOM()/65535) mSummaRes = mSummaRes + mZnaRes REPLACE Resource WITH mZnaRes DC_GetProgress(oProgress, ++nTime, nMax) DBSKIP(1) ENDDO DBGOTOP() ENDIF *************************************************************************************************** * MsgBox('STOP') DC_GetProgress(oProgress,nMax,nMax) oDialog:Destroy() aMess := {} AADD(aMess, L('Автоматическое задание значений ресурсов классов завершено успешно!')) AADD(aMess, L('Сумма ресурсов классов = ')+ALLTRIM(STR(mSummaRes))+L('. Среднее=')+ALLTRIM(STR(mSummaRes/N_Cls))) LB_Warning(aMess, L("4.1.6. Задача о назначениях. Создание базы ресурсов классов")) *************** Вернуться в исходное состояние ржима 4.1.6. CrDBResNaz416() // Если нет БД для отображения результатов назначения объектов на классы, то создать ее CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Klas_res EXCLUSIVE NEW USE RObj_zat EXCLUSIVE NEW USE Result_naz EXCLUSIVE NEW SELECT Klas_res DBGOTOP() SELECT RObj_zat DBGOTOP() SELECT Result_naz DBGOTOP() DC_GetRefresh(oBrowse1) DC_GetRefresh(oBrowse2) DC_GetRefresh(oBrowse3) ReTURN NIL ********************************************************************************************************************* ******************************************* ******** Создание БД ресурсов классов ******** и результатов назначений на классы ******************************************* FUNCTION CrDBRes4161() LOCAL oBrowse1, oBrowse2, oBrowse3 ***** Определение фактической максимальной длины наименования класса ***** и формирование массивов кодов и наименований классов CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() SELECT Classes nMax = N_Cls * 2 Mess = L('4.1.6. Задача о назначениях. Создание базы ресурсов классов') @ 4,5 DCPROGRESS oProgress SIZE 70,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 DCREAD GUI TITLE Mess PARENT @oDialog FIT EXIT oDialog:show() nTime = 0 DC_GetProgress(oProgress,0,nMax) mLenCls := -9999999999 aKodCls := {} aNameCls := {} DBGOTOP() DO WHILE .NOT. EOF() mLenCls = MAX(mLenCls, LEN(ALLTRIM(Name_cls))) AADD(aKodCls , Kod_cls ) AADD(aNameCls, DelZeroNameGr(Name_cls)) DC_GetProgress(oProgress, ++nTime, nMax) DBSKIP(1) ENDDO ***** Создание БД ресурсов классов ****************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций aStructure := { { "Kod" , "N", 15 , 0},; // 1 Код класса { "Name" , "C", mLenCls, 0},; // 2 Наименование класса { "Resource" , "N", 15 , 3},; // 3 Начальный ресурс класса { "OstatokRes", "N", 15 , 3},; // 4 Остаток ресурса класса LC { "Kol_Obj" , "N", 15 , 3},; // 5 Количество объектов, назначенных на класс LC { "Sum_UrSxod", "N", 15 , 3},; // 6 Суммарное сходство назначенных объектов LC { "Sum_Zatrat", "N", 15 , 3},; // 7 Суммарные затраты на назначенные объекты LC { "Svz_UdSxod", "N", 15 , 3},; // 8 Средневзвешенное удельное сходство LC { "Avr_UrSxod", "N", 15 , 3},; // 9 Средний на объект уровень сходства LC { "Avr_Zatrat", "N", 15 , 3},; // 10 Средние на объект затраты LC { "Ost_ResRND", "N", 15 , 3},; // 11 Остаток ресурса класса RND { "Kol_ObjRND", "N", 15 , 3},; // 12 Количество объектов, назначенных на класс RND { "SumUrSxRND", "N", 15 , 3},; // 13 Суммарное сходство назначенных объектов RND { "SumZatrRND", "N", 15 , 3},; // 14 Суммарные затраты на назначенные объекты RND { "SvzUdSxRND", "N", 15 , 3},; // 15 Средневзвешенное удельное сходство RND { "AvrUrSxRND", "N", 15 , 3},; // 16 Средний на объект уровень сходства RND { "AvrZatrRND", "N", 15 , 3} } // 17 Средние на объект затраты RND DbCreate( "Klas_res.dbf", aStructure ) ***** Заполнение БД ресурсов начальными данными CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Klas_res EXCLUSIVE NEW SELECT Klas_res FOR j=1 TO LEN(aKodCls) APPEND BLANK REPLACE Kod WITH aKodCls[j] REPLACE Name WITH DelZeroNameGr(aNameCls[j]) REPLACE Resource WITH 100 FOR i=4 to 17 FIELDPUT(i, 0) NEXT DC_GetProgress(oProgress, ++nTime, nMax) NEXT DBGOTOP() * MsgBox('STOP') DC_GetProgress(oProgress,nMax,nMax) oDialog:Destroy() LB_Warning(L('Создание базы ресурсов классов завершено успешно!'), L("4.1.6. Задача о назначениях. Создание базы ресурсов классов")) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций IF .NOT. FILE("RObj_zat.dbf") CrDBZat4162() ENDIF *************** Вернуться в исходное состояние ржима 4.1.6. CrDBResNaz416() // Если нет БД для отображения результатов назначения объектов на классы, то создать ее CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Klas_res EXCLUSIVE NEW USE RObj_zat EXCLUSIVE NEW USE Result_naz EXCLUSIVE NEW SELECT Klas_res DBGOTOP() SELECT RObj_zat DBGOTOP() SELECT Result_naz DBGOTOP() DC_GetRefresh(oBrowse1) DC_GetRefresh(oBrowse2) DC_GetRefresh(oBrowse3) ReTURN NIL **************************************************************************************************** *Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time *nMax = N_InpFiles *Mess = L('2.3.2.6. Объединение нескольких файлов исходных данных в один' *@ 4,5 DCPROGRESS oProgress SIZE 70,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 *DCREAD GUI TITLE Mess PARENT @oDialog FIT EXIT *oDialog:show() *nTime = 0 *DC_GetProgress(oProgress,0,nMax) *FOR ff=1 TO N_InpFiles * DC_GetProgress(oProgress, ++nTime, nMax) *NEXT **MsgBox('STOP') *DC_GetProgress(oProgress,nMax,nMax) *oDialog:Destroy() *Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time **************************************************************************************************** ****************************************************** ******** Запись БД ресурсов классов в виде Excel-файла ****************************************************** FUNCTION ExcelDB4161() * aStructure := { { "Kod" , "N", 15 , 0},; // 1 Код класса * { "Name" , "C", mLenCls, 0},; // 2 Наименование класса * { "Resource" , "N", 15 , 3},; // 3 Начальный ресурс класса * { "OstatokRes", "N", 15 , 3},; // 4 Остаток ресурса класса * { "Kol_Obj" , "N", 15 , 3},; // 5 Количество объектов, назначенных на класс * { "Sum_UrSxod", "N", 15 , 3},; // 6 Суммарное сходство назначенных объектов * { "Sum_Zatrat", "N", 15 , 3},; // 7 Суммарные затраты на назначенные объекты * { "Svz_UdSxod", "N", 15 , 3},; // 8 Средневзвешенное удельное сходство * { "Avr_UrSxod", "N", 15 , 3},; // 9 Средний на объект уровень сходства * { "Avr_Zatrat", "N", 15 , 3} } // 10 Средние на объект затраты aColumnNames := {} AADD(aColumnNames, 'Код класса') AADD(aColumnNames, 'Наименование класса') AADD(aColumnNames, 'Начальный ресурс класса') AADD(aColumnNames, 'Остаток ресурса класса') AADD(aColumnNames, 'Количество объектов, назначенных на класс') AADD(aColumnNames, 'Суммарное сходство назначенных объектов') AADD(aColumnNames, 'Суммарные затраты на назначенные объекты') AADD(aColumnNames, 'Средневзвешенное удельное сходство') AADD(aColumnNames, 'Средний на объект уровень сходства') AADD(aColumnNames, 'Средние на объект затраты') *DC_WorkArea2Excel( cExcelFile, nOrientation, lDisplayAlerts, ; * lVisible, aFields, lAutoFit, cDateFormat, aFieldEvals, ; * cPassword, aColumnNames ) cExcelFile = M_ApplsPath+"\Inp_data\Klas_res.xls" CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Klas_res EXCLUSIVE NEW;N_Cls = RECCOUNT() SELECT Klas_res DC_DbGoTop() DC_WorkArea2Excel( cExcelFile ,,,,,,,,,,, aColumnNames ) aMess := {} AADD(aMess, L('База данных ресурсов классов записана в файл: ')+M_ApplsPath+"\Inp_data\Klas_res.xls") LB_Warning(aMess, L("4.1.6. Задача о назначениях. Создание базы ресурсов классов")) ReTURN NIL ************************************************************************************************************************* *######################################################################################################################## ************************************************************************************************************************* *********************************************************************************************************************************************** ******** 4.1.6. Назначения объектов на классы (задача о назначениях) Функционально-стоимостной анализ в управлении персоналом ******** 4.1.6.1. Задание ограничений на ресурсы по классам ******** 4.1.6.2. Ввод затрат по объектам ******** 4.1.6.3. Назначения объектов на классы (LC-алгоритм), Razrab(). ******** 4.1.6.4. Сравнение эффективности LC и RND алгоритмов, Razrab(). *********************************************************************************************************************************************** ******** 4.1.6.2. Задание затрат по объектам ******** В данном режиме мы можем ввести и скорректировать затраты по объектам обучающей выборки *********************************************************************************************************************************************** FUNCTION F4_1_6_2() LOCAL Getlist := {}, oProgress, oDialog PUBLIC Time_progress, Wsego, lOk := .T., Sec_1, GetOptions Running(.T.) IF ApplChange("4.1.6.2()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ********* Проверки на существование необходимых БД FlagError = .F. IF .NOT. FILE("Abs.txt") // БД абс.частот LB_Warning(L("Проведите рассчет матрицы абсолютных частот Abs.txt в режиме 3.1 или 3.5!")) FlagError = .T. ENDIF IF .NOT. FILE("Prc1.txt") .OR.; // БД процентных распределений .NOT. FILE("Prc2.txt") LB_Warning(L("Проведите рассчет матриц условных и безусловных процентных распределений Prc1 и Prc2 в режиме 3.2 или 3.5 !")) FlagError = .T. ENDIF IF .NOT. FILE("Inf1.txt") // БЗ-1 LB_Warning(L("Проведите рассчет баз знаний Inf1 - Inf7 в режиме 3.3 или 3.5!")) FlagError = .T. ENDIF IF FILE("_RaspInf.arx") // Файл с информацией о том, в какой модели было проведено распознавание M_RaspInf = DC_ARestore("_RaspInf.arx") Ar_Model := {"Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } IF M_CurrInf <> M_RaspInf Mess = L("Результаты распознавания получены в модели модели: #, отличающейся от текущей: $") Mess = STRTRAN(Mess, "#", Ar_Model[M_RaspInf]) Mess = STRTRAN(Mess, "$", Ar_Model[M_CurrInf]) LB_Warning(Mess, L("4.1.6. Задача о назначениях. Задание затрат по объектам")) ENDIF ELSE aMess := {} AADD(aMess, L("Перед заданием затрат по объектам")) AADD(aMess, L("Необходимо выполнить режим 3.5 или 4.1.2 !!!")) LB_Warning(aMess, L("4.1.6. Задача о назначениях. Задание затрат по объектам")) FlagError = .T. ENDIF IF FlagError ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ***** Если нет БД затрат по объектам, то создать ее CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций IF .NOT. FILE("RObj_zat.dbf") CrDBZat4162() ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE RObj_zat EXCLUSIVE NEW SELECT RObj_zat DBGOTOP() ********* Открытие окна для просмотра и корректировки БД затрат по объектам /* ----- Create ToolBar ----- */ @ 31.5, 1 DCTOOLBAR oToolBar SIZE 150, 1.5 K=2.3 mMess = L('Помощь') DCADDBUTTON CAPTION mMess ; SIZE 5+K+LEN(mMess) ; ACTION {||Help4162(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Помощь по режиму 4.1.6.') mMess = L('Заново сформировать базу затрат') DCADDBUTTON CAPTION mMess ; SIZE K+LEN(mMess) ; ACTION {||CrDBZat4162(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Помощь по режиму 4.1.6.') mMess = L('Сформировать базу затрат автоматически') DCADDBUTTON CAPTION mMess ; SIZE K+LEN(mMess) ; ACTION {||AutoDB4162(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Помощь по режиму 4.1.6.') mMess = L('Записать базу затрат в виде Excel-файла') DCADDBUTTON CAPTION mMess ; SIZE K+LEN(mMess) ; ACTION {||ExcelDB4162(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Помощь по режиму 4.1.6.') aColors := { {GRA_CLR_WHITE,GRA_CLR_DARKRED },; {GRA_CLR_WHITE,GRA_CLR_DARKBLUE },; {GRA_CLR_BLACK,GRA_CLR_DARKGREEN} } aPres := ; { { XBP_PP_COL_HA_FGCLR, GRA_CLR_WHITE },; // Header FG Color { XBP_PP_COL_HA_BGCLR, GRA_CLR_DARKGRAY },; // Header BG Color { XBP_PP_COL_FA_FGCLR, GRA_CLR_YELLOW },; // Footer FG Color { XBP_PP_COL_FA_BGCLR, GRA_CLR_DARKGRAY },; // Footer BG Color { XBP_PP_COL_DA_ROWSEPARATOR, XBPCOL_SEP_DOTTED },; // Row Sep { XBP_PP_COL_DA_COLSEPARATOR, XBPCOL_SEP_DOTTED },; // Col Sep { XBP_PP_COL_HA_ALIGNMENT, XBPALIGN_LEFT },; // Header alignment (способ выравнивания наименований колонок) { XBP_PP_COL_DA_ROWHEIGHT, 20 },; // Row Height { XBP_PP_COL_DA_CELLHEIGHT, 20 } } // Cell Height /* ----- Create browse ----- */ @ 1, 0 DCBROWSE oBrowse ALIAS 'RObj_zat' SIZE 150,30 ; EDIT xbeBRW_ItemSelected MODE DCGUI_BROWSE_EDITDOWN ; HEADLINES 4 ; // Кол-во строк в заголовке PRESENTATION aPres ; DCBROWSECOL FIELD RObj_zat->Kod HEADER L("Код;класса" ) PARENT oBrowse WIDTH 5 PROTECT {|| .T. } // 1 Код объекта DCBROWSECOL FIELD RObj_zat->Name HEADER L("Наименование;объекта") PARENT oBrowse WIDTH 78 PROTECT {|| .T. } // 2 Наименование объекта DCBROWSECOL FIELD RObj_zat->Zatrati HEADER L("Затраты;на объект" ) PARENT oBrowse WIDTH 7 FONT "10.Arial Bold" // 3 Затраты на объект DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; OPTIONS GetOptions ; MODAL ; TITLE L('4.1.6. Задача о назначениях. Задание затрат по объектам') ; FIT ; CLEAREVENTS ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN nil ************************************************************************************************** ******** Помощь по режиму 4.1.6.2 ************************************************************************************************** FUNCTION Help4162() aHelp := {} AADD(aHelp, L('Режим: "4.1.6. РАЦИОНАЛЬНОЕ НАЗНАЧЕНИЕ ОБЪЕКТОВ НА КЛАССЫ (ЗАДАЧА О РАНЦЕ). ЗАДАНИЕ ЗАТРАТ ПО ОБЪЕКТАМ". ')) AADD(aHelp, L(' ')) AADD(aHelp, L('В данном режиме мы можем ввести и скорректировать ресурсы по классам, которые являются ограничениями при назначении объектов ')) AADD(aHelp, L('на классы и уменьшаются при назначении каждого объекта на величину затрат, заданную для данного объекта в режиме 4.1.6.2. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Значения затрат по каждому объекту можно корректировать вручную, а можно сформировать расчетным путем по всем объектам сразу. ')) AADD(aHelp, L('Во втором случае необходимо выбрать один из вариантов и задать его параметры: ')) AADD(aHelp, L('1. Значение затрат объектов вычисляется методом линейной интерполяции значений затрат начального и конечного объектов. ')) AADD(aHelp, L('2. Объекты имеют одинаковые затраты, вычисляемые как сумма затрат по всем объектам, деленная на число объектов. ')) AADD(aHelp, L('3. Объекты имеют одинаковые затраты, значение которых просто задается непосредственно в диалоге. ')) AADD(aHelp, L('4. Объекты имеют случайные значения затрат, подчиняющиеся равномерному распределению с заданным средним значением. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('При автоматическом задании затрат сбрасывается признак, что объект был ранее назначен. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Ссылки на работы в этой области: ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Луценко Е.В. Решение обобщенной задачи о назначениях в системно-когнитивном анализе / Е.В. Луценко, В.Е. Коржаков ')) AADD(aHelp, L('// Политематический сетевой электронный научный журнал Кубанского государственного аграрного университета (Научный журнал ')) AADD(aHelp, L('КубГАУ) [Электронный ресурс]. - Краснодар: КубГАУ, 2009. - №07(051). С. 83 - 108. - Шифр Информрегистра: 0420900012\0070, ')) AADD(aHelp, L('IDA [article ID]: 0510907004. - Режим доступа: http://ej.kubagro.ru/2009/07/pdf/04.pdf, 1,625 у.п.л. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Луценко Е.В., Коржаков В.Е., Ермоленко В.В. Интеллектуальные системы в контроллинге и менеджменте средних и малых фирм: ')) AADD(aHelp, L('Под науч. ред. д.э.н., проф. Е.В.Луценко. Монография (научное издание). - Майкоп: АГУ. 2011. - 392 с. ')) AADD(aHelp, L('- Режим доступа: http://lc.kubagro.ru/aidos/aidos11_LKE/index.htm ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Луценко Е.В. Автоматизированный системно-когнитивный анализ как метод комплексного решения проблемы управления персоналом с ')) AADD(aHelp, L('применением функционально-стоимостного анализа / Е.В. Луценко, В.Е. Коржаков // Политематический сетевой электронный научный ')) AADD(aHelp, L('журнал Кубанского государственного аграрного университета (Научный журнал КубГАУ) [Электронный ресурс]. - Краснодар: КубГАУ, 2014.')) AADD(aHelp, L('- №02(096). С. 1 - 16. - IDA [article ID]: 0961402001. - Режим доступа: http://ej.kubagro.ru/2014/02/pdf/01.pdf, 1 у.п.л. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Луценко Е.В. Управление персоналом с применением функционально-стоимостного и системно-когнитивного анализа / Е.В. Луценко, ')) AADD(aHelp, L('В.Е. Коржаков // Политематический сетевой электронный научный журнал Кубанского государственного аграрного университета (Научный ')) AADD(aHelp, L('журнал КубГАУ) [Электронный ресурс]. - Краснодар: КубГАУ, 2014. - №04(098). С. 1009 - 1041. - IDA [article ID]: 0981404075. ')) AADD(aHelp, L('- Режим доступа: http://ej.kubagro.ru/2014/04/pdf/75.pdf, 2,062 у.п.л. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Луценко Е.В. Интеллектуальное управление качеством систем путем решения обобщенной задачи о назначениях с применением АСК-анализа ')) AADD(aHelp, L('и системы <Эйдос-Х++> / Е.В. Луценко // Политематический сетевой электронный научный журнал Кубанского государственного аграрного ')) AADD(aHelp, L('университета (Научный журнал КубГАУ) [Электронный ресурс]. - Краснодар: КубГАУ, 2015. - №05(109). С. 1 - 51. - IDA [article ID]: ')) AADD(aHelp, L('1091505001. - Режим доступа: http://ej.kubagro.ru/2015/05/pdf/01.pdf, 3,188 у.п.л. ')) mHelpMax = -999;FOR h=1 TO LEN(aHelp);mHelpMax = MAX(mHelpMax, LEN(ALLTRIM(aHelp[h])));NEXT s=1;d=0.9;@0,0 DCGROUP oGroup1 CAPTION L(' ') SIZE mHelpMax-20, LEN(aHelp)*d+1.5 FOR h=1 TO LEN(aHelp);@s,2 DCSAY aHelp[h] SIZE 0 PARENT ogroup1;s=s+d;NEXT DCREAD GUI TO lExit FIT TITLE L('Помощь по режиму: "4.1.6. Задача о назначениях. Задание затрат по объектам"') RETURN NIL ************************************************************************************************** ******************************************************************************************* ******** Автоматически сформировать значения затрат расчетным путем по всем классам сразу ******************************************************************************************* FUNCTION AutoDB4162() LOCAL GetList := {}, aPres, oBrowse, oToolBar, aColors, bColor, GetOptions LOCAL oBrowse1, oBrowse2, oBrowse3 IF FILE("_AutoDB4162.arx") aAutoDB4162 = DC_ARestore("_AutoDB4162.arx") mMetod = aAutoDB4162[1] // Метод формирования затрат по объектам (1,2,3,4) mZat1 = aAutoDB4162[2] // Затраты начального объекта mZat2 = aAutoDB4162[3] // Затраты конечного объекта mSumZat = aAutoDB4162[4] // Суммарные затраты всех объектов mZnaZat = aAutoDB4162[5] // Значение затрат объекта mZatAvr = aAutoDB4162[6] // Среднее значение затрат по всем объектам ELSE mMetod = 3 // Метод формирования затрат по объектам (1,2,3,4) mZat1 = 20 // Затраты начального объекта mZat2 = 10 // Затраты конечного объекта mSumZat = 1000 // Суммарные затраты всех объектов mZnaZat = 8 // Значение затрат объекта mZatAvr = 8 // Среднее значение ресурса PRIVATE aAutoDB4162[6] aAutoDB4162[1] = mMetod // Метод формирования затрат по объектам (1,2,3,4) aAutoDB4162[2] = mZat1 // Затраты начального объекта aAutoDB4162[3] = mZat2 // Затраты конечного объекта aAutoDB4162[4] = mSumZat // Суммарные затраты всех объектов aAutoDB4162[5] = mZnaZat // Значение затрат объекта aAutoDB4162[6] = mZatAvr // Среднее значение затрат ENDIF mLen = 75.0 @ 1, 1 DCGROUP oGroup1 CAPTION L('Задайте метод формирования затрат объектов:') SIZE mLen, 5.5 @ 1, 1 DCRADIO mMetod VALUE 1 PROMPT L('Метод линейной интерполяции значений затрат начального и конечного объектов' ) PARENT oGroup1 @ 2, 1 DCRADIO mMetod VALUE 2 PROMPT L('Значение затрат объекта вычисляется как сумма затрат, деленная на число объектов' ) PARENT oGroup1 @ 3, 1 DCRADIO mMetod VALUE 3 PROMPT L('Значение затрат для всех объектов одинаково и задается в диалоге' ) PARENT oGroup1 @ 4, 1 DCRADIO mMetod VALUE 4 PROMPT L('Объекты имеют случайные значения затрат, подчиняющиеся равномерному распределению') PARENT oGroup1 @ 1,mLen+2 DCGROUP oGroup2 CAPTION L('Задайте параметры:') SIZE 35.0, 5.5 mPos = 15.50 mS1 = 0.25 mS2 = 0.10 @ 1+mS1, 2 DCSAY L("Затр.нач.объекта:") PARENT oGroup2 EDITPROTECT {|| .NOT.mMetod=1 } HIDE {|| .NOT.mMetod=1 } @ 1+mS2, mPos DCGET mZat1 PARENT oGroup2 PICTURE "###########.###" EDITPROTECT {|| .NOT.mMetod=1 } HIDE {|| .NOT.mMetod=1 } @ 2+mS1, 2 DCSAY L("Затр.кон.объекта:") PARENT oGroup2 EDITPROTECT {|| .NOT.mMetod=1 } HIDE {|| .NOT.mMetod=1 } @ 2+mS2, mPos DCGET mZat2 PARENT oGroup2 PICTURE "###########.###" EDITPROTECT {|| .NOT.mMetod=1 } HIDE {|| .NOT.mMetod=1 } @ 2+mS1, 2 DCSAY L("Суммарные затр.:") PARENT oGroup2 EDITPROTECT {|| .NOT.mMetod=2 } HIDE {|| .NOT.mMetod=2 } @ 2+mS2, mPos DCGET mSumZat PARENT oGroup2 PICTURE "###########.###" EDITPROTECT {|| .NOT.mMetod=2 } HIDE {|| .NOT.mMetod=2 } @ 3+mS1, 2 DCSAY L("Значен.затрат:") PARENT oGroup2 EDITPROTECT {|| .NOT.mMetod=3 } HIDE {|| .NOT.mMetod=3 } @ 3+mS2, mPos DCGET mZnaZat PARENT oGroup2 PICTURE "###########.###" EDITPROTECT {|| .NOT.mMetod=3 } HIDE {|| .NOT.mMetod=3 } @ 4+mS1, 2 DCSAY L("Сред.знач.затр.:") PARENT oGroup2 EDITPROTECT {|| .NOT.mMetod=4 } HIDE {|| .NOT.mMetod=4 } @ 4+mS2, mPos DCGET mZatAvr PARENT oGroup2 PICTURE "###########.###" EDITPROTECT {|| .NOT.mMetod=4 } HIDE {|| .NOT.mMetod=4 } DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; ADDBUTTONS; OPTIONS GetOptions ; MODAL ; TITLE L('4.1.6. Задача о назначениях. Задание затрат по объектам') ******************************************************************** IF lExit ** Button Ok ELSE RETURN NIL ENDIF ******************************************************************** *** Записать заданные параметры в виде файла, чтобы можно было загрузить их и отобразить в диаграмме aAutoDB4162[1] = mMetod // Метод формирования затрат по объектам (1,2,3,4) aAutoDB4162[2] = mZat1 // Затраты начального объекта aAutoDB4162[3] = mZat2 // Затраты конечного объекта aAutoDB4162[4] = mSumZat // Суммарные затраты всех объектов aAutoDB4162[5] = mZnaZat // Значение затрат объекта aAutoDB4162[6] = mZatAvr // Среднее значение затрат * aAutoDB4162 = DC_ARestore("_AutoDB4162.arx") DC_ASave(aAutoDB4162, "_AutoDB4162.arx") mSummaZat = 0 CrDBZat4162() *************************************************************************************************** IF mMetod = 1 // Метод линейной интерполяции значений затрат начального и конечного объектов ***** Заполнение БД затрат начальными данными CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE RObj_zat EXCLUSIVE NEW;N_Obj = RECCOUNT() SELECT RObj_zat nMax = N_Obj Mess = L('4.1.6. Задача о назначениях. Заполнение базы затрат начальными данными') @ 4,5 DCPROGRESS oProgress SIZE 70,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 DCREAD GUI TITLE Mess PARENT @oDialog FIT EXIT oDialog:show() nTime = 0 DC_GetProgress(oProgress,0,nMax) DBGOTOP() mX1 = Kod DBGOBOTTOM() mX2 = Kod DBGOTOP() DO WHILE .NOT. EOF() mZnaZat = mZat1+(Kod-mX1)/(mX2-mX1)*(mZat2-mZat1) mSummaZat = mSummaZat + mZnaZat REPLACE Zatrati WITH mZnaZat REPLACE AssignLC WITH 'N' REPLACE AssignRND WITH 'N' DC_GetProgress(oProgress, ++nTime, nMax) DBSKIP(1) ENDDO DBGOTOP() ENDIF *************************************************************************************************** IF mMetod = 2 // Значение затрат объекта вычисляется как сумма затрат, деленная на число объектов ***** Заполнение БД затрат начальными данными CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE RObj_zat EXCLUSIVE NEW;N_Obj = RECCOUNT() SELECT RObj_zat nMax = N_Obj Mess = L('4.1.6. Задача о назначениях. Заполнение базы затрат начальными данными') @ 4,5 DCPROGRESS oProgress SIZE 70,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 DCREAD GUI TITLE Mess PARENT @oDialog FIT EXIT oDialog:show() nTime = 0 DC_GetProgress(oProgress,0,nMax) DBGOTOP() DO WHILE .NOT. EOF() mZnaZat = mSumZat/N_Obj mSummaZat = mSummaZat + mZnaZat REPLACE Zatrati WITH mZnaZat REPLACE AssignLC WITH 'N' REPLACE AssignRND WITH 'N' DC_GetProgress(oProgress, ++nTime, nMax) DBSKIP(1) ENDDO DBGOTOP() ENDIF *************************************************************************************************** IF mMetod = 3 // Значение затрат для всех объектов одинаково и задается в диалоге ***** Заполнение БД затрат начальными данными CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE RObj_zat EXCLUSIVE NEW;N_Obj = RECCOUNT() SELECT RObj_zat nMax = N_Obj Mess = L('4.1.6. Задача о назначениях. Заполнение базы затрат начальными данными') @ 4,5 DCPROGRESS oProgress SIZE 70,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 DCREAD GUI TITLE Mess PARENT @oDialog FIT EXIT oDialog:show() nTime = 0 DC_GetProgress(oProgress,0,nMax) DBGOTOP() DO WHILE .NOT. EOF() mSummaZat = mSummaZat + mZnaZat REPLACE Zatrati WITH mZnaZat REPLACE AssignLC WITH 'N' REPLACE AssignRND WITH 'N' DC_GetProgress(oProgress, ++nTime, nMax) DBSKIP(1) ENDDO DBGOTOP() ENDIF *************************************************************************************************** IF mMetod = 4 // Объекты имеют случайные значения затрат, подчиняющиеся равномерному распределению ***** Заполнение БД затрат начальными данными CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE RObj_zat EXCLUSIVE NEW;N_Obj = RECCOUNT() SELECT RObj_zat nMax = N_Obj Mess = L('4.1.6. Задача о назначениях. Заполнение базы затрат начальными данными') @ 4,5 DCPROGRESS oProgress SIZE 70,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 DCREAD GUI TITLE Mess PARENT @oDialog FIT EXIT oDialog:show() nTime = 0 DC_GetProgress(oProgress,0,nMax) DBGOTOP() DO WHILE .NOT. EOF() mZnaZat = 2*mZatAvr*(RANDOM()/65535) mSummaZat = mSummaZat + mZnaZat REPLACE Zatrati WITH mZnaZat REPLACE AssignLC WITH 'N' REPLACE AssignRND WITH 'N' DC_GetProgress(oProgress, ++nTime, nMax) DBSKIP(1) ENDDO DBGOTOP() ENDIF *************************************************************************************************** * MsgBox('STOP') DC_GetProgress(oProgress,nMax,nMax) oDialog:Destroy() aMess := {} AADD(aMess, L('Автоматическое задание значений базы затрат по объектам завершено успешно!')) AADD(aMess, L('Сумма затрат объектов = ')+ALLTRIM(STR(mSummaZat))+L('. Среднее=')+ALLTRIM(STR(mSummaZat/N_Obj))) LB_Warning(aMess, L("4.1.6. Задача о назначениях. Создание базы затрат по объектам")) *************** Вернуться в исходное состояние ржима 4.1.6. CrDBResNaz416() // Если нет БД для отображения результатов назначения объектов на классы, то создать ее CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Klas_res EXCLUSIVE NEW USE RObj_zat EXCLUSIVE NEW USE Result_naz EXCLUSIVE NEW SELECT Klas_res DBGOTOP() SELECT RObj_zat DBGOTOP() SELECT Result_naz DBGOTOP() DC_GetRefresh(oBrowse1) DC_GetRefresh(oBrowse2) DC_GetRefresh(oBrowse3) ReTURN NIL ********************************************************************************************************************* ************************************ ******* Создание БД затрат объектов ************************************ FUNCTION CrDBZat4162() LOCAL oBrowse1, oBrowse2, oBrowse3 ***** Определение фактической максимальной длины наименования класса ***** и формирование массивов кодов и наименований объектов CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rso_Zag EXCLUSIVE NEW;N_Obj = RECCOUNT() SELECT Rso_Zag nMax = N_Obj * 2 Mess = L('4.1.6. Задача о назначениях. Создание базы затрат по объектам') @ 4,5 DCPROGRESS oProgress SIZE 70,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 DCREAD GUI TITLE Mess PARENT @oDialog FIT EXIT oDialog:show() nTime = 0 DC_GetProgress(oProgress,0,nMax) mLenObj := -9999999999 aKodObj := {} aNameObj := {} DBGOTOP() DO WHILE .NOT. EOF() mLenObj = MAX(mLenObj, LEN(ALLTRIM(Name_obj))) AADD(aKodObj , Kod_obj ) AADD(aNameObj, Name_obj) DC_GetProgress(oProgress, ++nTime, nMax) DBSKIP(1) ENDDO ***** Создание БД затрат объектов ****************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций aStructure := { { "Kod" , "N", 15 , 0},; // 1 Код объекта обучающей выборки { "Name" , "C", mLenObj, 0},; // 2 Наименование обучающей выборки { "Zatrati" , "N", 15 , 3},; // 3 Затраты на обучающей выборки { "AssignLC" , "C", 1 , 0},; // 4 Назначен объект или нет: "Y", "N" с помощью LC-алгоритма { "AssignRND" , "C", 1 , 0} } // 5 Назначен объект или нет: "Y", "N" с помощью RND-алгоритма DbCreate( "RObj_zat.dbf", aStructure ) ***** Заполнение БД затрат начальными данными CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE RObj_zat EXCLUSIVE NEW SELECT RObj_zat FOR j=1 TO LEN(aKodObj) APPEND BLANK REPLACE Kod WITH aKodObj[j] REPLACE Name WITH aNameObj[j] REPLACE Zatrati WITH 8 REPLACE AssignLC WITH 'N' REPLACE AssignRND WITH 'N' DC_GetProgress(oProgress, ++nTime, nMax) NEXT DBGOTOP() * MsgBox('STOP') DC_GetProgress(oProgress,nMax,nMax) oDialog:Destroy() LB_Warning(L('Создание базы затрат по объектам завершено успешно!', "4.1.6. Задача о назначениях. Создание базы затрат по объектам")) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций IF .NOT. FILE("Klas_res.dbf") CrDBRes4161() ENDIF *************** Вернуться в исходное состояние ржима 4.1.6. CrDBResNaz416() // Если нет БД для отображения результатов назначения объектов на классы, то создать ее CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Klas_res EXCLUSIVE NEW USE RObj_zat EXCLUSIVE NEW USE Result_naz EXCLUSIVE NEW SELECT Klas_res DBGOTOP() SELECT RObj_zat DBGOTOP() SELECT Result_naz DBGOTOP() DC_GetRefresh(oBrowse1) DC_GetRefresh(oBrowse2) DC_GetRefresh(oBrowse3) ReTURN NIL **************************************************************************************************** *Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time *nMax = N_InpFiles *Mess = L('2.3.2.6. Объединение нескольких файлов исходных данных в один') *@ 4,5 DCPROGRESS oProgress SIZE 70,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 *DCREAD GUI TITLE Mess PARENT @oDialog FIT EXIT *oDialog:show() *nTime = 0 *DC_GetProgress(oProgress,0,nMax) *FOR ff=1 TO N_InpFiles * DC_GetProgress(oProgress, ++nTime, nMax) *NEXT **MsgBox('STOP') *DC_GetProgress(oProgress,nMax,nMax) *oDialog:Destroy() *Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time **************************************************************************************************** ******************************************************* ******** Запись БД затрат на объекты в виде Excel-файла ******************************************************* FUNCTION ExcelDB4162() * ***** Создание БД затрат объектов ****************** * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * aStructure := { { "Kod" , "N", 15 , 0},; // 1 Код объекта обучающей выборки * { "Name" , "C", mLenObj, 0},; // 2 Наименование обучающей выборки * { "Zatrati" , "N", 15 , 3},; // 3 Затраты на обучающей выборки * { "AssignLC" , "C", 1 , 0},; // 4 Назначен объект или нет: "Y", "N" с помощью LC-алгоритма * { "AssignRND" , "C", 1 , 0} } // 5 Назначен объект или нет: "Y", "N" с помощью RND-алгоритма * DbCreate( "RObj_zat.dbf", aStructure ) aColumnNames := {} AADD(aColumnNames, 'Код объекта') AADD(aColumnNames, 'Наименование объекта') AADD(aColumnNames, 'Затраты на объект') *DC_WorkArea2Excel( cExcelFile, nOrientation, lDisplayAlerts, ; * lVisible, aFields, lAutoFit, cDateFormat, aFieldEvals, ; * cPassword, aColumnNames ) cExcelFile = M_ApplsPath+"\Inp_data\RObj_zat.xls" CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE RObj_zat EXCLUSIVE NEW;N_Obj = RECCOUNT() SELECT RObj_zat DC_DbGoTop() DC_WorkArea2Excel( cExcelFile ,,,,,,,,,,, aColumnNames ) aMess := {} AADD(aMess, L('База данных затрат объектов записана в файл: ')+M_ApplsPath+"\Inp_data\RObj_zat.xls") LB_Warning(aMess, L("4.1.6. Задача о назначениях. Создание базы затрат на объекты")) ReTURN NIL ***************************************************************************************************************************** ******** 4.1.6. Назначения объектов на классы (задача о назначениях) Функционально-стоимостной анализ в управлении персоналом ******** 4.1.6.1. Задание ограничений на ресурсы по классам ******** 4.1.6.2. Ввод затрат по объектам ******** 4.1.6.3. Назначения объектов на классы (LC-алгоритм) ******** 4.1.6.4. Сравнение эффективности LC и RND алгоритмов, Razrab(). ***************************************************************************************************************************** ******** 4.1.6.3. Назначения объектов на классы (LC-алгоритм) ******** Данный режим производит назначение объектов на классы с учетом степени соответствия объектов классам, ******** ограничений на ресурсы классов и затрат на назначение объектов. Первыми на класс назначаются наиболее ******** соответствующие ему объекты на назначение которых затраты минимальны (задача о назначениях, LC-алгоритм) ***************************************************************************************************************************** FUNCTION F4_1_6_3() LOCAL Getlist := {}, oProgress, oDialog PUBLIC Time_progress, Wsego, lOk := .T., Sec_1, GetOptions Running(.T.) IF ApplChange("4.1.6.3()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ********* Проверки на существование необходимых БД FlagError = .F. IF .NOT. FILE("Abs.txt") // БД абс.частот LB_Warning(L("Проведите рассчет матрицы абсолютных частот Abs.txt в режиме 3.1 или 3.5!")) FlagError = .T. ENDIF IF .NOT. FILE("Prc1.txt") .OR.; // БД процентных распределений .NOT. FILE("Prc2.txt") LB_Warning(L("Проведите рассчет матриц условных и безусловных процентных распределений Prc1 и Prc2 в режиме 3.2 или 3.5 !")) FlagError = .T. ENDIF IF .NOT. FILE("Inf1.txt") // БЗ-1 LB_Warning(L("Проведите рассчет баз знаний Inf1 - Inf7 в режиме 3.3 или 3.5!")) FlagError = .T. ENDIF IF FILE("_RaspInf.arx") // Файл с информацией о том, в какой модели было проведено распознавание M_RaspInf = DC_ARestore("_RaspInf.arx") Ar_Model := {"Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } IF M_CurrInf <> M_RaspInf Mess = L("Результаты распознавания получены в модели модели: #, отличающейся от текущей: $") Mess = STRTRAN(Mess, "#", Ar_Model[M_RaspInf]) Mess = STRTRAN(Mess, "$", Ar_Model[M_CurrInf]) LB_Warning(Mess, L("4.1.6. Задача о назначениях. Задание затрат по объектам")) ENDIF ELSE aMess := {} AADD(aMess, L("Перед заданием затрат по объектам")) AADD(aMess, L("Необходимо выполнить режим 3.5 или 4.1.2 !!!")) LB_Warning(aMess, L("4.1.6. Задача о назначениях. Задание затрат по объектам")) FlagError = .T. ENDIF IF .NOT. FILE("Klas_res.dbf") LB_Warning(L("Введите ресурсы по классам в режиме 4.1.6!")) FlagError = .T. ENDIF IF .NOT. FILE("RObj_zat.dbf") LB_Warning(L("Введите затраты на объекты в режиме 4.1.6!")) FlagError = .T. ENDIF IF FlagError ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF @ 0.0,0 DCGROUP oGroup1 CAPTION L('Описание LC-алгоритма назначения объектов на классы:') SIZE 65,20.0 @ 20.5,0 DCGROUP oGroup2 CAPTION L('Задайте нужный режим:' ) SIZE 65, 2.7 s=1 @s,1 DCSAY L('РАЦИОНАЛЬНОЕ РАСПРЕДЕЛЕНИЕ ОБЪЕКТОВ ПО КЛАССАМ' ) PARENT oGroup1 FONT '9.Helv Bold' SIZE 0;s=s+0.8 @s,1 DCSAY L('' ) PARENT oGroup1;s=s+0.8 @s,1 DCSAY L('Дано:' ) PARENT oGroup1 FONT '9.Helv Bold' SIZE 0;s=s+0.8 @s,1 DCSAY L('1. Результаты пакетного распознавания объектов в режиме 4.1.2 (БД: Rasp.dbf), ') PARENT oGroup1;s=s+0.8 @s,1 DCSAY L(' в которой определены уровни сходства всех объектов со всеми классами. ') PARENT oGroup1;s=s+0.8 @s,1 DCSAY L('2. Массив ограничений на ресурсы по классам, режим 4.1.6. (БД: Klas_res.dbf). ') PARENT oGroup1;s=s+0.8 @s,1 DCSAY L('3. Массив затрат на распознаваемые объекты, режим 4.1.6. (БД: RObj_zat.dbf). ') PARENT oGroup1;s=s+0.8 @s,1 DCSAY L('' ) PARENT oGroup1;s=s+0.8 @s,1 DCSAY L('Необходимо:' ) PARENT oGroup1 FONT '9.Helv Bold' SIZE 0;s=s+0.8 @s,1 DCSAY L('Распределить объекты по классам так, чтобы: ') PARENT oGroup1;s=s+0.8 @s,1 DCSAY L('- каждый объект был назначен только один раз, т.е. на единственный класс; ') PARENT oGroup1;s=s+0.8 @s,1 DCSAY L('- каждый объект был назначен на тот класс, которому он наиболее соответствует ') PARENT oGroup1;s=s+0.8 @s,1 DCSAY L(' (будем считать, что некоторый объект тем более соотвествует классу, чем выше ') PARENT oGroup1;s=s+0.8 @s,1 DCSAY L(' его сходство с данным классом и чем ниже затраты на использование объекта); ') PARENT oGroup1;s=s+0.8 @s,1 DCSAY L('- ресурсы классов были максимально использованы, а их остатки минимизированы. ') PARENT oGroup1;s=s+0.8 @s,1 DCSAY L('' ) PARENT oGroup1;s=s+0.8 @s,1 DCSAY L('Алгоритм:' ) PARENT oGroup1 FONT '9.Helv Bold' SIZE 0;s=s+0.8 @s,1 DCSAY L('1. Для всех объектов и классов находим удельное сходство на единицу затрат. ') PARENT oGroup1;s=s+0.8 @s,1 DCSAY L('2. Сортируем все объекты в порядке убывания удельного сходства по всем классам.') PARENT oGroup1;s=s+0.8 @s,1 DCSAY L('3. Организуем цикл по объектам. ') PARENT oGroup1;s=s+0.8 @s,1 DCSAY L('4. Назначаем текущий объект на тот класс, удельное сходство с которым макси- ') PARENT oGroup1;s=s+0.8 @s,1 DCSAY L(' мально, при условии, что у данного класса есть для этого ресурсы, и делать ') PARENT oGroup1;s=s+0.8 @s,1 DCSAY L(' это до тех пор, пока есть классы с ресурсами и не назначены все объекты. ') PARENT oGroup1;s=s+0.8 @1.0, 1.0 DCPUSHBUTTON CAPTION L('Назначить объекты на классы' ) SIZE 32, 1.1 PARENT oGroup2 ACTION {||Run4163('LC') } FONT "10.HelvBold" @1.0, 34.5 DCPUSHBUTTON CAPTION L('Ссылки на публикации по тематике' ) SIZE 29, 1.1 PARENT oGroup2 ACTION {||Help4163()} DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; FIT ; OPTIONS GetOptions ; MODAL ; TITLE L('4.1.6. Назначения объектов на классы (LC-алгоритм)') ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) ReTURN NIL ************************************************************************************************************************** ******** 4.1.6.3. Назначения объектов на классы (LC-алгоритми RND-алгоритм) ******** Данный режим производит назначение объектов на классы с учетом степени соответствия объектов классам, ******** ограничений на ресурсы классов и затрат на назначение объектов. Первыми на класс назначаются наиболее ******** соответствующие ему объекты на назначение которых затраты минимальны (задача о назначениях, LC-алгоритм) ************************************************************************************************************************** FUNCTION Run4163(mParam) LOCAL oResNaz N_ObjAssign = FILESTR('_Assign1.txt') // Считывание файла N_CopyAssign = FILESTR('_Assign2.txt') // Считывание файла N_TargetAssign = FILESTR('_Assign3.txt') // Считывание файла mN_ObjAssign = IF(N_ObjAssign = 'Y', .T., .F.) // Для команд интерфейса mN_CopyAssign = IF(N_CopyAssign = 'Y', .T., .F.) // Для команд интерфейса mN_TargetAssign = VAL(N_TargetAssign) // Для команд интерфейса ***** mParam = {'LC', 'RND'} ***** АЛГОРИТМ: ***** Определение максимальной длины наименования объекта CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE RObj_zat EXCLUSIVE NEW mLenObj = -99999 DBGOTOP() DO WHILE .NOT. EOF() mLenObj = MAX(mLenObj, LEN(ALLTRIM(Name))) DBSKIP(1) ENDDO ***** Определение максимальной длины наименования класса CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Klas_res EXCLUSIVE NEW mLenCls = -99999 DBGOTOP() DO WHILE .NOT. EOF() mLenCls = MAX(mLenCls, LEN(ALLTRIM(Name))) DBSKIP(1) ENDDO ***** 0. Создаем базу данных (похожую на Rasp.dbf) для выполнения п.1. CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций aStructure := { { "Kod_obj" , "N", 15 , 0},; // 1 Код объекта { "Name_Obj", "C", mLenObj, 0},; // 2 Наименование объекта { "Kod_Cls" , "N", 15 , 0},; // 3 Код класса { "Name_Cls", "C", mLenCls, 0},; // 4 Наименование класса { "UR_Sxod" , "N", 15 , 3},; // 5 Уровень сходства объекта с классом { "Fakt" , "C", 1 , 0},; // 6 Относится ли фактически объект к данному классу (если птичка, то относится) { "Zatrati" , "N", 15 , 3},; // 7 Затраты на данный объект расп.выборки { "UD_Sxod" , "N", 15 , 3},; // 8 Удельное сходство объекта с классом: Ud_Korr = Korr / Zatrati { "Klas_Naz", "N", 15 , 0},; // 9 Код класса, на который объект был назначен в соотвествии с алгоритмом { "Rand_key", "N", 15 , 0} } // 10 Ключ для случайного упорядочивания DbCreate( "Rasp_naz.dbf", aStructure ) Mess = L("1. Для всех объектов и классов находим удельное сходство на единицу затрат") ***** Сформировать БД Rasp_naz.dbf CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Klas_res EXCLUSIVE NEW USE RObj_zat EXCLUSIVE NEW USE Rasp EXCLUSIVE NEW USE Rasp_naz EXCLUSIVE NEW SELECT Rasp DBGOTOP() DO WHILE .NOT. EOF() M_KodObj = Kod_obj M_KodCls = Kod_cls M_Korr = Korr M_Fakt = Fakt IF M_Korr > 0 // На классы назначать только соответствующие им объекты ****** 1. Для всех объектов и классов находим удельное сходство на единицу затрат SELECT RObj_zat DBGOTO(M_KodObj) M_Zatr = Zatrati M_NameObj = Name SELECT Klas_res DBGOTO(M_KodCls) M_NameCls = Name SELECT Rasp_naz APPEND BLANK REPLACE Kod_obj WITH M_KodObj REPLACE Name_Obj WITH M_NameObj REPLACE Kod_Cls WITH M_KodCls REPLACE Name_Cls WITH M_NameCls REPLACE Ur_Sxod WITH M_Korr REPLACE Fakt WITH M_Fakt REPLACE Zatrati WITH M_Zatr // Затраты на данный объект расп.выборки REPLACE Ud_Sxod WITH M_Korr/M_Zatr // Ud_Korr = Korr / Zatrati, удельное сходство (сходство на единицу затрат) REPLACE Klas_Naz WITH 0 // Код класса, на который объект назначен r1 = PI()^1 * RANDOM()/65535 r2 = PI()^2 * RANDOM()/65535 r3 = PI()^3 * RANDOM()/65535 r4 = PI()^4 * RANDOM()/65535 mStr = VAL(STR(r1*r2*r3*r4, 15, 3)) REPLACE Rand_key WITH mStr // Случайный ключ для случайного упорядочивания (RND) SELECT Rasp ENDIF DBSKIP(1) ENDDO Mess = L("2. Физически сортируем все объекты в порядке убывания удельного сходства со всеми классами (LC-алгоритм) или случайным обраом (RND-алгоритм)") CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rasp_naz EXCLUSIVE NEW DO CASE CASE mParam = 'LC' DO CASE CASE mN_TargetAssign = 1 // 1. Повышение уровня системности. INDEX ON STR(9999999999.999-Ud_Sxod ,15,3) TO Rnz_udsx // Упорядочивание назначаемых объектов в порядке убывания удельного сходства с классами CASE mN_TargetAssign = 2 // 2. Понижение уровня системности. INDEX ON STR(Ud_Sxod ,15,3) TO Rnz_udsx // Упорядочивание назначаемых объектов в порядке возрастания удельного сходства с классами CASE mN_TargetAssign = 3 // 3. Минимизация средних затрат на назначения объектов. INDEX ON STR(zatrati ,15,3) TO Rnz_udsx // Упорядочивание назначаемых объектов в порядке возрастания затрат на назначение объектов CASE mN_TargetAssign = 4 // 4. Максимизация средних затрат на назначения объектов. INDEX ON STR(9999999999.999-Zatrati ,15,3) TO Rnz_udsx // Упорядочивание назначаемых объектов в порядке убывания затрат на назначение объектов ENDCASE CASE mParam = 'RND' INDEX ON STR(9999999999.999-Rand_key,15,3) TO Rnz_udsx // Упорядочивание назначаемых объектов в случайном порядке ENDCASE COPY STRUCTURE TO RaspSort CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rasp_naz INDEX Rnz_udsx EXCLUSIVE NEW USE RaspSort EXCLUSIVE NEW;ZAP SELECT Rasp_naz SET ORDER TO 1 DBGOTOP() DO WHILE .NOT. EOF() Ar := {} FOR j=1 TO FCOUNT() AADD(Ar, FIELDGET(j)) NEXT SELECT RaspSort APPEND BLANK FOR j=1 TO LEN(Ar) FIELDPUT(j, Ar[j]) NEXT SELECT Rasp_naz DBSKIP(1) ENDDO CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций COPY FILE RaspSort.dbf TO Rasp_naz.dbf ***** 3. Организуем цикл по объектам. ******* Создаем массив кодов уже назначенных объектов распознаваемой выборки, чтобы назначать объекты только один раз aObjNaz := {} CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE RObj_zat EXCLUSIVE NEW USE Klas_res EXCLUSIVE NEW USE Rasp_naz EXCLUSIVE NEW ****** Восстановление остатков. Сброс всех расчетных полей в БД Klass_res.dbf *********************************************************************************************************** * aStructure := { { "Kod" , "N", 15 , 0},; // 1 Код класса * { "Name" , "C", mLenCls, 0},; // 2 Наименование класса * { "Resource" , "N", 15 , 3},; // 3 Начальный ресурс класса * { "OstatokRes", "N", 15 , 3},; // 4 Остаток ресурса класса LC * { "Kol_Obj" , "N", 15 , 3},; // 5 Количество объектов, назначенных на класс LC * { "Sum_UrSxod", "N", 15 , 3},; // 6 Суммарное сходство назначенных объектов LC * { "Sum_Zatrat", "N", 15 , 3},; // 7 Суммарные затраты на назначенные объекты LC * { "Svz_UdSxod", "N", 15 , 3},; // 8 Средневзвешенное удельное сходство LC * { "Avr_UrSxod", "N", 15 , 3},; // 9 Средний на объект уровень сходства LC * { "Avr_Zatrat", "N", 15 , 3},; // 10 Средние на объект затраты LC * { "Ost_ResRND", "N", 15 , 3},; // 11 Остаток ресурса класса RND * { "Kol_ObjRND", "N", 15 , 3},; // 12 Количество объектов, назначенных на класс RND * { "SumUrSxRND", "N", 15 , 3},; // 13 Суммарное сходство назначенных объектов RND * { "SumZatrRND", "N", 15 , 3},; // 14 Суммарные затраты на назначенные объекты RND * { "SvzUdSxRND", "N", 15 , 3},; // 15 Средневзвешенное удельное сходство RND * { "AvrUrSxRND", "N", 15 , 3},; // 16 Средний на объект уровень сходства RND * { "AvrZatrRND", "N", 15 , 3} } // 17 Средние на объект затраты RND * DbCreate( "Klas_res.dbf", aStructure ) *********************************************************************************************************** SELECT Klas_res DBGOTOP() DO WHILE .NOT. EOF() DO CASE CASE mParam = 'LC' REPLACE OstatokRes WITH Resource FOR j=5 TO 10 FIELDPUT(j, 0) NEXT CASE mParam = 'RND' REPLACE Ost_ResRND WITH Resource FOR j=12 TO 17 FIELDPUT(j, 0) NEXT ENDCASE DBSKIP(1) ENDDO *MsgBox('STOP') **************************************************************** Mess = L("4. Назначение объектов на наиболее подходящие классы") **************************************************************** aClsAssign := {} // Коды классов, на которые объекты уже назначены SELECT Rasp_naz DBGOTOP() DO WHILE .NOT. EOF() * 4. Назначаем текущий объект на тот класс, удельное сходство с которым макси- * мально, при условии, что у данного класса есть для этого ресурсы, и делать * это до тех пор, пока есть классы с ресурсами и назначены не все объекты. M_KodRobj = Kod_obj M_KodKl = Kod_Cls M_Zatr = Zatrati // Можно назначать данный объект (или потому, что он не был назначен ранее, // или потому, что задана опция, что можно назначать ранее назначенные объекты) mFlagAss1 = .T. IF .NOT. mN_CopyAssign // Можно назначать ранее назначенные объекты ############################# SELECT RObj_zat DBGOTO(M_KodRobj) DO CASE CASE mParam = 'LC' IF AssignLC = 'Y' // Объект M_KodRobj не был назначен ранее с помощью LC-алгоритма mFlagAss1 = .F. ENDIF CASE mParam = 'RND' IF AssignRND = 'Y' // Объект M_KodRobj не был назначен ранее с помощью RND-алгоритма mFlagAss1 = .F. ENDIF ENDCASE ENDIF IF mFlagAss1 // Объект M_KodRobj не был назначен ранее или вообще не надо это проверять IF ASCAN(aObjNaz, M_KodRobj) = 0 // Объект M_KodRobj еще не назначен в этот раз (это проверять всегда) SELECT Rasp_naz mFlagAss2 = .T. // Если .T. - можно назначать объект на класс ############################ IF .NOT. mN_ObjAssign // Если можно назначать более 1 объекта на класс IF ASCAN(aClsAssign, M_KodKl) = 0 // На данный класс объект еще не назначен mFlagAss2 = .T. // Если .T. - можно назначать объект на класс, если есть ресурсы ENDIF ELSE // Можно назначать много объектов на класс mFlagAss2 = .T. // Если .T. - можно назначать объект на класс, если есть ресурсы ENDIF IF mFlagAss2 SELECT Klas_res DBGOTO(M_KodKl) DO CASE CASE mParam = 'LC' M_Ostatok = OstatokRes CASE mParam = 'RND' M_Ostatok = Ost_ResRND ENDCASE IF M_Zatr <= M_Ostatok // Если остатка ресурсов хватает для назначения текущего объекта, то назначить его DO CASE CASE mParam = 'LC' REPLACE OstatokRes WITH M_Ostatok - M_Zatr CASE mParam = 'RND' REPLACE Ost_ResRND WITH M_Ostatok - M_Zatr ENDCASE SELECT Rasp_naz REPLACE Klas_naz WITH M_KodKl AADD(aObjNaz, M_KodRobj) // Запомнить, что объект назначен, чтобы больше его не назначать IF mN_ObjAssign AADD(aClsAssign, M_KodKl) // Запомнить, что на данный класс объект уже назначен, чтобы больше на этот класс не назначать ENDIF ENDIF ENDIF ENDIF ENDIF SELECT Rasp_naz DBSKIP(1) ENDDO *MsgBox('STOP') ***** Отметить назначенные объекты в БД затрат, чтобы не назначать их в будущем CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE RObj_zat EXCLUSIVE NEW SELECT RObj_zat DBGOTOP() DO WHILE .NOT. EOF() IF ASCAN(aObjNaz, Kod) > 0 // Объект Kod назначен DO CASE CASE mParam = 'LC' REPLACE AssignLC WITH 'Y' CASE mParam = 'RND' REPLACE AssignRND WITH 'Y' ENDCASE ENDIF DBSKIP(1) ENDDO ***** ВЫВОД РЕЗУЛЬТАТОВ *********************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rasp_naz EXCLUSIVE NEW DO CASE CASE mParam = 'LC' DO CASE CASE mN_TargetAssign = 1 // 1. Повышение уровня системности. INDEX ON STR(Klas_naz,15)+STR(9999999999.999-Ud_Sxod ,15,3) TO Rnz_udsx // Упорядочивание назначаемых объектов в порядке убывания удельного сходства с классами CASE mN_TargetAssign = 2 // 2. Понижение уровня системности. INDEX ON STR(Klas_naz,15)+STR(Ud_Sxod ,15,3) TO Rnz_udsx // Упорядочивание назначаемых объектов в порядке возрастания удельного сходства с классами CASE mN_TargetAssign = 3 // 3. Минимизация средних затрат на назначения объектов. INDEX ON STR(Klas_naz,15)+STR(zatrati ,15,3) TO Rnz_udsx // Упорядочивание назначаемых объектов в порядке возрастания затрат на назначение объектов CASE mN_TargetAssign = 4 // 4. Максимизация средних затрат на назначения объектов. INDEX ON STR(Klas_naz,15)+STR(9999999999.999-Zatrati ,15,3) TO Rnz_udsx // Упорядочивание назначаемых объектов в порядке убывания затрат на назначение объектов ENDCASE CASE mParam = 'RND' INDEX ON STR(Klas_naz,15)+STR(9999999999.999-Rand_key,15,3) TO Rnz_udsx ENDCASE CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Klas_res EXCLUSIVE NEW USE RObj_zat EXCLUSIVE NEW USE Rasp_naz INDEX Rnz_udsx EXCLUSIVE NEW SELECT Rasp_naz SET ORDER TO 1 DBGOTOP() ******* Дорасчет БД Klas_res.dbf M_KodKl_Old = Klas_naz M_KolObj = 0 M_SumUrSx = 0 M_SumZatr = 0 DO WHILE .NOT. EOF() M_KodKln = Klas_naz IF M_KodKl_Old = M_KodKln ++M_KolObj M_SumUrSx = M_SumUrSx + Ur_Sxod M_SumZatr = M_SumZatr + Zatrati ELSE SELECT Klas_res DBGOTO(M_KodKl_Old) DO CASE CASE mParam = 'LC' REPLACE Sum_UrSxod WITH M_SumUrSx REPLACE Sum_Zatrat WITH M_SumZatr IF M_SumZatr > 0 REPLACE Svz_UdSxod WITH M_SumUrSx/M_SumZatr ENDIF IF M_KolObj > 0 REPLACE Kol_obj WITH M_KolObj REPLACE Avr_UrSxod WITH M_SumUrSx/M_KolObj REPLACE Avr_Zatrat WITH M_SumZatr/M_KolObj ENDIF CASE mParam = 'RND' REPLACE SumUrSxRND WITH M_SumUrSx REPLACE SumZatrRND WITH M_SumZatr IF M_SumZatr > 0 REPLACE SvzUdSxRND WITH M_SumUrSx/M_SumZatr ENDIF IF M_KolObj > 0 REPLACE Kol_ObjRND WITH M_KolObj REPLACE AvrUrSxRND WITH M_SumUrSx/M_KolObj REPLACE AvrZatrRND WITH M_SumZatr/M_KolObj ENDIF ENDCASE SELECT Rasp_naz M_KodKl_Old = Klas_naz M_KolObj = 0 M_SumUrSx = 0 M_SumZatr = 0 ++M_KolObj M_SumUrSx = M_SumUrSx + Ur_Sxod M_SumZatr = M_SumZatr + Zatrati ENDIF SELECT Rasp_naz DBSKIP(1) ENDDO SELECT Klas_res DBGOTO(M_KodKln) DO CASE CASE mParam = 'LC' REPLACE Sum_UrSxod WITH M_SumUrSx REPLACE Sum_Zatrat WITH M_SumZatr IF M_SumZatr > 0 REPLACE Svz_UdSxod WITH M_SumUrSx/M_SumZatr ENDIF IF M_KolObj > 0 REPLACE Kol_obj WITH M_KolObj REPLACE Avr_UrSxod WITH M_SumUrSx/M_KolObj REPLACE Avr_Zatrat WITH M_SumZatr/M_KolObj ENDIF CASE mParam = 'RND' REPLACE SumUrSxRND WITH M_SumUrSx REPLACE SumZatrRND WITH M_SumZatr IF M_SumZatr > 0 REPLACE SvzUdSxRND WITH M_SumUrSx/M_SumZatr ENDIF IF M_KolObj > 0 REPLACE Kol_ObjRND WITH M_KolObj REPLACE AvrUrSxRND WITH M_SumUrSx/M_KolObj REPLACE AvrZatrRND WITH M_SumZatr/M_KolObj ENDIF ENDCASE ****** Расчет итоговых строк БД Klas_res.dbf ****** Удалить их перед расчетом, т.к. после расчета они добавляются SELECT Klas_res DELETE FOR Name = "Сумма по классам:" DELETE FOR Name = "Среднее на класс:" PACK N_Klass = RECCOUNT() N_Field = FCOUNT() PRIVATE Ar_field[N_Field] // Значения строки: "Сумма по классам:" AFILL(Ar_field,0) // Сначала 0, чтобы посчитать сумму, а потом делим на N_Klass DBGOTOP() DO WHILE .NOT. EOF() SELECT Klas_res FOR j=3 TO N_Field Ar_field[j] = Ar_field[j] + FIELDGET(j) NEXT DBSKIP(1) ENDDO APPEND BLANK REPLACE Name WITH "Сумма по классам:" FOR j=3 TO N_Field FIELDPUT(j, Ar_field[j]) NEXT APPEND BLANK REPLACE Name WITH "Среднее на класс:" FOR j=3 TO N_Field FIELDPUT(j, Ar_field[j]/N_Klass) NEXT ************************* *** Pedro *************** *set device to printer *set printer on *set printer to ("Result_naz.txt") *set console off *...Print commands *Set device to screen *Set printer off *Set printer to *Set console on ************************* // Загрузить M_PathAppl с диска M_PathAppl = DC_ARestore("_PathAppl.arx") *mFileName = M_PathAppl+"Result_naz.txt" *mFileName = "Result_naz.txt" *MsgBox(mFileName) DO CASE CASE mParam = 'LC' mFileName = "ResNaz_LC.txt" CASE mParam = 'RND' mFileName = "ResNaz_RND.txt" ENDCASE set device to printer set printer on set printer to (mFileName) set console off Ln = 74 DO CASE CASE mParam = 'LC' // ############################################################################################################ ?"РЕЗУЛЬТАТЫ НАЗНАЧЕНИЙ ОБЪЕКТОВ НА КЛАССЫ, LC-АЛГОРИТМ" ?IF(mN_ObjAssign , "(допускается назначение более 1 объекта на класс)", "(не допускается назначение более 1 объекта на класс)") ?IF(mN_CopyAssign, "(допускается назначение ранее назначенных объектов)" , "(не допускается назначение ранее назначенных объектов)") DO CASE CASE mN_TargetAssign = 1 ?"(Цель - 1. Повышение уровня системности)" CASE mN_TargetAssign = 2 ?"(Цель - 2. Понижение уровня системности)" CASE mN_TargetAssign = 3 ?"(Цель - 3. Минимизация средних затрат на назначения объектов)" CASE mN_TargetAssign = 4 ?"(Цель - 4. Максимизация средних затрат на назначения объектов)" ENDCASE ?DTOC(DATE())+SPACE(2)+TIME()+SPACE(43)+"г.Краснодар" ?REPLICATE("=",Ln) mStr = "|ХАРАКТЕРИСТИКИ ЭФФЕКТИВНОСТИ НАЗНАЧЕНИЯ:" ;?mStr+SPACE(Ln-1-LEN(mStr))+"|" ?REPLICATE("~",Ln) mStr = "|СУММА ПО ВСЕМ КЛАССАМ:" ;?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Начальный ресурс класса:............................ " +ALLTRIM(STR(Ar_field[ 3],17,7));?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Остаток ресурса после назначений объектов на классы: " +ALLTRIM(STR(Ar_field[ 4],17,7));?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Всего назначено на классы объектов:................. " +ALLTRIM(STR(Ar_field[ 5],17)) ;?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Суммарное сходство:................................. " +ALLTRIM(STR(Ar_field[ 6],17,7));?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Фактические суммарные затраты:...................... " +ALLTRIM(STR(Ar_field[ 7],17,7));?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Средневзвешенное удельное сходство:................. " +ALLTRIM(STR(Ar_field[ 8],17,7));?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Среднее на объект суммарное сходство:............... " +ALLTRIM(STR(Ar_field[ 9],17,7));?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Средние на объект фактические суммарные затраты:.... " +ALLTRIM(STR(Ar_field[10],17,7));?mStr+SPACE(Ln-1-LEN(mStr))+"|" ?REPLICATE("~",Ln) mStr = "|СРЕДНЕЕ НА КЛАСС:" ;?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Начальный ресурс класса:............................ " +ALLTRIM(STR(Ar_field[ 3]/N_Klass,17,7));?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Остаток ресурса после назначений объектов на классы: " +ALLTRIM(STR(Ar_field[ 4]/N_Klass,17,7));?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|В среднем на класс назначено объектов:.............. " +ALLTRIM(STR(Ar_field[ 5]/N_Klass,17)) ;?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Суммарное сходство:................................. " +ALLTRIM(STR(Ar_field[ 6]/N_Klass,17,7));?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Фактические суммарные затраты:...................... " +ALLTRIM(STR(Ar_field[ 7]/N_Klass,17,7));?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Средневзвешенное удельное сходство:................. " +ALLTRIM(STR(Ar_field[ 8]/N_Klass,17,7));?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Среднее на объект суммарное сходство:............... " +ALLTRIM(STR(Ar_field[ 9]/N_Klass,17,7));?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Средние на объект фактические суммарные затраты:.... " +ALLTRIM(STR(Ar_field[10]/N_Klass,17,7));?mStr+SPACE(Ln-1-LEN(mStr))+"|" ?REPLICATE("=",Ln) ?"" SELECT Rasp_naz SET FILTER TO Klas_naz > 0 SET ORDER TO 1 DBGOTOP() M_KodKl_Old = -9999 Num_pp = 0 DBGOTOP() DO WHILE .NOT. EOF() M_KodObj = Kod_obj // Здесь ВСЕ проверить, наименования полей заменены на новые M_NameObj = Name_Obj M_KodCls = Kod_Cls M_NameCls = Name_Cls M_UrSxod = Ur_Sxod M_Zatr = Zatrati M_UdSxod = Ud_Sxod M_KodKln = Klas_naz ** Печать информации по новому классу из БД Klas_res.dbf IF M_KodKl_Old <> M_KodKln Num_pp = 0 M_KodKl_Old = Klas_naz SELECT Klas_res DBGOTO(M_KodCls) ?REPLICATE("=",Ln) mStr = "|КЛАСС НАЗНАЧЕНИЯ:" ;?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Код: "+ALLTRIM(STR(M_KodKln,4))+", наименование: " +ALLTRIM(M_NameCls) ;?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Начальный ресурс класса:........................... " +ALLTRIM(STR(Resource ,17,7));?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Остаток ресурса после назначений объектов на класс: " +ALLTRIM(STR(OstatokRes,17,7));?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Всего на данный класс назначено объектов:.......... " +ALLTRIM(STR(Kol_obj,17)) ;?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Суммарное сходство:................................ " +ALLTRIM(STR(Sum_UrSxod,17,7));?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Фактические суммарные затраты:..................... " +ALLTRIM(STR(Sum_Zatrat,17,7));?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Средневзвешенное удельное сходство:................ " +ALLTRIM(STR(Svz_UdSxod,17,7));?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Среднее на объект суммарное сходство:.............. " +ALLTRIM(STR(Avr_UrSxod,17,7));?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Средние на объект фактические суммарные затраты:... " +ALLTRIM(STR(Avr_Zatrat,17,7));?mStr+SPACE(Ln-1-LEN(mStr))+"|" ?REPLICATE("~",Ln) mStr = "| Номер | Код | Наименование |Ур-нь сходст| Затраты на |Удельное сход";?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|по пор.|объекта| объекта |об.с классом|назн. объекта|об. с классом";?mStr+SPACE(Ln-1-LEN(mStr))+"|" * | 12345 | 12345 |123456789012345|1234.6789012|12345.7890123|12345.7890123 * 12345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890 * 10 20 30 40 50 60 70 75 ?REPLICATE("~",Ln) ENDIF mStr = "|"+" "+STR(++Num_pp,5)+" "+"|"+" "+STR(M_KodObj,5)+" "+"|"+SUBSTR(M_NameObj,1,15)+"|"+STR(M_UrSxod,12,7)+"|"+STR(M_Zatr,13,7)+"|"+STR(M_UdSxod,13,7);?mStr+SPACE(Ln-1-LEN(mStr))+"|" SELECT Rasp_naz DBSKIP(1) ENDDO ?REPLICATE("=",Ln) ?"" mStr = "ДАННЫЕ ПО НЕНАЗНАЧЕННЫМ ОБЪЕКТАМ (LC-алгоритм):" ;?mStr+SPACE(Ln-1-LEN(mStr)) ?REPLICATE("=",Ln) mStr = "|Ном| Код | Наименование | Код | Наименование |Ур.сход|Затр.на|Уд.сх.";?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "| |объек| объекта |клас.| класса |об.с кл|объект |об.кл.";?mStr+SPACE(Ln-1-LEN(mStr))+"|" * |123|12345|123456789012345|12345|12345678901234567|123.567|123.567|12.456 * 12345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890 * 10 20 30 40 50 60 70 75 ?REPLICATE("~",Ln) ***** Убрать из списка неназначенных объектов все назначенные (с помощью массива) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rasp_naz EXCLUSIVE NEW SELECT Rasp_naz SET FILTER TO Klas_naz = 0 N_ObjNen = 0 // Количество неназначенных объектов Num_pp = 0 mSum_UrSxod = 0 mSum_Zatr = 0 mSum_UdSxod = 0 DBGOTOP() DO WHILE .NOT. EOF() M_KodObj = Kod_obj IF ASCAN(aObjNaz, M_KodObj) = 0 // Объект Kod_obj не назначен mStr = "|"+STR(++Num_pp,3)+"|"+STR(Kod_obj,5)+"|"+SUBSTR(Name_Obj,1,15)+"|"+STR(Kod_cls,5)+"|"+SUBSTR(Name_cls,1,17)+"|"+STR(Ur_Sxod,7,3)+"|"+STR(Zatrati,7,3)+"|"+STR(Ud_Sxod,6,3);?mStr+SPACE(Ln-1-LEN(mStr))+"|" ++N_ObjNen mSum_UrSxod = mSum_UrSxod + Ur_Sxod mSum_Zatr = mSum_Zatr + Zatrati mSum_UdSxod = mSum_UdSxod + Ud_Sxod ENDIF DBSKIP(1) ENDDO ?REPLICATE("~",Ln) mAvr_UrSxod = mSum_UrSxod / N_ObjNen mAvr_Zatr = mSum_Zatr / N_ObjNen mAvr_UdSxod = mSum_UdSxod / N_ObjNen * Str = "|Ном| Код | Наименование | Код | Наименование |Ур.сход|Затр.на|Уд.сх.";?mStr+SPACE(Ln-1-LEN(mStr))+"|" * Str = "| |объек| объекта |клас.| класса |об.с кл|объект |об.кл.";?mStr+SPACE(Ln-1-LEN(mStr))+"|" * |123|12345|123456789012345|12345|12345678901234567|123.567|123.567|123.567 * 12345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890 * 10 20 30 40 50 60 70 75 mStr = "| | |В СРЕДНЕМ: | | |"+STR(mAvr_UrSxod,7,3)+"|"+STR(mAvr_Zatr,7,3)+"|"+STR(mAvr_UdSxod,6,3);?mStr+SPACE(Ln-1-LEN(mStr))+"|" ?REPLICATE("=",Ln) ?"" mStr = "ДАННЫЕ ПО КЛАССАМ, НА КОТОРЫЕ НЕ БЫЛО НАЗНАЧЕНИЙ ОБЪЕКТОВ (LC-алгоритм):" ;?mStr+SPACE(Ln-1-LEN(mStr)) ?REPLICATE("=",Ln) mStr = "|Номер| Код | Наименование | Начальный ";?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "| |класса| класса | ресурс класса ";?mStr+SPACE(Ln-1-LEN(mStr))+"|" * |12345|123456|1234567890123456789012345678901234567890123|12345678901.345 * 12345678901234567890123456789012345678901234567890123456789012345678901234 * 10 20 30 40 50 60 70 74 ?REPLICATE("~",Ln) ***** Убрать из списка классов все, на которые были назначения CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Klas_res EXCLUSIVE NEW SELECT Klas_res SET FILTER TO KOL_OBJ = 0 // Количество объектов, назначенных на класс N_ClsNen = 0 // Количество неназначенных классов Num_pp = 0 mSum_Resurs = 0 // Суммарный ресурс неназначенных классов DBGOTOP() DO WHILE .NOT. EOF() mName = ALLTRIM(SUBSTR(Name,1,43)) IF LEN(mName) < 43 mName = mName + REPLICATE('.',43-LEN(ALLTRIM(mName))) ENDIF mStr = "|"+STR(++Num_pp,5)+"|"+STR(Kod,6)+"|"+mName+"|"+STR(RESOURCE,15,3);?mStr+SPACE(Ln-1-LEN(mStr))+"|" ++N_ClsNen mSum_Resurs = mSum_Resurs + RESOURCE DBSKIP(1) ENDDO ?REPLICATE("~",Ln) mAvr_Resurs = mSum_Resurs / N_ClsNen // Средний ресурс неназначенных классов * mStr = "|Номер| Код | Наименование | Начальный ";?mStr+SPACE(Ln-1-LEN(mStr))+"|" * mStr = "| |класса| класса | ресурс класса ";?mStr+SPACE(Ln-1-LEN(mStr))+"|" * |12345|123456|1234567890123456789012345678901234567890123|12345678901.345 * 12345678901234567890123456789012345678901234567890123456789012345678901234 * 10 20 30 40 50 60 70 74 mStr = "| | | СУММА : |"+STR(mSum_Resurs,15,3);?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "| | | СРЕДНЕЕ: |"+STR(mAvr_Resurs,15,3);?mStr+SPACE(Ln-1-LEN(mStr))+"|" ?REPLICATE("=",Ln) mStr = 'Универсальная когнитивная аналитическая система "Эйдос"' ;?mStr+SPACE(Ln-1-LEN(mStr)) CASE mParam = 'RND' // ############################################################################################################ ?"РЕЗУЛЬТАТЫ НАЗНАЧЕНИЙ ОБЪЕКТОВ НА КЛАССЫ, RND-АЛГОРИТМ" ?IF(mN_ObjAssign , "(допускается назначение более 1 объекта на класс)", "(не допускается назначение более 1 объекта на класс)") ?IF(mN_CopyAssign, "(допускается назначение ранее назначенных объектов)" , "(не допускается назначение ранее назначенных объектов)") DO CASE CASE mN_TargetAssign = 1 ?"(Цель - 1. Повышение уровня системности)" CASE mN_TargetAssign = 2 ?"(Цель - 2. Понижение уровня системности)" CASE mN_TargetAssign = 3 ?"(Цель - 3. Минимизация средних затрат на назначения объектов)" CASE mN_TargetAssign = 4 ?"(Цель - 4. Максимизация средних затрат на назначения объектов)" ENDCASE ?DTOC(DATE())+SPACE(2)+TIME()+SPACE(43)+"г.Краснодар" ?REPLICATE("=",Ln) mStr = "|ХАРАКТЕРИСТИКИ ЭФФЕКТИВНОСТИ НАЗНАЧЕНИЯ:" ;?mStr+SPACE(Ln-1-LEN(mStr))+"|" ?REPLICATE("~",Ln) mStr = "|СУММА ПО ВСЕМ КЛАССАМ:" ;?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Начальный ресурс класса:............................ " +ALLTRIM(STR(Ar_field[ 3],17,7));?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Остаток ресурса после назначений объектов на классы: " +ALLTRIM(STR(Ar_field[11],17,7));?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Всего назначено на классы объектов:................. " +ALLTRIM(STR(Ar_field[12],17)) ;?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Суммарное сходство:................................. " +ALLTRIM(STR(Ar_field[13],17,7));?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Фактические суммарные затраты:...................... " +ALLTRIM(STR(Ar_field[14],17,7));?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Средневзвешенное удельное сходство:................. " +ALLTRIM(STR(Ar_field[15],17,7));?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Среднее на объект суммарное сходство:............... " +ALLTRIM(STR(Ar_field[16],17,7));?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Средние на объект фактические суммарные затраты:.... " +ALLTRIM(STR(Ar_field[17],17,7));?mStr+SPACE(Ln-1-LEN(mStr))+"|" ?REPLICATE("~",Ln) mStr = "|СРЕДНЕЕ НА КЛАСС:" ;?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Начальный ресурс класса:............................ " +ALLTRIM(STR(Ar_field[ 3]/N_Klass,17,7));?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Остаток ресурса после назначений объектов на классы: " +ALLTRIM(STR(Ar_field[11]/N_Klass,17,7));?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|В среднем на класс назначено объектов:.............. " +ALLTRIM(STR(Ar_field[12]/N_Klass,17)) ;?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Суммарное сходство:................................. " +ALLTRIM(STR(Ar_field[13]/N_Klass,17,7));?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Фактические суммарные затраты:...................... " +ALLTRIM(STR(Ar_field[14]/N_Klass,17,7));?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Средневзвешенное удельное сходство:................. " +ALLTRIM(STR(Ar_field[15]/N_Klass,17,7));?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Среднее на объект суммарное сходство:............... " +ALLTRIM(STR(Ar_field[16]/N_Klass,17,7));?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Средние на объект фактические суммарные затраты:.... " +ALLTRIM(STR(Ar_field[17]/N_Klass,17,7));?mStr+SPACE(Ln-1-LEN(mStr))+"|" ?REPLICATE("=",Ln) ?"" SELECT Rasp_naz SET FILTER TO Klas_naz > 0 SET ORDER TO 1 DBGOTOP() M_KodKl_Old = -9999 Num_pp = 0 DBGOTOP() DO WHILE .NOT. EOF() M_KodObj = Kod_obj // Здесь ВСЕ проверить, наименования полей заменены на новые M_NameObj = Name_Obj M_KodCls = Kod_Cls M_NameCls = Name_Cls M_UrSxod = Ur_Sxod M_Zatr = Zatrati M_UdSxod = Ud_Sxod M_KodKln = Klas_naz ** Печать информации по новому классу из БД Klas_res.dbf IF M_KodKl_Old <> M_KodKln Num_pp = 0 M_KodKl_Old = Klas_naz SELECT Klas_res DBGOTO(M_KodCls) ?REPLICATE("=",Ln) mStr = "|КЛАСС НАЗНАЧЕНИЯ:" ;?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Код: "+ALLTRIM(STR(M_KodKln,4))+", наименование: " +ALLTRIM(M_NameCls) ;?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Начальный ресурс класса:........................... " +ALLTRIM(STR(Resource ,17,7));?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Остаток ресурса после назначений объектов на класс: " +ALLTRIM(STR(Ost_ResRND,17,7));?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Всего на данный класс назначено объектов:.......... " +ALLTRIM(STR(Kol_ObjRND,17)) ;?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Суммарное сходство:................................ " +ALLTRIM(STR(SumUrSxRND,17,7));?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Фактические суммарные затраты:..................... " +ALLTRIM(STR(SumZatrRND,17,7));?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Средневзвешенное удельное сходство:................ " +ALLTRIM(STR(SvzUdSxRND,17,7));?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Среднее на объект суммарное сходство:.............. " +ALLTRIM(STR(AvrUrSxRND,17,7));?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|Средние на объект фактические суммарные затраты:... " +ALLTRIM(STR(Avr_Zatrat,17,7));?mStr+SPACE(Ln-1-LEN(mStr))+"|" ?REPLICATE("~",Ln) mStr = "| Номер | Код | Наименование |Ур-нь сходст| Затраты на |Удельное сход";?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "|по пор.|объекта| объекта |об.с классом|назн. объекта|об. с классом";?mStr+SPACE(Ln-1-LEN(mStr))+"|" * | 12345 | 12345 |123456789012345|1234.6789012|12345.7890123|12345.7890123 * 12345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890 * 10 20 30 40 50 60 70 75 ?REPLICATE("~",Ln) ENDIF mStr = "|"+" "+STR(++Num_pp,5)+" "+"|"+" "+STR(M_KodObj,5)+" "+"|"+SUBSTR(M_NameObj,1,15)+"|"+STR(M_UrSxod,12,7)+"|"+STR(M_Zatr,13,7)+"|"+STR(M_UdSxod,13,7);?mStr+SPACE(Ln-1-LEN(mStr))+"|" SELECT Rasp_naz DBSKIP(1) ENDDO ?REPLICATE("=",Ln) ?"" mStr = "ДАННЫЕ ПО НЕНАЗНАЧЕННЫМ ОБЪЕКТАМ (RND-алгоритм):" ;?mStr+SPACE(Ln-1-LEN(mStr)) ?REPLICATE("=",Ln) mStr = "|Ном| Код | Наименование | Код | Наименование |Ур.сход|Затр.на|Уд.сх.";?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "| |объек| объекта |клас.| класса |об.с кл|объект |об.кл.";?mStr+SPACE(Ln-1-LEN(mStr))+"|" * |123|12345|123456789012345|12345|12345678901234567|123.567|123.567|12.456 * 12345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890 * 10 20 30 40 50 60 70 75 ?REPLICATE("~",Ln) ***** Убрать из списка неназначенных объектов все назначенные (с помощью массива) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rasp_naz EXCLUSIVE NEW SELECT Rasp_naz SET FILTER TO Klas_naz = 0 N_ObjNen = 0 // Количество неназначенных объектов Num_pp = 0 mSum_UrSxod = 0 mSum_Zatr = 0 mSum_UdSxod = 0 DBGOTOP() DO WHILE .NOT. EOF() M_KodObj = Kod_obj IF ASCAN(aObjNaz, M_KodObj) = 0 // Объект Kod_obj не назначен mStr = "|"+STR(++Num_pp,3)+"|"+STR(Kod_obj,5)+"|"+SUBSTR(Name_Obj,1,15)+"|"+STR(Kod_cls,5)+"|"+SUBSTR(Name_cls,1,17)+"|"+STR(Ur_Sxod,7,3)+"|"+STR(Zatrati,7,3)+"|"+STR(Ud_Sxod,6,3);?mStr+SPACE(Ln-1-LEN(mStr))+"|" ++N_ObjNen mSum_UrSxod = mSum_UrSxod + Ur_Sxod mSum_Zatr = mSum_Zatr + Zatrati mSum_UdSxod = mSum_UdSxod + Ud_Sxod ENDIF DBSKIP(1) ENDDO ?REPLICATE("~",Ln) mAvr_UrSxod = mSum_UrSxod / N_ObjNen mAvr_Zatr = mSum_Zatr / N_ObjNen mAvr_UdSxod = mSum_UdSxod / N_ObjNen * Str = "|Ном| Код | Наименование | Код | Наименование |Ур.сход|Затр.на|Уд.сх.";?mStr+SPACE(Ln-1-LEN(mStr))+"|" * Str = "| |объек| объекта |клас.| класса |об.с кл|объект |об.кл.";?mStr+SPACE(Ln-1-LEN(mStr))+"|" * |123|12345|123456789012345|12345|12345678901234567|123.567|123.567|123.567 * 12345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890 * 10 20 30 40 50 60 70 75 mStr = "| | |В СРЕДНЕМ: | | |"+STR(mAvr_UrSxod,7,3)+"|"+STR(mAvr_Zatr,7,3)+"|"+STR(mAvr_UdSxod,6,3);?mStr+SPACE(Ln-1-LEN(mStr))+"|" ?REPLICATE("=",Ln) ?"" mStr = "ДАННЫЕ ПО КЛАССАМ, НА КОТОРЫЕ НЕ БЫЛО НАЗНАЧЕНИЙ ОБЪЕКТОВ (RND-алгоритм):";?mStr+SPACE(Ln-1-LEN(mStr)) ?REPLICATE("=",Ln) mStr = "|Номер| Код | Наименование | Начальный ";?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "| |класса| класса | ресурс класса ";?mStr+SPACE(Ln-1-LEN(mStr))+"|" * |12345|123456|1234567890123456789012345678901234567890123|12345678901.345 * 12345678901234567890123456789012345678901234567890123456789012345678901234 * 10 20 30 40 50 60 70 74 ?REPLICATE("~",Ln) ***** Убрать из списка классов все, на которые были назначения CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Klas_res EXCLUSIVE NEW SELECT Klas_res SET FILTER TO KOL_OBJ = 0 // Количество объектов, назначенных на класс N_ClsNen = 0 // Количество неназначенных классов Num_pp = 0 mSum_Resurs = 0 // Суммарный ресурс неназначенных классов DBGOTOP() DO WHILE .NOT. EOF() mName = ALLTRIM(SUBSTR(Name,1,43)) IF LEN(mName) < 43 mName = mName + REPLICATE('.',43-LEN(ALLTRIM(mName))) ENDIF mStr = "|"+STR(++Num_pp,5)+"|"+STR(Kod,6)+"|"+mName+"|"+STR(RESOURCE,15,3);?mStr+SPACE(Ln-1-LEN(mStr))+"|" ++N_ClsNen mSum_Resurs = mSum_Resurs + RESOURCE DBSKIP(1) ENDDO ?REPLICATE("~",Ln) mAvr_Resurs = mSum_Resurs / N_ClsNen // Средний ресурс неназначенных классов * mStr = "|Номер| Код | Наименование | Начальный ";?mStr+SPACE(Ln-1-LEN(mStr))+"|" * mStr = "| |класса| класса | ресурс класса ";?mStr+SPACE(Ln-1-LEN(mStr))+"|" * |12345|123456|1234567890123456789012345678901234567890123|12345678901.345 * 12345678901234567890123456789012345678901234567890123456789012345678901234 * 10 20 30 40 50 60 70 74 mStr = "| | | СУММА : |"+STR(mSum_Resurs,15,3);?mStr+SPACE(Ln-1-LEN(mStr))+"|" mStr = "| | | СРЕДНЕЕ: |"+STR(mAvr_Resurs,15,3);?mStr+SPACE(Ln-1-LEN(mStr))+"|" ?REPLICATE("=",Ln) mStr = 'Универсальная когнитивная аналитическая система "Эйдос"';?mStr+SPACE(Ln-1-LEN(mStr)) ENDCASE *** Pedro ********** Set device to screen Set printer off Set printer to Set console on DBGOTOP() *aMess := {} *AADD(aMess, L('ПРОЦЕСС НАЗНАЧЕНИЯ ОБЪЕКТОВ НА КЛАССЫ ЗАВЕРШЕН УСПЕШНО !!!') *AADD(aMess, L('Результаты назначений в файлах: "Result_naz.txt", "Rasp_naz.dbf", "Klas_res.dbf"') *AADD(aMess, L('в папке: '+M_PathAppl) *LB_Warning(aMess, L("4.1.6. Задача о назначениях. Назначение объектов на классы") *RUNSHELL( mFileName,"NOTEPAD.EXE",.T.,.T.) // Посмотреть напечатанный файл в блокноте **************** Вернуться в исходное состояние ржима 4.1.6. *CrDBResNaz416() // Если нет БД для отображения результатов назначения объектов на классы, то создать ее *CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций *USE Klas_res EXCLUSIVE NEW *USE RObj_zat EXCLUSIVE NEW *USE Result_naz EXCLUSIVE NEW *SELECT Klas_res *DBGOTOP() *SELECT RObj_zat *DBGOTOP() *SELECT Result_naz *DBGOTOP() *DC_GetRefresh(oBrowse3) ReTURN NIL ************************************************************************************************** ******** Помощь по режиму 4.1.6.3 ************************************************************************************************** FUNCTION Help4163() aHelp := {} AADD(aHelp, L('Режим: "4.1.6. РАЦИОНАЛЬНОЕ НАЗНАЧЕНИЕ ОБЪЕКТОВ НА КЛАССЫ (ЗАДАЧА О РАНЦЕ)". ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Ссылки на работы проф.Е.В.Луценко в этой области: ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Луценко Е.В. Решение обобщенной задачи о назначениях в системно-когнитивном анализе / Е.В. Луценко, В.Е. Коржаков ')) AADD(aHelp, L('// Политематический сетевой электронный научный журнал Кубанского государственного аграрного университета (Научный журнал ')) AADD(aHelp, L('КубГАУ) [Электронный ресурс]. - Краснодар: КубГАУ, 2009. - №07(051). С. 83 - 108. - Шифр Информрегистра: 0420900012\0070, ')) AADD(aHelp, L('IDA [article ID]: 0510907004. - Режим доступа: http://ej.kubagro.ru/2009/07/pdf/04.pdf, 1,625 у.п.л. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Луценко Е.В., Коржаков В.Е., Ермоленко В.В. Интеллектуальные системы в контроллинге и менеджменте средних и малых фирм: ')) AADD(aHelp, L('Под науч. ред. д.э.н., проф. Е.В.Луценко. Монография (научное издание). - Майкоп: АГУ. 2011. - 392 с. ')) AADD(aHelp, L('- Режим доступа: http://lc.kubagro.ru/aidos/aidos11_LKE/index.htm ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Луценко Е.В. Автоматизированный системно-когнитивный анализ как метод комплексного решения проблемы управления персоналом с ')) AADD(aHelp, L('применением функционально-стоимостного анализа / Е.В. Луценко, В.Е. Коржаков // Политематический сетевой электронный научный ')) AADD(aHelp, L('журнал Кубанского государственного аграрного университета (Научный журнал КубГАУ) [Электронный ресурс]. - Краснодар: КубГАУ, 2014')) AADD(aHelp, L('- №02(096). С. 1 - 16. - IDA [article ID]: 0961402001. - Режим доступа: http://ej.kubagro.ru/2014/02/pdf/01.pdf, 1 у.п.л. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Луценко Е.В. Управление персоналом с применением функционально-стоимостного и системно-когнитивного анализа / Е.В. Луценко, ')) AADD(aHelp, L('В.Е. Коржаков // Политематический сетевой электронный научный журнал Кубанского государственного аграрного университета (Научный ')) AADD(aHelp, L('журнал КубГАУ) [Электронный ресурс]. - Краснодар: КубГАУ, 2014. - №04(098). С. 1009 - 1041. - IDA [article ID]: 0981404075. ')) AADD(aHelp, L('- Режим доступа: http://ej.kubagro.ru/2014/04/pdf/75.pdf, 2,062 у.п.л. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Луценко Е.В. Интеллектуальное управление качеством систем путем решения обобщенной задачи о назначениях с применением АСК-анализа')) AADD(aHelp, L('и системы <Эйдос-Х++> / Е.В. Луценко // Политематический сетевой электронный научный журнал Кубанского государственного аграрного')) AADD(aHelp, L('университета (Научный журнал КубГАУ) [Электронный ресурс]. - Краснодар: КубГАУ, 2015. - №05(109). С. 1 - 51. - IDA [article ID]: ')) AADD(aHelp, L('1091505001. - Режим доступа: http://ej.kubagro.ru/2015/05/pdf/01.pdf, 3,188 у.п.л. ')) mHelpMax = -999;FOR h=1 TO LEN(aHelp);mHelpMax = MAX(mHelpMax, LEN(ALLTRIM(aHelp[h])));NEXT s=1;d=0.9;@0,0 DCGROUP oGroup1 CAPTION L(' ') SIZE mHelpMax-20, LEN(aHelp)*d+1.5 FOR h=1 TO LEN(aHelp);@s,2 DCSAY aHelp[h] SIZE 0 PARENT ogroup1;s=s+d;NEXT DCREAD GUI TO lExit FIT TITLE L('Помощь по режиму: "4.1.6. Рациональное назначение объектов на классы"') RETURN NIL ************************************************************************************************** ************************************************************************************************ ******** 4.1.6. Назначения объектов на классы (задача о назначениях) ******** Управление персоналом на основе АСК-анализа и функционально-стоимостного анализа ******** Все в одном окне: вверху слева - ресурсы по классам, ******** вверху справа - затраты на объекты ******** внизу отображение текстовых выходных форм с результатами ************************************************************************************************ FUNCTION F4_1_6() *********************************************************************************************************************************************** ******** 4.1.6. Назначения объектов на классы (задача о назначениях) Функционально-стоимостной анализ в управлении персоналом ******** 4.1.6.1. Задание ограничений на ресурсы по классам, Razrab(). ******** 4.1.6.2. Ввод затрат на объекты, Razrab(). ******** 4.1.6.3. Назначения объектов на классы (LC-алгоритм), Razrab(). ******** 4.1.6.4. Сравнение эффективности LC и RND алгоритмов, Razrab(). *********************************************************************************************************************************************** LOCAL GetList[0], oProgress, oDialog, oResNaz, oBrowse1, oBrowse2, oBrowse3 LOCAL cText, GetOptions, nWidth, cFont, cOutString, oMemo, oButton PUBLIC Time_progress, Wsego, lOk := .T., Sec_1 Running(.T.) IF ApplChange("4.1.6()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ********* Проверки на существование необходимых БД FlagError = .F. IF .NOT. FILE("Abs.txt") // БД абс.частот LB_Warning(L("Проведите рассчет матрицы абсолютных частот Abs.txt в режиме 3.1 или 3.5!")) FlagError = .T. ENDIF IF .NOT. FILE("Prc1.txt") .OR.; // БД процентных распределений .NOT. FILE("Prc2.txt") LB_Warning(L("Проведите рассчет матриц условных и безусловных процентных распределений Prc1 и Prc2 в режиме 3.2 или 3.5 !")) FlagError = .T. ENDIF IF .NOT. FILE("Inf1.txt") // БЗ-1 LB_Warning(L("Проведите рассчет баз знаний Inf1 - Inf7 в режиме 3.3 или 3.5!")) FlagError = .T. ENDIF IF FILE("_RaspInf.arx") // Файл с информацией о том, в какой модели было проведено распознавание M_RaspInf = DC_ARestore("_RaspInf.arx") Ar_Model := {"Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } IF M_CurrInf <> M_RaspInf Mess = L("Результаты распознавания получены в модели модели: #, отличающейся от текущей: $") Mess = STRTRAN(Mess, "#", Ar_Model[M_RaspInf]) Mess = STRTRAN(Mess, "$", Ar_Model[M_CurrInf]) LB_Warning(Mess, L("4.1.6. Рациональное назначение объектов на классы (задача о ранце)")) ENDIF ELSE aMess := {} AADD(aMess, L("Перед заданием ограничений на ресурсы по классам")) AADD(aMess, L("Необходимо выполнить режим 3.5 или 4.1.2 !!!")) LB_Warning(aMess, L("4.1.6. Рациональное назначение объектов на классы (задача о ранце)")) FlagError = .T. ENDIF IF FlagError ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ***** Если нет БД ресурсов классов, то создать ее CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций IF .NOT. FILE("Klas_res.dbf") CrDBRes4161() ENDIF ***** Если нет БД затрат по объектам, то создать ее CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций IF .NOT. FILE("RObj_zat.dbf") CrDBZat4162() ENDIF CrDBResNaz416() // Если нет БД для отображения результатов назначения объектов на классы, то создать ее CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Klas_res EXCLUSIVE NEW USE RObj_zat EXCLUSIVE NEW USE Result_naz EXCLUSIVE NEW SELECT Klas_res DBGOTOP() SELECT RObj_zat DBGOTOP() SELECT Result_naz DBGOTOP() aColors := { {GRA_CLR_WHITE,GRA_CLR_DARKRED },; {GRA_CLR_WHITE,GRA_CLR_DARKBLUE },; {GRA_CLR_BLACK,GRA_CLR_DARKGREEN} } PUBLIC aPres := ; { { XBP_PP_COL_HA_FGCLR, GRA_CLR_WHITE },; // Header FG Color { XBP_PP_COL_HA_BGCLR, GRA_CLR_DARKGRAY },; // Header BG Color { XBP_PP_COL_FA_FGCLR, GRA_CLR_YELLOW },; // Footer FG Color { XBP_PP_COL_FA_BGCLR, GRA_CLR_DARKGRAY },; // Footer BG Color { XBP_PP_COL_DA_ROWSEPARATOR, XBPCOL_SEP_DOTTED },; // Row Sep { XBP_PP_COL_DA_COLSEPARATOR, XBPCOL_SEP_DOTTED },; // Col Sep { XBP_PP_COL_HA_ALIGNMENT, XBPALIGN_LEFT },; // Header alignment (способ выравнивания наименований колонок) { XBP_PP_COL_DA_ROWHEIGHT, 22 },; // Row Height { XBP_PP_COL_DA_CELLHEIGHT, 22 } } // Cell Height ***************************************************************** // Границы рамки ********** WW = 78.0 // Ширина рамки HW = 17.0 // Высота рамки @0 , 0 DCGROUP oGroup1 CAPTION L('Задание ресурсов на классы:' ) SIZE WW , HW FONT "8.MS Sans Serif Bold" @0 ,WW+2 DCGROUP oGroup2 CAPTION L('Задание затрат на объекты:' ) SIZE WW , HW FONT "8.MS Sans Serif Bold" @HW+0.8, 0 DCGROUP oGroup3 CAPTION L('Результаты назначения объектов на классы:') SIZE 2*WW+2, HW FONT "8.MS Sans Serif Bold" NF = (WW-19)/2 // Размер поля наименования класса и объекта ****** Открытие окна для просмотра и корректировки БД ресурсов @ 1, 2 DCBROWSE oBrowse1 ALIAS 'Klas_res' SIZE WW-4,HW-4 FONT "8.MS Sans Serif"; EDIT xbeBRW_ItemSelected MODE DCGUI_BROWSE_EDITDOWN ; HEADLINES 2 ; // Кол-во строк в заголовке PRESENTATION aPres ; PARENT oGroup1 * PRESENTATION LC_BrowPres() ; // Только просмотр БД Users DCBROWSECOL FIELD Klas_res->Kod HEADER L("Код;класса" ) PARENT oBrowse1 WIDTH 6 PROTECT {|| .T. } // 1 Код класса DCBROWSECOL FIELD Klas_res->Name HEADER L("Наименование;класса" ) PARENT oBrowse1 WIDTH NF PROTECT {|| .T. } // 2 Наименование класса DCBROWSECOL FIELD Klas_res->Resource HEADER L("Начальный;ресурс класса") PARENT oBrowse1 WIDTH 7 FONT "10.Arial Bold" // 3 Начальный ресурс класса ********* Открытие окна для просмотра и корректировки БД затрат по объектам @ 1, 2 DCBROWSE oBrowse2 ALIAS 'RObj_zat' SIZE WW-4,HW-4 FONT "8.MS Sans Serif"; EDIT xbeBRW_ItemSelected MODE DCGUI_BROWSE_EDITDOWN ; HEADLINES 2 ; // Кол-во строк в заголовке PRESENTATION aPres ; PARENT oGroup2 DCBROWSECOL FIELD RObj_zat->Kod HEADER L("Код;объекта" ) PARENT oBrowse2 WIDTH 6 PROTECT {|| .T. } // 1 Код объекта DCBROWSECOL FIELD RObj_zat->Name HEADER L("Наименование;объекта" ) PARENT oBrowse2 WIDTH NF PROTECT {|| .T. } // 2 Наименование объекта DCBROWSECOL FIELD RObj_zat->Zatrati HEADER L("Затраты;на объект" ) PARENT oBrowse2 WIDTH 7 FONT "10.Arial Bold" // 3 Затраты на объект ********* Открытие нижнего окна для отображения результатов назначения объектов на классы aBrowPres := ; {{ XBP_PP_COL_DA_FGCLR, GRA_CLR_BLACK }, /* Row FG Color */ ; { XBP_PP_COL_DA_BGCLR, GRA_CLR_WHITE }, /* Row BG Color */ ; { XBP_PP_COL_DA_ROWHEIGHT, 14 }, /* Row Height 13 */ ; { XBP_PP_HILITE_FGCLR, GRA_CLR_BLACK }, /* Hilite FG color */ ; { XBP_PP_HILITE_BGCLR, GRA_CLR_WHITE }, /* Hilite BG color */ ; { XBP_PP_COL_DA_CELLFRAMELAYOUT , 2 }, /* Cell Frame Layout*/ ; { XBP_PP_COL_DA_COLSEPARATOR , 1 }, /* Column Separator */ ; { XBP_PP_COL_DA_FRAMELAYOUT , 0 }} /* Frame Layout */ ; @ 1, 2 DCBROWSE oBrowse3 ALIAS 'Result_naz' SIZE 2*WW-2,HW-4 FONT "8.Courier New"; EDIT xbeBRW_ItemSelected MODE DCGUI_BROWSE_EDITDOWN ; HEADLINES 1 ; // Кол-во строк в заголовке PRESENTATION aBrowPres ; PARENT oGroup3 DCBROWSECOL FIELD Result_naz->Result_LC HEADER L('LC-алгоритм' ) WIDTH 75.1 PARENT oBrowse3 PROTECT {|| .T. } DCBROWSECOL FIELD Result_naz->Result_RND HEADER L('RND-алгоритм') WIDTH 75.1 PARENT oBrowse3 PROTECT {|| .T. } ***************************************************************************** ***** Кнопки левого окна (ресурсы классов) ********************************** mMess1 = L('Помощь') @HW-2.4, 2 DCPUSHBUTTON CAPTION mMess1 SIZE LEN(mMess1)+4, 1.5 PARENT oGroup1 ACTION {||Help4161(), DC_GetRefresh(GetList) } FONT "8.MS Sans Serif" mMess2 = L('Пересоздать базу ресурсов') @HW-2.4, 3+5+LEN(mMess1) DCPUSHBUTTON CAPTION mMess2 SIZE LEN(mMess2)-1, 1.5 PARENT oGroup1 ACTION {||CrDBRes4161(), DC_GetRefresh(GetList) } FONT "8.MS Sans Serif" mMess3 = L('Задать значения ресурсов автоматически') @HW-2.4, 4+6+LEN(mMess1)+LEN(mMess2) DCPUSHBUTTON CAPTION mMess3 SIZE LEN(mMess3)-3, 1.5 PARENT oGroup1 ACTION {||AutoDB4161(), DC_GetRefresh(GetList) } FONT "8.MS Sans Serif" ***************************************************************************** ***** Кнопки правого окна (затраты объектов) ******************************** mMess1 = L('Помощь') @HW-2.4, 2 DCPUSHBUTTON CAPTION mMess1 SIZE LEN(mMess1)+4, 1.5 PARENT oGroup2 ACTION {||Help4162(), DC_GetRefresh(GetList) } FONT "8.MS Sans Serif" mMess2 = L('Пересоздать базу затрат') @HW-2.4, 3+6+LEN(mMess1) DCPUSHBUTTON CAPTION mMess2 SIZE LEN(mMess2)-1, 1.5 PARENT oGroup2 ACTION {||CrDBZat4162(), DC_GetRefresh(GetList) } FONT "8.MS Sans Serif" mMess3 = L('Задать значения затрат автоматически') @HW-2.4, 4+8+LEN(mMess1)+LEN(mMess2) DCPUSHBUTTON CAPTION mMess3 SIZE LEN(mMess3)-1, 1.5 PARENT oGroup2 ACTION {||AutoDB4162(), DC_GetRefresh(GetList) } FONT "8.MS Sans Serif" ***************************************************************************** ***** Кнопки нижнего окна (результаты назначения объектов на классы) ******** mMess1 = L('Назначить объекты на классы') @HW-2.4, 2 DCPUSHBUTTON CAPTION mMess1 SIZE LEN(mMess1)+10,1.5 PARENT oGroup3 ACTION {||RunLCRND4163(), DC_GetRefresh(GetList) } FONT "10.HelvBold" mMess2 = L('Ссылки на публикации по тематике') @HW-2.4, 16+LEN(mMess1) DCPUSHBUTTON CAPTION mMess2 SIZE LEN(mMess2), 1.5 PARENT oGroup3 ACTION {||Help4163(), DC_GetRefresh(GetList) } FONT "8.MS Sans Serif" mMess3 = L('Сравнить LC-алгоритм назначения объектов на классы с назначением случайным образом') // Более правильно было бы сравнить еще с назначением по уровню сходства без учета ФСА #################### @HW-2.4, 24+LEN(mMess1)+LEN(mMess2) DCPUSHBUTTON CAPTION mMess3 SIZE LEN(mMess3)-9, 1.5 PARENT oGroup3 ACTION {||CompLCRND(), DC_GetRefresh(GetList) } FONT "8.MS Sans Serif" ***************************************************************************** DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; OPTIONS GetOptions ; MODAL ; TITLE L('4.1.6. Рациональное назначение объектов на классы (задача о ранце)') ; FIT ; CLEAREVENTS ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) ReTURN nil ************************************************************************************************************************ ******** Назначить объекты на классы с учетом ресурсов классов, затрат на объекты и степени сходства объектов с классами ******** Каждый объект назначать 1 раз. На каждый класс назначать либо сколько угодно объектов, либо не более 1 объекта ******** Сравнить LC-алгоритм назначения объектов на классы с назначением случайным образом ************************************************************************************************************************ FUNCTION RunLCRND4163() LOCAL oBrowse1, oBrowse2, oBrowse3 ****** Параметры интерфейса **************************************************** IF .NOT. FILE('_Assign1.txt') .OR.; .NOT. FILE('_Assign2.txt') .OR.; .NOT. FILE('_Assign3.txt') * MsgBox('STOP') N_ObjAssign = 'Y' N_CopyAssign = 'Y' N_TargetAssign = '1' STRFILE(N_ObjAssign , '_Assign1.txt') // Запись файла STRFILE(N_CopyAssign , '_Assign2.txt') // Запись файла STRFILE(N_TargetAssign, '_Assign3.txt') // Запись файла ENDIF N_ObjAssign = FILESTR('_Assign1.txt') // Считывание файла N_CopyAssign = FILESTR('_Assign2.txt') // Считывание файла N_TargetAssign = FILESTR('_Assign3.txt') // Считывание файла mN_ObjAssign = IF(N_ObjAssign = 'Y', .T., .F.) // Для команд интерфейса mN_CopyAssign = IF(N_CopyAssign = 'Y', .T., .F.) // Для команд интерфейса mN_TargetAssign = VAL(N_TargetAssign) // Для команд интерфейса ******************************************************************************** // Границы рамки ********** WW = 78.0 // Ширина рамки @0.0, 0 DCGROUP oGroup1 CAPTION L('Допускается ли назначать:') SIZE WW, 3.5 FONT "8.MS Sans Serif Bold" @4.5, 0 DCGROUP oGroup2 CAPTION L('Цель назначения объектов:') SIZE WW, 5.5 FONT "8.MS Sans Serif Bold" NF = (WW-19)/2 // Размер поля наименования класса и объекта ****************************************************************************** @0.8, 2 DCCHECKBOX mN_ObjAssign PROMPT L('Более 1 объекта на класс?') PARENT oGroup1 FONT "8.MS Sans Serif" mMess1 = 'Помощь' @0.8,66 DCPUSHBUTTON CAPTION mMess1 SIZE LEN(mMess1)+4, 1.1 PARENT oGroup1 ACTION {||Help4164(), DC_GetRefresh(GetList) } FONT "8.MS Sans Serif" @2.0, 2 DCCHECKBOX mN_CopyAssign PROMPT L('Ранее назначенные объекты?') PARENT oGroup1 FONT "8.MS Sans Serif" mMess1 = 'Помощь' @2.0,66 DCPUSHBUTTON CAPTION mMess1 SIZE LEN(mMess1)+4, 1.1 PARENT oGroup1 ACTION {||Help4165(), DC_GetRefresh(GetList) } FONT "8.MS Sans Serif" ****************************************************************************** @0.8, 2 DCRADIO mN_TargetAssign VALUE 1 PROMPT L('1. Повышение уровня системности' ) PARENT oGroup2 FONT "8.MS Sans Serif" @1.8, 2 DCRADIO mN_TargetAssign VALUE 2 PROMPT L('2. Понижение уровня системности' ) PARENT oGroup2 FONT "8.MS Sans Serif" @2.8, 2 DCRADIO mN_TargetAssign VALUE 3 PROMPT L('3. Минимация средних затрат на назначения' ) PARENT oGroup2 FONT "8.MS Sans Serif" @3.8, 2 DCRADIO mN_TargetAssign VALUE 4 PROMPT L('4. Максимизация средних затрат на назначения') PARENT oGroup2 FONT "8.MS Sans Serif" @0.8,66 DCPUSHBUTTON CAPTION L(mMess1) SIZE LEN(mMess1)+4, 1.1 PARENT oGroup2 ACTION {||Help4166(), DC_GetRefresh(GetList) } FONT "8.MS Sans Serif" ****************************************************************************** DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; ADDBUTTONS; OPTIONS GetOptions ; MODAL ; TITLE L('4.1.6. Рациональное назначение объектов на классы (задача о ранце)') ; CLEAREVENTS IF lExit ** Button Ok ELSE RETURN NIL ENDIF ****************************************************************************** ****************************************************************************** N_ObjAssign = IF(mN_ObjAssign , 'Y', 'N') N_CopyAssign = IF(mN_CopyAssign, 'Y', 'N') N_TargetAssign = ALLTRIM(STR(mN_TargetAssign)) STRFILE(N_ObjAssign , '_Assign1.txt') // Запись файла STRFILE(N_CopyAssign , '_Assign2.txt') // Запись файла STRFILE(N_TargetAssign, '_Assign3.txt') // Запись файла ****************************************************************************** Run4163('LC' ) // Назначение объектов на классы по LC-алгоритму Run4163('RND') // Назначение объектов на классы по RND-алгоритму ***** Загнать сформированный текст с результатами назначения объектов на классы в БД для визуализации в нижнем окне CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Result_naz EXCLUSIVE NEW;ZAP SELECT Result_naz cText_LC = MemoRead("ResNaz_LC.txt") // Загрузка файла с результатами назначения в переменную cText_RND = MemoRead("ResNaz_RND.txt") // Загрузка файла с результатами назначения в переменную N_LineLC = MlCount( cText_LC , 75 ) N_LineRND = MlCount( cText_RND, 75 ) *DC_DebugQout( MAX( N_LineLC, N_LineRND ) ) FOR j=1 TO MAX( N_LineLC, N_LineRND ) APPEND BLANK IF j <= N_LineLC REPLACE Result_LC WITH ALLTRIM(MemoLine( cText_LC , 75, j )) // Присвоение строки ENDIF IF j <= N_LineRND REPLACE Result_RND WITH ALLTRIM(MemoLine( cText_RND, 75, j )) // Присвоение строки ENDIF NEXT *** Рассчитать эффективность LC-алгоритма по сравнению с RND в % на основе БД Klas_res.dbf, и отображать результаты по клавише CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Klas_res EXCLUSIVE NEW SET FILTER TO Kod > 0 Ln = 53 DBGOTOP() DO WHILE .NOT. EOF() mStr = "Класс: код="+ALLTRIM(STR(Kod))+", наименование: "+ALLTRIM(Name) Ln = MAX(Ln, LEN(mStr)) DBSKIP(1) ENDDO CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций aStructure := { { "Indicator" , "C", Ln, 0},; { "LC_algorit", "N", 15, 3},; { "RND_algori", "N", 15, 3},; { "LC_RND_per", "N", 15, 3} } DbCreate( "ResNaz_IT.dbf", aStructure ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Klas_res EXCLUSIVE NEW USE ResNaz_IT EXCLUSIVE NEW ******* Выборка исходных данных для расчета % aSum := {} aAvr := {} aPerSum := {} aPerAvr := {} SELECT Klas_res SET FILTER TO DBGOBOTTOM() FOR j=1 TO 17 AADD(aAvr, FIELDGET(j)) NEXT DBSKIP(-1) FOR j=1 TO 17 AADD(aSum, FIELDGET(j)) AADD(aPerSum, 0) AADD(aPerAvr, 0) NEXT ******* Расчет % FOR j=4 TO 10 IF aSum[7+j] <> 0 aPerSum[j] = aSum[j]/aSum[7+j]*100 ENDIF NEXT FOR j=4 TO 10 IF aAvr[7+j] <> 0 aPerAvr[j] = aAvr[j]/aAvr[7+j]*100 ENDIF NEXT ****** Занесение результатов расчета % в БД ResNaz_IT.dbf SELECT ResNaz_IT APPEND BLANK REPLACE Indicator WITH "СРАВНЕНИЕ ЭФФЕКТИВНОСТИ НАЗНАЧЕНИЯ ОБЪЕКТОВ НА КЛАССЫ" APPEND BLANK REPLACE Indicator WITH "С ПОМОЩЬЮ LC-АЛГОРИТМА ПО СРАВНЕНИЮ С RND-АЛГОРИТМОМ:" APPEND BLANK REPLACE Indicator WITH IF(mN_ObjAssign , "(допускается назначение более 1 объекта на класс)", "(не допускается назначение более 1 объекта на класс)") APPEND BLANK REPLACE Indicator WITH IF(mN_CopyAssign, "(допускается назначение ранее назначенных объектов)" , "(не допускается назначение ранее назначенных объектов)") APPEND BLANK DO CASE CASE mN_TargetAssign = 1 REPLACE Indicator WITH "(Цель - 1. Повышение уровня системности)" CASE mN_TargetAssign = 2 REPLACE Indicator WITH "(Цель - 2. Понижение уровня системности)" CASE mN_TargetAssign = 3 REPLACE Indicator WITH "(Цель - 3. Минимизация средних затрат на назначения объектов)" CASE mN_TargetAssign = 4 REPLACE Indicator WITH "(Цель - 4. Максимизация средних затрат на назначения объектов)" ENDCASE APPEND BLANK REPLACE Indicator WITH REPLICATE("=",Ln) APPEND BLANK REPLACE Indicator WITH "СУММА ПО ВСЕМ КЛАССАМ:" APPEND BLANK REPLACE Indicator WITH "Начальный ресурс класса:" REPLACE LC_algorit WITH aSum[ 3] REPLACE RND_algori WITH aSum[ 3] REPLACE LC_RND_per WITH 100 APPEND BLANK REPLACE Indicator WITH "Остаток ресурса после назначений объектов на классы:" REPLACE LC_algorit WITH aSum[ 4] REPLACE RND_algori WITH aSum[11] REPLACE LC_RND_per WITH aPerSum[ 4] APPEND BLANK REPLACE Indicator WITH "Всего назначено на классы объектов:" REPLACE LC_algorit WITH aSum[ 5] REPLACE RND_algori WITH aSum[12] REPLACE LC_RND_per WITH aPerSum[ 5] APPEND BLANK REPLACE Indicator WITH "Суммарное сходство:" REPLACE LC_algorit WITH aSum[ 6] REPLACE RND_algori WITH aSum[13] REPLACE LC_RND_per WITH aPerSum[ 6] APPEND BLANK REPLACE Indicator WITH "Фактические суммарные затраты:" REPLACE LC_algorit WITH aSum[ 7] REPLACE RND_algori WITH aSum[14] REPLACE LC_RND_per WITH aPerSum[ 7] APPEND BLANK REPLACE Indicator WITH "Средневзвешенное удельное сходство:" REPLACE LC_algorit WITH aSum[ 8] REPLACE RND_algori WITH aSum[15] REPLACE LC_RND_per WITH aPerSum[ 8] APPEND BLANK REPLACE Indicator WITH "Среднее на объект суммарное сходство:" REPLACE LC_algorit WITH aSum[ 9] REPLACE RND_algori WITH aSum[16] REPLACE LC_RND_per WITH aPerSum[ 9] APPEND BLANK REPLACE Indicator WITH "Средние на объект фактические суммарные затраты:" REPLACE LC_algorit WITH aSum[10] REPLACE RND_algori WITH aSum[17] REPLACE LC_RND_per WITH aPerSum[10] APPEND BLANK REPLACE Indicator WITH REPLICATE("~",Ln) APPEND BLANK REPLACE Indicator WITH "СРЕДНЕЕ НА КЛАСС:" APPEND BLANK REPLACE Indicator WITH "Начальный ресурс класса:" REPLACE LC_algorit WITH aAvr[ 3] REPLACE RND_algori WITH aAvr[ 3] REPLACE LC_RND_per WITH 100 APPEND BLANK REPLACE Indicator WITH "Остаток ресурса после назначений объектов на классы:" REPLACE LC_algorit WITH aAvr[ 4] REPLACE RND_algori WITH aAvr[11] REPLACE LC_RND_per WITH aPerAvr[ 4] APPEND BLANK REPLACE Indicator WITH "В среднем на класс назначено объектов:" REPLACE LC_algorit WITH aAvr[ 5] REPLACE RND_algori WITH aAvr[12] REPLACE LC_RND_per WITH aPerAvr[ 5] APPEND BLANK REPLACE Indicator WITH "Суммарное сходство:" REPLACE LC_algorit WITH aAvr[ 6] REPLACE RND_algori WITH aAvr[13] REPLACE LC_RND_per WITH aPerAvr[ 6] APPEND BLANK REPLACE Indicator WITH "Фактические суммарные затраты:" REPLACE LC_algorit WITH aAvr[ 7] REPLACE RND_algori WITH aAvr[14] REPLACE LC_RND_per WITH aPerAvr[ 7] APPEND BLANK REPLACE Indicator WITH "Средневзвешенное удельное сходство:" REPLACE LC_algorit WITH aAvr[ 8] REPLACE RND_algori WITH aAvr[15] REPLACE LC_RND_per WITH aPerAvr[ 8] APPEND BLANK REPLACE Indicator WITH "Среднее на объект суммарное сходство:" REPLACE LC_algorit WITH aAvr[ 9] REPLACE RND_algori WITH aAvr[16] REPLACE LC_RND_per WITH aPerAvr[ 9] APPEND BLANK REPLACE Indicator WITH "Средние на объект фактические суммарные затраты:" REPLACE LC_algorit WITH aAvr[10] REPLACE RND_algori WITH aAvr[17] REPLACE LC_RND_per WITH aPerAvr[10] APPEND BLANK REPLACE Indicator WITH REPLICATE("=",Ln) ******* Формирование и запись выходных форм по классам (эффективность LC-алгоритма по сравнению с RND-алгоритмом) SELECT Klas_res SET FILTER TO Kod > 0 DBGOTOP() DO WHILE .NOT. EOF() ******* Выборка исходных данных для расчета % aSum := {} aPer := {} SELECT Klas_res mKod = Kod mName = Name FOR j=1 TO 17 AADD(aSum, FIELDGET(j)) AADD(aPer, 0) NEXT ******* Расчет % FOR j=4 TO 10 IF aSum[7+j] <> 0 aPer[j] = aSum[j]/aSum[7+j]*100 ENDIF NEXT ****** Занесение результатов расчета % в БД ResNaz_IT.dbf SELECT ResNaz_IT APPEND BLANK REPLACE Indicator WITH "СРАВНЕНИЕ ЭФФЕКТИВНОСТИ НАЗНАЧЕНИЯ ОБЪЕКТОВ НА КЛАСС" APPEND BLANK REPLACE Indicator WITH "С ПОМОЩЬЮ LC-АЛГОРИТМА ПО СРАВНЕНИЮ С RND-АЛГОРИТМОМ:" APPEND BLANK REPLACE Indicator WITH "Класс: код="+ALLTRIM(STR(mKod))+", наименование: "+ALLTRIM(mName) APPEND BLANK REPLACE Indicator WITH REPLICATE("~",Ln) APPEND BLANK REPLACE Indicator WITH "Начальный ресурс класса:" REPLACE LC_algorit WITH aSum[ 3] REPLACE RND_algori WITH aSum[ 3] REPLACE LC_RND_per WITH 100 APPEND BLANK REPLACE Indicator WITH "Остаток ресурса после назначений объектов на классы:" REPLACE LC_algorit WITH aSum[ 4] REPLACE RND_algori WITH aSum[11] REPLACE LC_RND_per WITH aPer[ 4] APPEND BLANK REPLACE Indicator WITH "Всего назначено на классы объектов:" REPLACE LC_algorit WITH aSum[ 5] REPLACE RND_algori WITH aSum[12] REPLACE LC_RND_per WITH aPer[ 5] APPEND BLANK REPLACE Indicator WITH "Суммарное сходство:" REPLACE LC_algorit WITH aSum[ 6] REPLACE RND_algori WITH aSum[13] REPLACE LC_RND_per WITH aPer[ 6] APPEND BLANK REPLACE Indicator WITH "Фактические суммарные затраты:" REPLACE LC_algorit WITH aSum[ 7] REPLACE RND_algori WITH aSum[14] REPLACE LC_RND_per WITH aPer[ 7] APPEND BLANK REPLACE Indicator WITH "Средневзвешенное удельное сходство:" REPLACE LC_algorit WITH aSum[ 8] REPLACE RND_algori WITH aSum[15] REPLACE LC_RND_per WITH aPer[ 8] APPEND BLANK REPLACE Indicator WITH "Среднее на объект суммарное сходство:" REPLACE LC_algorit WITH aSum[ 9] REPLACE RND_algori WITH aSum[16] REPLACE LC_RND_per WITH aPer[ 9] APPEND BLANK REPLACE Indicator WITH "Средние на объект фактические суммарные затраты:" REPLACE LC_algorit WITH aSum[10] REPLACE RND_algori WITH aSum[17] REPLACE LC_RND_per WITH aPer[10] APPEND BLANK REPLACE Indicator WITH REPLICATE("=",Ln) SELECT Klas_res DBSKIP(1) ENDDO aMess := {} AADD(aMess, L('ПРОЦЕСС НАЗНАЧЕНИЯ ОБЪЕКТОВ НА КЛАССЫ ЗАВЕРШЕН УСПЕШНО !!!')) AADD(aMess, L(' ')) AADD(aMess, L('Результаты назначений в файлах:')) AADD(aMess, L('"ResNaz_LC.txt", "ResNaz_RND.txt", "ResNaz_IT.dbf", "Result_naz.dbf", "Rasp_naz.dbf", "Klas_res.dbf"')) AADD(aMess, L('в папке: ')+M_PathAppl) LB_Warning(aMess, L("4.1.6. Задача о назначениях. Назначение объектов на классы")) *RUNSHELL( mFileName,"NOTEPAD.EXE",.T.,.T.) // Посмотреть напечатанный файл в блокноте CrDBResNaz416() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Klas_res EXCLUSIVE NEW USE RObj_zat EXCLUSIVE NEW USE Result_naz EXCLUSIVE NEW SELECT Klas_res DBGOTOP() SELECT RObj_zat DBGOTOP() SELECT Result_naz DBGOTOP() DC_GetRefresh(oBrowse1) DC_GetRefresh(oBrowse2) DC_GetRefresh(oBrowse3) ReTURN nil ********************************************************************************************* ******** Если нет БД для отображения результатов назначения объектов на классы, то создать ее ********************************************************************************************* FUNCTION CrDBResNaz416() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций **** Подготовка переменной для отображения результатов назначения объектов на классы CrLf = CHR(13)+CHR(10) // Конец строки (записи) mFileNameLC = 'ResNaz_LC.txt' // Текстовый файл с результатами назначения объектов на классы по LC-алгоритму mFileNameRND = 'ResNaz_RND.txt' // Текстовый файл с результатами назначения объектов на классы по RND-алгоритму // Загрузить M_PathAppl с диска M_PathAppl = DC_ARestore("_PathAppl.arx") *mFileName = M_PathAppl+mFileName IF .NOT.FILE(mFileNameLC) // Если файл с результатами назначения отсуствует, создать его со строчкой о необходимости назначить объекты на классы cText = CrLf+L('Отсутствует текстовый файл: ')+CrLf+M_PathAppl+mFileNameLC+CrLf+'с результатами назначения объектов на классы по LC-алгоритму.'+CrLf+CrLf+'Необходимо назначить объекты на классы!' MemoWrit(mFileNameLC, cText) // Запись файла с сообщением о необходимости выполнить назначение объектов на классы ENDIF IF .NOT.FILE(mFileNameRND) // Если файл с результатами назначения отсуствует, создать его со строчкой о необходимости назначить объекты на классы cText = CrLf+L('Отсутствует текстовый файл: ')+CrLf+M_PathAppl+mFileNameRND+CrLf+'с результатами назначения объектов на классы по RND-алгоритму.'+CrLf+CrLf+'Необходимо назначить объекты на классы!' MemoWrit(mFileNameRND, cText) // Запись файла с сообщением о необходимости выполнить назначение объектов на классы ENDIF IF .NOT. FILE("Result_naz.dbf") CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций aStructure := { { "Result_LC" , "C", 75, 0},; { "Result_RND", "C", 75, 0} } DbCreate( "Result_naz.dbf", aStructure ) ***** Загнать сформированный текст с результатами назначения объектов на классы в БД для визуализации в окне cText_LC = MemoRead("ResNaz_LC.txt") // Загрузка файла с результатами назначения в переменную cText_RND = MemoRead("ResNaz_RND.txt") // Загрузка файла с результатами назначения в переменную N_LineLC = MlCount( cText_LC , 75 ) N_LineRND = MlCount( cText_RND, 75 ) * DC_DebugQout( MAX( N_LineLC, N_LineRND ) ) USE Result_naz EXCLUSIVE NEW SELECT Result_naz FOR j=1 TO MAX( N_LineLC, N_LineRND ) APPEND BLANK IF j <= N_LineLC REPLACE Result_LC WITH ALLTRIM(MemoLine( cText_LC , 75, j )) // Присвоение строки ENDIF IF j <= N_LineRND REPLACE Result_RND WITH ALLTRIM(MemoLine( cText_RND, 75, j )) // Присвоение строки ENDIF NEXT ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций ReTURN nil ******************************************************************************************************************* ******** Отобразить результаты сравнения LC-алгоритма назначения объектов на классы с назначением случайным образом ******************************************************************************************************************* FUNCTION CompLCRND() LOCAL oBrowse1, oBrowse2, oBrowse3 IF .NOT. FILE('ResNaz_IT.dbf') ReTURN NIL ENDIF ** Файл параметров интерфейса *********************************** IF FILE("\_4_1_6.arx") // Файл параметров aParInt = DC_ARestore("\_4_1_6.arx") ELSE PRIVATE aParInt[3] aParInt[1] = .F. aParInt[2] = .F. aParInt[3] = 1 DC_ASave(aParInt, Disk_dir+"\_4_1_6.arx") DC_ASave(aParInt, "_4_1_6.arx") ENDIF PUBLIC N_ObjAssign := aParInt[1] // Назначать на каждый класс не более 1 объекта? PUBLIC N_CopyAssign := aParInt[2] // Назначать только ранее не назначенные объекты? PUBLIC N_TargetAssign := aParInt[3] // 1. Повышение уровня системности. // 2. Понижение уровня системности. // 3. Минимизация средних затрат на назначения объектов. // 4. Максимизация средних затрат на назначения объектов. ***************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE ResNaz_IT EXCLUSIVE NEW SELECT ResNaz_IT DBGOTOP() RW = 110 // Ширина правого окна @ 0, 0 DCGROUP oGroup1 CAPTION L('LC- и RND-алгоритмы назначения объектов на классы:') SIZE 65,21.0 @ 0,67 DCGROUP oGroup2 CAPTION L('Сравнение результатов работы LC- и RND-алгоритмов:') SIZE RW,21.0 s=1 @s,1 DCSAY L('РАЦИОНАЛЬНОЕ РАСПРЕДЕЛЕНИЕ ОБЪЕКТОВ ПО КЛАССАМ' ) PARENT oGroup1 FONT '9.Helv Bold' SIZE 0;s=s+0.8 @s,1 DCSAY L('' ) PARENT oGroup1;s=s+0.8 @s,1 DCSAY L('Дано:' ) PARENT oGroup1 FONT '9.Helv Bold' SIZE 0;s=s+0.8 @s,1 DCSAY L('1. Результаты пакетного распознавания объектов в режиме 4.1.2 (БД: Rasp.dbf), ') PARENT oGroup1;s=s+0.8 @s,1 DCSAY L(' в которой определены уровни сходства всех объектов со всеми классами. ') PARENT oGroup1;s=s+0.8 @s,1 DCSAY L('2. Массив ограничений на ресурсы по классам, режим 4.1.6. (БД: Klas_res.dbf). ') PARENT oGroup1;s=s+0.8 @s,1 DCSAY L('3. Массив затрат на распознаваемые объекты, режим 4.1.6. (БД: RObj_zat.dbf). ') PARENT oGroup1;s=s+0.8 @s,1 DCSAY L('' ) PARENT oGroup1;s=s+0.8 @s,1 DCSAY L('Необходимо:' ) PARENT oGroup1 FONT '9.Helv Bold' SIZE 0;s=s+0.8 @s,1 DCSAY L('Распределить объекты по классам так, чтобы: ') PARENT oGroup1;s=s+0.8 @s,1 DCSAY L('- каждый объект был назначен только один раз, т.е. на единственный класс; ') PARENT oGroup1;s=s+0.8 @s,1 DCSAY L('- каждый объект был назначен на тот класс, которому он наиболее соответствует ') PARENT oGroup1;s=s+0.8 @s,1 DCSAY L(' (будем считать, что некоторый объект тем более соотвествует классу, чем выше ') PARENT oGroup1;s=s+0.8 @s,1 DCSAY L(' его сходство с данным классом и чем ниже затраты на использование объекта); ') PARENT oGroup1;s=s+0.8 @s,1 DCSAY L('- ресурсы классов были максимально использованы, а их остатки минимизированы. ') PARENT oGroup1;s=s+0.8 @s,1 DCSAY L('' ) PARENT oGroup1;s=s+0.8 @s,1 DCSAY L('Алгоритм:' ) PARENT oGroup1 FONT '9.Helv Bold' SIZE 0;s=s+0.8 @s,1 DCSAY L('1. Для всех объектов и классов находим удельное сходство на единицу затрат. ') PARENT oGroup1;s=s+0.8 @s,1 DCSAY L('2. LC-алгоритм: сортируем объекты по убыванию удельного сходства с классами. ') PARENT oGroup1;s=s+0.8 @s,1 DCSAY L('2. RND-алгоритм: сортируем объекты в случайном порядке. ') PARENT oGroup1;s=s+0.8 @s,1 DCSAY L('3. Организуем цикл по объектам в порядке сортировки. ') PARENT oGroup1;s=s+0.8 @s,1 DCSAY L('4. Назначаем текущий объект на тот класс, удельное сходство с которым макси- ') PARENT oGroup1;s=s+0.8 @s,1 DCSAY L(' мально, при условии, что у данного класса есть для этого ресурсы, и делать ') PARENT oGroup1;s=s+0.8 @s,1 DCSAY L(' это до тех пор, пока есть классы с ресурсами и не назначены все объекты. ') PARENT oGroup1;s=s+0.8 ********* Открытие окна для отображения результатов назначения объектов на классы aBrowPres := ; {{ XBP_PP_COL_DA_FGCLR, GRA_CLR_BLACK }, /* Row FG Color */ ; { XBP_PP_COL_DA_BGCLR, GRA_CLR_WHITE }, /* Row BG Color */ ; { XBP_PP_COL_DA_ROWHEIGHT, 20 }, /* Row Height */ ; { XBP_PP_HILITE_FGCLR, GRA_CLR_BLACK }, /* Hilite FG color */ ; { XBP_PP_HILITE_BGCLR, GRA_CLR_WHITE }, /* Hilite BG color */ ; { XBP_PP_COL_DA_CELLFRAMELAYOUT , 2 }, /* Cell Frame Layout*/ ; { XBP_PP_COL_DA_COLSEPARATOR , 1 }, /* Column Separator */ ; { XBP_PP_COL_DA_FRAMELAYOUT , 0 }} /* Frame Layout */ ; ************************************************ * aStructure := { { "Indicator" , "C", Ln, 0},; * { "LC_algorit", "N", 15, 3},; * { "RND_algori", "N", 15, 3},; * { "LC_RND_per", "N", 15, 3} } * DbCreate( "ResNaz_IT.dbf", aStructure ) ************************************************ @ 1, 2 DCBROWSE oBrowse4 ALIAS 'ResNaz_IT' SIZE RW-4,19.5 FONT "8.MS Sans Serif"; EDIT xbeBRW_ItemSelected MODE DCGUI_BROWSE_EDITDOWN ; HEADLINES 1 ; // Кол-во строк в заголовке PRESENTATION aBrowPres ; PARENT oGroup2 DCBROWSECOL FIELD ResNaz_IT->Indicator HEADER L('Показатель сравнения') WIDTH 42.5 PARENT oBrowse4 PROTECT {|| .T. } DCBROWSECOL DATA FieldAnchor(2,9,3) HEADER L('LC-алгоритм' ) WIDTH 5 PARENT oBrowse4 PROTECT {|| .T. } DCBROWSECOL DATA FieldAnchor(3,9,3) HEADER L('RND-алгоритм' ) WIDTH 5 PARENT oBrowse4 PROTECT {|| .T. } DCBROWSECOL DATA FieldAnchor(4,9,3) HEADER L('LC/RND*100 (%)' ) WIDTH 5 PARENT oBrowse4 PROTECT {|| .T. } DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; FIT ; OPTIONS GetOptions ; MODAL ; TITLE L('4.1.6. Рациональное назначение объектов на классы (задача о ранце)') CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Klas_res EXCLUSIVE NEW USE RObj_zat EXCLUSIVE NEW USE Result_naz EXCLUSIVE NEW SELECT Klas_res DBGOTOP() SELECT RObj_zat DBGOTOP() SELECT Result_naz DBGOTOP() DC_GetRefresh(oBrowse1) DC_GetRefresh(oBrowse2) DC_GetRefresh(oBrowse3) ReTURN NIL ****************************************************************************************************************** ******** Интерфейс ввода изображений в систему "Эйдос". Данный режим обеспечивает оцифровку, кодирование и ввод ******** в систему "Эйдос" изображений по их внешним контурам и формирование файла исходных данных "Inp_data.xls", ******** в котором каждое изображение представлено строкой, для их импорта в систему в режиме 2.3.2.2' ****************************************************************************************************************** FUNCTION F2324ok() Running(.T.) CrLf = CHR(13)+CHR(10) // Конец строки (записи) ** Проверка наличия модуля ввода изображений IF .NOT. FILE("_2324.exe") aMess := {} AADD(aMess, L('В текущей папке: ')+M_PathAppl) AADD(aMess, L('отсуствует модуль ввода изображений: "_2324.exe"')) LB_Warning(aMess, L('2.3.2.4. Интерфейс ввода изображений в систему "Эйдос"')) Running(.F.) ReTURN NIL ENDIF ** Проверка контрольной суммы (т.е. целостности и версии) модуля ввода изображений cFile = "_2324.exe" IF FILECHECK(cFile) <> 84119108 Mess = L('Исполнимый модуль: "#" поврежден и не может быть запущен!') Mess = STRTRAN(Mess, "#", cFile) // Либо эта строчка, либо следующая * Mess = STRTRAN(Mess, "#", ALLTRIM(STR(FILECHECK(cFile),19))) // Отображение контрольной суммы файла LB_Warning(Mess) Running(.F.) ReTURN NIL ENDIF ** Проверка наличия файла параметров модуля ввода изображений ** - если его нет - задать параметры по умолчанию и записать файл ** - если есть - загрузить файл и присвоить значения параметров переменным для их корректировки в диалоге IF .NOT. FILE("_2324.txt") mParam := "" mParam := mParam + 'Стандартизировать_размеры: C Yes' + CrLf // 1 mParam := mParam + 'Стандартизировать_поворот: C Yes' + CrLf // 2 mParam := mParam + 'Trimming______изображений: C Yes' + CrLf // 3 mParam := mParam + 'Показывать__окно_MS_Excel: C Yes' + CrLf // 4 mParam := mParam + 'Количество__градаций_угла: N 120' + CrLf // 5 * 12345678901234567890123456789012 * 10 20 30 StrFile(mParam, '_2324.txt') // Запись текстового файла: '_2324.txt' с параметрами mParam StrFile(ConvToAnsiCP(mParam), "_2324.ini") // Запись текстового файла: '_2324.ini' с параметрами mParam в кодировке ANSI Windows ENDIF mParam = FileStr('_2324.txt') // Загрузка текстового файла: '_2324.txt' с параметрами mParam mLine1 = ALLTRIM(MemoLine( mParam , 75, 1 )) // Присвоение 1-й строки mLine2 = ALLTRIM(MemoLine( mParam , 75, 2 )) // Присвоение 2-й строки mLine3 = ALLTRIM(MemoLine( mParam , 75, 3 )) // Присвоение 3-й строки mLine4 = ALLTRIM(MemoLine( mParam , 75, 4 )) // Присвоение 4-й строки mLine5 = ALLTRIM(MemoLine( mParam , 75, 5 )) // Присвоение 5-й строки StandVol = IF (SUBSTR(mLine1,30,3)="Yes", .T., .F.) // Стандартизировать_размеры StandPov = IF (SUBSTR(mLine2,30,3)="Yes", .T., .F.) // Стандартизировать_поворот Trimming = IF (SUBSTR(mLine3,30,3)="Yes", .T., .F.) // Стандартизировать_поворот ViewExcel = IF (SUBSTR(mLine4,30,3)="Yes", .T., .F.) // Показывать__окно_MS_Excel N_GradUg = VAL(SUBSTR(mLine5,30,3)) // Количество__градаций_угла * MsgBox(mLine1) * MsgBox(mLine2) * MsgBox(mLine3) * MsgBox(mLine4) * MsgBox(mLine5) * MsgBox(SUBSTR(mLine1,30,3)) * MsgBox(SUBSTR(mLine2,30,3)) * MsgBox(SUBSTR(mLine3,30,3)) * MsgBox(SUBSTR(mLine4,30,3)) * MsgBox(SUBSTR(mLine5,30,3)) ************ Корректировка параметров в диалоге и запись скорректированных параметров в виде файла @0,0 DCGROUP oGroup1 CAPTION L('Задайте параметры ввода изображений:') SIZE 80.0, 6.5 p = 4.5 @1 , 2 DCCHECKBOX StandVol PROMPT L('Стандартизировать размеры изображений? ') PARENT oGroup1 // 1 @2 , 2 DCCHECKBOX StandPov PROMPT L('Стандартизировать поворот изображений? ') PARENT oGroup1 // 2 @3 , 2 DCCHECKBOX Trimming PROMPT L('Кадрировать и обрезать изображения? ') PARENT oGroup1 // 3 @4 , 2 DCCHECKBOX ViewExcel PROMPT L('Отображать заполнение данными MS Excel? ') PARENT oGroup1 // 4 @5.2, p DCSAY L('Задайте количество градаций угла <= 360:') PARENT oGroup1 // 5 @5.2,38.0 DCGET N_GradUg PICTURE "###" PARENT oGroup1 @1.0,52 DCPUSHBUTTON CAPTION L('Пояснение по работе режима') SIZE LEN(L('Пояснение по работе режима')), 3.8 ACTION {||Help2324()} PARENT oGroup1 DCREAD GUI; TO lExit ; FIT; ADDBUTTONS; MODAL; TITLE L('2.3.2.4. Интерфейс ввода изображений в систему "Эйдос"') ******************************************************************** IF lExit ** Button Ok ELSE ReTURN NIL ENDIF ******************************************************************** ** Проверки на корректность заданного числа градаций угла IF N_GradUg < 2 aMess := {} AADD(aMess, L('Задано недопустимое число градаций угла: ')+ALLTRIM(STR(N_GradUg))+',') AADD(aMess, L('Поэтому оно принято минимальным допустимым: = 2.')) LB_Warning(aMess, L('2.3.2.4. Интерфейс ввода изображений в систему "Эйдос"')) N_GradUg = 2 ENDIF IF N_GradUg > 360 aMess := {} AADD(aMess, L('Задано недопустимое число градаций угла: ')+ALLTRIM(STR(N_GradUg))+',') AADD(aMess, L('Поэтому оно принято максимальным допустимым: = 360.')) LB_Warning(aMess, L('2.3.2.4. Интерфейс ввода изображений в систему "Эйдос"')) N_GradUg = 360 ENDIF ** Запись заданных параметров в виде файла для их использования в будущем mParam := "" mParam := mParam + 'Стандартизировать_размеры: C ' + IF(StandVol, "Yes", "No" ) + CrLf // 1 mParam := mParam + 'Стандартизировать_поворот: C ' + IF(StandPov, "Yes", "No" ) + CrLf // 2 mParam := mParam + 'Trimming______изображений: C ' + IF(Trimming, "Yes", "No" ) + CrLf // 3 mParam := mParam + 'Показывать__окно_MS_Excel: C ' + IF(ViewExcel, "Yes", "No" ) + CrLf // 4 mParam := mParam + 'Количество__градаций_угла: N ' + STRTRAN(STR(N_GradUg,3)," ", "0") + CrLf // 5 StrFile(mParam, '_2324.txt') // Запись текстового файла: '_2324.txt' с параметрами mParam StrFile(ConvToAnsiCP(mParam), "_2324.ini") // Запись текстового файла: '_2324.ini' с параметрами mParam в кодировке ANSI Windows * RunShell("","_2324.exe",.T.) // Запуск модуля оцифровки изображений RunShell("","_2324.exe",.F.) // Запуск модуля оцифровки изображений (чтобы процесс не бежал дальше, пока _2324.exe не закончится) ******************************************************************************* ******* Сюда вставить: ######################################################## ******************************************************************************* ******* - преобразование БД Inp_data.xlsx => dbf ******* - открытие этой БД и задание параметров программного интерфейса 2.3.2.2 ******* - запись файла с параметрами интерфейса: _2_3_2_2.arx ******************************************************************************* ******* - преобразование БД Inp_data.xlsx => dbf ****************************** // Определить, есть ли файлы в папке: '.AID_DATA\Inp_data\' DIRCHANGE(Disk_dir+'\AID_DATA\Inp_data\') * MsgBox(Disk_dir+'\AID_DATA\Inp_data\') *** ПРЕОБРАЗОВАНИЕ EXCEL-ФАЙЛА Inp_data.xlsx в БД: Inp_data.dbf *** и файл наименований классификационных и описательных шкал: Inp_name.txt DO CASE CASE FILE('Inp_data.xlsx') = .T. mFlag = LC_Excel2WorkArea( 'Inp_data.xlsx', Disk_dir+'\AID_DATA\Inp_data\' ) CASE FILE('Inp_data.xls') = .T. mFlag = LC_Excel2WorkArea( 'Inp_data.xls', Disk_dir+'\AID_DATA\Inp_data\' ) OTHERWISE Mess = L('В папке: ')+M_ApplsPath+L('\Inp_data\ должен быть файл: "Inp_data.xlsx" или "Inp_data.xls"') LB_Warning(Mess) Help2322xls() // Пояснение о назначении режима ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDCASE IF .NOT. mFlag LB_Warning(L('Исправьте файл исходных данных !'), L('2.3.2.2. Универсальный программный интерфейс импорта данных в систему "ЭЙДОС-X++"' )) Help2322xls() // Пояснение о назначении режима ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF Flag_InpRasp = .F. IF FILE("Inp_rasp.xls") .OR. FILE("Inp_rasp.xlsx") Flag_InpRasp = .T. ENDIF ******* - открытие этой БД и задание параметров программного интерфейса 2.3.2.2 CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Inp_data EXCLUSIVE NEW ******* - запись файла с параметрами интерфейса: _2_3_2_2.arx ***************** Regim = 1 // Формализации ПО или ген.расп.выб. Flag_zer = 1 // Считать нули и пробелы отсутствием данных? [1]-да, [2]-нет N_Chast = 1 // На сколько частей N разбивать обучающую или распознаваемую выборку (в зависимости от Regim) M_ClSc1 = 2 // Номер начального столбца диапазона классификационных шкал M_ClSc2 = 2 // Номер конечного столбца диапазона классификационных шкал M_OpSc1 = 8 // Номер начального столбца диапазона описательных шкал M_OpSc2 = FCOUNT() // Номер конечного столбца диапазона описательных шкал M_ObAnk = 3 // Создавать анкеты исходной выборки по строкам Inp_data-[1], по классам-[2], и 1-е, и 2-е [3] M_Interval = 1 // 1-равные интервалы, 2-адаптивные интервалы (с примерно равным количеством наблюдений, по Котельникову) N_SKGrCl = 10 N_SKGrPr = 10 K_N_ClSc = 1 K_N_OpSc = 1 K_N_GrClSc = 10 K_N_GrOpSc = 10 M_Scenario = .F. mGorizMin = 5 mGorizMax = 5 mGlubMin = 5 mGlubMax = 5 K_GradNClSc = 10 K_GradNOpSc = 10 M_ChastObi = .F. M_ChastRso = .F. N_ChastObi = 1 N_ChastRso = 1 DO CASE CASE FILE('Inp_data.xls') = .T. M_XlsDbf = 1 // Тип файла ихсодных данных: '.xls' CASE FILE('Inp_data.xlsx') = .T. M_XlsDbf = 2 // Тип файла ихсодных данных: '.xlsx' ENDCASE mTxtCSField = 1 // Способ интерпретации значений текстовых полей - классификационных шкал файла исходных данных mTxtOSField = 1 // Способ интерпретации значений текстовых полей - описательных шкал файла исходных данных mTxtCSSep = " " // Разделитель элементов классификационных шкал, если mTxtCSField=3 mTxtOSSep = " " // Разделитель элементов описательных шкал, если mTxtOSField=3 * mScenario = 1 // mScenario=1 Не применять сценарный метод АСК-анализа и спец.интерпретацию TXT-полей (старый вариант) mScenario = 1 // Не применять сценарный метод АСК-анализа mSpecInterprCls = .F. // Не применять спец.интерпретацию текстовых полей классов mSpecInterprAtr = .F. // Не применять спец.интерпретацию текстовых полей признаков mNameGrNumSc= 1 // Какие наименования ГРАДАЦИЙ числовых шкал использовать mClsAvr = .F. // .F. - делать модель из Inp_data, .T. - делать модель из Inp_data_avr mSortUnqCls = 1 // Выделять уникальные значения классов и сортировать, 1-да, 2-нет mLemmatCls = 2 // Проводить лемматизацию классов, 1-да, 2-нет mSortUnqGos = 1 // Выделять уникальные значения признаков и сортировать, 1-да, 2-нет mLemmatGos = 2 // Проводить лемматизацию признаков, 1-да, 2-нет // Сохранить файл с информацией о заданых параметрах программного интерфейса в текущей директории системы PRIVATE aSoftInt[40] aSoftInt[ 1] = Regim aSoftInt[ 2] = Flag_zer aSoftInt[ 3] = M_ClSc1 aSoftInt[ 4] = M_ClSc2 aSoftInt[ 5] = M_OpSc1 aSoftInt[ 6] = M_OpSc2 aSoftInt[ 7] = N_SKGrCl aSoftInt[ 8] = N_SKGrPr aSoftInt[ 9] = K_N_ClSc aSoftInt[10] = K_N_OpSc aSoftInt[11] = K_N_GrClSc aSoftInt[12] = K_N_GrOpSc aSoftInt[13] = M_ObAnk aSoftInt[14] = N_Chast aSoftInt[15] = M_Interval aSoftInt[16] = M_Scenario aSoftInt[17] = K_GradNClSc // Количество градаций в числовой классификационной шкале aSoftInt[18] = K_GradNOpSc // Количество градаций в числовой описательной шкале aSoftInt[19] = mGorizMin aSoftInt[20] = mGorizMax aSoftInt[21] = mGlubMin aSoftInt[22] = mGlubMax aSoftInt[23] = M_ChastObi aSoftInt[24] = M_ChastRso aSoftInt[25] = N_ChastObi aSoftInt[26] = N_ChastRso aSoftInt[27] = M_XlsDbf aSoftInt[28] = mTxtCSField aSoftInt[29] = mTxtOSField aSoftInt[30] = mTxtCSSep aSoftInt[31] = mTxtOSSep * aSoftInt[32] = mScenario // mScenario=1 Не применять сценарный метод АСК-анализа и спец.интерпретацию TXT-полей (старый вариант) aSoftInt[32] = mScenario // mScenario=1 Не применять сценарный метод АСК-анализа aSoftInt[33] = mSpecInterprCls // .T. - Применить спец.интерпретацию текстовых полей классов, .F. - не применять aSoftInt[34] = mSpecInterprAtr // .T. - Применить спец.интерпретацию текстовых полей признаков, .F. - не применять aSoftInt[35] = mNameGrNumSc // Какие наименования ГРАДАЦИЙ числовых шкал использовать aSoftInt[36] = mClsAvr // .F. = модель без усреднения по классам aSoftInt[37] = mSortUnqCls // Выделять уникальные значения классов и сортировать, 1-да, 2-нет aSoftInt[38] = IF(mSpecInterprCls,mLemmatCls,2) // Проводить лемматизацию классов, 1-да, 2-нет aSoftInt[39] = mSortUnqGos // Выделять уникальные значения признаков и сортировать, 1-да, 2-нет aSoftInt[40] = IF(mSpecInterprAtr,mLemmatGos,2) // Проводить лемматизацию признаков, 1-да, 2-нет CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) DC_ASave(aSoftInt , '_2_3_2_2.arx') ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** ************************************************************************ StrFile(mParam, '_2324.txt') // Запись текстового файла: '_2324.txt' с параметрами mParam StrFile(ConvToAnsiCP(mParam), "_2324.ini") // Запись текстового файла: '_2324.ini' с параметрами mParam в кодировке ANSI Windows DC_ASave(aParInt, Disk_dir+'\AID_DATA\Inp_data\_2324.ini') // Информация о типе используемого API для интеллектуальных облачных Эйдос-приложений, чтобы при их загрузке сразу запускать нужный API StrFile('API_type=2.3.2.4.', Disk_dir+'\AID_DATA\Inp_data\API_type.txt') ************************************************************************ aMess := {} AADD(aMess, L('Офифровка изображений по внешним контурам успешно завершена !')) AADD(aMess, L('xlsx, dbf и txt-файлы с результатами оцифровки в стандарте режима')) AADD(aMess, L('API-2.3.2.2 находятся в папке: ')+Disk_dir+'\AID_DATA\Inp_data\') LB_Warning(aMess, L('Система "Эйдос-X++"' )) Running(.F.) ReTURN NIL ************************************************************************************************** ******** Помощь по режиму 2.3.2.4 ************************************************************************************************** FUNCTION Help2324() aHelp := {} AADD(aHelp, L('Режим: "2.3.2.4. Интерфейс ввода изображений в систему "Эйдос"". ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Данный режим обеспечивает кодирование bmp и jpg изображений и формирование файла исходных данных "Inp_data.xls", ')) AADD(aHelp, L('в котором каждое изображение представлено строкой. Этот файл исходных данных используется для формализации предметной ')) AADD(aHelp, L('области в универсальном программном интерфейсе системы <Эйдос> с внешними базами данных (режим 2.3.2.2, а затем для ')) AADD(aHelp, L('созданиями и верификации моделей в режиме 3.5. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Исходные изображения в виде графических файлов должны находиться в папке: ...AID_DATA/INP_DATA/ и вложенных папках. ')) AADD(aHelp, L('Имена папок и файлов изображений должны удовлетворять требованиям MS Windows, т.е. могут включать русские символы ')) AADD(aHelp, L('и пробелы. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Стандартизация размеров обеспечивает инвариантность моделей изображений относительно их размеров. ')) AADD(aHelp, L('Стандартизация поворота обеспечивает инвариантность моделей изображений относительно их поворота. ')) AADD(aHelp, L('Число точек контура, сипользуемых при анализе. Чем оно меньше, тем меньше учитываются высокочастотные гармоники. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('В файле исходных данных "Inp_data.xlsx": ')) AADD(aHelp, L(' ')) AADD(aHelp, L('- значения 1-й колонки: <Наименования объектов обучающей выборки> формируются путем <склеивания> наименования папки ')) AADD(aHelp, L('с изображениями + < - > + имя файла изображения; ')) AADD(aHelp, L('- значения 2-й колонки: <Классы> - это часть имени файлов изображений до черточки: "-", пример имени файла: ')) AADD(aHelp, L(' "Гелиос - 0003.jpg", соответствующий класс: "Гелиос", имеется в виду, что имя файла состоит из двух частей: ')) AADD(aHelp, L(' до черточки - имя класса, после черточки - номер объекта, относящегося к этому классу, а потом расширение; ')) AADD(aHelp, L('- значения 3-й и 4-й колонок: Координаты X и Y центров тяжести изображений; ')) AADD(aHelp, L('- смысл колонок 5-й, 6-й и 7-й: <Площадь (пикс.)>, <Среднее> и <Ср.кв.откл.> ясен из их названий. Единственное, что ')) AADD(aHelp, L('нужно пояснить, что их значения берутся до стандартизации; ')) AADD(aHelp, L('- значения последующих колонок имеют смысл длины радиус-вектора от центра тяжести изображения до его границы (контура) ')) AADD(aHelp, L('при соответствующем значении угла в полярной системе координат. Число градаций угла не может быть меньшим 2 и большим ')) AADD(aHelp, L('360, т.е. шаг изменения угла не должен быть меньше 1° и больше 180°. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Изображения, полученные в результате анализа исходных изображений и заданных в диалоге преобразований, фактически ')) AADD(aHelp, L('использованные для оцифровки, сохраняются в папке ...AID_DATA/INP_DATA/Out_data. На изображениях серым цветом ')) AADD(aHelp, L('показано исходное изображение, обведенное оранжевым контуром, а голубым контуром с желтыми точками показан итоговый ')) AADD(aHelp, L('повернутый и приведенный к заданному количеству градаций контур. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Данный интерфейс описан в работе авторов: ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Луценко Е.В. Автоматизированный системно-когнитивный анализ изображений по их внешним контурам (обобщение, абстрагирование,')) AADD(aHelp, L('классификация и идентификация) / Е.В. Луценко, Д.К. Бандык // Политематический сетевой электронный научный журнал Кубанс- ')) AADD(aHelp, L('кого государственного аграрного университета (Научный журнал КубГАУ) [Электронный ресурс]. - Краснодар: КубГАУ, 2015. - ')) AADD(aHelp, L('№06(110). С.138-167. - IDA [article ID]: 1101506009. - Режим доступа: http://ej.kubagro.ru/2015/06/pdf/09.pdf, 1,875 у.п.л.')) AADD(aHelp, L(' ')) AADD(aHelp, L('Луценко Е.В., Бандык Д.К. Интерфейс ввода изображений в систему "Эйдос" (Подсистема <Эйдос-img>). Свид. РосПатента РФ на ')) AADD(aHelp, L('программу для ЭВМ, Заявка № 2015614954 от 11.06.2015, Гос.рег.№ 2015618040, зарегистр. 29.07.2015. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Луценко Е.В. Автоматизированный системно-когнитивный анализ изображений по их пикселям (обобщение, абстрагирование, класси-')) AADD(aHelp, L('фикация и идентификация) / Е.В. Луценко // Политематический сетевой электронный научный журнал Кубанского государственного ')) AADD(aHelp, L('аграрного университета (Научный журнал КубГАУ) [Электронный ресурс]. - Краснодар: КубГАУ, 2015. - №07(111). С. 366 - 394. ')) AADD(aHelp, L('- IDA [article ID]: 1111507019. - Режим доступа: http://ej.kubagro.ru/2015/07/pdf/19.pdf, 1,812 у.п.л. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Луценко Е.В. Решение задач ампелографии с применением АСК-анализа изображений листьев по их внешним контурам (обобщение, ')) AADD(aHelp, L('абстрагирование, классификация и идентификация) / Е.В. Луценко, Д.К. Бандык, Л.П. Трошин // Политематический сетевой ')) AADD(aHelp, L('электронный научный журнал Кубанского государственного аграрного университета (Научный журнал КубГАУ) [Электронный ресурс].')) AADD(aHelp, L('- Краснодар: КубГАУ, 2015. - №08(112). С. 846 - 894. - IDA [article ID]: 1121508064. - Режим доступа: ')) AADD(aHelp, L('http://ej.kubagro.ru/2015/08/pdf/64.pdf, 3,062 у.п.л. ')) mHelpMax = -999;FOR h=1 TO LEN(aHelp);mHelpMax = MAX(mHelpMax, LEN(ALLTRIM(aHelp[h])));NEXT s=1;d=0.8;@0,0 DCGROUP oGroup1 CAPTION L(' ') SIZE mHelpMax-20, LEN(aHelp)*d+1.5 FOR h=1 TO LEN(aHelp);@s,2 DCSAY aHelp[h] SIZE 0 PARENT ogroup1;s=s+d;NEXT DCREAD GUI TO lExit FIT TITLE L('2.3.2.4. Интерфейс ввода изображений в систему "Эйдос"') RETURN NIL ************************************************************************************************** ************************************************************************************************** ******** Помощь по режиму 4.1.6.4 ************************************************************************************************** FUNCTION Help4164() aHelp := {} AADD(aHelp, L('Режим: "4.1.6. РАЦИОНАЛЬНОЕ НАЗНАЧЕНИЕ ОБЪЕКТОВ НА КЛАССЫ (ЗАДАЧА О РАНЦЕ)". ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Опцию: "Назначать не более 1 объекта на класс", имеет смысл использовать ')) AADD(aHelp, L('при разумной комплектации какого-либо сложного изделия, например автомобиля, ')) AADD(aHelp, L('когда каждый элемент комплектации (объект, деталь) назначается на каждую ')) AADD(aHelp, L('позицию (класс) 1 раз, например 1 инжектор, 1 левая фара, и т.д. С аналогичной ')) AADD(aHelp, L('ситуацией мы сталкиваемся при назначении кандидатов на такие должности, например,')) AADD(aHelp, L('в спортивной команде, на каждой из которых может быть только один человек. ')) mHelpMax = -999;FOR h=1 TO LEN(aHelp);mHelpMax = MAX(mHelpMax, LEN(ALLTRIM(aHelp[h])));NEXT s=1;d=0.9;@0,0 DCGROUP oGroup1 CAPTION L(' ') SIZE mHelpMax-5, LEN(aHelp)*d+1.5 FOR h=1 TO LEN(aHelp);@s,2 DCSAY aHelp[h] SIZE 0 PARENT ogroup1;s=s+d;NEXT DCREAD GUI TO lExit FIT TITLE L('4.1.6. Рациональное назначение объектов на классы') RETURN NIL ************************************************************************************************** ************************************************************************************************** ******** Помощь по режиму 4.1.6.5 ************************************************************************************************** FUNCTION Help4165() aHelp := {} AADD(aHelp, L('Режим: "4.1.6. РАЦИОНАЛЬНОЕ НАЗНАЧЕНИЕ ОБЪЕКТОВ НА КЛАССЫ (ЗАДАЧА О РАНЦЕ)". ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Данная опция позволяет подать на назначение не все объекты, а только не назначенные на классы ')) AADD(aHelp, L('при предыдущих назначениях. Например, если объектов задано значительно больше, чем классов и ')) AADD(aHelp, L('была задана опция: <Назначать не более 1 объекта на класс>, то при каждом последующем назначении ')) AADD(aHelp, L('будут получаться автомобили со все более высокой себестоимостью и все более низкого качества, ')) AADD(aHelp, L('собранные из деталей, отбракованных при сборке предыдущих автомобилей. То же самое можно сказать ')) AADD(aHelp, L('об основном и дополнительном составе сборной: во 2-ю сборную входят игроки, не вошедшие в 1-ю, ')) AADD(aHelp, L('в 3-ю сборную - не вошедшие в 1-ю и 2-ю, и вообще в N-ю - не вошедшие в 1-ю, 2-ю,..., (N-1)-ю. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Если данная опция не установлена, то все объекты считаются ранее не назначенными. Признак, что ')) AADD(aHelp, L('объект был ранее назначен, сбрасывается, при пересоздании базы затрат и при автоматическом ')) AADD(aHelp, L('задании затрат. При назначении объектов на классы этот признак устанавливается для назначенных ')) AADD(aHelp, L('объектов независимо от того, установлена ли опция: "Назначать только ранее не назначенные объекты".')) AADD(aHelp, L('Но учитывается этот признак при назначении объектов только в случае, если эта опция установлена. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Если специалистов по персоналу не интересуют финансовые аспекты назначения персонала, то они могут ')) AADD(aHelp, L('задать на классы практически неограниченные ресурсы, а затраты на назначение для всех респондентов ')) AADD(aHelp, L('сделать малыми и одинаковыми (например, равными 1). Тогда система просто назначит сотрудников на ')) AADD(aHelp, L('должности, которым они больше всего соответствуют без учета затрат на это. ')) mHelpMax = -999;FOR h=1 TO LEN(aHelp);mHelpMax = MAX(mHelpMax, LEN(ALLTRIM(aHelp[h])));NEXT s=1;d=0.9;@0,0 DCGROUP oGroup1 CAPTION L(' ') SIZE mHelpMax-15, LEN(aHelp)*d+1.5 FOR h=1 TO LEN(aHelp);@s,2 DCSAY aHelp[h] SIZE 0 PARENT ogroup1;s=s+d;NEXT DCREAD GUI TO lExit FIT TITLE L('4.1.6. Рациональное назначение объектов на классы') RETURN NIL ************************************************************************************************** ********************************* ******** Помощь по режиму 4.1.6.6 ********************************* FUNCTION Help4166() LOCAL GetList[0], cText ** Файл параметров интерфейса *********************************** IF FILE("\_4_1_6.arx") // Файл параметров aParInt = DC_ARestore("\_4_1_6.arx") ELSE PRIVATE aParInt[3] aParInt[1] = .F. aParInt[2] = .F. aParInt[3] = 1 DC_ASave(aParInt, Disk_dir+"\_4_1_6.arx") DC_ASave(aParInt, "_4_1_6.arx") ENDIF PUBLIC N_ObjAssign := aParInt[1] // Назначать на каждый класс не более 1 объекта? PUBLIC N_CopyAssign := aParInt[2] // Назначать только ранее не назначенные объекты? PUBLIC N_TargetAssign := aParInt[3] // 1. Повышение уровня системности. // 2. Понижение уровня системности. // 3. Минимизация средних затрат на назначения объектов. // 4. Максимизация средних затрат на назначения объектов. ***************************************************************** aHelp := {} AADD(aHelp, L('Режим: "4.1.6. РАЦИОНАЛЬНОЕ НАЗНАЧЕНИЕ ОБЪЕКТОВ НА КЛАССЫ (ЗАДАЧА О РАНЦЕ)". ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Опция: "Цель управления качеством системы:" позволяет выбрать одну из четырех целей работы LC-алгоритма: ')) AADD(aHelp, L('1. Повышение уровня системности. ')) AADD(aHelp, L('2. Понижение уровня системности. ')) AADD(aHelp, L('3. Минимизация средних затрат на назначения объектов. ')) AADD(aHelp, L('4. Максимизация средних затрат на назначения объектов. ')) AADD(aHelp, L('====================================================== ')) AADD(aHelp, L(' ')) AADD(aHelp, L('1. Повышение уровня системности обеспечивает максимальное повышение качества системы с минимальными затратами на это. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('2. Понижение уровня системности обеспечивает максимальное понижение качества системы с максимальными затратами на это, ')) AADD(aHelp, L(' что практически означает уничтожение системы (антисистема). ')) AADD(aHelp, L(' ')) AADD(aHelp, L('3. Минимизация средних затрат на назначения объектов приводит к назначению максимального количества сотрудников без ')) AADD(aHelp, L(' учета степени их соответствия требованиям должностей с минимальной средней оплатой (всеобщая занятость населения ')) AADD(aHelp, L(' и высокая скрытая безработица). Что-то вроде этого получается при сильной социальной политике. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('4. Максимизация средних затрат на назначения объектов приводит к назначению минимального количества сотрудников без ')) AADD(aHelp, L(' учета степени их соответствия требованиям должностей с максимальной средней оплатой (низкая занятость населения ')) AADD(aHelp, L(' и высокая реальная безработица). Аналогичный подход используется руководством при назначении "своих" людей. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('На практике приходится применять все четыре подхода в различных комбинациях в зависимости от обстоятельств. ')) AADD(aHelp, L('Например, чтобы коллектив выполнял свою функцию, т.е. вообще работал, сначала используется 1-я цель. Но так производятся ')) AADD(aHelp, L('назначения не на все должности, а в основном на исполнительские. После этого для назначения на престижные руководящие и ')) AADD(aHelp, L('хорошо оплачиваемые должности "своих" людей используется 4-я цель. 2-я цель используется военными и в конкурентной борьбе,')) AADD(aHelp, L('а 3-я для того, чтобы не возникло социального бунта при недопустимом повышении уровня реальной безработицы. ')) mHelpMax = -999;FOR h=1 TO LEN(aHelp);mHelpMax = MAX(mHelpMax, LEN(ALLTRIM(aHelp[h])));NEXT s=1;d=0.9;@0,0 DCGROUP oGroup1 CAPTION L(' ') SIZE mHelpMax-18, LEN(aHelp)*d+1.5 FOR h=1 TO LEN(aHelp);@s,2 DCSAY aHelp[h] SIZE 0 PARENT ogroup1;s=s+d;NEXT DCREAD GUI TO lExit FIT TITLE L('4.1.6. Рациональное назначение объектов на классы. (C) Система "ЭЙДОС-X++"') RETURN NIL ************************************************************************************************** ************************************************************************************************** ******** Помощь по выбору способа оцифровки изображений ************************************************************************************************** FUNCTION HelpASCAimages() aHelp := {} AADD(aHelp, L('Оцифровку и АСК-анализ изображений возможно проводить: ')) AADD(aHelp, L(' ')) AADD(aHelp, L('1. По всем пикселям изображений. ')) AADD(aHelp, L('2. По внешним контурам изображений. ')) AADD(aHelp, L('3. По внешним и внутренним контурам изображений. ')) AADD(aHelp, L('------------------------------------------------------------------------ ')) AADD(aHelp, L('В 1-м случае формируется база данных результатов оцифровки изображений в стандарте программного ')) AADD(aHelp, L(' интерфейса с внешними БД 2.3.2.3, В БД Inp_data.dbf будут содержаться данные о всех ')) AADD(aHelp, L(' пикселях изображения. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Во 2-м случае формируется база данных результатов оцифровки изображений в стандарте программного ')) AADD(aHelp, L(' интерфейса с внешними БД 2.3.2.2, В базе данных Inp_data.xls будут содержаться данные ')) AADD(aHelp, L(' о пикселях внешнего контура изображения. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('В 3-м случае формируется база данных результатов оцифровки изображений в стандарте программного ')) AADD(aHelp, L(' интерфейса с внешними БД 2.3.2.2, В базе данных Inp_data.xls будут содержаться данные ')) AADD(aHelp, L(' о пикселях как внешнего, так и внутренних контуров изображения ("мультиконтур") ')) AADD(aHelp, L(' (режим в процессе разработки). ')) AADD(aHelp, L('======================================================================== ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Публикации по теме: ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Луценко Е.В. Системно-когнитивный подход к синтезу эффективного алфавита / Е.В. Луценко // Политема- ')) AADD(aHelp, L('тический сетевой электронный научный журнал Кубанского государственного аграрного университета (Науч- ')) AADD(aHelp, L('ный журнал КубГАУ) [Электронный ресурс]. - Краснодар: КубГАУ, 2009. - №07(051). С. 109 - 129. - Шифр ')) AADD(aHelp, L('Информрегистра: 0420900012\0067, IDA [article ID]: 0510907005. - Режим доступа: ')) AADD(aHelp, L('http://ej.kubagro.ru/2009/07/pdf/05.pdf, 1,312 у.п.л. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Луценко Е.В. Cистемно-когнитивный анализ изображений (обобщение, абстрагирование, классификация и ')) AADD(aHelp, L('идентификация) / Е.В. Луценко // Политематический сетевой электронный научный журнал Кубанского госу- ')) AADD(aHelp, L('дарственного аграрного университета (Научный журнал КубГАУ) [Электронный ресурс]. - Краснодар: КубГАУ, ')) AADD(aHelp, L('2009. - №02(046). С. 146 - 164. - Шифр Информрегистра: 0420900012\0017, IDA [article ID]: 0460902010. ')) AADD(aHelp, L('- Режим доступа: http://ej.kubagro.ru/2009/02/pdf/10.pdf, 1,188 у.п.л. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Луценко Е.В. Автоматизированный системно-когнитивный анализ изображений по их внешним контурам (обоб- ')) AADD(aHelp, L('щение, абстрагирование, классификация и идентификация) / Е.В. Луценко, Д.К. Бандык // Политематичес- ')) AADD(aHelp, L('кий сетевой электронный научный журнал Кубанского государственного аграрного университета (Научный ')) AADD(aHelp, L('журнал КубГАУ) [Электронный ресурс]. - Краснодар: КубГАУ, 2015. - №06(110). С. 138 - 167. - IDA ')) AADD(aHelp, L('[article ID]: 1101506009. - Режим доступа: http://ej.kubagro.ru/2015/06/pdf/09.pdf, 1,875 у.п.л. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Луценко Е.В., Бандык Д.К. Интерфейс ввода изображений в систему "Эйдос" (Подсистема <Эйдос-img>). Свид.')) AADD(aHelp, L('РосПатента РФ на программу для ЭВМ, Заявка № 2015614954 от 11.06.2015, Гос.рег.№ 2015618040, зарегистр.')) AADD(aHelp, L('29.07.2015. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Луценко Е.В. Автоматизированный системно-когнитивный анализ изображений по их пикселям (обобщение, ')) AADD(aHelp, L('абстрагирование, классификация и идентификация) /Е.В.Луценко // Политематический сетевой электронный ')) AADD(aHelp, L('научный журнал Кубанского государственного аграрного университета (Научный журнал КубГАУ) [Электронный ')) AADD(aHelp, L('ресурс]. - Краснодар: КубГАУ, 2015. - №07(111). С. 366 - 394. - IDA [article ID]: 1111507019. - Режим ')) AADD(aHelp, L('доступа: http://ej.kubagro.ru/2015/07/pdf/19.pdf, 1,812 у.п.л. ')) mHelpMax = -999;FOR h=1 TO LEN(aHelp);mHelpMax = MAX(mHelpMax, LEN(ALLTRIM(aHelp[h])));NEXT s=1;d=0.8;@0,0 DCGROUP oGroup1 CAPTION L(' ') SIZE mHelpMax-17, LEN(aHelp)*d+1.5 FOR h=1 TO LEN(aHelp);@s,2 DCSAY aHelp[h] SIZE 0 PARENT ogroup1;s=s+d;NEXT DCREAD GUI TO lExit FIT TITLE L('Помощь по режиму оцифровки изображений. (C) Система "ЭЙДОС-X++"') RETURN NIL ************************************************************************************************** ******************************************************************************************** ******** АСК-анализ изображений по всем пикселям (на примере символов) ******************************************************************************************** FUNCTION GenGraSimbPix() LOCAL GetList[0], GetOptions, oSay, hDC1, hDC2, oStatic, oStatic1, aPixel LOCAL nXSize := 1313, nYSize := 640 // Размер графического окна для самого графика в пикселях LOCAL hMemoryDC := CreateMemoryDC( hDC1, nXSize, nYSize ) // Для ускорения работы GetPixel() примерно в 50 раз *** Удалить содержимое папки: ...\AID_DATA\Inp_data ********* *** Удалить содержимое папки: ...\AID_DATA\Out_data ********* // Путь на папку с исходными БД лабораторной работы M_PathInpData = UPPER(Disk_dir + "\AID_DATA\Inp_data\") s = 1 d = 0.7 @0,0 DCGROUP oGroup1 CAPTION L('Этапы АСК-анализа изображений:') SIZE 95.0, 10.5 @s,2 DCSAY L("Данная работа предполагает выполнение следующих ЭТАПОВ:" ) PARENT oGroup1;s=s+1.3*d @s,2 DCSAY L("1. Задание параметров и генерация изображений символов, просмотр таблицы шрифта. В результате в папке:" ) PARENT oGroup1;s=s+1.3*d @s,2 DCSAY M_PathInpData+L(" создаются папки с bmp-файлами изображений символов заданных шрифтов и размеров." ) PARENT oGroup1;s=s+d @s,2 DCSAY L(" Поэтому перед запуском этого режима необходимо удалить содержимое папки:"+M_PathInpData ) PARENT oGroup1;s=s+d @s,2 DCSAY L("2. Оцифровка изображений по всем их пикселям: 2.3.2.4. Изображения берутся из папки: ")+M_PathInpData PARENT oGroup1;s=s+d @s,2 DCSAY L('3. Ввод оцифрованных изображений в систему "Эйдос" в режиме: 2.3.2.3.' ) PARENT oGroup1;s=s+d @s,2 DCSAY L(' После этого возникает новое приложение, название которого можно поменять в режиме 1.3.' ) PARENT oGroup1;s=s+1.3*d @s,2 DCSAY L("4. Просмотр классификационных и описательных шкал и градаций и обучающей выборки: 2.1, 2.2, 2.3.1, 2.4.") PARENT oGroup1;s=s+1.3*d @s,2 DCSAY L("5. Синтез и верификация системно-когнитивных моделей изображений: 3.4., 3.5, 4.1.3.6." ) PARENT oGroup1;s=s+1.3*d @s,2 DCSAY L("6. Решение задач идентификации и исследования изображений: 4.1.3.1, 4.1.3.2." ) PARENT oGroup1;s=s+1.3*d @s,2 DCSAY L("7. Просмотр и запись информационных портретов классов - обобщенных изображений символов." ) PARENT oGroup1;s=s+2.3*d **************************************************************************************************************************** @s,0 DCGROUP oGroup2 CAPTION L('Задайте режим:') SIZE 95.0, 12.5 s = 1 d = 0.8 w = 91 mMess = L('1. Задание параметров и генерация изображений символов,просмотр таблицы шрифта ')+SPACE(00) @s,2 DCPUSHBUTTON CAPTION mMess SIZE w, 1.3 ACTION {||ParGenSimb('Pix')} PARENT oGroup2;s=s+2.0*d mMess = L('2. Оцифровка изображений по всем пикселям: 2.3.2.5. ')+SPACE(28) @s,2 DCPUSHBUTTON CAPTION mMess SIZE w, 1.3 ACTION {||F2_3_2_5()} PARENT oGroup2;s=s+2.0*d mMess = L('3. Ввод оцифрованных изображений в систему "Эйдос" в режиме: 2.3.2.3. ')+SPACE(15) @s,2 DCPUSHBUTTON CAPTION mMess SIZE w, 1.3 ACTION {||F2_3_2_3("")} PARENT oGroup2;s=s+2.0*d m1 = L("Запустите эти режимы (2.1, 2.2, 2.3.1, 2.4) по очереди из главного меню") m2 = L('АСК-анализ изображений в системе "Эйдос-Х++"') mMess = L('4. Просмотр класс.и опис.шкал и градаций и обуч.выборки: 2.1, 2.2, 2.3.1, 2.4. ')+SPACE(18) @s,2 DCPUSHBUTTON CAPTION mMess SIZE w, 1.3 ACTION {||LB_Warning(m1, m2 )} PARENT oGroup2;s=s+2.0*d mMess = L('5. Синтез и верификация системно-когнитивных моделей изображений: 3.4, 3.5, 4.1.3.6.')+SPACE(01) @s,2 DCPUSHBUTTON CAPTION mMess SIZE w, 1.3 ACTION {||F3_4(.T., 0, 0, 0, .T.,"")} PARENT oGroup2;s=s+2.0*d mMess = L('6. Решение задач идентификации и исследования изображений: 4.1.3.2, 4.1.3.1. ')+SPACE(12) @s,2 DCPUSHBUTTON CAPTION mMess SIZE w, 1.3 ACTION {||F4_1_3_2()} PARENT oGroup2;s=s+2.0*d mMess = L('7. Просмотр и запись информационных портретов классов - обобщенных изображений ')+SPACE(01) @s,2 DCPUSHBUTTON CAPTION mMess SIZE w, 1.3 ACTION {||InfPortSimbPix()} PARENT oGroup2;s=s+2.0*d DCREAD GUI; TO lExit ; FIT; ADDBUTTONS; MODAL; TITLE L("4.7 (4.8) АСК-анализ изображений по всем их пикселям") ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN nil ****************************************************************************************************************** ********************************************************************************************************************** ******** Интерфейс ввода изображений в систему "Эйдос". Данный режим обеспечивает оцифровку, кодирование и ввод ******** в систему "Эйдос" изображений по всем их пикселям и формирование файла исходных данных "Inp_data.dbf" или ******** "Inp_rasp.dbf" в котором каждое изображение представлено столбцом, для их импорта в систему в режиме 2.3.2.3. ********************************************************************************************************************** FUNCTION F2_3_2_5() LOCAL GetList[0], GetOptions, oSay, hDC1, hDC2, oStatic1, oStatic2, aPixel Running(.T.) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы DC_LoadRdds() nInpData = 1 @0, 1 DCGROUP oGroup1 CAPTION L('Задайте цель загрузки изображений') SIZE 75.0, 3.5 @1, 2 DCRADIO nInpData VALUE 1 PROMPT L('1. Формализация предметной области (загрузка из папки:')+' '+M_ApplsPath+'\Inp_data\)' PARENT oGroup1 @2, 2 DCRADIO nInpData VALUE 2 PROMPT L('2. Создание распознаваемой выборки (загрузка из папки:')+' '+M_ApplsPath+'\Inp_rasp\)' PARENT oGroup1 DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; ADDBUTTONS; OPTIONS GetOptions ; MODAL ; TITLE L('2.3.2.5. АСК-анализ изображений по пикселям и спектру') ******************************************************************** IF lExit ** Button Ok ELSE ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ******************************************************************** *** Определение путей на файлы изображений символов *** Сформировать массив наименований папок и в каждой из них массив полных имен графических файлов IF nInpData = 1 cWorkPath = M_ApplsPath+"\Inp_data\" ELSE cWorkPath = M_ApplsPath+"\Inp_rasp\" ENDIF aAll := DIRECTORY( cWorkPath + "*.*", 'D' ) // Почему-то в массив попадает информация не только по директориям IF LEN(aAll) = 0 Mess = L('В папке:')+' '+cWorkPath+' '+L('нет файлов!') LB_Warning(Mess, L("Оцифровка изображений по всем пикселям" )) RETURN nil ENDIF * DC_DebugQout( aAll ) aDir := {} FOR j = 1 TO LEN(aAll) IF aAll[j, 5] = "D" IF aAll[j, 5] <> '.' IF aAll[j, 5] <> '..' AADD(aDir, aAll[j, 1]) ENDIF ENDIF ENDIF NEXT * DC_DebugQout( aDIR ) aFileName := {} // Массив полных имен файлов изображений aFileNmSh := {} // Массив коротких имен файлов изображений IF LEN(aDIR) = 0 Mess = L("В папке:")+' '+cWorkPath+' '+L('нет поддиректорий!') LB_Warning(Mess, L("Оцифровка изображений по всем пикселям" )) RETURN nil ENDIF FOR j = 1 TO LEN(aDIR) aFNbmp = DIRECTORY( cWorkPath + aDIR[j] + "\*.bmp" ) IF LEN(aFNbmp) > 0 FOR f = 1 TO LEN(aFNbmp) AADD(aFileName, cWorkPath + aDIR[j] + "\" + aFNbmp[f,1] ) AADD(aFileNmSh, aFNbmp[f,1] ) NEXT ENDIF aFNjpg = DIRECTORY( cWorkPath + aDIR[j] + "\*.jpg" ) IF LEN(aFNjpg) > 0 FOR f = 1 TO LEN(aFNjpg) AADD(aFileName, cWorkPath + aDIR[j] + "\" + aFNjpg[f,1] ) AADD(aFileNmSh, aFNjpg[f,1] ) NEXT ENDIF NEXT * DC_DebugQout( aFileName ) * DC_DebugQout( aFileNmSh ) IF LEN(aFileName) = 0 Mess = L("В поддиректориях папки:")+' '+cWorkPath+' '+L("нет bmp и jpg графических файлов!") LB_Warning(Mess, L("Оцифровка изображений по всем пикселям" )) Running(.F.) RETURN nil ENDIF *** Если БД "Image.dbf" нет, то создать ее IF .NOT. FILE("Image.dbf") GenDBFImage(.F.) ENDIF * Записать массив полных имен файлов изображений, а потом считать и использовать его DC_ASave(aFileName, "_FileName.arx") * DC_DebugQout( aFileNmSh ) * aFileName := DC_ARestore("_FileName.arx") * DC_DebugQout( aFileNmSh ) DC_ASave(aFileNmSh, "_FileNmSh.arx") * aFileNmSh := DC_ARestore("_FileNmSh.arx") * DC_DebugQout( aFileNmSh ) * MsgBox('STOP') ******************************************************************************************************** *** Формирование БД Inp_data.dbf или Inp_rasp.dbf для режима 2.3.2.5() с описаниями изображений символов ******************************************************************************************************** @ 0,0 DCPUSHBUTTON CAPTION L('1. Пересоздать (стереть) БД для изображений: "Image.Dbf"') SIZE 80, 1.5 ; ACTION {||GenDBFImage(.T.)} FONT '9.Lucida Console' @ 2,0 DCPUSHBUTTON CAPTION L('2. Загрузить изображения из:')+' '+cWorkPath+' '+L('в БД "Image.Dbf"') SIZE 80, 1.5 ; ACTION {||CreateImages()} FONT '9.Lucida Console' @ 4,0 DCPUSHBUTTON CAPTION L('3. Просмотреть изображения, сохраненные в БД "Image.Dbf"') SIZE 80, 1.5 ; ACTION {||PlaybackImages()} FONT '9.Lucida Console' @ 6,0 DCPUSHBUTTON CAPTION L('4. Создать БД:')+' '+IF(nInpData=1,'"Inp_data.dbf"','"Inp_rasp.dbf"')+' '+L('для программного интерфейса: 2.3.2.3.') SIZE 80, 1.5 ; ACTION {||CreateDBF2325(nInpData)} FONT '9.Lucida Console' * @8,0 dcpushbuttonxp size 100,100 pixel CAPTION L('Hello;World' align XBPALIGN_LEFT radius 10 color GRA_CLR_WHITE, GRA_CLR_DARKCYAN FONT '16.Arial' DCREAD GUI ; TO lExit ; FIT ; ADDBUTTONS; OPTIONS GetOptions ; MODAL ; TITLE L('АСК-анализ изображений по спектру') ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** ************************************************************************ // Информация о типе используемого API для интеллектуальных облачных Эйдос-приложений, чтобы при их загрузке сразу запускать нужный API StrFile('API_type=2.3.2.5.', Disk_dir+'\AID_DATA\Inp_data\API_type.txt') ************************************************************************ Running(.F.) RETURN nil ************************************************************************************************** FUNCTION Help2325() aHelp := {} AADD(aHelp, L('Задание цветовых схем в API-2.3.2.5: "Ввод изображений с учетом цвета пикселей" ')) AADD(aHelp, L('')) AADD(aHelp, L('Цветовая схема: "1. СПЕКТР с заданным числом цветов" создается расчетным путем.')) AADD(aHelp, L('')) AADD(aHelp, L('Пользователь может поместить в папку с исполнимым модулем системы "Эйдос"')) AADD(aHelp, L('MS Excel файл с ПОЛЬЗОВАТЕЛЬСКОЙ цветовой схемой следующего стандарта: ')) AADD(aHelp, L('')) AADD(aHelp, L('API-2.3.2.5: "Стандарт MS Excel файла с пользовательской цветовой схемой"')) AADD(aHelp, L('=========================================================================')) AADD(aHelp, L('! № ! RGB-представление цвета! Наименование цвета !')) AADD(aHelp, L('=========================================================================')) AADD(aHelp, L('! 1 ! 237,171,086 ! RAL 1000 !')) AADD(aHelp, L('! 2 ! 162,153,133 ! RAL 1001 !')) AADD(aHelp, L('! 3 ! 146,117,073 ! RAL 1002 !')) AADD(aHelp, L('=========================================================================')) AADD(aHelp, L('Яркости лучей в RGB представлении цвета должны быть через запятую.')) AADD(aHelp, L('Имя файла с ПОЛЬЗОВАТЕЛЬСКОЙ цветовой схемой должно быть: "User_color.xlsx"')) mHelpMax = -999;FOR h=1 TO LEN(aHelp);mHelpMax = MAX(mHelpMax, LEN(ALLTRIM(aHelp[h])));NEXT s=1;d=0.9;@0,0 DCGROUP oGroup1 CAPTION L(' ') SIZE mHelpMax-60, LEN(aHelp)*d+1.5 FOR h=1 TO LEN(aHelp);@s,2 DCSAY aHelp[h] SIZE 0 PARENT ogroup1;s=s+d;NEXT DCREAD GUI TO lExit FIT MODAL TITLE L('Помощь по режиму: 2.3.2.5: "Ввод изображений с учетом цвета пикселей"') RETURN NIL ************************************************************************************************** ************************************************************************************ ******** 4. Создать БД "Inp_data.dbf" или "Inp_rasp.dbf" для программного интерфейса ******** - только пиксели ******** - только спектр ******** - пиксели и спектр ************************************************************************************ FUNCTION CreateDBF2325(nInpData) LOCAL aPixel, hDC1, GetList[0] LOCAL oProgress, oDialog, lOk := .t., oButton, nEvent, mp1, mp2, oXbp PUBLIC aSay[10], Mess98, Mess99 ****** При запуске режима проверить, существует ли база приложений Appls.dbf, ****** и, если существует, найти текущее приложение и присвоить глобальным переменным ****** значения пути на него и его имени, а если не существует, то создать ****** и записать в виде файлов в текщей папке с исполнимым модулем системы PUBLIC M_PathAppl := "", M_NameAppl := "" IF .NOT. FILE("Appls.dbf") GenDbfAppls() ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Appls EXCLUSIVE NEW SELECT Appls DBGOTOP() DO WHILE .NOT. EOF() IF LEN(ALLTRIM(By_default)) > 0 REPLACE By_default WITH "W" M_PathAppl = ALLTRIM(Path_Appl) // Путь на текущее приложение M_NameAppl = ALLTRIM(Name_Appl) EXIT ENDIF DBSKIP(1) ENDDO nWidthMax = VAL(FileStr('_WidthMax.txt')) nHeightMax = VAL(FileStr('_HeightMax.txt')) IF .NOT. FILE("_FileName.arx") LB_Warning(L('Необходимо выполнить п.п.1-2 данного режима'), L("2.3.2.5: Ввод изображений с учетом цвета пикселей")) RETURN nil ENDIF IF .NOT. FILE("Image.dbf") LB_Warning(L('Необходимо выполнить п.п.1-2 данного режима'), L("2.3.2.5: Ввод изображений с учетом цвета пикселей")) RETURN nil ENDIF * DC_ASave(aFileName, "_FileName.arx") aFileName := DC_ARestore("_FileName.arx") * DC_ASave(aFileNmSh, "_FileNmSh.arx") // Массивы с русскими буквами считыватся не те, что записывались aFileNmSh := DC_ARestore("_FileNmSh.arx") * DC_DebugQout( aFileNmSh ) IF LEN(aFileName) = 0 LB_Warning(L('Необходимо выполнить п.п.1-2 данного режима'), L("2.3.2.5: Ввод изображений с учетом цвета пикселей")) RETURN nil ENDIF IF LEN(aFileNmSh) = 0 LB_Warning(L('Необходимо выполнить п.п.1-2 данного режима'), L("2.3.2.5: Ввод изображений с учетом цвета пикселей")) RETURN nil ENDIF * https://colorscheme.ru/ral-colors/ral-classic.html mColorScheme = 1 @0, 1 DCGROUP oGroup1 CAPTION L('Задайте цветовую схему для кодирования изображений') SIZE 65.0, 5.5 @1, 2 DCRADIO mColorScheme VALUE 1 PROMPT L('1. СПЕКТР с заданным числом цветов') PARENT oGroup1 @2, 2 DCRADIO mColorScheme VALUE 2 PROMPT L('2. Пользовательская цветовая схема') PARENT oGroup1 @3.5,2 DCPUSHBUTTON CAPTION L('Как задать цветовую схему для кодирования изображений'); SIZE 2+LEN(L("Стандарт MS Excel файла с пользовательской цветовой схемой")), 1.3 ; ACTION {||Help2325(), DC_GetRefresh(GetList)} PARENT oGroup1 DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; ADDBUTTONS; OPTIONS GetOptions ; MODAL ; TITLE L('2.3.2.5. АСК-анализ изображений по пикселям и цветам') ******************************************************************** IF lExit ** Button Ok ELSE ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ******************************************************************** IF mColorScheme = 1 // '1. СПЕКТР с заданным числом цветов <<<===############################### ***** А если считать спектр? ************* ***** - только пиксели ***** - только спектр ***** - пиксели и спектр nRadio = 2 @ 0, 0 DCGROUP oGroup1 CAPTION L('Задайте, как анализировать изображения:') SIZE 60.0, 20.5 @ 1, 2 DCRADIO nRadio VALUE 1 PROMPT L('1. Только по пикселям.' ) PARENT oGroup1 @ 2, 2 DCRADIO nRadio VALUE 2 PROMPT L('2. Только по спектру. ' ) PARENT oGroup1 // Доля (%) пикселей заданного диапазона цветов @ 3, 2 DCRADIO nRadio VALUE 3 PROMPT L('3. По пикселям и спектру.' ) PARENT oGroup1 *** Если спектр, то: "Сколько цветов в спектре?" N_ColorSpectr = 35 @ 2.25, 30 DCSAY L('Сколько цветов в спектре?') PARENT oGroup1 EDITPROTECT {|| .NOT.nRadio=2 } HIDE {|| .NOT.nRadio=2 };@ 2.1, 51 DCSAY L(' ') GET N_ColorSpectr PARENT oGroup1 PICTURE "###" EDITPROTECT {|| .NOT.nRadio=2 } HIDE {|| .NOT.nRadio=2 } @ 3.25, 30 DCSAY L('Сколько цветов в спектре?') PARENT oGroup1 EDITPROTECT {|| .NOT.nRadio=3 } HIDE {|| .NOT.nRadio=3 };@ 3.1, 51 DCSAY L(' ') GET N_ColorSpectr PARENT oGroup1 PICTURE "###" EDITPROTECT {|| .NOT.nRadio=3 } HIDE {|| .NOT.nRadio=3 } nRadioBlack = 1 @ 4.5, 1 DCGROUP oGroup2 CAPTION L('Как кодировать черный цвет исходных изображений:') SIZE 58.0, 3.5 PARENT oGroup1 HIDE {|| .NOT. nRadio<>1} @ 1, 2 DCRADIO nRadioBlack VALUE 1 PROMPT L('как истинно-черный цвет' ) PARENT oGroup2 @ 2, 2 DCRADIO nRadioBlack VALUE 2 PROMPT L('как отсутствие цвета' ) PARENT oGroup2 nRadioWhite = 1 @ 8.5, 1 DCGROUP oGroup3 CAPTION L('Как кодировать белый цвет исходных изображений:') SIZE 58.0, 3.5 PARENT oGroup1 HIDE {|| .NOT. nRadio<>1} @ 1, 2 DCRADIO nRadioWhite VALUE 1 PROMPT L('как истинно-белый цвет' ) PARENT oGroup3 @ 2, 2 DCRADIO nRadioWhite VALUE 2 PROMPT L('как отсутствие цвета' ) PARENT oGroup3 nRadioBackground = 1 @12.5, 1 DCGROUP oGroup4 CAPTION L('Учитывать фон изображений?') SIZE 58.0, 3.5 PARENT oGroup1 HIDE {|| .NOT. nRadio<>1} // т.е. пиксели с цветом, которых больше всего в изображении @ 1, 2 DCRADIO nRadioWhite VALUE 1 PROMPT L('Не учитывать' ) PARENT oGroup4 @ 2, 2 DCRADIO nRadioWhite VALUE 2 PROMPT L('Учитывать' ) PARENT oGroup4 *nInpData = 1 @16.5, 1 DCGROUP oGroup5 CAPTION L('Какую базу данных создавать?') SIZE 58.0, 3.5 PARENT oGroup1 HIDE {|| .NOT. nRadio<>1} @ 1, 2 DCRADIO nInpData VALUE 1 PROMPT L('"Inp_data.dbf" - полная формализация предметной области') PARENT oGroup5 @ 2, 2 DCRADIO nInpData VALUE 2 PROMPT L('"Inp_rasp.dbf" - только распознаваемая выборка' ) PARENT oGroup5 DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; ADDBUTTONS; OPTIONS GetOptions ; MODAL ; TITLE L('2.3.2.5. АСК-анализ изображений по пикселям и спектру') ******************************************************************** IF lExit ** Button Ok ELSE ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ******************************************************************** IF nRadio > 1 IF N_ColorSpectr < 2 aMess := {} AADD(aMess, L('В спектре должно быть задано не менее 2 цветов!')) AADD(aMess, L('Будет задано 35 цветов в спектре!')) LB_Warning(aMess, L("2.3.2.5: Ввод изображений с учетом цвета пикселей")) N_ColorSpectr = 35 ENDIF * IF N_ColorSpectr > 640 * aMess := {} * AADD(aMess, L('В спектре должно быть задано не более 640 цветов, т.к.')) * AADD(aMess, L('при отображении спектра используется окно 640x480 pix.')) * AADD(aMess, L('Будет задано 35 цветов в спектре!')) * LB_Warning(aMess, L("2.3.2.5: Ввод изображений с учетом цвета пикселей")) * N_ColorSpectr = 35 * ENDIF ENDIF ENDIF // '1. СПЕКТР с заданным числом цветов <<<===############################### ***** Создать БД: "Inp_data.dbf" или "Inp_rasp.dbf" **************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * SpectrInterv: 999/999-{123,123,123} * 123456789012 R G B * 12345678901234567890123456789012345 * 10 20 30 aStructure := { { "ScaleName", "C",255, 0 },; // Наименование шкалы { "Data_Type", "C", 1, 0 } } // Тип данных в шкале: N - числовой, С - символьный FOR j=1 TO LEN(aFileNmSh) mFieldName = "Obj"+ALLTRIM(STR(j)) mLen = MAX(8, LEN(ALLTRIM(aFileNmSh[j]))) AADD(aStructure, { mFieldName, "C", mLen, 0 } ) NEXT IF nInpData = 1 DbCreate( "Inp_data.dbf", aStructure ) ELSE DbCreate( "Inp_rasp.dbf", aStructure ) ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций IF nInpData = 1 USE Inp_data EXCLUSIVE NEW ELSE USE Inp_rasp EXCLUSIVE NEW ENDIF * Размер записи, число записей mRecSize = RECSIZE() // Размер записи БД Inp_data.dbf * размер базы данных должен быть меньше 2 Гб ************************************************************* ***** Создать БД: "SpectralRanges.dbf" ********************** ***** Для определения спектрального дипазона по цвету пикселя CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * SpectrInterv: 999/999-{123,123,123} * 123456789012 R G B * 12345678901234567890123456789012345 * 10 20 30 aStructure := { { "ScaleName", "C",255, 0 },; // Наименование шкалы { "fRed" , "N", 3, 0 },; { "fGreen" , "N", 3, 0 },; { "fBlue" , "N", 3, 0 } } DbCreate( "SpectralRanges.dbf", aStructure ) ************************************************************* ************* Подготовка баз данных цветовых схем ************* IF mColorScheme = 2 // 2. Пользовательская цветовая схема <<<===############################### IF .NOT. FILE("User_color.xlsx") aMess := {} AADD(aMess, L('В папке с исполнимым модулем системы "Эйдос":'+' '+Disk_dir+'\')) AADD(aMess, L('Должен быть файл: "User_color.xlsx" с пользовательской цветовой схемой')) LB_Warning(aMess, L('2.3.2.5. АСК-анализ изображений по пикселям и цветам')) Running(.F.) RETURN NIL ENDIF *** ПРЕОБРАЗОВАНИЕ EXCEL-ФАЙЛА "User_color.xlsx" в БД: "User_color.dbf *** и файл наименований классификационных и описательных шкал: Inp_name.txt cExcelFile = "User_color.xlsx" mFlag = LC_Excel2WorkArea( cExcelFile, Disk_dir ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE User_color EXCLUSIVE NEW;N_ColorSpectr =RECCOUNT() // Число цветовых диапазонов (интервалов) <<<===################################## USE SpectralRanges EXCLUSIVE NEW IF N_ColorSpectr < 2 aMess := {} AADD(aMess, L('В спектре должно быть задано не менее 2 цветов!')) AADD(aMess, L('Будет задано 35 цветов в спектре!')) LB_Warning(aMess, L("2.3.2.5. АСК-анализ изображений по пикселям и цветам" )) Running(.F.) RETURN NIL ENDIF aRed := {} aGreen := {} aBlue := {} mLenN_ColorSpectr = LEN(ALLTRIM(STR(N_ColorSpectr))) SELECT User_color DBGOTOP() DO WHILE .NOT. EOF() mColor = ALLTRIM(FIELDGET(2)) mColorName = ALLTRIM(FIELDGET(3)) mRed = VAL(TOKEN(mColor, ",", 1)) mGreen = VAL(TOKEN(mColor, ",", 2)) mBlue = VAL(TOKEN(mColor, ",", 3)) AADD(aRed , mRed ) AADD(aGreen, mGreen) AADD(aBlue , mBlue ) SELECT SpectralRanges APPEND BLANK REPLACE ScaleName WITH "SPECTRINTERV: "+STR(RECNO(),mLenN_ColorSpectr)+'/'+ALLTRIM(STR(N_ColorSpectr))+'-{'+STRTRAN(STR(mRed,3),' ','0')+','+STRTRAN(STR(mGreen,3),' ','0')+','+STRTRAN(STR(mBlue,3),' ','0')+'}-'+mColorName REPLACE fRed WITH mRed REPLACE fGreen WITH mGreen REPLACE fBlue WITH mBlue SELECT User_color DBSKIP(1) ENDDO nRadio = 2 nRadioBlack = 1 nRadioWhite = 1 nRadioBackground = 1 ENDIF IF mColorScheme = 1 // '1. СПЕКТР с заданным числом цветов <<<===############################### CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE SpectralRanges EXCLUSIVE NEW * N_ColorSpectr // Число цветовых диапазонов (интервалов) <<<===################################## ma := 127.5 mb := 127.5 mc := 127.5 mU := 0 mV := 120 mW := 240 mDelta = 360 / N_ColorSpectr // <<<===################################## n = 360 aRed := {} aGreen := {} aBlue := {} FOR j=1 TO N_ColorSpectr mRed := INT( ma * (1 + COS( ( n + mU ) * GradRad ) ) ) mGreen := INT( mb * (1 + COS( ( n + mV ) * GradRad ) ) ) mBlue := INT( mc * (1 + COS( ( n + mW ) * GradRad ) ) ) * fColor := GraMakeRGBColor({ mRed, mGreen, mBlue }) APPEND BLANK *** МОЖНО ОПРЕДЕЛИТЬ НАИМЕНОВАНИЕ ЦВЕТА ПО СПЕКТРУ И ВСТАВИТЬ ЕГО REPLACE ScaleName WITH "SPECTRINTERV: "+ALLTRIM(STR(j,15))+'/'+ALLTRIM(STR(N_ColorSpectr))+'-{'+STRTRAN(STR(mRed,3),' ','0')+','+STRTRAN(STR(mGreen,3),' ','0')+','+STRTRAN(STR(mBlue,3),' ','0')+'}' REPLACE fRed WITH mRed REPLACE fGreen WITH mGreen REPLACE fBlue WITH mBlue AADD(aRed , mRed ) AADD(aGreen, mGreen) AADD(aBlue , mBlue ) n = n - mDelta NEXT ENDIF ***** Определение максимального размера изображения CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Image VIA 'FOXCDX' EXCLUSIVE NEW nXSize = -999999999 nYSize = -999999999 aFileNmSh := {} // Короткие имена файлов aFileXSize := {} // Размер изображения по X aFileYSize := {} // Размер изображения по Y DO WHILE !IMAGE->(Eof()) aPixel := Bin2Var(IMAGE->array) // Загрузка массива из БД Image nXSize = MAX(nXSize, Len(aPixel)) nYSize = MAX(nYSize, Len(aPixel[1])) AADD(aFileNmSh, FIELDGET(2)) // Для формирования имен классов. Вместо записи и считывания массива использовать БД AADD(aFileXSize, Len(aPixel)) // Размер изображения по оси X AADD(aFileYSize, Len(aPixel[1])) // Размер изображения по оси Y IMAGE->(dbSkip()) ENDDO ***** Создание БД Inp_data или Inp_rasp с пустыми записями CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций IF nInpData = 1 USE Inp_data EXCLUSIVE NEW ELSE USE Inp_rasp EXCLUSIVE NEW ENDIF ****** Наименование классификационной шкалы, тип данных в шкале, а потом значения градаций шкалы, т.е. классы APPEND BLANK REPLACE ScaleName WITH "Класс" REPLACE Data_Type WITH "C" // Символьный тип данных в шкале "Класс" (а данном случае) FOR j=1 TO LEN(aFileNmSh) mFileNmSh = ALLTRIM(aFileNmSh[j]) mPos = AT('.bmp', mFileNmSh);IF mPos > 0;mFileNmSh = SUBSTR(mFileNmSh, 1, mPos-1);ENDIF // Взять наименование класса до расширения mPos = AT('.BMP', mFileNmSh);IF mPos > 0;mFileNmSh = SUBSTR(mFileNmSh, 1, mPos-1);ENDIF // Взять наименование класса до расширения mPos = AT('.jpg', mFileNmSh);IF mPos > 0;mFileNmSh = SUBSTR(mFileNmSh, 1, mPos-1);ENDIF // Взять наименование класса до расширения mPos = AT('.JPG', mFileNmSh);IF mPos > 0;mFileNmSh = SUBSTR(mFileNmSh, 1, mPos-1);ENDIF // Взять наименование класса до расширения mPos = AT('-' , mFileNmSh);IF mPos > 0;mFileNmSh = SUBSTR(mFileNmSh, 1, mPos-1);ENDIF // Взять наименование класса до тире, если оно есть, т.к. после тире идет номер экземляра IF LEN(ALLTRIM(mFileNmSh)) > 0 FIELDPUT(2+j, ALLTRIM(mFileNmSh)) ENDIF * MsgBox(mFileNmSh) NEXT ****** Это нужно для Inp_spectr.dbf для визуализации спектров APPEND BLANK REPLACE ScaleName WITH "Размер изображения по X" REPLACE Data_Type WITH "N" // Размер изображения по X FOR j=1 TO LEN(aFileNmSh) FIELDPUT(2+j, ALLTRIM(STR(aFileXSize[j]))) NEXT APPEND BLANK REPLACE ScaleName WITH "Размер изображения по Y" REPLACE Data_Type WITH "N" // Размер изображения по Y FOR j=1 TO LEN(aFileNmSh) FIELDPUT(2+j, ALLTRIM(STR(aFileYSize[j]))) NEXT ******* Формирование БД Inp_data.dbf или Inp_rasp.dbf ********* mFlagErr = .F. FOR y := 1 TO nYSize FOR x := 1 TO nXSize IF mRecSize * (RECCOUNT()+3) < 2*1024^3 // 2 Гб APPEND BLANK // <<<===################### REPLACE ScaleName WITH "Pixel("+ALLTRIM(STR(x))+","+ALLTRIM(STR(y))+")" REPLACE Data_Type WITH "N" // Числовой тип данных в шкале "Класс" (а данном случае) ELSE mFlagErr = .T. EXIT ENDIF NEXT NEXT IF mFlagErr aMess := {} IF nInpData = 1 AADD(aMess, L('БД "Inp_data.dbf" для программного интерфейса 2.3.2.3 создана,')) ELSE AADD(aMess, L('БД "Inp_rasp.dbf" для программного интерфейса 2.3.2.3 создана,')) ENDIF AADD(aMess, L('Но ее размер достиг 2 Гб и в ней поместились не все изображения. ')) AADD(aMess, L('Рекомендуем уменьшить размеры изображений или их количество. ')) LB_Warning(aMess, L("2.3.2.5: Ввод изображений с учетом цвета пикселей")) * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * RETURN NIL ENDIF ***** Ввод в БД Inp_data оцифрованных изображений из БД Image CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Image VIA 'FOXCDX' EXCLUSIVE NEW;N_Rec = RECCOUNT() *DO CASE * CASE mColorScheme = 1 // Расчетный спектр USE SpectralRanges EXCLUSIVE NEW * CASE mColorScheme = 2 // Пользовательская цветовая схема * USE User_color EXCLUSIVE NEW *ENDCASE IF nInpData = 1 USE Inp_data EXCLUSIVE NEW ELSE USE Inp_rasp EXCLUSIVE NEW ENDIF **************************************************************************************************** *Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time *nMax = N_InpFiles *Mess = L('2.3.2.6. Объединение нескольких файлов исходных данных в один' *@ 4,5 DCPROGRESS oProgress SIZE 70,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 *DCREAD GUI TITLE Mess PARENT @oDialog FIT EXIT *oDialog:show() *nTime = 0 *DC_GetProgress(oProgress,0,nMax) *FOR ff=1 TO N_InpFiles * DC_GetProgress(oProgress, ++nTime, nMax) *NEXT **MsgBox('STOP') *DC_GetProgress(oProgress,nMax,nMax) *oDialog:Destroy() *Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time **************************************************************************************************** *nMax = N_Rec * nXSize * nYSize IF nInpData = 1 Mess = L('Создание БД "Inp_data.dbf" для программного интерфейса 2.3.2.3.') ELSE Mess = L('Создание БД "Inp_rasp.dbf" для программного интерфейса 2.3.2.3.') ENDIF *@ 4,5 DCPROGRESS oProgress SIZE 75,1.1 MAXCOUNT nMax COLOR aColor[154] PERCENT EVERY 100 *DCREAD GUI TITLE Mess PARENT @oDialog FIT EXIT *oDialog:show() *nTime = 0 *DC_GetProgress(oProgress,0,nMax) ************************************************************************************* *** Отображение стадии и прогноза времени исполнения ******************************** ************************************************************************************* Wsego = 2 * N_Rec mTitleName = L('Идет расчет спектров изображений:') // Отображение стадии исполнения. Будет написано прямо в окне Progress-bar d = 0 @0,0 DCGROUP oGroup1 CAPTION L('Стадии исполнения процесса') FONT "6.Helv" SIZE 105+d, 2.5 PARENT oTabPage1 @4,0 DCGROUP oGroup2 CAPTION L('Прогноз времени исполнения') FONT "6.Helv" SIZE 105+d, 5.0 PARENT oTabPage2 s = 1 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 1] FONT "10.Helv" s++ @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay97 FONT "10.HelvBold" s++ @0.2+s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay98 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @1.5+s ,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay99 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @s ,1 DCPROGRESS oProgress ; SIZE 95,1.5 ; PERCENT ; EVERY 1+INT(Wsego/nEvery) ; // Кол-во обновлений изображения MAXCOUNT Wsego ; COLOR GRA_CLR_CYAN // Цвет полосы @s++,97 DCPUSHBUTTON CAPTION L('&Cancel') ; ACTION {||lOk:=.T.} OBJECT oButton ; SIZE 7,1.5 DCREAD GUI ; TITLE mTitleName ; FIT ; EXIT ; MODAL; Parent @oDialog // <<<<<<<<<<<<<<<<<<<<< oDialog:alwaysOnTop = .T. // Окно открывается на переднем плане oDialog:show() // Начало отсчета времени для прогнозирования длительности исполнения Time_progress = 0 // Прошло секунд с начала процесса // Процесс может идти больше суток, поэтому для определения // во всех случаях вычисляется время, прошедшее с начала года T_Mess1 = L("Начало:")+" "+TIME() // Начало Sec_1 = (DOY(DATE())-1)*86400+SECONDS() PUBLIC T1 := (DOY(DATE())-1)*86400+SECONDS() // Время предыдущей индикации процесса исполнения PUBLIC T2 := (DOY(DATE())-1)*86400+SECONDS()+1 // Текущее время (1-й раз оно заметно больше T1 чтобы было отображение) PUBLIC T1tp := T1 PUBLIC T2tp := T2 ********************************************************************************* aInp_name := {} // Массив с наименованиями колонок - объектов обучающей выборки, для формирования файла: Inp_name.txt SELECT Image DBGOTOP() DO WHILE !IMAGE->(Eof()) aSay[ 1]:SetCaption(L(Mess)) aPixel := Bin2Var(IMAGE->array) // Загрузка массива из БД Image nXSizeAr = Len(aPixel) nYSizeAr = Len(aPixel[1]) AADD(aInp_name, ALLTRIM(IMAGE->image_name)) SELECT Image mNumImage = RECNO() * @ 0,0 DCSTATIC TYPE XBPSTATIC_TYPE_BITMAP ; * COLOR nil, GRA_CLR_PALEGRAY ; * SIZE Len(aPixel), Len(aPixel[1]) PIXEL ; * EVAL {|o|hDC1 := GetWindowDC(o:getHWnd())} * DCREAD GUI FIT TITLE ALLTRIM(IMAGE->image_name) ; * EVAL {|o|TransferImageDB(hDC1, aPixel), ; * Sleep(0), ; * PostAppEvent(xbeP_Close,,,o)} ****** Ввод в БД Inp_data или Inp_rasp оцифрованного изображения IF nInpData = 1 SELECT Inp_data ELSE SELECT Inp_rasp ENDIF FOR y := 1 TO nYSize FOR x := 1 TO nXSize IF x <= nXSizeAr .AND. y <= nYSizeAr nColor = AutomationTranslateColor(aPixel[x, y], .t.) IF GraIsRGBColor(nColor) // Это цвет? * aRGB = GraGetRGBIntensity(nColor) // Взаимнообратные операции преобразования формы кодирования цвета в массиве RGB и одним числом * nColorPix = GraMakeRGBColor(aRGB) * MsgBox(STR(nColor)+STR(nColorPix)) // nColor === nColorPix DBGOTO(3+x+(y-1)*nXSize) // Классифкационная шкала: "Класс" и тип данных в ней (+1, т.к. 1-я строка - строка классов), * nColor = AutomationTranslateColor(aPixel[x, y], .t.) // затем 2 строки с размерами изображения по X и по Y nColor = aPixel[x, y] IF nRadio > 1 IF nColor=GraMakeRGBColor({1,1,1}) IF nRadioBlack=2 // Если черный цвет и его кодировать как отсутствие цвета nColor = 0 ENDIF ENDIF IF nColor=GraMakeRGBColor({255,255,255}) IF nRadioWhite=2 // Если белый цвет и его кодировать как отсутствие цвета nColor = 0 ENDIF ENDIF ENDIF FIELDPUT(2+mNumImage, ALLTRIM(STR(nColor))) // Запись цвета пикселя в текстовом формате (который в 2.3.2.3 используется для все полей) ENDIF ENDIF * DC_GetProgress(oProgress, ++nTime, nMax) NEXT NEXT *** Отображение стадии и прогноза времени исполнения **************** lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) SELECT Image DBSKIP(1) ENDDO *MsgBox('STOP') *DC_GetProgress(oProgress,nMax,nMax) *oDialog:Destroy() *************************************************************** ***** Дорасчет спектров объектов в БД Inp_data.dbf или Inp_rasp *************************************************************** IF nRadio > 1 * PRIVATE hMemoryDC := CreateMemoryDC( hDC1, nXSize, nYSize ) // Для ускорения работы GetPixel() примерно в 50 раз aSpectrInterv := {} * DO CASE * CASE mColorScheme = 1 // Расчетный спектр SELECT SpectralRanges DBGOTOP() DO WHILE .NOT. EOF() AADD(aSpectrInterv, ALLTRIM(ScaleName)) DBSKIP(1) ENDDO * CASE mColorScheme = 2 // Пользовательская цветовая схема * SELECT User_color * DBGOTOP() * DO WHILE .NOT. EOF() * AADD(aSpectrInterv, ALLTRIM(FIELDGET(2))) * DBSKIP(1) * ENDDO * ENDCASE IF nInpData = 1 SELECT Inp_data ELSE SELECT Inp_rasp ENDIF mRecnoSpectr = RECCOUNT()+1 FOR y = 1 TO N_ColorSpectr APPEND BLANK REPLACE ScaleName WITH aSpectrInterv[y] REPLACE Data_Type WITH "N" // Числовой тип данных в шкале "Класс" (в данном случае) NEXT nMax = FCOUNT()-2 FOR mObj = 3 TO FCOUNT() * oScrn := DC_WaitOn(L('Идет расчет спектра изображения:')+' '+ALLTRIM(STR(mObj-2))+'/'+ALLTRIM(STR(LEN(aInp_name)))+'-'+ALLTRIM(aInp_name[mObj-2])+L('. Немного подождите!'),,,,,,,,,,,.F.) aSay[ 1]:SetCaption(L('Обрабатывается файл:')+' '+ALLTRIM(STR(mObj-2))+'/'+ALLTRIM(STR(LEN(aInp_name)))+'-'+ALLTRIM(aInp_name[mObj-2])) ********* Расчет массива спектра aSpectrumAbs := {} // Массив числа пикселей объекта с цветом, попадающим в диапазон FOR j=1 TO N_ColorSpectr AADD(aSpectrumAbs, 0) NEXT mSumPix = 0 DBGOTOP() DO WHILE .NOT. EOF() mColor = VAL(ALLTRIM(FIELDGET(mObj))) // ПРЕОБРАЗОВАТЬ В ЧИСЛО IF mColor > 0 // Для определения цветового диапазона, с которым наиболее сходен цвет пикселя, использовать Евклидово расстояние между цветом пикселя и цветом диапазона * SpectrInterv: 999/999-{123,123,123} * 123456789012 R G B * 12345678901234567890123456789012345 * 10 20 30 nColor = AutomationTranslateColor(mColor, .t.) aRGB = GraGetRGBIntensity(nColor) // Взаимнообратные операции преобразования формы кодирования цвета в массиве RGB и одним числом * SELECT SpectralRanges * mColorDistance = SQRT((aRGB[1]-&fRed)^2+(aRGB[2]-&fGreen)^2+(aRGB[3]-&fBlue)^2) * INDEX ON STR(SQRT((aRGB[1]-&fRed)^2+(aRGB[2]-&fGreen)^2+(aRGB[3]-&fBlue)^2),8) TO SpectralRanges * INDEX ON STR( (aRGB[1]-&fRed)^2+(aRGB[2]-&fGreen)^2+(aRGB[3]-&fBlue)^2 ,8) TO SpectralRanges * INDEX ON STR( ABS(aRGB[1]-&fRed)+ABS(aRGB[2]-&fGreen)+ABS(aRGB[3]-&fBlue) ,8) TO SpectralRanges * @1, 2 DCRADIO mColorScheme VALUE 1 PROMPT L('1. СПЕКТР с заданным числом цветов ') PARENT oGroup1 * @2, 2 DCRADIO mColorScheme VALUE 2 PROMPT L('2. Каталог цветов RAL CLASSIC ') PARENT oGroup1 * @3, 2 DCRADIO mColorScheme VALUE 3 PROMPT L('3. Каталог цветов RAL DESIGN ') PARENT oGroup1 * @4, 2 DCRADIO mColorScheme VALUE 4 PROMPT L('4. Каталог цветов RAL EFFECT ') PARENT oGroup1 * @5, 2 DCRADIO mColorScheme VALUE 5 PROMPT L('5. Каталог цветов автомобилей GTA:V') PARENT oGroup1 mClrDistMin = 9999999 * MsgBox(STR(N_ColorSpectr)+' '+STR(LEN(aRed))+' '+STR(LEN(aGreen))+' '+STR(LEN(aBlue))+' '+STR(aRGB[1])+' '+STR(aRGB[2])+' '+STR(aRGB[3])) // =213 RAL FOR j=1 TO N_ColorSpectr * MsgBox(STR((aRed[j]-aRGB[1])^2+(aGreen[j]-aRGB[2])^2+(aBlue[j]-aRGB[3])^2)) mColorDistance = SQRT((aRed[j]-aRGB[1])^2+(aGreen[j]-aRGB[2])^2+(aBlue[j]-aRGB[3])^2) // Цветовое расстояние <<<===################################################## IF mClrDistMin >= mColorDistance mClrDistMin = mColorDistance mNumDistMin = j ENDIF NEXT * DBGOTOP() // Для варианта с индексным массивом * mPos1 = 15 * mPos2 = AT('/', ScaleName)-1 * mRanges = VAL(SUBSTR(ScaleName, mPos1, mPos2-mPos1+1)) aSpectrumAbs[mNumDistMin] = aSpectrumAbs[mNumDistMin] + 1 mSumPix++ ENDIF IF nInpData = 1 SELECT Inp_data ELSE SELECT Inp_rasp ENDIF DBSKIP(1) ENDDO ********* Дорасчет массива спектра aSpectrumPrc := {} // Массив % пикселей объекта с цветом, попадающим в диапазон, от числа всех пикселей объекта FOR j=1 TO LEN(aSpectrumAbs) AADD(aSpectrumPrc, aSpectrumAbs[j]/mSumPix*100) NEXT **** Если не учитывать фон, то удалить все пиксели с наиболее часто встречающимся цветом IF nRadioBackground = 1 aTmp := {} FOR j=1 TO LEN(aSpectrumAbs) AADD(aTmp, aSpectrumAbs[j]) NEXT ASORT(aTmp) mMaxPix = aTmp[LEN(aTmp)] FOR j=1 TO LEN(aSpectrumAbs) IF mMaxPix = aSpectrumAbs[j] aSpectrumPrc[j] = 0 ENDIF NEXT ENDIF ********* Запись массива спектра DBGOTO(mRecnoSpectr) FOR j=1 TO LEN(aSpectrumPrc) FIELDPUT(mObj, ALLTRIM(STR(aSpectrumPrc[j],8,4))) DBSKIP(1) NEXT * DC_Impl(oScrn) *** Отображение стадии и прогноза времени исполнения **************** lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) NEXT oSay97:SetCaption(L("Расчет спектров изображений успешно завершен !!!")) * MILLISEC(1000) oSay97:SetCaption(oSay97:caption) oButton:SetCaption(L('&Ok')) // Деструктурирование окна отображения графического Progress-bar oButton:activate := {||PostAppEvent(xbeP_Close,,,oDialog)} //<<<<<< Add This DC_AppEvent( @lOk ) PostAppEvent(xbeP_Activate,,,DC_GetObject(GetList,'DCGUI_BUTTON_OK')) // Роджер oDialog:Destroy() ENDIF ***** Файл: Inp_data.dbf скопировать как Inp_spectr.dbf IF nRadio > 1 CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций IF nInpData = 1 Name_SS = "Inp_data.dbf" ELSE Name_SS = "Inp_rasp.dbf" ENDIF Name_DD = Disk_dir+"\Inp_spectr.dbf" COPY FILE (Name_SS) TO (Name_DD) ENDIF ***** Файл: Inp_data.dbf скопировать в папку \AID_DATA\Inp_data IF nRadio = 1 CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций IF nInpData = 1 USE Inp_data EXCLUSIVE NEW ELSE USE Inp_rasp EXCLUSIVE NEW ENDIF DELETE FOR 1 < RECNO() .AND. RECNO() < 3 PACK ENDIF IF nRadio = 2 CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций IF nInpData = 1 USE Inp_data EXCLUSIVE NEW ELSE USE Inp_rasp EXCLUSIVE NEW ENDIF DELETE FOR 1 < RECNO() .AND. RECNO() < mRecnoSpectr PACK ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций IF nInpData = 1 Name_SS = "Inp_data.dbf" Name_DD = Disk_dir+"\AID_DATA\Inp_data\Inp_data.dbf" ELSE Name_SS = "Inp_rasp.dbf" Name_DD = Disk_dir+"\AID_DATA\Inp_data\Inp_rasp.dbf" ENDIF COPY FILE (Name_SS) TO (Name_DD) *** Сформировать файл Inp_name.txt с наименованиями колонок - объектов обучающей выборки CrLf = CHR(13)+CHR(10) // Конец строки (абзаца) (CrLf) mInp_name = "" FOR j=1 TO LEN(aInp_name) mInp_name = mInp_name + aInp_name[j] + CrLf NEXT StrFile( mInp_name, Disk_dir+"\AID_DATA\Inp_data\Inp_name.txt") // Записать в папку Inp_data ***** Запись БД Inp_data.dbf или Inp_rasp.dbf в виде Excel-файла с именами колонок из Inp_data.xls или ***** Попробовать преобразовать Inp_data.dbf и _ColumnNames.arx в Inp_data.xls DIRCHANGE(Disk_dir +"\AID_DATA\Inp_data\") CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций IF nInpData = 1 USE Inp_data EXCLUSIVE NEW SELECT Inp_data ELSE USE Inp_rasp EXCLUSIVE NEW SELECT Inp_rasp ENDIF aColumnNames := {} AADD(aColumnNames, "Наименование шкалы") AADD(aColumnNames, "Тип данных шкалы") FOR j=1 TO LEN(aInp_name) AADD(aColumnNames, aInp_name[j]) NEXT aFields := {} FOR j=1 TO FCOUNT() AADD(aFields, FIELDNAME(j)) NEXT *FUNCTION DC_WorkArea2Excel( cExcelFile, nOrientation, lDisplayAlerts, ; // Original DC * lVisible, aFields, lAutoFit, cDateFormat, aFieldEvals, ; * cPassword, lFreezeRow1, lCsvFallBack, aColumnNames ) // Модифицированная функция Роджера: имена колонок берутся из aColumnNames только если LEN(aFields)=LEN(aColumnNames) // Убрана пустая строка после наименований колонок IF nInpData = 1 cExcelFile = Disk_dir +"\AID_DATA\Inp_data\Inp_data.xls" // Необходимо полное имя ELSE cExcelFile = Disk_dir +"\AID_DATA\Inp_data\Inp_rasp.xls" // Необходимо полное имя ENDIF *DC_WorkArea2Excel(cExcelFile,,,,aFields,,,,,,, aColumnNames ) ***** Сформировать файл параметров для интерфейса 2.3.2.3. (точно также сделать после Диминой программы после xls=>dbf) ************************************************************************************************************* * aParInt[1] = 1 // XLS - MS Excel-2003 * aParInt[1] = 2 // XLSX- MS Excel-2007 (2010 и более поздние) * aParInt[1] = 3 // DBF - DBASE IV (DBF/NTX) * aParInt[2] = 1 // Считать нули и пробелы отсутствием данных * aParInt[2] = 2 // Не считать нули и пробелы отсутствием данных * aParInt[3] = номер ПЕРВОЙ строки с классификационными шкалами * aParInt[4] = номер ПОСЛЕДНЕЙ строки с классификационными шкалами * aParInt[5] = номер ПЕРВОЙ строки с описательными шкалами * aParInt[6] = номер ПОСЛЕДНЕЙ строки с описательными шкалами * aParInt[7] = 3 // число градаций в классификационной шкале * aParInt[8] = 3 // число градаций в описательной шкале * aParInt[9] = 1 // Формировать классификационные и описательные шкалы и градации и обучающую выборку * aParInt[9] = 2 // Формировать только распознаваемую выборку * aParInt[10]= 1 // Наменования ГРАДАЦИЙ числовых шкал - Только интервальные числовые значения * aParInt[10]= 2 // Наменования ГРАДАЦИЙ числовых шкал - Только наименования интервальных числовых значений * aParInt[10]= 3 // Наменования ГРАДАЦИЙ числовых шкал - И интервальные числовые значения, и их наименования ************************************************************************************************************* CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций IF nInpData = 1 USE Inp_data EXCLUSIVE NEW ELSE USE Inp_rasp EXCLUSIVE NEW ENDIF N_Obj = FCOUNT()-2 N_Rec = RECCOUNT() IF FILE(Disk_dir+"\_2_3_2_3.arx") // Файл параметров aParInt = DC_ARestore(Disk_dir+"\_2_3_2_3.arx") aParInt[ 6] = N_Rec // номер ПОСЛЕДНЕЙ строки с описательными шкал ELSE PRIVATE aParInt[10] aParInt[ 1] = 3 // DBF - DBASE IV (DBF/NTX) // Тоже будет работать * aParInt[ 1] = 1 // XLS - MS Excel-2003 aParInt[ 2] = 1 // Считать нули и пробелы отсутствием данных (1-ДА, 2-НЕТ) aParInt[ 3] = 1 // номер ПЕРВОЙ строки с классификационными шкалами aParInt[ 4] = 1 // номер ПОСЛЕДНЕЙ строки с классификационными шкалами aParInt[ 5] = 4 // номер ПЕРВОЙ строки с описательными шкалами (во 2-й и 3-й строках размеры изобр.по X и по Y) aParInt[ 6] = N_Rec // номер ПОСЛЕДНЕЙ строки с описательными шкалами aParInt[ 7] = 3 // число градаций в классификационной шкале aParInt[ 8] = 3 // число градаций в описательной шкале IF nInpData = 1 aParInt[ 9] = 1 // Формировать классификационные и описательные шкалы и градации и обучающую выборку ELSE aParInt[ 9] = 2 // Формировать только распознаваемую выборку ENDIF aParInt[10] = 1 // Наменования ГРАДАЦИЙ числовых шкал - Только интервальные числовые значения ENDIF DC_ASave(aParInt, Disk_dir+"\_2_3_2_3.arx") DC_ASave(aParInt, "_2_3_2_3.arx") DC_ASave(aParInt, Disk_dir+'\AID_DATA\Inp_data\_2_3_2_3.arx') // Информация о типе используемого API для интеллектуальных облачных Эйдос-приложений, чтобы при их загрузке сразу запускать нужный API StrFile('API_type=2.3.2.3.', Disk_dir+'\AID_DATA\Inp_data\API_type.txt') DIRCHANGE(Disk_dir) *aMess := {} *IF nInpData = 1 * AADD(aMess, L('БД "Inp_data.dbf" для программного интерфейса 2.3.2.3 успешно создана.')) *ELSE * AADD(aMess, L('БД "Inp_rasp.dbf" для программного интерфейса 2.3.2.3 успешно создана.')) *ENDIF *AADD(aMess, L('Теперь нужно запустить интерфейс 2.3.2.3 с параметрами по умолчанию.')) *AADD(aMess, L('После этого надо запустить синтез и верификацию моделей в режиме 3.5,')) *AADD(aMess, L('а также в режиме 4.7 визуализацию спектров объектов и классов.')) *AADD(aMess, L('Можно также смотреть все выходные формы во всех режимах, как обычно.')) *LB_Warning(aMess, L("2.3.2.5: Ввод изображений с учетом цвета пикселей")) ******************************************************************************************************************************** *** Режим представляет собой ПРОГРАММНЫЙ ИНТЕРФЕЙС ФОРМАЛИЗАЦИИ ПРЕДМЕТНОЙ ОБЛАСТИ И ИМПОРТА ДАННЫХ В СИСТЕМУ "ЭЙДОС-Х". *** Данный программный интерфейс обеспечивает автоматическое формирование классификационных и описательных шкал и градаций *** и обучающей выборки на основе XLS, XLSX или DBF-файла с исходными данными стандарта, описанного в Help режима стандарта, *** представляющего собой ТРАНСПОНИРОВАННЫЙ файл стандарта режима 2.3.2.2. Кроме того он обеспечивает автоматический ввод *** распознаваемой выборки из внешней базы данных. В этом режиме может быть до 1000000 шкал и до 2035 объектов обучающей выборки ******************************************************************************************************************************** F2_3_2_3() ********** Вставка наименований цветов - градаций описательных шкал *********************** IF mColorScheme = 1 // '1. СПЕКТР с заданным числом цветов <<<===############################### oScr := DC_WaitOn(L('Вставка наименований цветов - градаций описательных шкал. Немного подождите!'),,,,,,,,,,,.F.) DIRCHANGE(Disk_dir) // Перейти в папку с системой IF .NOT. FILE('Htmlcolor.DBF') aMess := {} AADD(aMess, L('В папке с исполнимым модулем системы "Эйдос"')) AADD(aMess, L('должен быть файл: "Htmlcolor.DBF"')) AADD(aMess, L('с расчетной цветовой схемой "Спектр"')) LB_Warning(aMess, L("2.3.2.5: Ввод изображений с учетом цвета пикселей")) RETURN nil ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Htmlcolor EXCLUSIVE NEW aColName := {} aColRed := {} aColGreen := {} aColBlue := {} SELECT Htmlcolor DBGOTOP() DO WHILE .NOT. EOF() mRGB1 = ALLTRIM(FIELDGET(2)) AADD(aColName , ALLTRIM(FIELDGET(1))) AADD(aColRed , VAL(TOKEN(mRGB1,',',1))) AADD(aColGreen, VAL(TOKEN(mRGB1,',',2))) AADD(aColBlue , VAL(TOKEN(mRGB1,',',3))) DBSKIP(1) ENDDO * 12345678901=18-6-1=mPos2-mPos1-1 * 1/35-{255,063,063} * 1234567890123456789 * mPos1=6 mPos2=18 * DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы Эйдос CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Appls EXCLUSIVE NEW SELECT Appls DBGOTOP() DO WHILE .NOT. EOF() IF LEN(ALLTRIM(BY_DEFAULT)) > 0 M_PathAppl = PATH_APPL EXIT ENDIF DBSKIP(1) ENDDO DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Gr_OpSc EXCLUSIVE NEW SELECT Gr_OpSc DBGOTOP() DO WHILE .NOT. EOF() mRGB2 = ALLTRIM(FIELDGET(3)) mPos1 = AT('{', mRGB2) mPos2 = AT('}', mRGB2) mRGB2 = SUBSTR(mRGB2, mPos1+1, mPos2-mPos1-1) mColRed = VAL(TOKEN(mRGB2,',',1)) mColGreen = VAL(TOKEN(mRGB2,',',2)) mColBlue = VAL(TOKEN(mRGB2,',',3)) mMinDist = 999999999 mColName = '' FOR j=1 TO LEN(aColName) mDist = SQRT((mColRed-aColRed[j])^2+(mColGreen-aColGreen[j])^2+(mColBlue-aColBlue[j])^2) IF mMinDist > mDist mMinDist = mDist mColName = aColName[j] ENDIF NEXT REPLACE NAME_GROS WITH ALLTRIM(NAME_GROS) + '-' + mColName DBSKIP(1) ENDDO CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с системой DC_Impl(oScr) ENDIF Running(.F.) RETURN nil **************************************************************** ******** 1. Пересоздать (стереть) БД для изображений: "Image.Dbf" **************************************************************** FUNCTION GenDBFImage(mDialog) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций ********** Создать БД Image.dbf и ее индексные массивы aStructure := { { "Image_name", "C", 250, 0 },; // Полное имя файла (с путем доступа) { "Short_name", "C", 250, 0 },; // Короткое имя файла (без пути доступа) { "Xcentr" , "N", 19, 7 },; // Координата X центра тяжести { "Ycentr" , "N", 19, 7 },; // Координата Y центра тяжести { "Array" , "M", 10, 0 } } // Memo-поле с 2d-массивом цветов изображения по пикселям DbCreate( "Image.dbf", aStructure, "FOXCDX" ) IF mDialog LB_Warning(L('База изображений "Image.Dbf" создана!'), L("2.3.2.5: Ввод изображений с учетом цвета пикселей")) ENDIF RETURN nil ***************************************************************** ******** 2. Оцифровать изображения и записать их в БД "Image.Dbf" ***************************************************************** FUNCTION CreateImages() LOCAL GetList[0], oStatic, oBitmap, aImages, i, hDC1, aPixel ** Загрузить и использовать массив полных имен файлов изображений * DC_ASave(aFileName, "_FileName.arx") aFileName := DC_ARestore("_FileName.arx") FOR i := 1 TO Len(aFileName) oBitmap := DC_GetBitmap(aFileName[i]) @ 0,0 DCSTATIC TYPE XBPSTATIC_TYPE_BITMAP ; CAPTION oBitmap PREEVAL {|o|o:autoSize := .t.} ; EVAL {|o|hDC1 := GetWindowDC(o:getHWnd()), ; aPixel := Array(o:caption:xSize,o:caption:ySize)} DCREAD GUI FIT TITLE aFileName[i] ; EVAL {|o|LoadArray(hDC1,aPixel), ; Save2Dbf(aPixel,aFileName[i]), ; PostAppEvent(xbeP_Close,,,o)} NEXT *LB_Warning(L('Изображения оцифрованы и записаны в БД "Image.Dbf"'), L("2.3.2.5: Ввод изображений с учетом цвета пикселей")) RETURN nil * --------- * PROC appsys ; RETURN * --------- FUNCTION LoadArray( hDC1, aPixel ) LOCAL i, j, oScrn, nXSize := Len(aPixel), nYSize := Len(aPixel[1]) LOCAL hMemoryDC := CreateMemoryDC( hDC1, nXSize, nYSize ) // Для ускорения работы GetPixel() примерно в 50 раз nWidthMax = VAL(FileStr('_WidthMax.txt')) nHeightMax = VAL(FileStr('_HeightMax.txt')) *IF !aPixel[1,1] == nil * DCMSGBOX 'Array is already loaded!' * RETURN nil *ENDIF *oScrn := DC_WaitOn('',,,,,,,,,,,.F.) FOR i := 1 TO nXSize FOR j := 1 TO nYSize aPixel[i,j] := GetPixel(hMemoryDC,i-1,j-1) * // Если aPixel[i,j]=0 (RGB(0,0,0)), заменить его на RGB(1,1,1), т.е. на истинно-черный цвет, а не отсутствие других цветов * IF aPixel[i,j] = 0 * aPixel[i,j] = GraMakeRGBColor({1,1,1}) * ENDIF NEXT NEXT *DC_Impl(oScrn) RETURN nil * ---------- FUNCTION Save2Dbf( aArray, cImage ) LOCAL cArray := Var2Bin(aArray) * DC_ASave(aFileNmSh, "_FileNmSh.arx") aFileNmSh := DC_ARestore("_FileNmSh.arx") USE Image VIA 'FOXCDX' EXCLUSIVE LOCATE FOR Trim(IMAGE->image_name) == cImage IF Eof() dbAppend() REPLACE IMAGE->Image_name WITH ALLTRIM(ConvToOemCP(cImage)) ,; // Кодировка OEM (DOS) IMage->Short_name WITH ConvToOemCP(aFileNmSh[RECNO()]) ,; // Кодировка OEM (DOS) IMage->Array WITH cArray ENDIF IMAGE->(dbCloseArea()) RETURN nil ***************************************************************** ******** 3. Просмотреть изображения, сохраненные в БД "Image.Dbf" ***************************************************************** FUNCTION PlaybackImages() LOCAL aPixel, hDC1, GetList[0] USE Image VIA 'FOXCDX' EXCLUSIVE DO WHILE !IMAGE->(Eof()) aPixel := Bin2Var(IMAGE->array) @ 0,0 DCSTATIC TYPE XBPSTATIC_TYPE_BITMAP ; COLOR nil, GRA_CLR_PALEGRAY ; SIZE Len(aPixel), Len(aPixel[1]) PIXEL ; EVAL {|o|hDC1 := GetWindowDC(o:getHWnd())} DCREAD GUI FIT TITLE ALLTRIM(IMAGE->image_name) ; EVAL {|o|TransferImageDB(hDC1, aPixel), ; Sleep(0), ; PostAppEvent(xbeP_Close,,,o)} IMAGE->(dbSkip()) ENDDO LB_Warning(L('Просмотр изображений из БД "Image.Dbf", закончен!'), L("2.3.2.5: Ввод изображений с учетом цвета пикселей")) RETURN nil * ---------- FUNCTION TransferImageDB( hDC1, aPixel ) LOCAL i, j, lEmptyArray := aPixel[1,1] == nil, ; nXSize := Len(aPixel), nYSize := Len(aPixel[1]) FOR i := 0 TO nXSize-1 FOR j := 0 TO nYSize-1 SetPixel(hDC1,i,j,aPixel[i+1,j+1]) NEXT NEXT RETURN nil * --------- // Для ускорения работы GetPixel() примерно в 50 раз -------------------- FUNCTION CreateMemoryDC( hDC, nXSize, nYSize ) LOCAL hMemoryDC, hBMP hMemoryDC := CreateCompatibleDC(hDC) // create compatible memory DC hBMP := CreateCompatibleBitmap(hDC,nXSize,nYSize) // create DDB SelectObject(hMemoryDC,hBMP) // put hBMP into memory DC BitBlt( hMemoryDC,0,0,nXSize,nYSize,hDC,0,0,SRCCOPY ) // copy desktop DC into memory DC RETURN hMemoryDC * ---------- *#command GDIFUNCTION ([]) ; * => ; *FUNCTION ([]);; *STATIC scHCall := nil ;; *IF scHCall == nil ;; * IF snHdll == nil ;; * snHDll := DllLoad('GDI32.DLL') ;; * ENDIF ;; * scHCall := DllPrepareCall(snHDll,DLL_STDCALL,<(Func)>) ;; *ENDIF ;; *RETURN DllExecuteCall(scHCall,) *GDIFUNCTION GetPixel( nHDC, x, y) *GDIFUNCTION SetPixel( nHDC, x, y, n ) *DLLFUNCTION GetWindowDC( hwnd ) USING STDCALL FROM USER32.DLL *DLLFUNCTION CreateCompatibleDC( nHDC ) USING STDCALL FROM GDI32.DLL *DLLFUNCTION CreateCompatibleBitmap( nHDC, dw, dh ) USING STDCALL FROM GDI32.DLL *DLLFUNCTION SelectObject(hMemoryDC,hBMP) USING STDCALL FROM GDI32.DLL *DLLFUNCTION BitBlt( hDC,nXDest,nYDest,nXSize,nYSize,hDCSrc,nXSrc,nYSrc,dwROP ) USING STDCALL FROM GDI32.DLL ******************************************************************************************** ******** АСК-анализ изображений по их внешним контурам (на примере символов) ******************************************************************************************** FUNCTION GenGraSimbOk() LOCAL GetList[0] *** Удалить содержимое папки: ...\AID_DATA\Inp_data ********* *** Удалить содержимое папки: ...\AID_DATA\Out_data ********* // Путь на папку с исходными БД лабораторной работы M_PathInpData = UPPER(Disk_dir + "\AID_DATA\Inp_data\") s = 1 d = 0.7 @0,0 DCGROUP oGroup1 CAPTION L('Этапы АСК-анализа изображений:') SIZE 95.0, 13.0 @s,2 DCSAY L("Данная работа предполагает выполнение следующих ЭТАПОВ:" ) PARENT oGroup1;s=s+1.3*d @s,2 DCSAY L("1. Задание параметров и генерация изображений символов, просмотр таблицы шрифта. В результате в папке:" ) PARENT oGroup1;s=s+1.3*d @s,2 DCSAY M_PathInpData+L(" создаются папки с bmp-файлами изображений символов заданных шрифтов и размеров." ) PARENT oGroup1;s=s+d @s,2 DCSAY L(" Поэтому перед запуском этого режима необходимо удалить содержимое папки:")+M_PathInpData PARENT oGroup1;s=s+d @s,2 DCSAY L("2. Оцифровка изображений по внешнему контуру: 2.3.2.4. Изображения берутся из папки: ")+M_PathInpData PARENT oGroup1;s=s+d @s,2 DCSAY L(" Кроме того этим режимом создается папка: ")+UPPER(ALLTRIM(M_ApplsPath)) + "\Out_data\" PARENT oGroup1;s=s+d @s,2 DCSAY L(" с изображениями, на которых обозначены центр тяжести изображения, контур и точки на контуре," ) PARENT oGroup1;s=s+d @s,2 DCSAY L(' расстояния до которых от центра тяжести изображения занесены в базу исходных данных: "Inp_data.xlsx".') PARENT oGroup1;s=s+1.3*d @s,2 DCSAY L('3. Ввод оцифрованных изображений в систему "Эйдос" в режиме: 2.3.2.2.' ) PARENT oGroup1;s=s+d @s,2 DCSAY L(' После этого возникает новое приложение, название которого можно поменять в режиме 1.3.' ) PARENT oGroup1;s=s+1.3*d @s,2 DCSAY L("4. Просмотр классификационных и описательных шкал и градаций и обучающей выборки: 2.1, 2.2, 2.3.1, 2.4." ) PARENT oGroup1;s=s+1.3*d @s,2 DCSAY L("5. Синтез и верификация системно-когнитивных моделей изображений: 3.4, 3.5, 4.1.3.6." ) PARENT oGroup1;s=s+1.3*d @s,2 DCSAY L("6. Решение задач идентификации и исследования изображений: 4.1.3.1, 4.1.3.2." ) PARENT oGroup1;s=s+1.3*d @s,2 DCSAY L("7. Просмотр и запись информационных портретов классов - обобщенных изображений символов." ) PARENT oGroup1;s=s+2.8*d **************************************************************************************************************************** @s,0 DCGROUP oGroup2 CAPTION L('Задайте режим:') SIZE 95.0, 13.0 s = 1 d = 0.8 w = 91 mMess = L('1. Задание параметров и генерация изображений символов,просмотр таблицы шрифта ')+SPACE(00) @s,2 DCPUSHBUTTON CAPTION mMess SIZE w, 1.3 ACTION {||ParGenSimb('Ok')} PARENT oGroup2;s=s+2.0*d mMess = L('2. Оцифровка изображений по внешнему контуру: 2.3.2.4. ')+SPACE(28) @s,2 DCPUSHBUTTON CAPTION mMess SIZE w, 1.3 ACTION {||F2324ok()} PARENT oGroup2;s=s+2.0*d mMess = L('3. Ввод оцифрованных изображений в систему "Эйдос" в режиме: 2.3.2.2. ')+SPACE(15) @s,2 DCPUSHBUTTON CAPTION mMess SIZE w, 1.3 ACTION {||F2_3_2_2("","")} PARENT oGroup2;s=s+2.0*d m1 = L("Запустите эти режимы (2.1, 2.2, 2.3.1, 2.4) по очереди из главного меню") m2 = L('АСК-анализ изображений в системе "Эйдос-Х++"') mMess = L('4. Просмотр класс.и опис.шкал и градаций и обуч.выборки: 2.1, 2.2, 2.3.1, 2.4. ')+SPACE(18) @s,2 DCPUSHBUTTON CAPTION mMess SIZE w, 1.3 ACTION {||LB_Warning(m1, m2 )} PARENT oGroup2;s=s+2.0*d mMess = L('5. Синтез и верификация системно-когнитивных моделей изображений: 3.4, 3.5, 4.1.3.6.')+SPACE(01) @s,2 DCPUSHBUTTON CAPTION mMess SIZE w, 1.3 ACTION {||F3_4(.T., 0, 0, 0, .T.,"")} PARENT oGroup2;s=s+2.0*d mMess = L('6. Решение задач идентификации и исследования изображений: 4.1.3.2, 4.1.3.1. ')+SPACE(12) @s,2 DCPUSHBUTTON CAPTION mMess SIZE w, 1.3 ACTION {||F4_1_3_2()} PARENT oGroup2;s=s+2.0*d mMess = L('7. Просмотр и запись информационных портретов классов - обобщенных изображений ')+SPACE(01) @s,2 DCPUSHBUTTON CAPTION mMess SIZE w, 1.3 ACTION {||InfPortSimbKon()} PARENT oGroup2;s=s+2.0*d DCREAD GUI; TO lExit ; FIT; ADDBUTTONS; MODAL; TITLE L("АСК-анализ изображений по их внешним контурам") ***** Восстановить состояние среды на момент запуска режима 1.3. ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** DIRCHANGE(Disk_dir) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE USERS INDEX ON Kod_AdmApp TO USERS CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Appls EXCLUSIVE NEW INDEX ON Kod_AdmApp TO APPLS USE USERS INDEX USERS EXCLUSIVE SELECT Users DO CASE CASE Flag_SysAdmin = .T. SET FILTER TO // Сисадмин видит все CASE Flag_AdmAppl = .T. SET FILTER TO Kod_AdmApp = M_KodAdmAppls // Адм.прил. и пользователь CASE Flag_User = .T. // Видят только свои приложения SET FILTER TO Kod_AdmApp = M_KodAdmAppls OTHERWISE LB_Warning(L("Этот режим доступен только после авторизации в режиме 1.1 !!!")) RETURN NIL ENDCASE DBGOTOP();DBGOBOTTOM();DBGOTOP() USE APPLS INDEX APPLS EXCLUSIVE NEW SELECT Appls DO CASE CASE Flag_SysAdmin = .T. SET FILTER TO // Сисадмин видит и может все CASE Flag_AdmAppl = .T. SET FILTER TO Kod_AdmApp = M_KodAdmAppls // Адм.приложения и пользователь CASE Flag_User = .T. // Видят только свои приложения SET FILTER TO Kod_AdmApp = M_KodAdmAppls OTHERWISE LB_Warning(L("Этот режим доступен только после авторизации в режиме 1.1 !!!")) RETURN NIL ENDCASE DBGOTOP();DBGOBOTTOM();DBGOTOP() RETURN nil **************************************************************************************** ******** 1. Задание параметров и генерация изображений символов, просмотр таблицы шрифта **************************************************************************************** FUNCTION ParGenSimb(mParam) LOCAL GetList[0] ******* Узнать разрешение экрана и не показывать изображений большой размерности **************** nWidth := AppDeskTop():currentSize()[1] // current screen size width in pixels nHeight := AppDeskTop():currentSize()[2] // current screen size height in pixels * nWidth = 1366 // <<<===########################## * nHeight = 768 * F4_8('L('4.7. АСК-анализ изображений по пикселям, спектрам и контурам')') // Если F4_8() запускается не из главного меню, а из F4_7(), то может работать на любом экране * IF mTitle = L('4.8. Геокогнитивная подсистема') // 4.8. Геокогнитивная подсистема работает только на экранах с разрешением 1920 x 1080 и более IF nWidth < 1800 aMess := {} AADD(aMess, L("Для правильного отображения графической формы")) AADD(aMess, L("необходимо разрешение экрана 1800 pix по горизонтали,")) AADD(aMess, L("а фактически установлено: ")+ALLTRIM(STR(nWidth))+" pix") LB_Warning(aMess ) Running(.F.) ReTURN NIL ENDIF IF nHeight < 850 aMess := {} AADD(aMess, L("Для правильного отображения графической формы")) AADD(aMess, L("необходимо разрешение экрана 850 pix по вертикали,")) AADD(aMess, L("а фактически установлено: ")+ALLTRIM(STR(nHeight))+" pix") LB_Warning(aMess ) Running(.F.) ReTURN NIL ENDIF * ENDIF ************************************************************************************************* ERASE('_Pix.txt');StrFile(ALLTRIM(mParam), '_Pix.txt') // Запись текстового файла _Pix.txt *Param = FileStr('_Pix.txt') PUBLIC aPar[6] IF .NOT. FILE('_ParGenSimb.arx') AFILL(aPar, .T.) aPar[1] = .T. ELSE aPar = DC_ARestore("_ParGenSimb.arx") ENDIF PUBLIC cFont := Pad('400.Arial Bold',50) IF .NOT. FILE('_Font.txt') cFont := Pad('400.Arial Bold',50) ELSE cFont = FileStr('_Font.txt') ENDIF cFont = cFont + SPACE(50-LEN(ALLTRIM(cFont))+1) @ 0,0 DCGROUP oGroup1 CAPTION L('1. Задание параметров и генерация изображений символов, просмотр таблицы шрифта') SIZE 90.0, 2.5 @ 1,2 DCSAY L('Задайте тип и размер шрифта:') GET cFont POPUP {|c|DC_PopFont(c)} SAYSIZE 0 SAYBOTTOM PARENT oGroup1 @ 3, 0 DCGROUP oGroup2 CAPTION L('Задайте, какие символы отображать:') SIZE 90.0, 7.5 @ 1, 2 DCCHECKBOX aPar[1] PROMPT L('Цифры' ) PARENT oGroup2 @ 2, 2 DCCHECKBOX aPar[2] PROMPT L('Буквы' ) PARENT oGroup2 @ 3, 2 DCCHECKBOX aPar[3] PROMPT L('Латинские') PARENT oGroup2 EDITPROTECT {|| aPar[2]<>.T. } HIDE {|| aPar[2]<>.T. } @ 4, 2 DCCHECKBOX aPar[4] PROMPT L('Русские' ) PARENT oGroup2 EDITPROTECT {|| aPar[2]<>.T. } HIDE {|| aPar[2]<>.T. } @ 5, 2 DCCHECKBOX aPar[5] PROMPT L('Заглавные') PARENT oGroup2 EDITPROTECT {|| aPar[3]<>.T. .AND. aPar[4]<>.T. } HIDE {|| aPar[3]<>.T. .AND. aPar[4]<>.T. } @ 6, 2 DCCHECKBOX aPar[6] PROMPT L('Строчные' ) PARENT oGroup2 EDITPROTECT {|| aPar[3]<>.T. .AND. aPar[4]<>.T. } HIDE {|| aPar[3]<>.T. .AND. aPar[4]<>.T. } @ 2,55 DCPUSHBUTTON CAPTION L('Отобразить шрифт') SIZE 20, 3.8 ACTION {||DisplayFonts(cFont)} PARENT oGroup2 DCREAD GUI; TO lExit ; FIT; ADDBUTTONS; MODAL; TITLE L("1. Задание параметров и генерация изображений символов, просмотр таблицы шрифта") IF lExit ** Button Ok ELSE RETURN nil ENDIF DC_ASave(aPar, "_ParGenSimb.arx") ERASE('_Font.txt');StrFile(ALLTRIM(cFont), '_Font.txt') // Запись текстового файла _Font.txt DrawSimbolMax() // Найти размеры области отображения расчетным путем без визуализации символов DrawSimbol( cFont ) // Отобразить и записать символы *DC_Main() // Оцифровка изображений по пикселям и записать изображений в базу данных (Роджер) RETURN nil ******************************************************************** * ------------- FUNCTION DisplayFonts( cFont ) LOCAL GetList[0], i, nRow, nCol cFont = FileStr('_Font.txt') cFont := Alltrim(cFont) nRow := 1 nCol := 0 FOR i := 1 TO 255 @ nRow, nCol DCSAY Str(i,3) FONT '10.Lucida Console' SAYRIGHTBOTTOM SAYSIZE 10 @ DCGUI_ROW, DCGUI_COL + 10 DCSAY Chr(i) FONT cFont SAYSIZE 0 SAYBOTTOM nRow++ IF nRow % 33 == 0 nRow := 1 nCol += 18 ENDIF NEXT DCREAD GUI FIT TITLE 'Displaying Fonts: ' + cFont MODAL RETURN nil ****************************************************************************************************** ******** Найти размеры области отображения расчетным путем без визуализации символов ***************** ****************************************************************************************************** FUNCTION DrawSimbolMax( cFontMax ) LOCAL GetList := {}, oStaticMax PRIVATE nEvent, mp1, mp2, oXbp // Переменные анализа событий PUBLIC X_MaxW := 1313, Y_MaxW := 640 // Размер графического окна для самого графика в пикселях @ 2,1 DCSTATIC TYPE XBPSTATIC_TYPE_RECESSEDBOX SIZE X_MaxW, Y_MaxW PIXEL; // Размер окна в пикселях (от Тома) OBJECT oStaticMax; EVAL {|| _PresSpaceSimbolMax( oStaticMax ) } DCREAD GUI ; TITLE L('Рисование изображений символов в системе ЭЙДОС-X++"'); // Надпись на окне графика FIT ; BUTTONS DCGUI_BUTTON_EXIT RETURN NIL ******************************************************************** STATIC FUNCTION _PresSpaceSimbolMax( oStaticMax ) LOCAL oPSMax, oDevice PUBLIC X_MaxW := 1313, Y_MaxW := 640 // Размер графического окна для самого графика в пикселях oPSMax := XbpPresSpace():new() // Create a PS oDevice := oStaticMax:winDevice() // Get the device context oPSMax:create( oDevice ) // Link device context to PS oPSMax:SetViewPort( { 0, 0, X_MaxW, Y_MaxW } ) oStaticMax:paint := {|mp1,mp2,obj| mp1 := LC_DrawSimbolMax( oPSMax, oStaticMax ) } RETURN NIL ******************************************************* STATIC FUNCTION LC_DrawSimbolMax( oPSMax, oStaticMax ) LOCAL oBitmap cFont = FileStr('_Font.txt') aPar = DC_ARestore("_ParGenSimb.arx") PUBLIC X_MaxW := 1313, Y_MaxW := 640 // Размер графического окна для самого графика в пикселях ***** Запись изображения символа в папку с именем - названием шрифта: cFont в виде файла с имененем: Символ: CHR(mSimb) DIRCHANGE(Disk_dir+"/AID_DATA/Inp_data/") mFontDir = ALLTRIM(cFont) mFontDir = STRTRAN(mFontDir,' ','_') mFontDir = STRTRAN(mFontDir,'.','_') IF FILEDATE(mFontDir,16) = CTOD("//") DIRMAKE(mFontDir) Mess = L('В папке текущего приложения не было директории: "')+mFontDir+L('" для изображений символов этого шрифта и она была создана!') LB_Warning(Mess, L('Рисование изображений символов в системе "ЭЙДОС-X++"' )) ENDIF DIRCHANGE(mFontDir) // Перейти в папку mFontDir **** Написать заголовок диаграммы aFonts := XbpFont():new():list() // Все доступные шрифты oFont := XbpFont():new():create(cFont) GraSetFont(oPSMax , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_BOTTOM // Выравнивание символов по вертикали по низу GraSetAttrString( oPSMax, aAttrF ) *** Найти ширину и высоту области отображения всех символов расчетным путем nWidthMax := -9999999999 nHeightMax := -9999999999 FOR mSimb = 1 TO 255 cFileName = "No name" // Чтобы не записывать изображений, которые не нужно IF aPar[1] // Цифры IF 48 <= mSimb .AND. mSimb <= 57 cFileName = "Num "+ConvToAnsiCP(CHR(mSimb))+".bmp" // Чтобы в именах файлов можно было использовать русские символы ENDIF ENDIF IF aPar[2] // Буквы IF aPar[3] // Латинские IF aPar[5] // Заглавные IF 65 <= mSimb .AND. mSimb <= 90 cFileName = "Eng Upper "+ConvToAnsiCP(CHR(mSimb))+".bmp" // Чтобы в именах файлов можно было использовать русские символы ENDIF ENDIF IF aPar[6] // Строчные IF 97 <= mSimb .AND. mSimb <= 122 cFileName = "Eng Lower "+ConvToAnsiCP(CHR(mSimb))+".bmp" // Чтобы в именах файлов можно было использовать русские символы ENDIF ENDIF ENDIF IF aPar[4] // Русские IF aPar[5] // Заглавные IF 128 <= mSimb .AND. mSimb <= 159 cFileName = "Rus Upper "+ConvToAnsiCP(CHR(mSimb))+".bmp" // Чтобы в именах файлов можно было использовать русские символы ENDIF ENDIF IF aPar[6] // Строчные IF 160 <= mSimb .AND. mSimb <= 175 cFileName = "Rus Lower "+ConvToAnsiCP(CHR(mSimb))+".bmp" // Чтобы в именах файлов можно было использовать русские символы ENDIF IF 224 <= mSimb .AND. mSimb <= 239 cFileName = "Rus Lower "+ConvToAnsiCP(CHR(mSimb))+".bmp" // Чтобы в именах файлов можно было использовать русские символы ENDIF ENDIF ENDIF ENDIF IF cFileName <> "No name" // Чтобы не записывать изображений, которые не нужно aArray := GraQueryTextBox( oPSMax, CHR(mSimb) ) * aArray := { { nXLeft , nYTop }, ; // upper left corner * { nXLeft , nYBottom }, ; // lower left corner * { nXRight, nYTop }, ; // upper right corner * { nXRight, nYBottom }, ; // lower right corner * { nXPen , nYPen } } // pen position nWidth := aArray[3,1] - aArray[1,1] // width nHeight := aArray[1,2] - aArray[2,2] // height nWidthMax := MAX(nWidthMax , nWidth ) nHeightMax := MAX(nHeightMax, nHeight) * IF mSimb = 158 * MsgBox(cFileName+STR(mSimb)+". Длина текста: "+CHR(mSimb)+" в пикселях="+ALLTRIM(STR(nWidthMax))+". Высота текста в пикселях="+ALLTRIM(STR(nHeightMax))) * ENDIF ENDIF NEXT DIRCHANGE(Disk_dir) * DIRCHANGE('..') ERASE('_WidthMax.txt') ;StrFile(ALLTRIM(STR(nWidthMax)), '_WidthMax.txt') // Запись текстового файла c шириной области отображения ERASE('_HeightMax.txt');StrFile(ALLTRIM(STR(nHeightMax)),'_HeightMax.txt') // Запись текстового файла c высотой области отображения ***** Стиль для написания сообщения oFontmax := XbpFont():new():create('40.Arial Narrow') GraSetFont(oPSMax, oFontMax) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_BOTTOM // Выравнивание символов по вертикали по низу GraSetAttrString( oPSMax, aAttrF ) // Установить символьные атрибуты Mess = L("Расчет размеров области отображения закончен.") aArray := GraQueryTextBox( oPSMax, Mess ) nWidth := aArray[3,1] - aArray[1,1] // width nHeight := aArray[1,2] - aArray[2,2] // heigh GraStringAt( oPSMax, { X_MaxW/2-nWidth/2, Y_MaxW-300 }, Mess ) Mess = L("Нажмите Esc !") aArray := GraQueryTextBox( oPSMax, Mess ) nWidth := aArray[3,1] - aArray[1,1] // width nHeight := aArray[1,2] - aArray[2,2] // heigh GraStringAt( oPSMax, { X_MaxW/2-nWidth/2, Y_MaxW-400 }, Mess ) RETURN NIL *********************************************** ******** ВИЗУАЛИЗАЦИЯ СИМВОЛОВ **************** *********************************************** FUNCTION DrawSimbol( cFont ) LOCAL GetList := {}, oStatic PRIVATE nEvent, mp1, mp2, oXbp // Переменные анализа событий cFont = FileStr('_Font.txt') nWidthMax = VAL(FileStr('_WidthMax.txt')) nHeightMax = VAL(FileStr('_HeightMax.txt')) @ 2,1 DCSTATIC TYPE XBPSTATIC_TYPE_RECESSEDBOX SIZE nWidthMax, nHeightMax PIXEL; // Размер окна в пикселях (от Тома) OBJECT oStatic; EVAL {|| _PresSpaceSimbol( oStatic, cFont) } DCREAD GUI ; TITLE 'Image'; // Надпись на окне графика FIT ; BUTTONS DCGUI_BUTTON_EXIT RETURN NIL ************************************************* STATIC FUNCTION _PresSpaceSimbol( oStatic, cFont ) LOCAL oPS, oDevice cFont = FileStr('_Font.txt') nWidthMax = VAL(FileStr('_WidthMax.txt')) nHeightMax = VAL(FileStr('_HeightMax.txt')) oPS := XbpPresSpace():new() // Create a PS oDevice := oStatic:winDevice() // Get the device context oPS:create( oDevice ) // Link device context to PS oPS:SetViewPort( { 0, 0, nWidthMax, nHeightMax } ) oStatic:paint := {|mp1,mp2,obj| mp1 := LC_DrawSimbol( oPS, oStatic, cFont ) } RETURN NIL ******************************************************* STATIC FUNCTION LC_DrawSimbol( oPS, oStatic, cFont ) LOCAL oBitmap cFont = FileStr('_Font.txt') nWidthMax = VAL(FileStr('_WidthMax.txt')) nHeightMax = VAL(FileStr('_HeightMax.txt')) aPar = DC_ARestore("_ParGenSimb.arx") *ERASE('_Pix.txt');StrFile(ALLTRIM(mParam), '_Pix.txt') // Запись текстового файла _Pix.txt mParam = FileStr('_Pix.txt') // Параметр, задающий, создавать изображения на черном фоне (Pix) или на белом (Ok) **** Написать заголовок диаграммы aFonts := XbpFont():new():list() // Все доступные шрифты oFont := XbpFont():new():create(cFont) GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) * aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_COLOR ] := GRA_CLR_WHITE aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_BOTTOM // Выравнивание символов по вертикали по низу GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты ***** Запись изображения символа в папку с именем - названием шрифта: cFont в виде файла с имененем: Символ: CHR(mSimb) DIRCHANGE(Disk_dir+"/AID_DATA/Inp_data/") mFontDir = ALLTRIM(cFont) mFontDir = STRTRAN(mFontDir,' ','_') mFontDir = STRTRAN(mFontDir,'.','_') IF FILEDATE(mFontDir,16) = CTOD("//") DIRMAKE(mFontDir) Mess = L('В папке текущего приложения не было директории: "')+mFontDir+L('" для изображений символов этого шрифта и она была создана!') LB_Warning(Mess, L('Рисование изображений символов в системе "ЭЙДОС-X++"' )) ENDIF DIRCHANGE(mFontDir) // Перейти в папку mFontDir *** Формирование графического файла *** Formation of the image file FOR mSimb = 1 TO 255 cFileName = "No name" // Чтобы не записывать изображений, которые не нужно IF aPar[1] // Цифры IF 48 <= mSimb .AND. mSimb <= 57 cFileName = "Num "+ConvToAnsiCP(CHR(mSimb))+".bmp" // Чтобы в именах файлов можно было использовать русские символы ENDIF ENDIF IF aPar[2] // Буквы IF aPar[3] // Латинские IF aPar[5] // Заглавные IF 65 <= mSimb .AND. mSimb <= 90 cFileName = "Eng Upper "+ConvToAnsiCP(CHR(mSimb))+".bmp" // Чтобы в именах файлов можно было использовать русские символы ENDIF ENDIF IF aPar[6] // Строчные IF 97 <= mSimb .AND. mSimb <= 122 cFileName = "Eng Lower "+ConvToAnsiCP(CHR(mSimb))+".bmp" // Чтобы в именах файлов можно было использовать русские символы ENDIF ENDIF ENDIF IF aPar[4] // Русские IF aPar[5] // Заглавные IF 128 <= mSimb .AND. mSimb <= 159 cFileName = "Rus Upper "+ConvToAnsiCP(CHR(mSimb))+".bmp" // Чтобы в именах файлов можно было использовать русские символы ENDIF ENDIF IF aPar[6] // Строчные IF 160 <= mSimb .AND. mSimb <= 175 cFileName = "Rus Lower "+ConvToAnsiCP(CHR(mSimb))+".bmp" // Чтобы в именах файлов можно было использовать русские символы ENDIF IF 224 <= mSimb .AND. mSimb <= 239 cFileName = "Rus Lower "+ConvToAnsiCP(CHR(mSimb))+".bmp" // Чтобы в именах файлов можно было использовать русские символы ENDIF ENDIF ENDIF ENDIF IF cFileName <> "No name" // Чтобы не записывать изображений, которые не нужно *** Стереть окно, т.е. нарисовать желтый прямоугольник с желтыми границами (фон окна) *** Erase window, ie draw a yellow square with yellow border (window background) * GraSetColor( oPS, GRA_CLR_YELLOW, GRA_CLR_YELLOW ) * GraSetColor( oPS, GRA_CLR_WHITE, GRA_CLR_WHITE ) ** Задание цвета окна и его отображение DO CASE CASE mParam = 'Pix' GraSetColor( oPS, GRA_CLR_BLACK, GRA_CLR_BLACK ) CASE mParam = 'Ok' GraSetColor( oPS, GRA_CLR_WHITE, GRA_CLR_WHITE ) ENDCASE GraBox( oPS, { 0, 0 }, { nWidthMax, nHeightMax }, GRA_FILL ) *** Стереть область изображения символа, т.е. нарисовать белый прямоугольник с белыми границами *** Erase the character image area, ie, draw a white rectangle with a white border aArray := GraQueryTextBox( oPS, CHR(mSimb) ) * aArray := { { nXLeft , nYTop }, ; // upper left corner * { nXLeft , nYBottom }, ; // lower left corner * { nXRight, nYTop }, ; // upper right corner * { nXRight, nYBottom }, ; // lower right corner * { nXPen , nYPen } } // pen position nWidth := aArray[3,1] - aArray[1,1] // width nHeight := aArray[1,2] - aArray[2,2] // height ** Задание цвета прямоугольника и его отображение DO CASE CASE mParam = 'Pix' GraSetColor( oPS, GRA_CLR_BLACK, GRA_CLR_BLACK ) CASE mParam = 'Ok' GraSetColor( oPS, GRA_CLR_WHITE, GRA_CLR_WHITE ) ENDCASE GraBox( oPS, { 0, 0 }, { nWidth, nHeight }, GRA_FILL ) ** Задание цвета символа и его отображение DO CASE CASE mParam = 'Pix' GraSetColor( oPS, GRA_CLR_WHITE, GRA_CLR_WHITE ) CASE mParam = 'Ok' GraSetColor( oPS, GRA_CLR_BLACK, GRA_CLR_BLACK ) ENDCASE GraStringAt( oPS, { 0, 0 }, CHR(mSimb)) // Отобразить символ * GraSetColor( oPS, GRA_CLR_BLUE, GRA_CLR_BLUE ) * DrawBorderTxtBox(oPS, { 0, 0 }, CHR(mSimb) ) // Рамка области изображения символа ERASE( cFileName );DC_Scrn2ImageFile( oStatic, cFileName ) // Стереть старый файл и записать новый * IF mSimb = 158 * MsgBox(cFileName+STR(mSimb)+". Длина текста: "+CHR(mSimb)+" в пикселях="+ALLTRIM(STR(nWidth))+". Высота текста в пикселях="+ALLTRIM(STR(nHeight))) * ENDIF * INKEY(0) ENDIF NEXT DIRCHANGE(Disk_dir) * DIRCHANGE('..') ERASE('_FontDir.txt');StrFile(ALLTRIM(mFontDir), '_FontDir.txt') // Запись текстового файла _Font.txt LB_Warning(L("Процесс генерации изображений символов завершен успешно!"), L("АСК-анализ изображений" )) RETURN NIL **************************************************************************************************** ******** Визуализация информационных портретов символов в стилях: "Контур", "Витраж", "Триангуляция" **************************************************************************************************** FUNCTION InfPortSimbKon() mPuthSystem = ApplChange("") // Перейти в папку текущего приложения IF .NOT. FILE("Abs.txt") // БД абс.частот LB_Warning(L("Проведите рассчет матрицы абсолютных частот Abs.txt в режиме 3.1!")) RETURN NIL ENDIF IF .NOT. FILE("Prc1.txt") .OR.; // БД процентных распределений .NOT. FILE("Prc2.txt") LB_Warning(L("Проведите рассчет матриц условных и безусловных процентных распределений Prc1 и Prc2 в режиме 3.2 !")) RETURN NIL ENDIF IF .NOT. FILE("Inf1.txt") // БЗ-1 LB_Warning(L("Проведите рассчет заданных баз знаний Inf1.txt - Inf7.dbf в режиме 3.5!")) RETURN NIL ENDIF PUBLIC aWorkInf[11] IF .NOT. FILE('_WorkInf.arx') AFILL(aWorkInf, .F.) aWorkInf[4] = .T. aWorkInf[11] = 0 ELSE aWorkInf = DC_ARestore("_WorkInf.arx") ENDIF ********************************************************************************************************************** // Диалог задания моделей для верификации @ 0,0 DCGROUP oGroup1 CAPTION L('Задайте стат.модели и модели знаний для работы') SIZE 87,13.5 @ 1,1 DCSAY L('Статистические базы:' ) PARENT oGroup1 @ 2,3 DCCHECKBOX aWorkInf[ 1] PROMPT L('1. ABS - частный критерий: количество встреч сочетаний: "класс-признак" у объектов обуч.выборки') PARENT oGroup1 @ 3,3 DCCHECKBOX aWorkInf[ 2] PROMPT L('2. PRC1 - частный критерий: усл. вероятность i-го признака среди признаков объектов j-го класса ') PARENT oGroup1 @ 4,3 DCCHECKBOX aWorkInf[ 3] PROMPT L('3. PRC2 - частный критерий: условная вероятность i-го признака у объектов j-го класса ') PARENT oGroup1 @ 5.2,1 DCSAY L('Системно-когнитивные модели (Базы знаний):' ) PARENT oGroup1 @ 6,3 DCCHECKBOX aWorkInf[ 4] PROMPT L('4. INF1 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC1 ') PARENT oGroup1 @ 7,3 DCCHECKBOX aWorkInf[ 5] PROMPT L('5. INF2 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC2 ') PARENT oGroup1 @ 8,3 DCCHECKBOX aWorkInf[ 6] PROMPT L('6. INF3 - частный критерий: Xи-квадрат, разности между фактическими и ожидаемыми абс.частотами ') PARENT oGroup1 @ 9,3 DCCHECKBOX aWorkInf[ 7] PROMPT L('7. INF4 - частный критерий: ROI (Return On Investment); вероятности из PRC1 ') PARENT oGroup1 @10,3 DCCHECKBOX aWorkInf[ 8] PROMPT L('8. INF5 - частный критерий: ROI (Return On Investment); вероятности из PRC2 ') PARENT oGroup1 @11,3 DCCHECKBOX aWorkInf[ 9] PROMPT L('9. INF6 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC1 ') PARENT oGroup1 @12,3 DCCHECKBOX aWorkInf[10] PROMPT L('10.INF7 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC2 ') PARENT oGroup1 @14,0 DCGROUP oGroup2 CAPTION L('Задайте, какие градации отображать:') SIZE 87,2.5 @ 1,2 DCSAY L("Имеющие значимость не менее % от максимальной: ") PARENT oGroup2 @ 1,44 DCSAY L(" ") GET aWorkInf[11] PICTURE "###########" PARENT oGroup2 DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; OPTIONS GetOptions ; ADDBUTTONS; MODAL ; TITLE L('АСК-анализ изображений') ******************************************************************** IF lExit ** Button Ok ELSE RETURN NIL ENDIF DC_ASave(aWorkInf, "_WorkInf.arx") ***** Преобразовать выбранные модели: txt => dbf mLenNameMax = CreateStructAll() // Создание файлов структур баз данных всех моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() // Количество классов (градаций классификационных шкал) USE Attributes EXCLUSIVE NEW;N_Gos = RECCOUNT() // Количество признаков (градаций описательных шкал) USE Gr_OpSc EXCLUSIVE NEW;N_Gos = RECCOUNT() // Количество признаков (градаций описательных шкал) USE Opis_Sc EXCLUSIVE NEW ***** Копирование основных БД всех моделей из txt в dbf формат с числом полей до 2035 IF N_Cls > 2035 LB_Warning(L("Будут показаны только первые 2035 колонок", 'АСК-анализ изображений' )) ENDIF * ########################################################################### // Открытие текстовых баз данных ******************************************** *** Создание баз данных в dbf-формате с найденной максимальной длиной наименования шкалы + строки и столбцы, как в Inf# GenDbfAbsOld(mLenNameMax) GenDbfPrcOld(mLenNameMax) GenDbfInfOld(mLenNameMax) *DC_ASave(aInfStruct, "_InfStruct.arx") // Когда БД создается - записывать структуру, когда открывается - считывать aInfStruct = DC_ARestore("_InfStruct.arx") *DC_ASave(aStrEmpty, "_aStrEmpty.arx") // Записывать только после расчета Abs.txt, а при расчете остальных БД только считывать *DC_ASave(aColEmpty, "_aColEmpty.arx") aStrEmpty = DC_ARestore("_aStrEmpty.arx") aColEmpty = DC_ARestore("_aColEmpty.arx") ************************************************* ***** Формирование пустой записи N_Col = N_Cls+6 // Число полей CrLf = CHR(13)+CHR(10) // Конец строки (записи) Lc_buf = "" FOR j=1 TO N_Col * S = IF(j=2*INT(j/2),"#","X") // Для отладки S = " " // Для работы Lc_buf = Lc_buf + REPLICATE(S, aInfStruct[j,3]) NEXT Lc_buf = Lc_buf + CrLf PUBLIC Len_LcBuf := LEN(Lc_buf) ****** Создаем стат.базы и базы знаний (7 по частным критериям знаний) Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } PUBLIC nHandle[LEN(Ar_Model)] FOR z=1 TO LEN(Ar_Model) nHandle[z] := FOpen( Ar_Model[z]+".txt", FO_READWRITE ) // Открыть все текстовые базы данных ######################################## NEXT **** Рассчет массива начальных позиций полей в строке PUBLIC aPos[N_Col] aPos[1] = 1 FOR j=2 TO N_Col aPos[j] = aPos[j-1] + aInfStruct[j-1,3] NEXT * ########################################################################### ***** Открытие основных БД.dbf всех моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() // Количество классов (градаций классификационных шкал) FOR z=1 TO LEN(Ar_Model) M_Inf = Ar_Model[z] USE (M_Inf) EXCLUSIVE NEW NEXT ***************************** nMax = N_Gos + 4 + ( N_Gos + 3 ) * 9 Mess = L('Копирование основных баз данных моделей: Abs, Prc#, Inf#: txt=>dbf') @ 4,5 DCPROGRESS oProgr SIZE 80,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 DCREAD GUI TITLE Mess PARENT @oDial FIT EXIT oDial:show() nTime = 0 DC_GetProgress(oProgr,0,nMax) ***************************** *** Копирование БД.txt => БД.dbf ************** (но не более 2035 полей классов) mNCls = IF(N_Cls<=2035,N_Cls,2035) FOR z=1 TO LEN(Ar_Model) M_Inf = Ar_Model[z] SELECT(M_Inf) FOR i=1 TO N_Gos * IF aStrEmpty[i] DBGOTO(i) Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], i, 1 ));FIELDPUT(1, Fv) Fv = LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], i, 2 ) ;FIELDPUT(2, Fv) FOR j=1 TO mNCls * IF aColEmpty[j] Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], i, 2+j ));FIELDPUT(2+j, Fv) * ENDIF NEXT FOR j=1 TO 3 Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], i, mNCls+2+j ));FIELDPUT(mNCls+2+j, Fv) NEXT * ENDIF DC_GetProgress(oProgr, ++nTime, nMax) NEXT FOR i=1 TO 4 DBGOTO(N_Gos+i) Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], N_Gos+i, 1 ));FIELDPUT(1, Fv) Fv = LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], N_Gos+i, 2 ) ;FIELDPUT(2, Fv) FOR j=1 TO mNCls * IF aColEmpty[j] Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], N_Gos+i, 2+j ));FIELDPUT(2+j, Fv) * ENDIF NEXT FOR j=1 TO 3 Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], N_Gos+i, mNCls+2+j ));FIELDPUT(mNCls+2+j, Fv) NEXT DC_GetProgress(oProgr, ++nTime, nMax) NEXT NEXT DC_GetProgress(oProgr,nMax,nMax) oDial:Destroy() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций FOR z=1 TO LEN(nHandle) FClose( nHandle[z] ) // Закрытие dbf и txt баз данных ###################################### NEXT ***** Открытие необходимых баз данных ***** Открыть выбранные модели Ar_Model := {"Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Opis_Sc EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW FOR mNumMod=1 TO LEN(Ar_Model) // Начало цикла по стат.моделям и моделям знаний IF aWorkInf[mNumMod] M_Inf = Ar_Model[mNumMod] USE (M_Inf) EXCLUSIVE NEW ENDIF NEXT ******************************************************************************** ****** Нарисовать систему описательных шкал и градаций в форме четырехугольников ******************************************************************************** ERASE('_Regim.txt');StrFile('Сетка', '_Regim.txt') // Запись текстового файла с режимом отображения, СЕЙЧАС РИСУЕТ ВСЕ ПОДРЯД, кроме Делоне DrawOpScGr('Сетка') ERASE('_Regim.txt');StrFile('Витраж', '_Regim.txt') // Запись текстового файла с режимом отображения DrawOpScGr('Витраж') * ERASE('_Regim.txt');StrFile('Трианг', '_Regim.txt') // Запись текстового файла с режимом отображения ####################################### * DrawOpScGr('Трианг') * ERASE('_Regim.txt');StrFile('Трианг', '_Regim.txt') // Режим отладки триангуляции * DrawOpScGrDebug('Трианг') * QUIT ************************************************************* ****** Процесс рисования информационных портретов изображений ************************************************************* PUBLIC aKodCls := {} // Массив кодов классов PUBLIC aNameCls := {} // Массив наименований классов SELECT Classes DBGOTOP() DO WHILE .NOT. EOF() AADD(aKodCls , Kod_Cls) AADD(aNameCls, DelZeroNameGr(Name_cls)) DBSKIP(1) ENDDO Ar_Model := {"Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } FOR mSimb = 1 TO N_Cls // Начало цикла по символам (классам) ERASE('_Simb.txt') StrFile(ALLTRIM(STR(mSimb)), '_Simb.txt') // Запись текстового файла с номером символа FOR mNumMod=1 TO LEN(Ar_Model) // Начало цикла по стат.моделям и моделям знаний IF aWorkInf[mNumMod] ERASE('_NumMod.txt') StrFile(ALLTRIM(STR(mNumMod)), '_NumMod.txt') // Запись текстового файла с номером модели M_Inf = Ar_Model[mNumMod] SELECT(M_Inf) SET FILTER TO Kod_pr <> 0 DBGOTOP();DBGOBOTTOM();DBGOTOP() ERASE('_Regim.txt');StrFile('Витраж', '_Regim.txt') // Запись текстового файла с режимом отображения DrawIPSimbol() // ################################################ * ERASE('_Regim.txt');StrFile('Трианг', '_Regim.txt') // Запись текстового файла с режимом отображения * DrawIPSimbol() // ################################################ ENDIF NEXT NEXT ***** Восстановить состояние среды на момент запуска режима 1.3. ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** DIRCHANGE(Disk_dir) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE USERS INDEX ON Kod_AdmApp TO USERS CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Appls EXCLUSIVE NEW INDEX ON Kod_AdmApp TO APPLS USE USERS INDEX USERS EXCLUSIVE SELECT Users DO CASE CASE Flag_SysAdmin = .T. SET FILTER TO // Сисадмин видит все CASE Flag_AdmAppl = .T. SET FILTER TO Kod_AdmApp = M_KodAdmAppls // Адм.прил. и пользователь CASE Flag_User = .T. // Видят только свои приложения SET FILTER TO Kod_AdmApp = M_KodAdmAppls OTHERWISE LB_Warning(L("Этот режим доступен только после авторизации в режиме 1.1 !!!")) RETURN NIL ENDCASE DBGOTOP();DBGOBOTTOM();DBGOTOP() USE APPLS INDEX APPLS EXCLUSIVE NEW SELECT Appls DO CASE CASE Flag_SysAdmin = .T. SET FILTER TO // Сисадмин видит и может все CASE Flag_AdmAppl = .T. SET FILTER TO Kod_AdmApp = M_KodAdmAppls // Адм.приложения и пользователь CASE Flag_User = .T. // Видят только свои приложения SET FILTER TO Kod_AdmApp = M_KodAdmAppls OTHERWISE LB_Warning(L("Этот режим доступен только после авторизации в режиме 1.1 !!!")) RETURN NIL ENDCASE DBGOTOP();DBGOBOTTOM();DBGOTOP() RETURN NIL ************************************************************************************ ******** Визуализация информационного портрета символа в стилях: "Контур", "Витраж" ************************************************************************************ FUNCTION DrawIPSimbol() LOCAL GetList := {}, oStatic PRIVATE nEvent, mp1, mp2, oXbp // Переменные анализа событий PUBLIC X_MaxW := 1313, Y_MaxW := 640 // Размер графического окна для самого графика в пикселях @ 2,1 DCSTATIC TYPE XBPSTATIC_TYPE_RECESSEDBOX SIZE X_MaxW+11, Y_MaxW+20 PIXEL; // Размер окна в пикселях (от Тома) OBJECT oStatic; EVAL {|| _PresSpaceIPSimbol( oStatic ) } DCREAD GUI ; TITLE L("Визуализация информационного портрета символа в системе ЭЙДОС-X++"); // Надпись на окне графика FIT ; BUTTONS DCGUI_BUTTON_EXIT RETURN NIL ************************************************* STATIC FUNCTION _PresSpaceIPSimbol( oStatic ) LOCAL oPS, oDevice PUBLIC X_MaxW := 1313, Y_MaxW := 640 // Размер графического окна для самого графика в пикселях oPS := XbpPresSpace():new() // Create a PS oDevice := oStatic:winDevice() // Get the device context oPS:create( oDevice ) // Link device context to PS oPS:SetViewPort( { 0, 0, X_MaxW, Y_MaxW } ) oStatic:paint := {|mp1,mp2,obj| mp1 := LC_DrawIPSimbol( oPS, oStatic ) } RETURN NIL ******************************************************* STATIC FUNCTION LC_DrawIPSimbol( oPS, oStatic ) LOCAL oBitmap mSimbol = VAL(FileStr('_Simb.txt')) mNumMod = VAL(FileStr('_NumMod.txt')) mRegim = FileStr('_Regim.txt') * PRIVATE X0 := 0 + X_MaxW/2 * PRIVATE Y0 := 5 + Y_MaxW/2 // Начало координат по осям X и Y * PRIVATE W_Wind := X_MaxW - X0 // Ширина окна для самого графика * PRIVATE H_Wind := Y_MaxW - Y0 // Высота окна для самого графика **** Написать заголовок диаграммы aFonts := XbpFont():new():list() // Все доступные шрифты oFont := XbpFont():new():create('16.Arial Bold') GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты mTitle = 'ИНФОРМАЦИОННЫЙ ПОРТРЕТ: ['+ALLTRIM(STR(aKodCls[mSimbol]))+']-"'+aNameCls[mSimbol]+'" В МОДЕЛИ: "'+Ar_Model[mNumMod]+'"' aTxtPar = DC_GraQueryTextbox(mTitle, oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox("Длина текста в пикселях="+ALLTRIM(STR(aTxtPar[1]))+". Высота текста в пикселях="+ALLTRIM(STR(aTxtPar[2]))) GraStringAt( oPS, { X_MaxW/2, Y_MaxW+aTxtPar[2]+5 }, mTitle) oFont := XbpFont():new():create('14.Arial Bold') GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты mTitle = 'Показаны градации со значимостью не менее '+ALLTRIM(STR(aWorkInf[11]))+'% от максимальной. Модель: "'+M_Inf+'"' aTxtPar = DC_GraQueryTextbox(mTitle, oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox("Длина текста в пикселях="+ALLTRIM(STR(aTxtPar[1]))+". Высота текста в пикселях="+ALLTRIM(STR(aTxtPar[2]))) GraStringAt( oPS, { X_MaxW/2, Y_MaxW+aTxtPar[2]-25 }, mTitle) ******** Визуализация информационного портрета символа в стиле: "Контур" ******************************************** aInf := {} // Массив значений информативностей точек контура aAngle := {} // Массив углов, соответствующих точкам контура aRadiusAvr := {} // Массив средних интервальных значений радиус-векторов на точки контура aRadiusMin := {} // Массив минимальных интервальных значений радиус-векторов на точки контура aRadiusMax := {} // Массив максимальных интервальных значений радиус-векторов на точки контура mRadiusMax := -9999 // Максимальное интервальное значение радиус-вектора на точки контура SELECT(M_Inf) DBGOTOP() DO WHILE .NOT. EOF() IF Kod_pr > 0 mRec = RECNO() mVol = FIELDGET(2+mSimbol) IF mVol <> 0 AADD(aInf , mVol) AADD(aAngle, VAL(SUBSTR(Name,1,3))) SELECT Attributes DBGOTO(mRec) AADD(aRadiusAvr, Avr_GrInt) AADD(aRadiusMin, Min_GrInt) AADD(aRadiusMax, Max_GrInt) mRadiusMax = MAX(mRadiusMax, Max_GrInt) ENDIF ENDIF SELECT(M_Inf) DBSKIP(1) ENDDO N = LEN(aAngle) FOR j=1 TO N AADD(aInf , aInf[1]) AADD(aAngle, aAngle[1]) AADD(aRadiusAvr, aRadiusAvr[1]) AADD(aRadiusMin, aRadiusMin[1]) AADD(aRadiusMax, aRadiusMax[1]) NEXT ****** Массив с информацией об описательных шкалах aAngle := {} // Массив углов, соответствующих описательным шкалам (точкам контура) SELECT Opis_Sc N_OpSc = RECCOUNT() IF N_OpSc = 1 RETURN NIL ENDIF PUBLIC aOpSc[N_OpSc+1,5] mNum = 0 DBGOTOP() DO WHILE .NOT. EOF() mVal = VAL(SUBSTR(Name_OpSc,1,3)) AADD (aAngle, mval) mNum++ aOpSc[mNum, 1] = Kod_OpSc aOpSc[mNum, 2] = mVal aOpSc[mNum, 3] = N_GROPSC aOpSc[mNum, 4] = KODGR_MIN aOpSc[mNum, 5] = KODGR_MAX DBSKIP(1) ENDDO FOR j=1 TO 5 aOpSc[N_OpSc+1, j] = aOpSc[1, j] NEXT ****** Найти максимальное значение радиус-вектора mRadiusMax = -9999 // Максимальное интервальное значение радиус-вектора на точки контура SELECT Attributes DBGOTOP() DO WHILE .NOT. EOF() mRadiusMax = MAX(mRadiusMax, Max_GrInt) DBSKIP(1) ENDDO ****** Минимальное и максимальное значение интегральной информативности в текущей модели mInfMin = +99999999 // Для шкалирования цвета mInfMax = -99999999 mIntInfMax = -99999999 // Максимальное значение интtгральной информативности mIntInfMin = +99999999 // Минимальное значение интtгральной информативности SELECT(M_Inf) DBGOTOP() DO WHILE .NOT. EOF() IF Kod_pr > 0 mVol = FIELDGET(2+mSimbol) mInfMin = MIN(mInfMin, mVol) mInfMax = MAX(mInfMax, mVol) mIntInfMax = MAX(mIntInfMax, Disp) // 100% mIntInfMin = MIN(mIntInfMin, Disp) ENDIF DBSKIP(1) ENDDO * MsgBox(STR(mInfMax)+STR(mInfMin)) mNGrad = mInfMax - mInfMin // Диапазон изменения цвета mNGradII = mIntInfMax - mIntInfMin // Диапазон изменения цвета интегральной информативности # Диапазон цветов до фиолетового, а не до пурпурного *** Расчет позиций центров изображений в стилях "Контур" и "Витраж" Dx = 50 Dy = 50 Ax = ( X_MaxW/2 - 2*Dx ) / ( 2 * mRadiusMax ) Ay = ( Y_MaxW - 2*Dy ) / ( 2 * mRadiusMax ) Dx = (X_MaxW/2 - 2*mRadiusMax)/1.5 Dy = Y_MaxW/2 - 2*mRadiusMax X0kont = X_MaxW/4 X0vitr = 3*X_MaxW/4 Y0 = Y_MaxW/2 + 5 ****** Надписи стилей oFont := XbpFont():new():create('14.Arial Bold') GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraStringAt( oPS, { 120, Y_MaxW+aTxtPar[2]-55 }, 'Стиль: "Сеть (невод)"') // ############################################################ IF mRegim = 'Витраж' GraStringAt( oPS, { X_MaxW-100, Y_MaxW+aTxtPar[2]-55 }, 'Стиль: "Витраж"') ENDIF IF mRegim = 'Трианг' GraStringAt( oPS, { X_MaxW-100, Y_MaxW+aTxtPar[2]-55 }, 'Стиль: "Триангуляция"') ENDIF ****** Рисование координатной сетки oFont := XbpFont():new():create('8.Arial') GraSetFont(oPS , oFont) // Установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := aColor[146] aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_SOLID // Тип линии aAttr [ GRA_AL_COLOR ] := aColor[146] // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты ******** Для изображения в стиле "Контур" mPhase = 0 // Поворот изображения при визуализации, чтобы совпадало с видом в обуч.выборке X1 := X0kont Y1 := Y0 FOR p=1 TO LEN(aAngle) X2 := X1 + Ax * mRadiusMax * COS( (aAngle[p]+mPhase) * GradRad ) Y2 := Y1 - Ay * mRadiusMax * SIN( (aAngle[p]+mPhase) * GradRad ) GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии X2 := X1 + Ax * (mRadiusMax+5) * COS( (aAngle[p]+mPhase) * GradRad ) Y2 := Y1 - Ay * (mRadiusMax+5) * SIN( (aAngle[p]+mPhase) * GradRad ) GraStringAt( oPS, { X2, Y2 }, ALLTRIM(STR(aAngle[p]))) NEXT aAttr := ARRAY( GRA_AM_COUNT ) // Массив для атрибутов маркеров aAttr[ GRA_AM_SYMBOL ] := GRA_MARKSYM_DOT aAttr[ GRA_AM_COLOR ] := aColor[12] // Задать цвет точки GraSetAttrMarker( oPS, aAttr ) FOR r=0 TO mRadiusMax STEP mRadiusMax/5 FOR p=1 TO 360 STEP 0.5 X2 := X1 + Ax * r * COS( (p+mPhase) * GradRad ) Y2 := Y1 - Ay * r * SIN( (p+mPhase) * GradRad ) GraMarker( oPS, { X2, Y2 } ) // Нарисовать точку координатной окружности NEXT GraStringAt( oPS, { X2, Y2 }, ALLTRIM(STR(r*100,3))) NEXT ******** Для изображения в стиле "Витраж" X1 := X0vitr Y1 := Y0 FOR p=1 TO LEN(aAngle) X2 := X1 + Ax * mRadiusMax * COS( (aAngle[p]+mPhase) * GradRad ) Y2 := Y1 - Ay * mRadiusMax * SIN( (aAngle[p]+mPhase) * GradRad ) GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии X2 := X1 + Ax * (mRadiusMax+5) * COS( (aAngle[p]+mPhase) * GradRad ) Y2 := Y1 - Ay * (mRadiusMax+5) * SIN( (aAngle[p]+mPhase) * GradRad ) GraStringAt( oPS, { X2, Y2 }, ALLTRIM(STR(aAngle[p]))) NEXT aAttr := ARRAY( GRA_AM_COUNT ) // Массив для атрибутов маркеров aAttr[ GRA_AM_SYMBOL ] := GRA_MARKSYM_DOT aAttr[ GRA_AM_COLOR ] := aColor[12] // Задать цвет точки GraSetAttrMarker( oPS, aAttr ) FOR r=0 TO mRadiusMax STEP mRadiusMax/5 FOR p=1 TO 360 STEP 0.5 X2 := X1 + Ax * r * COS( (p+mPhase) * GradRad ) Y2 := Y1 - Ay * r * SIN( (p+mPhase) * GradRad ) GraMarker( oPS, { X2, Y2 } ) // Нарисовать точку координатной окружности NEXT GraStringAt( oPS, { X2, Y2 }, ALLTRIM(STR(r*100,3))) NEXT ******** Визуализация информационного портрета символа в стиле: "Контур" ******************************************** RS = 3 aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_SOLID // Тип линии aAttr [ GRA_AL_COLOR ] := aColor[222] // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты * ################################################################################################################## * mRegim = 'Прозрачная сетка' - входит во 2-й и 3-й * mRegim = 'Градиентная заливка' - Витраж * mRegim = 'Триангуляция Делоне' - Трианг // В разработке IF mRegim = 'Витраж' ****** Визуализация информационного портрета в стиле: "Витраж" ******************************************** X0kont = X_MaxW/4 X0vitr = 3*X_MaxW/4 X0 = X0kont SELECT Attributes FOR mNOpSc = 1 TO N_OpSc // Цикл по описательным шкалам FOR mGrOpSc = aOpSc[mNOpSc,4] TO aOpSc[mNOpSc,5] // Цикл по градациям описательных шкал SELECT Attributes DBGOTO(mGrOpSc) mMinGrInt1 = MIN_GRINT mMaxGrInt1 = MAX_GRINT SELECT(M_Inf) DBGOTO(mGrOpSc) mInf1 = FIELDGET(2+mSimbol) SELECT Attributes * aOpSc[mNum, 3] = N_GROPSC * aOpSc[mNum, 4] = KODGR_MIN * aOpSc[mNum, 5] = KODGR_MAX DBGOTO(mGrOpSc) IF mNOpSc < N_OpSc DBGOTO(mGrOpSc+aOpSc[mNOpSc,3]) ELSE DBGOTO(mGrOpSc-aOpSc[mNOpSc,4]+1) // ??????????????????? ENDIF mRecno = RECNO() mMinGrInt2 = MIN_GRINT mMaxGrInt2 = MAX_GRINT SELECT(M_Inf) DBGOTO(mRecno) mInf2 = FIELDGET(2+mSimbol) ********* Фильтр ******* mFlagView = .T. IF aWorkInf[11] > 0 mFlagView = .F. IF mInf1 >= mInfMax * aWorkInf[11] / 100 .AND.; mInf2 >= mInfMax * aWorkInf[11] / 100 mFlagView = .T. ENDIF ENDIF ***** Нарисовать четырехугольник *************** X1 := X0 + Ax * mMinGrInt1 * COS( aOpSc[mNOpSc,2] * GradRad ) Y1 := Y0 - Ay * mMinGrInt1 * SIN( aOpSc[mNOpSc,2] * GradRad ) X2 := X0 + Ax * mMaxGrInt1 * COS( aOpSc[mNOpSc,2] * GradRad ) Y2 := Y0 - Ay * mMaxGrInt1 * SIN( aOpSc[mNOpSc,2] * GradRad ) X3 := X0 + Ax * mMinGrInt2 * COS( aOpSc[mNOpSc+1,2] * GradRad ) Y3 := Y0 - Ay * mMinGrInt2 * SIN( aOpSc[mNOpSc+1,2] * GradRad ) X4 := X0 + Ax * mMaxGrInt2 * COS( aOpSc[mNOpSc+1,2] * GradRad ) Y4 := Y0 - Ay * mMaxGrInt2 * SIN( aOpSc[mNOpSc+1,2] * GradRad ) GraSetColor( oPS, aColor[222], aColor[222] ) GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии GraLine( oPS, { X1, Y1 }, { X3, Y3 } ) // Нарисовать отрезок прямой линии GraLine( oPS, { X3, Y3 }, { X4, Y4 } ) // Нарисовать отрезок прямой линии GraLine( oPS, { X2, Y2 }, { X4, Y4 } ) // Нарисовать отрезок прямой линии IF mFlagView ********* Нарисовать точки контура ma := 127.5 mb := 127.5 mc := 127.5 mU := 0 mV := 120 mW := 240 mColor1 = ABS(INT( mDeltaSpectr + (360-mDeltaSpectr) * (mInf1 - mInfMin) / (mInfMax-mInfMin) )) // Сделать нормировку значений по цветам спектра: MAX=Красный, MIN-фиолетовый ############################## R := INT( ma * (1 + COS( ( mColor1 + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( mColor1 + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( mColor1 + mW ) * GradRad ) ) ) fColor1 := GraMakeRGBColor({ R, G, B }) mColor2 = ABS(INT( mDeltaSpectr + (360-mDeltaSpectr) * (mInf2 - mInfMin) / (mInfMax-mInfMin) )) // Сделать нормировку значений по цветам спектра: MAX=Красный, MIN-фиолетовый ############################## R := INT( ma * (1 + COS( ( mColor2 + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( mColor2 + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( mColor2 + mW ) * GradRad ) ) ) fColor2 := GraMakeRGBColor({ R, G, B }) GraSetColor( oPS, fColor1, fColor1 ) X1 := X0 + Ax * mMinGrInt1 * COS( aOpSc[mNOpSc,2] * GradRad ) Y1 := Y0 - Ay * mMinGrInt1 * SIN( aOpSc[mNOpSc,2] * GradRad ) GraArc( oPS, { X1, Y1 }, RS, ,,, GRA_OUTLINEFILL ) // Нарисовать точку контура GraSetColor( oPS, fColor2, fColor2 ) X2 := X0 + Ax * mMaxGrInt1 * COS( aOpSc[mNOpSc,2] * GradRad ) Y2 := Y0 - Ay * mMaxGrInt1 * SIN( aOpSc[mNOpSc,2] * GradRad ) GraArc( oPS, { X2, Y2 }, RS, ,,, GRA_OUTLINEFILL ) // Нарисовать точку контура ENDIF NEXT NEXT ****** Визуализация когнитивной функции на информационном портрете в стиле: "Контур" ********************** SELECT Attributes FOR mNOpSc = 1 TO N_OpSc // Цикл по описательным шкалам *** Поиск наиболее информативной градации 1-й описательной шкалы mMaxInf1 = -9999999999 FOR mGrOpSc1 = aOpSc[mNOpSc,4] TO aOpSc[mNOpSc,5] // Цикл по градациям описательных шкал SELECT(M_Inf) DBGOTO(mGrOpSc1) mInf1 = FIELDGET(2+mSimbol) IF mMaxInf1 < mInf1 mMaxInf1 = mInf1 SELECT Attributes DBGOTO(mGrOpSc1) mMinGrInt1 = MIN_GRINT mMaxGrInt1 = MAX_GRINT ENDIF NEXT *** Поиск наиболее информативной градации 2-й описательной шкалы IF mNOpSc+1 <= N_OpSc mNOpSc2 = mNOpSc+1 ELSE mNOpSc2 = 1 ENDIF mMaxInf2 = -9999999999 FOR mGrOpSc2 = aOpSc[mNOpSc2,4] TO aOpSc[mNOpSc2,5] // Цикл по градациям описательных шкал SELECT(M_Inf) DBGOTO(mGrOpSc2) mInf2 = FIELDGET(2+mSimbol) IF mMaxInf2 < mInf2 mMaxInf2 = mInf2 SELECT Attributes DBGOTO(mGrOpSc2) mMinGrInt2 = MIN_GRINT mMaxGrInt2 = MAX_GRINT ENDIF NEXT ***** Нарисовать четырехугольник *************** X1 := X0 + Ax * mMinGrInt1 * COS( aOpSc[mNOpSc,2] * GradRad ) Y1 := Y0 - Ay * mMinGrInt1 * SIN( aOpSc[mNOpSc,2] * GradRad ) X2 := X0 + Ax * mMaxGrInt1 * COS( aOpSc[mNOpSc,2] * GradRad ) Y2 := Y0 - Ay * mMaxGrInt1 * SIN( aOpSc[mNOpSc,2] * GradRad ) X3 := X0 + Ax * mMinGrInt2 * COS( aOpSc[mNOpSc2,2] * GradRad ) Y3 := Y0 - Ay * mMinGrInt2 * SIN( aOpSc[mNOpSc2,2] * GradRad ) X4 := X0 + Ax * mMaxGrInt2 * COS( aOpSc[mNOpSc2,2] * GradRad ) Y4 := Y0 - Ay * mMaxGrInt2 * SIN( aOpSc[mNOpSc2,2] * GradRad ) * fColor1 = GRA_CLR_RED * fColor2 = GRA_CLR_RED * fColor3 = GRA_CLR_RED ********* Заграска четырехугольника градацией цвета **************************** ma := 127.5 mb := 127.5 mc := 127.5 mU := 0 mV := 120 mW := 240 mColor1 = ABS(INT( mDeltaSpectr + (360-mDeltaSpectr) * (mMaxInf1 - mInfMin) / (mInfMax-mInfMin) )) // Сделать нормировку значений по цветам спектра: MAX=Красный, MIN-фиолетовый ############################## R := INT( ma * (1 + COS( ( mColor1 + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( mColor1 + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( mColor1 + mW ) * GradRad ) ) ) fColor1 := GraMakeRGBColor({ R, G, B }) mColor2 = ABS(INT( mDeltaSpectr + (360-mDeltaSpectr) * (mMaxInf2 - mInfMin) / (mInfMax-mInfMin) )) // Сделать нормировку значений по цветам спектра: MAX=Красный, MIN-фиолетовый ############################## R := INT( ma * (1 + COS( ( mColor2 + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( mColor2 + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( mColor2 + mW ) * GradRad ) ) ) fColor2 := GraMakeRGBColor({ R, G, B }) aClrs := {} AADD(aClrs, fColor1);AADD(aClrs, fColor1);AADD(aClrs, fColor2) GraGradient(oPS, {X1,Y1}, {{X2,Y2}, {X3,Y3}}, aClrs, GRA_GRADIENT_TRIANGLE) aClrs := {} AADD(aClrs, fColor1);AADD(aClrs, fColor2);AADD(aClrs, fColor2) GraGradient(oPS, {X2,Y2}, {{X3,Y3}, {X4,Y4}}, aClrs, GRA_GRADIENT_TRIANGLE) aClrs := {} AADD(aClrs, fColor1);AADD(aClrs, fColor1);AADD(aClrs, fColor2) GraGradient(oPS, {X1,Y1}, {{X2,Y2}, {X4,Y4}}, aClrs, GRA_GRADIENT_TRIANGLE) aClrs := {} AADD(aClrs, fColor1);AADD(aClrs, fColor2);AADD(aClrs, fColor2) GraGradient(oPS, {X1,Y1}, {{X3,Y3}, {X4,Y4}}, aClrs, GRA_GRADIENT_TRIANGLE) * GraSetColor( oPS, aColor[222], aColor[222] ) GraSetColor( oPS, GRA_CLR_RED, GRA_CLR_RED ) GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии GraLine( oPS, { X1, Y1 }, { X3, Y3 } ) // Нарисовать отрезок прямой линии GraLine( oPS, { X3, Y3 }, { X4, Y4 } ) // Нарисовать отрезок прямой линии GraLine( oPS, { X2, Y2 }, { X4, Y4 } ) // Нарисовать отрезок прямой линии NEXT ****** Визуализация описательных шкал и градаций в стиле: "Витраж" ******************************************** X0kont = X_MaxW/4 X0vitr = 3*X_MaxW/4 X0 = X0vitr FOR mNOpSc = 1 TO N_OpSc // Цикл по описательным шкалам FOR mGrOpSc = aOpSc[mNOpSc,4] TO aOpSc[mNOpSc,5] // Цикл по градациям описательных шкал SELECT Attributes DBGOTO(mGrOpSc) mMinGrInt1 = MIN_GRINT mMaxGrInt1 = MAX_GRINT SELECT(M_Inf) DBGOTO(mGrOpSc) mInf1 = FIELDGET(2+mSimbol) SELECT Attributes IF mNOpSc < N_OpSc DBGOTO(mGrOpSc+aOpSc[mNOpSc,3]) ELSE DBGOTO(mGrOpSc-aOpSc[mNOpSc,4]+1) ENDIF mRecno = RECNO() mMinGrInt2 = MIN_GRINT mMaxGrInt2 = MAX_GRINT SELECT(M_Inf) DBGOTO(mRecno) mInf2 = FIELDGET(2+mSimbol) ********* Фильтр ******* mFlagView = .T. IF aWorkInf[11] > 0 mFlagView = .F. IF mInf1 >= mInfMax * aWorkInf[11] / 100 .AND.; mInf2 >= mInfMax * aWorkInf[11] / 100 mFlagView = .T. ENDIF ENDIF ***** Нарисовать прямоугольник *************** X1 := X0 + Ax * mMinGrInt1 * COS( aOpSc[mNOpSc,2] * GradRad ) Y1 := Y0 - Ay * mMinGrInt1 * SIN( aOpSc[mNOpSc,2] * GradRad ) X2 := X0 + Ax * mMaxGrInt1 * COS( aOpSc[mNOpSc,2] * GradRad ) Y2 := Y0 - Ay * mMaxGrInt1 * SIN( aOpSc[mNOpSc,2] * GradRad ) X3 := X0 + Ax * mMinGrInt2 * COS( aOpSc[mNOpSc+1,2] * GradRad ) Y3 := Y0 - Ay * mMinGrInt2 * SIN( aOpSc[mNOpSc+1,2] * GradRad ) X4 := X0 + Ax * mMaxGrInt2 * COS( aOpSc[mNOpSc+1,2] * GradRad ) Y4 := Y0 - Ay * mMaxGrInt2 * SIN( aOpSc[mNOpSc+1,2] * GradRad ) * GraArc( oPS, { X2, Y2 }, RS, ,,, GRA_OUTLINEFILL ) // Нарисовать точку контура IF mFlagView ********* Заграска четырехугольника градацией цвета **************************** ma := 127.5 mb := 127.5 mc := 127.5 mU := 0 mV := 120 mW := 240 mColor1 = ABS(INT( mDeltaSpectr + (360-mDeltaSpectr) * (mInf1 - mInfMin) / (mInfMax-mInfMin) )) // Сделать нормировку значений по цветам спектра: MAX=Красный, MIN-фиолетовый ############################## R := INT( ma * (1 + COS( ( mColor1 + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( mColor1 + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( mColor1 + mW ) * GradRad ) ) ) fColor1 := GraMakeRGBColor({ R, G, B }) mColor2 = ABS(INT( mDeltaSpectr + (360-mDeltaSpectr) * (mInf2 - mInfMin) / (mInfMax-mInfMin) )) // Сделать нормировку значений по цветам спектра: MAX=Красный, MIN-фиолетовый ############################## R := INT( ma * (1 + COS( ( mColor2 + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( mColor2 + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( mColor2 + mW ) * GradRad ) ) ) fColor2 := GraMakeRGBColor({ R, G, B }) ***** Закрасить фон четырехугольника градиентным цветом *************** * GraSetColor( oPS, fColor, fColor ) aClrs := {} AADD(aClrs, fColor1);AADD(aClrs, fColor1);AADD(aClrs, fColor2) GraGradient(oPS, {X1,Y1}, {{X2,Y2}, {X3,Y3}}, aClrs, GRA_GRADIENT_TRIANGLE) aClrs := {} AADD(aClrs, fColor1);AADD(aClrs, fColor2);AADD(aClrs, fColor2) GraGradient(oPS, {X2,Y2}, {{X3,Y3}, {X4,Y4}}, aClrs, GRA_GRADIENT_TRIANGLE) aClrs := {} AADD(aClrs, fColor1);AADD(aClrs, fColor1);AADD(aClrs, fColor2) GraGradient(oPS, {X1,Y1}, {{X2,Y2}, {X4,Y4}}, aClrs, GRA_GRADIENT_TRIANGLE) aClrs := {} AADD(aClrs, fColor1);AADD(aClrs, fColor2);AADD(aClrs, fColor2) GraGradient(oPS, {X1,Y1}, {{X3,Y3}, {X4,Y4}}, aClrs, GRA_GRADIENT_TRIANGLE) ENDIF ******* Отобразить сетку (или может не нужно?) GraSetColor( oPS, aColor[222], aColor[222] ) GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии GraLine( oPS, { X1, Y1 }, { X3, Y3 } ) // Нарисовать отрезок прямой линии GraLine( oPS, { X3, Y3 }, { X4, Y4 } ) // Нарисовать отрезок прямой линии GraLine( oPS, { X2, Y2 }, { X4, Y4 } ) // Нарисовать отрезок прямой линии NEXT NEXT ****** Визуализация спектра - легенды ************************ N_Line = 360 // Число линий в спектре D = 100 Delta = INT(360/ N_Line ) Kx = (X_MaxW-2*D) / N_Line * (1 + mDeltaSpectr/360) // Коэффициент масштабирования по оси X: преобразует аргумент функции в номер пикселя по оси X mColorZer = ABS(INT( mDeltaSpectr + (360-mDeltaSpectr) * (0 - mInfMin) / (mInfMax-mInfMin) )) // Сделать нормировку значений по цветам спектра: MAX=Красный, MIN-фиолетовый ############################## ma := 255/2 mb := 255/2 mc := 255/2 mU := 0 mV := 120 mW := 240 R := INT( ma * (1 + COS( ( mColorZer + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( mColorZer + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( mColorZer + mW ) * GradRad ) ) ) fColorZer := GraMakeRGBColor({ R, G, B }) Column = 0 mMinZer = +99999999 X1zer = 0 X2zer = 0 FOR n = 359 TO mDeltaSpectr STEP -Delta ma := 255/2 mb := 255/2 mc := 255/2 mU := 0 mV := 120 mW := 240 R := INT( ma * (1 + COS( ( n + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( n + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( n + mW ) * GradRad ) ) ) fColor := GraMakeRGBColor({ R, G, B }) ***** Закрасить фон прямоугольника *************** GraSetColor( oPS, fColor, fColor ) ++Column X1 := D + (Column-1) * Kx + mDeltaSpectr / 2 X2 := D + Column * Kx + mDeltaSpectr / 2 Y1 := 0 Y2 := 0 + 30 GraBox( oPS, { X1, Y1 }, { X2, Y2 }, GRA_FILL) mZer = ABS( fColor - fColorZer ) IF mZer < mMinZer mMinZer = mZer X1zer = X1 X2zer = X2 ENDIF NEXT ** Еще сделать надпись нуля, если он не совпадает с минимумом ################ IF mMinZer <> +99999999 GraSetColor( oPS, aColor[222], aColor[222] ) GraStringAt( oPS, { X1zer, Y2+10 }, ALLTRIM(STR(0,15,3))) GraBox( oPS, { X1zer, Y1 }, { X2zer, Y2 }, GRA_OUTLINE ) ENDIF ****** Надписи на легенде oFont := XbpFont():new():create('10.Arial') aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю относительно точки начала вывода aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты Column = 0 FOR n = 360 TO mDeltaSpectr STEP -Delta ++Column NEXT X1 := D + mDeltaSpectr / 2 X2 := D + mDeltaSpectr / 2 + Column * Kx - 10 GraStringAt( oPS, { X1, Y2+10 }, ALLTRIM(STR(mInfMax,15,3))) aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_RIGHT // Выравнивание символов по горизонтали по правому краю относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraStringAt( oPS, { X2, Y2+10 }, ALLTRIM(STR(mInfMin,15,3))) ******** Запись изображения символа в папку с именем: "InpPortCHR" в виде файла с имененем: "Код и наименование класса" IF FILEDATE("InpPortCHR",16) = CTOD("//") DIRMAKE("InpPortCHR") Mess = L('В папке текущего приложения: "#" не было директории "InpPortCHR" для графических диаграмм нейронов и она была создана!') Mess = STRTRAN(Mess, "#", UPPER(ALLTRIM(M_PathAppl))) LB_Warning(Mess, L('АСК-анализ изображений в системе "ЭЙДОС-X++"' )) ENDIF cFileName = M_PathAppl+"\InpPortCHR\"+ConvToAnsiCP(aNameCls[mSimbol]+'-витраж-')+Ar_Model[mNumMod]+".bmp" // Чтобы в именах файлов можно было использовать русские символы ERASE(cFileName) DC_Scrn2ImageFile( oStatic, cFileName ) ENDIF * ################################################################################################################## * mRegim = 'Прозрачная сетка' - Сетка (входит и во 2-й, и в 3-й) * mRegim = 'Градиентная заливка' - Витраж * mRegim = 'Триангуляция Делоне' - Трианг // В разработке IF mRegim = 'Трианг' // В разработке X0kont = X_MaxW/4 X0vitr = 3*X_MaxW/4 X0 = X0kont ****** Визуализация информационного портрета в стиле: "Контур" ******************************************** SELECT Attributes FOR mNOpSc = 1 TO N_OpSc // Цикл по описательным шкалам FOR mGrOpSc = aOpSc[mNOpSc,4] TO aOpSc[mNOpSc,5] // Цикл по градациям описательных шкал SELECT Attributes DBGOTO(mGrOpSc) mMinGrInt1 = MIN_GRINT mMaxGrInt1 = MAX_GRINT SELECT(M_Inf) DBGOTO(mGrOpSc) mInf1 = FIELDGET(2+mSimbol) SELECT Attributes * aOpSc[mNum, 3] = N_GROPSC * aOpSc[mNum, 4] = KODGR_MIN * aOpSc[mNum, 5] = KODGR_MAX DBGOTO(mGrOpSc) IF mNOpSc < N_OpSc DBGOTO(mGrOpSc+aOpSc[mNOpSc,3]) ELSE DBGOTO(mGrOpSc-aOpSc[mNOpSc,4]+1) ENDIF mRecno = RECNO() mMinGrInt2 = MIN_GRINT mMaxGrInt2 = MAX_GRINT SELECT(M_Inf) DBGOTO(mRecno) mInf2 = FIELDGET(2+mSimbol) ********* Фильтр ******* mFlagView = .T. IF aWorkInf[11] > 0 mFlagView = .F. IF mInf1 >= mInfMax * aWorkInf[11] / 100 .AND.; mInf2 >= mInfMax * aWorkInf[11] / 100 mFlagView = .T. ENDIF ENDIF ***** Нарисовать четырехугольник *************** X1 := X0 + Ax * mMinGrInt1 * COS( aOpSc[mNOpSc,2] * GradRad ) Y1 := Y0 - Ay * mMinGrInt1 * SIN( aOpSc[mNOpSc,2] * GradRad ) X2 := X0 + Ax * mMaxGrInt1 * COS( aOpSc[mNOpSc,2] * GradRad ) Y2 := Y0 - Ay * mMaxGrInt1 * SIN( aOpSc[mNOpSc,2] * GradRad ) X3 := X0 + Ax * mMinGrInt2 * COS( aOpSc[mNOpSc+1,2] * GradRad ) Y3 := Y0 - Ay * mMinGrInt2 * SIN( aOpSc[mNOpSc+1,2] * GradRad ) X4 := X0 + Ax * mMaxGrInt2 * COS( aOpSc[mNOpSc+1,2] * GradRad ) Y4 := Y0 - Ay * mMaxGrInt2 * SIN( aOpSc[mNOpSc+1,2] * GradRad ) ******* Отобразить сетку (или может не нужно?) GraSetColor( oPS, aColor[222], aColor[222] ) GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии GraLine( oPS, { X1, Y1 }, { X3, Y3 } ) // Нарисовать отрезок прямой линии GraLine( oPS, { X3, Y3 }, { X4, Y4 } ) // Нарисовать отрезок прямой линии GraLine( oPS, { X2, Y2 }, { X4, Y4 } ) // Нарисовать отрезок прямой линии IF mFlagView ********* Нарисовать точки контура ma := 127.5 mb := 127.5 mc := 127.5 mU := 0 mV := 120 mW := 240 mColor1 = ABS(INT( mDeltaSpectr + (360-mDeltaSpectr) * (mInf1 - mInfMin) / (mInfMax-mInfMin) )) // Сделать нормировку значений по цветам спектра: MAX=Красный, MIN-фиолетовый ############################## R := INT( ma * (1 + COS( ( mColor1 + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( mColor1 + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( mColor1 + mW ) * GradRad ) ) ) fColor1 := GraMakeRGBColor({ R, G, B }) mColor2 = ABS(INT( mDeltaSpectr + (360-mDeltaSpectr) * (mInf2 - mInfMin) / (mInfMax-mInfMin) )) // Сделать нормировку значений по цветам спектра: MAX=Красный, MIN-фиолетовый ############################## R := INT( ma * (1 + COS( ( mColor2 + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( mColor2 + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( mColor2 + mW ) * GradRad ) ) ) fColor2 := GraMakeRGBColor({ R, G, B }) GraSetColor( oPS, fColor1, fColor1 ) X1 := X0 + Ax * mMinGrInt1 * COS( aOpSc[mNOpSc,2] * GradRad ) Y1 := Y0 - Ay * mMinGrInt1 * SIN( aOpSc[mNOpSc,2] * GradRad ) GraArc( oPS, { X1, Y1 }, RS, ,,, GRA_OUTLINEFILL ) // Нарисовать точку контура GraSetColor( oPS, fColor2, fColor2 ) X2 := X0 + Ax * mMaxGrInt1 * COS( aOpSc[mNOpSc,2] * GradRad ) Y2 := Y0 - Ay * mMaxGrInt1 * SIN( aOpSc[mNOpSc,2] * GradRad ) GraArc( oPS, { X2, Y2 }, RS, ,,, GRA_OUTLINEFILL ) // Нарисовать точку контура ENDIF NEXT NEXT ****** #################################################################################################### ****** Визуализация когнитивной функции на информационном портрете в стиле: "Витраж" ********************** ****** Переделать в стиле "Триангуляция" ################################################################## ****** #################################################################################################### SELECT Attributes FOR mNOpSc = 1 TO N_OpSc // Цикл по описательным шкалам *** Поиск наиболее информативной градации 1-й описательной шкалы mMaxInf1 = -9999999999 FOR mGrOpSc1 = aOpSc[mNOpSc,4] TO aOpSc[mNOpSc,5] // Цикл по градациям описательных шкал SELECT(M_Inf) DBGOTO(mGrOpSc1) mInf1 = FIELDGET(2+mSimbol) IF mMaxInf1 < mInf1 mMaxInf1 = mInf1 SELECT Attributes DBGOTO(mGrOpSc1) mMinGrInt1 = MIN_GRINT mAvrGrInt1 = AVR_GRINT mMaxGrInt1 = MAX_GRINT ENDIF NEXT *** Поиск наиболее информативной градации 2-й описательной шкалы IF mNOpSc+1 <= N_OpSc mNOpSc2 = mNOpSc+1 ELSE mNOpSc2 = 1 ENDIF mMaxInf2 = -9999999999 FOR mGrOpSc2 = aOpSc[mNOpSc2,4] TO aOpSc[mNOpSc2,5] // Цикл по градациям описательных шкал SELECT(M_Inf) DBGOTO(mGrOpSc2) mInf2 = FIELDGET(2+mSimbol) IF mMaxInf2 < mInf2 mMaxInf2 = mInf2 SELECT Attributes DBGOTO(mGrOpSc2) mMinGrInt2 = MIN_GRINT mAvrGrInt2 = AVR_GRINT mMaxGrInt2 = MAX_GRINT ENDIF NEXT ***** Нарисовать четырехугольник *************** X1 := X0 + Ax * mMinGrInt1 * COS( aOpSc[mNOpSc,2] * GradRad ) Y1 := Y0 - Ay * mMinGrInt1 * SIN( aOpSc[mNOpSc,2] * GradRad ) X2 := X0 + Ax * mMaxGrInt1 * COS( aOpSc[mNOpSc,2] * GradRad ) Y2 := Y0 - Ay * mMaxGrInt1 * SIN( aOpSc[mNOpSc,2] * GradRad ) X3 := X0 + Ax * mMinGrInt2 * COS( aOpSc[mNOpSc2,2] * GradRad ) Y3 := Y0 - Ay * mMinGrInt2 * SIN( aOpSc[mNOpSc2,2] * GradRad ) X4 := X0 + Ax * mMaxGrInt2 * COS( aOpSc[mNOpSc2,2] * GradRad ) Y4 := Y0 - Ay * mMaxGrInt2 * SIN( aOpSc[mNOpSc2,2] * GradRad ) ********* Заграска четырехугольника градацией цвета **************************** ma := 127.5 mb := 127.5 mc := 127.5 mU := 0 mV := 120 mW := 240 mColor1 = ABS(INT( mDeltaSpectr + (360-mDeltaSpectr) * (mMaxInf1 - mInfMin) / (mInfMax-mInfMin) )) // Сделать нормировку значений по цветам спектра: MAX=Красный, MIN-фиолетовый ############################## R := INT( ma * (1 + COS( ( mColor1 + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( mColor1 + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( mColor1 + mW ) * GradRad ) ) ) fColor1 := GraMakeRGBColor({ R, G, B }) mColor2 = ABS(INT( mDeltaSpectr + (360-mDeltaSpectr) * (mMaxInf2 - mInfMin) / (mInfMax-mInfMin) )) // Сделать нормировку значений по цветам спектра: MAX=Красный, MIN-фиолетовый ############################## R := INT( ma * (1 + COS( ( mColor2 + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( mColor2 + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( mColor2 + mW ) * GradRad ) ) ) fColor2 := GraMakeRGBColor({ R, G, B }) aClrs := {} AADD(aClrs, fColor1);AADD(aClrs, fColor1);AADD(aClrs, fColor2) GraGradient(oPS, {X1,Y1}, {{X2,Y2}, {X3,Y3}}, aClrs, GRA_GRADIENT_TRIANGLE) aClrs := {} AADD(aClrs, fColor1);AADD(aClrs, fColor2);AADD(aClrs, fColor2) GraGradient(oPS, {X2,Y2}, {{X3,Y3}, {X4,Y4}}, aClrs, GRA_GRADIENT_TRIANGLE) aClrs := {} AADD(aClrs, fColor1);AADD(aClrs, fColor1);AADD(aClrs, fColor2) GraGradient(oPS, {X1,Y1}, {{X2,Y2}, {X4,Y4}}, aClrs, GRA_GRADIENT_TRIANGLE) aClrs := {} AADD(aClrs, fColor1);AADD(aClrs, fColor2);AADD(aClrs, fColor2) GraGradient(oPS, {X1,Y1}, {{X3,Y3}, {X4,Y4}}, aClrs, GRA_GRADIENT_TRIANGLE) ******* Отобразить сетку (или может не нужно?) GraSetColor( oPS, aColor[222], aColor[222] ) GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии GraLine( oPS, { X1, Y1 }, { X3, Y3 } ) // Нарисовать отрезок прямой линии GraLine( oPS, { X3, Y3 }, { X4, Y4 } ) // Нарисовать отрезок прямой линии GraLine( oPS, { X2, Y2 }, { X4, Y4 } ) // Нарисовать отрезок прямой линии NEXT ********************* **** Д Е Л О Н Е **** ********************* *************************************************************************************************************** ****** Визуализация описательных шкал и градаций в стиле: "Тиангуляция" *************************************** ****** Отображать просто сетку и с цветовым кодированием инт.инфорамативности просто по сетке и с триангуляцией ****** Отобразить треугольники с переливом цвета между вершинами *************************************************************************************************************** ****** ######################################################################################################## X0kont = X_MaxW/4 X0vitr = 3*X_MaxW/4 X0 = X0vitr ****** 1. Создать БД четырехугольников и треугольников: 2 смежные шкалы, 2 смежные градации FOR mNOpSc = 1 TO N_OpSc // Цикл по описательным шкалам FOR mGrOpSc = aOpSc[mNOpSc,4] TO aOpSc[mNOpSc,5] // Цикл по градациям описательных шкал ****** Выборка данных для отображения ******** * aOpSc[mNum, 3] = N_GROPSC * aOpSc[mNum, 4] = KODGR_MIN * aOpSc[mNum, 5] = KODGR_MAX ****** Начальная шкала, начальная градация SELECT Attributes DBGOTO(mGrOpSc) mMinGrInt1 = MIN_GRINT mMaxGrInt1 = MAX_GRINT SELECT(M_Inf) DBGOTO(mGrOpSc) mInf1 = FIELDGET(2+mSimbol) ****** Начальная шкала, следующая градация SELECT Attributes DBGOTO(mGrOpSc+1) mMinGrInt2 = MIN_GRINT mMaxGrInt2 = MAX_GRINT SELECT(M_Inf) DBGOTO(mGrOpSc+1) mInf2 = FIELDGET(2+mSimbol) ****** Следующая шкала, начальная градация SELECT Attributes IF mNOpSc < N_OpSc DBGOTO(mGrOpSc+aOpSc[mNOpSc,3]) ELSE DBGOTOP() ENDIF mRecno = RECNO() mKodOpSc2 = Kod_OpSc mMinGrInt3 = MIN_GRINT mMaxGrInt3 = MAX_GRINT SELECT(M_Inf) DBGOTO(mRecno) mInf3 = FIELDGET(2+mSimbol) ****** Следующая шкала, следующая градация SELECT Attributes DBGOTO(mRecno) mMinGrInt4 = MIN_GRINT mMaxGrInt4 = MAX_GRINT SELECT(M_Inf) DBGOTO(mRecno) mInf4 = FIELDGET(2+mSimbol) ********* Фильтр ******* mFlagView = .T. IF aWorkInf[11] > 0 mFlagView = .F. IF mInf1 >= mInfMax * aWorkInf[11] / 100 .AND.; mInf2 >= mInfMax * aWorkInf[11] / 100 .AND.; mInf3 >= mInfMax * aWorkInf[11] / 100 .AND.; mInf4 >= mInfMax * aWorkInf[11] / 100 mFlagView = .T. ENDIF ENDIF ***** Расчет координат вершин четырехгольника *************** X1 := X0 + Ax * mMaxGrInt1 * COS( aOpSc[mNOpSc,2] * GradRad ) Y1 := Y0 - Ay * mMaxGrInt1 * SIN( aOpSc[mNOpSc,2] * GradRad ) Z1 := mInf1 X2 := X0 + Ax * mMaxGrInt2 * COS( aOpSc[mNOpSc,2] * GradRad ) Y2 := Y0 - Ay * mMaxGrInt2 * SIN( aOpSc[mNOpSc,2] * GradRad ) Z2 := mInf2 X3 := X0 + Ax * mMaxGrInt3 * COS( aOpSc[mKodOpSc2,2] * GradRad ) Y3 := Y0 - Ay * mMaxGrInt3 * SIN( aOpSc[mKodOpSc2,2] * GradRad ) Z3 := mInf3 X4 := X0 + Ax * mMaxGrInt4 * COS( aOpSc[mKodOpSc2,2] * GradRad ) Y4 := Y0 - Ay * mMaxGrInt4 * SIN( aOpSc[mKodOpSc2,2] * GradRad ) Z4 := mInf4 IF mFlagView ********* Расчет параметров заливки градиентным цветом для всех треугольников ***************** ma := 127.5 mb := 127.5 mc := 127.5 mU := 0 mV := 120 mW := 240 mColor1 = ABS(INT( mDeltaSpectr + (360-mDeltaSpectr) * (mInf1 - mInfMin) / (mInfMax-mInfMin) )) R := INT( ma * (1 + COS( ( mColor1 + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( mColor1 + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( mColor1 + mW ) * GradRad ) ) ) fColor1 := GraMakeRGBColor({ R, G, B }) mColor2 = ABS(INT( mDeltaSpectr + (360-mDeltaSpectr) * (mInf2 - mInfMin) / (mInfMax-mInfMin) )) R := INT( ma * (1 + COS( ( mColor2 + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( mColor2 + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( mColor2 + mW ) * GradRad ) ) ) fColor2 := GraMakeRGBColor({ R, G, B }) mColor3 = ABS(INT( mDeltaSpectr + (360-mDeltaSpectr) * (mInf3 - mInfMin) / (mInfMax-mInfMin) )) R := INT( ma * (1 + COS( ( mColor3 + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( mColor3 + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( mColor3 + mW ) * GradRad ) ) ) fColor3 := GraMakeRGBColor({ R, G, B }) mColor4 = ABS(INT( mDeltaSpectr + (360-mDeltaSpectr) * (mInf4 - mInfMin) / (mInfMax-mInfMin) )) R := INT( ma * (1 + COS( ( mColor2 + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( mColor2 + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( mColor2 + mW ) * GradRad ) ) ) fColor4 := GraMakeRGBColor({ R, G, B }) ***** Градиентная заливка треугольников *********************************** aClrs := {} AADD(aClrs, fColor1);AADD(aClrs, fColor2);AADD(aClrs, fColor3) GraGradient(oPS, {X1,Y1}, {{X2,Y2}, {X3,Y3}}, aClrs, GRA_GRADIENT_TRIANGLE) aClrs := {} AADD(aClrs, fColor2);AADD(aClrs, fColor3);AADD(aClrs, fColor4) GraGradient(oPS, {X2,Y2}, {{X3,Y3}, {X4,Y4}}, aClrs, GRA_GRADIENT_TRIANGLE) * aClrs := {} * AADD(aClrs, fColor1);AADD(aClrs, fColor2);AADD(aClrs, fColor4) * GraGradient(oPS, {X1,Y1}, {{X2,Y2}, {X4,Y4}}, aClrs, GRA_GRADIENT_TRIANGLE) * aClrs := {} * AADD(aClrs, fColor1);AADD(aClrs, fColor3);AADD(aClrs, fColor4) * GraGradient(oPS, {X1,Y1}, {{X3,Y3}, {X4,Y4}}, aClrs, GRA_GRADIENT_TRIANGLE) ENDIF ******* Отобразить сетку (или может не нужно?) * GraSetColor( oPS, aColor[222], aColor[222] ) * GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии * GraLine( oPS, { X1, Y1 }, { X3, Y3 } ) // Нарисовать отрезок прямой линии * GraLine( oPS, { X3, Y3 }, { X4, Y4 } ) // Нарисовать отрезок прямой линии * GraLine( oPS, { X2, Y2 }, { X4, Y4 } ) // Нарисовать отрезок прямой линии NEXT NEXT ****** Визуализация спектра - легенды ************************ N_Line = 360 // Число линий в спектре D = 100 Delta = INT(360/ N_Line ) Kx = (X_MaxW-2*D) / N_Line * (1 + mDeltaSpectr/360) // Коэффициент масштабирования по оси X: преобразует аргумент функции в номер пикселя по оси X mColorZer = ABS(INT( mDeltaSpectr + (360-mDeltaSpectr) * (0 - mInfMin) / (mInfMax-mInfMin) )) // Сделать нормировку значений по цветам спектра: MAX=Красный, MIN-фиолетовый ############################## ma := 255/2 mb := 255/2 mc := 255/2 mU := 0 mV := 120 mW := 240 R := INT( ma * (1 + COS( ( mColorZer + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( mColorZer + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( mColorZer + mW ) * GradRad ) ) ) fColorZer := GraMakeRGBColor({ R, G, B }) Column = 0 mMinZer = +99999999 X1zer = 0 X2zer = 0 FOR n = 359 TO mDeltaSpectr STEP -Delta ma := 255/2 mb := 255/2 mc := 255/2 mU := 0 mV := 120 mW := 240 R := INT( ma * (1 + COS( ( n + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( n + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( n + mW ) * GradRad ) ) ) fColor := GraMakeRGBColor({ R, G, B }) ***** Закрасить фон прямоугольника *************** GraSetColor( oPS, fColor, fColor ) ++Column X1 := D + (Column-1) * Kx + mDeltaSpectr / 2 X2 := D + Column * Kx + mDeltaSpectr / 2 Y1 := 0 Y2 := 0 + 30 GraBox( oPS, { X1, Y1 }, { X2, Y2 }, GRA_FILL) mZer = ABS( fColor - fColorZer ) IF mZer < mMinZer mMinZer = mZer X1zer = X1 X2zer = X2 ENDIF NEXT ** Еще сделать надпись нуля, если он не совпадает с минимумом ################ IF mMinZer <> +99999999 GraSetColor( oPS, aColor[222], aColor[222] ) GraStringAt( oPS, { X1zer, Y2+10 }, ALLTRIM(STR(0,15,3))) GraBox( oPS, { X1zer, Y1 }, { X2zer, Y2 }, GRA_OUTLINE ) ENDIF ****** Надписи на легенде oFont := XbpFont():new():create('10.Arial') aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю относительно точки начала вывода aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты Column = 0 FOR n = 360 TO mDeltaSpectr STEP -Delta ++Column NEXT X1 := D + mDeltaSpectr / 2 X2 := D + mDeltaSpectr / 2 + Column * Kx - 10 GraStringAt( oPS, { X1, Y2+10 }, ALLTRIM(STR(mInfMax,15,3))) aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_RIGHT // Выравнивание символов по горизонтали по правому краю относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraStringAt( oPS, { X2, Y2+10 }, ALLTRIM(STR(mInfMin,15,3))) ******** Запись изображения символа в папку с именем: "InpPortCHR" в виде файла с имененем: "Код и наименование класса" IF FILEDATE("InpPortCHR",16) = CTOD("//") DIRMAKE("InpPortCHR") Mess = L('В папке текущего приложения: "#" не было директории "InpPortCHR" для графических диаграмм нейронов и она была создана!') Mess = STRTRAN(Mess, "#", UPPER(ALLTRIM(M_PathAppl))) LB_Warning(Mess, L('АСК-анализ изображений в системе "ЭЙДОС-X++"' )) ENDIF cFileName = M_PathAppl+"\InpPortCHR\"+ConvToAnsiCP(aNameCls[mSimbol]+' триангуляция-')+Ar_Model[mNumMod]+".bmp" // Чтобы в именах файлов можно было использовать русские символы ERASE(cFileName) DC_Scrn2ImageFile( oStatic, cFileName ) ENDIF ***** Джимми ************ * LOCAL oBitmap // В начале * oBitmap := GraSaveScreen( oPS, oStatic:CurrentPos() , oStatic:CurrentSize() ) * DIRCHANGE(mFontDir) // Перейти в папку mFontDir * cFileName = 'CHR'+STRTRAN(STR(mSimbol,3)," ","0")+".bmp" // Если цифры или латинские буквы - имя - прямо сам символ, а иначе код: CHR### * oBitmap:Savefile(cFileName) * DIRCHANGE("..") // Перейти в текущую папку RETURN NIL ***************************** ***************************** ***************************** ******************************************************************************** ****** Нарисовать систему описательных шкал и градаций в форме четырехугольников ******************************************************************************** FUNCTION DrawOpScGr() LOCAL GetList := {}, oStatic PRIVATE nEvent, mp1, mp2, oXbp // Переменные анализа событий PUBLIC X_MaxW := 1313, Y_MaxW := 640 // Размер графического окна для самого графика в пикселях @ 2,1 DCSTATIC TYPE XBPSTATIC_TYPE_RECESSEDBOX SIZE X_MaxW+11, Y_MaxW+20 PIXEL; // Размер окна в пикселях (от Тома) OBJECT oStatic; EVAL {|| _PresSpaceOpScGr( oStatic ) } DCREAD GUI ; TITLE L("Визуализация информационного портрета символа в системе ЭЙДОС-X++"); // Надпись на окне графика FIT ; BUTTONS DCGUI_BUTTON_EXIT RETURN NIL ************************************************* STATIC FUNCTION _PresSpaceOpScGr( oStatic ) LOCAL oPS, oDevice PUBLIC X_MaxW := 1313, Y_MaxW := 640 // Размер графического окна для самого графика в пикселях oPS := XbpPresSpace():new() // Create a PS oDevice := oStatic:winDevice() // Get the device context oPS:create( oDevice ) // Link device context to PS oPS:SetViewPort( { 0, 0, X_MaxW, Y_MaxW } ) oStatic:paint := {|mp1,mp2,obj| mp1 := LC_DrawOpScGr( oPS, oStatic ) } RETURN NIL ***************************************************** ****** Рисование системы описательных шкал и градаций ***************************************************** STATIC FUNCTION LC_DrawOpScGr( oPS, oStatic ) mSimbol = VAL(FileStr('_Simb.txt')) mNumMod = VAL(FileStr('_NumMod.txt')) mRegim = FileStr('_Regim.txt') * mRegim = 'Сетка' * mRegim = 'Витраж' * mRegim = 'Трианг' // В разработке PRIVATE X0 := 0 + X_MaxW/2 PRIVATE Y0 := 15 + Y_MaxW/2 // Начало координат по осям X и Y PRIVATE W_Wind := X_MaxW - X0 // Ширина окна для самого графика PRIVATE H_Wind := Y_MaxW - Y0 // Высота окна для самого графика ****** Массивы с информацией об описательных шкалах и градациях описательных шкал aAngle := {} // Массив углов, соответствующих описательным шкалам (точкам контура) SELECT Opis_Sc N_OpSc = RECCOUNT() IF N_OpSc = 1 RETURN NIL ENDIF ******** Фиктивная последняя шкала тождественная первой DBGOTOP() Ar := {} FOR j=1 TO FCOUNT() AADD(Ar, FIELDGET(j)) NEXT APPEND BLANK FOR j=1 TO LEN(Ar) FIELDPUT(j, Ar[j]) NEXT PUBLIC aOpSc[RECCOUNT(),5] mNum = 0 DBGOTOP() DO WHILE .NOT. EOF() mVal = VAL(SUBSTR(Name_OpSc,1,3)) AADD (aAngle, mval) ++mNum aOpSc[mNum, 1] = Kod_OpSc aOpSc[mNum, 2] = mVal aOpSc[mNum, 3] = N_GROPSC aOpSc[mNum, 4] = KODGR_MIN aOpSc[mNum, 5] = KODGR_MAX DBSKIP(1) ENDDO ******** Удалить фиктивную последняю шкалу, тождественную первой DBGOBOTTOM() DELETE PACK SELECT Attributes FOR z=1 TO aOpSc[1, 3] DBGOTO(z) Ar := {} FOR j=1 TO FCOUNT() AADD(Ar, FIELDGET(j)) NEXT APPEND BLANK FOR j=1 TO LEN(Ar) FIELDPUT(j, Ar[j]) NEXT NEXT PUBLIC aGrOpSc[RECCOUNT(),4] mNum = 0 DBGOTOP() DO WHILE .NOT. EOF() ++mNum aGrOpSc[mNum, 1] = Kod_OpSc aGrOpSc[mNum, 2] = Min_GrInt aGrOpSc[mNum, 3] = Max_GrInt SELECT(M_Inf) DBGOTO(mNum) aGrOpSc[mNum, 4] = Disp SELECT Attributes DBSKIP(1) ENDDO ****** Удалить из БД Attributes записи по фиктивной шкале и ее градациям N_Rec = RECCOUNT() FOR j=N_Rec TO N_Rec-aOpSc[1, 3]+1 STEP -1 DBGOTO(j) DELETE NEXT PACK ****** Найти максимальное значение радиус-вектора mRadiusMax = -9999 // Максимальное интервальное значение радиус-вектора на точки контура SELECT Attributes DBGOTOP() DO WHILE .NOT. EOF() mRadiusMax = MAX(mRadiusMax, Max_GrInt) DBSKIP(1) ENDDO ****** Минимальное и максимальное значение интегральной информативности в текущей модели mIntInfMax = -9999 // Максимальное значение интtгральной информативности mIntInfMin = +9999 // Минимальное значение интtгральной информативности SELECT(M_Inf) DBGOTOP() DO WHILE .NOT. EOF() mIntInfMax = MAX(mIntInfMax, Disp) mIntInfMin = MIN(mIntInfMin, Disp) DBSKIP(1) ENDDO mNGradII = mIntInfMax - mIntInfMin // Диапазон изменения цвета ######################### Диапазон цветов до фиолетового, а не до пурпурного *** Расчет позиций центров изображений в стилях "Контур", "Витраж" и "Триангуляция" Dx = 150 Dy = 45 Ax = ( X_MaxW - 2 * Dx ) / ( 2 * mRadiusMax ) Ay = ( Y_MaxW - 2 * Dy ) / ( 2 * mRadiusMax ) Dx = ( X_MaxW - 2 * mRadiusMax ) / 2 Dy = ( Y_MaxW - 2 * mRadiusMax ) / 2 X0 = Dx + mRadiusMax Y0 = Dy + mRadiusMax ****** Рисование координатной сетки oFont := XbpFont():new():create('8.Arial') GraSetFont(oPS , oFont) // Установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := aColor[146] aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_SOLID // Тип линии aAttr [ GRA_AL_COLOR ] := aColor[146] // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты X1 := X0 Y1 := Y0 FOR p=1 TO LEN(aAngle) X2 := X1 + Ax * mRadiusMax * COS( aAngle[p] * GradRad ) Y2 := Y1 - Ay * mRadiusMax * SIN( aAngle[p] * GradRad ) GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии X2 := X1 + Ax * (mRadiusMax+5) * COS( aAngle[p] * GradRad ) Y2 := Y1 - Ay * (mRadiusMax+5) * SIN( aAngle[p] * GradRad ) GraStringAt( oPS, { X2, Y2 }, ALLTRIM(STR(aAngle[p]))) NEXT aAttr := ARRAY( GRA_AM_COUNT ) // Массив для атрибутов маркеров aAttr[ GRA_AM_SYMBOL ] := GRA_MARKSYM_DOT aAttr[ GRA_AM_COLOR ] := aColor[12] // Задать цвет точки GraSetAttrMarker( oPS, aAttr ) FOR r=0 TO mRadiusMax STEP mRadiusMax/5 FOR p=1 TO 360 STEP 0.5 X2 := X1 + Ax * r * COS( p * GradRad ) Y2 := Y1 - Ay * r * SIN( p * GradRad ) GraMarker( oPS, { X2, Y2 } ) // Нарисовать точку координатной окружности NEXT GraStringAt( oPS, { X2, Y2 }, ALLTRIM(STR(r*100,3))) NEXT ****** Рисование изображений RS = 3 aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_SOLID // Тип линии aAttr [ GRA_AL_COLOR ] := aColor[222] // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты * ################################################################################################################## * mRegim = 'Сетка' * mRegim = 'Витраж' * mRegim = 'Трианг' // В разработке IF mRegim = 'Сетка' * aOpSc[mOpSc, 1] = Kod_OpSc * aOpSc[mOpSc, 2] = mVal * aOpSc[mOpSc, 3] = N_GROPSC * aOpSc[mOpSc, 4] = KODGR_MIN * aOpSc[mOpSc, 5] = KODGR_MAX * aGrOpSc[mGrOpSc, 1] = Kod_OpSc * aGrOpSc[mGrOpSc, 2] = Min_GrInt * aGrOpSc[mGrOpSc, 3] = Max_GrInt * aGrOpSc[mGrOpSc, 4] = Int_inf ****** Визуализация описательных шкал и градаций в стиле: "Контур" ******************************************** SELECT Attributes FOR mNOpSc = 1 TO N_OpSc // Цикл по описательным шкалам FOR mGrOpSc = aOpSc[mNOpSc,4] TO aOpSc[mNOpSc,5] // Цикл по градациям описательных шкал mMinGrInt1 = aGrOpSc[mGrOpSc, 2] mMaxGrInt1 = aGrOpSc[mGrOpSc, 3] mIntInf1 = aGrOpSc[mGrOpSc, 4] mMinGrInt2 = aGrOpSc[mGrOpSc+aOpSc[mNOpSc,3], 2] mMaxGrInt2 = aGrOpSc[mGrOpSc+aOpSc[mNOpSc,3], 3] mIntInf2 = aGrOpSc[mGrOpSc+aOpSc[mNOpSc,3], 4] ********* Фильтр ******* mFlagView = .T. IF aWorkInf[11] > 0 mFlagView = .F. IF mInf1 >= mInfMax * aWorkInf[11] / 100 .AND.; mInf2 >= mInfMax * aWorkInf[11] / 100 mFlagView = .T. ENDIF ENDIF * IF mFlagView * MsgBox(STR(aOpSc[mNOpSc ,2])+STR(mMinGrInt1)+STR(mMaxGrInt1)) * MsgBox(STR(aOpSc[mNOpSc+1,2])+STR(mMinGrInt2)+STR(mMaxGrInt2)) ***** Нарисовать четырехугольник *************** X1 := X0 + Ax * mMinGrInt1 * COS( aOpSc[mNOpSc ,2] * GradRad ) Y1 := Y0 - Ay * mMinGrInt1 * SIN( aOpSc[mNOpSc ,2] * GradRad ) X2 := X0 + Ax * mMaxGrInt1 * COS( aOpSc[mNOpSc ,2] * GradRad ) Y2 := Y0 - Ay * mMaxGrInt1 * SIN( aOpSc[mNOpSc ,2] * GradRad ) X3 := X0 + Ax * mMinGrInt2 * COS( aOpSc[mNOpSc+1,2] * GradRad ) Y3 := Y0 - Ay * mMinGrInt2 * SIN( aOpSc[mNOpSc+1,2] * GradRad ) X4 := X0 + Ax * mMaxGrInt2 * COS( aOpSc[mNOpSc+1,2] * GradRad ) Y4 := Y0 - Ay * mMaxGrInt2 * SIN( aOpSc[mNOpSc+1,2] * GradRad ) GraSetColor( oPS, aColor[222], aColor[222] ) GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии GraLine( oPS, { X1, Y1 }, { X3, Y3 } ) // Нарисовать отрезок прямой линии GraLine( oPS, { X3, Y3 }, { X4, Y4 } ) // Нарисовать отрезок прямой линии GraLine( oPS, { X2, Y2 }, { X4, Y4 } ) // Нарисовать отрезок прямой линии * GraArc( oPS, { X2, Y2 }, RS, ,,, GRA_OUTLINEFILL ) // Нарисовать точку контура * ENDIF NEXT NEXT ****** Визуализация наиболее значимых градаций описательных шкал в стиле: "Контур" ********************** * aOpSc[mOpSc, 1] = Kod_OpSc * aOpSc[mOpSc, 2] = mVal * aOpSc[mOpSc, 3] = N_GROPSC * aOpSc[mOpSc, 4] = KODGR_MIN * aOpSc[mOpSc, 5] = KODGR_MAX * aGrOpSc[mGrOpSc, 1] = Kod_OpSc * aGrOpSc[mGrOpSc, 2] = Min_GrInt * aGrOpSc[mGrOpSc, 3] = Max_GrInt * aGrOpSc[mGrOpSc, 4] = Int_inf SELECT Attributes FOR mOpSc = 1 TO N_OpSc // Цикл по описательным шкалам *** Поиск наиболее информативной градации 1-й описательной шкалы mMaxInf1 = -9999999999 FOR mGrOpSc = aOpSc[mOpSc,4] TO aOpSc[mOpSc,5] // Цикл по градациям описательных шкал IF mMaxInf1 < aGrOpSc[mGrOpSc, 4] mMaxInf1 = aGrOpSc[mGrOpSc, 4] mMinGrInt1 = aGrOpSc[mGrOpSc, 2] mMaxGrInt1 = aGrOpSc[mGrOpSc, 3] ENDIF NEXT *** Поиск наиболее информативной градации 2-й описательной шкалы mMaxInf2 = -9999999999 FOR mGrOpSc = aOpSc[mOpSc+1,4] TO aOpSc[mOpSc+1,5] // Цикл по градациям описательных шкал IF mMaxInf2 < aGrOpSc[mGrOpSc, 4] mMaxInf2 = aGrOpSc[mGrOpSc, 4] mMinGrInt2 = aGrOpSc[mGrOpSc, 2] mMaxGrInt2 = aGrOpSc[mGrOpSc, 3] ENDIF NEXT ***** Нарисовать четырехугольник *************** X1 := X0 + Ax * mMinGrInt1 * COS( aOpSc[mOpSc ,2] * GradRad ) Y1 := Y0 - Ay * mMinGrInt1 * SIN( aOpSc[mOpSc ,2] * GradRad ) X2 := X0 + Ax * mMaxGrInt1 * COS( aOpSc[mOpSc ,2] * GradRad ) Y2 := Y0 - Ay * mMaxGrInt1 * SIN( aOpSc[mOpSc ,2] * GradRad ) X3 := X0 + Ax * mMinGrInt2 * COS( aOpSc[mOpSc+1,2] * GradRad ) Y3 := Y0 - Ay * mMinGrInt2 * SIN( aOpSc[mOpSc+1,2] * GradRad ) X4 := X0 + Ax * mMaxGrInt2 * COS( aOpSc[mOpSc+1,2] * GradRad ) Y4 := Y0 - Ay * mMaxGrInt2 * SIN( aOpSc[mOpSc+1,2] * GradRad ) * fColor1 = GRA_CLR_RED * fColor2 = GRA_CLR_RED * fColor3 = GRA_CLR_RED ********* Заграска четырехугольника градацией цвета **************************** ma := 127.5 mb := 127.5 mc := 127.5 mU := 0 mV := 120 mW := 240 mColor1 = ABS(INT( mDeltaSpectr + (360-mDeltaSpectr) * (mMaxInf1 - mIntInfMin) / (mIntInfMax - mIntInfMin) )) // Сделать нормировку значений по цветам спектра: MAX=Красный, MIN-фиолетовый ############################## R := INT( ma * (1 + COS( ( mColor1 + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( mColor1 + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( mColor1 + mW ) * GradRad ) ) ) fColor1 := GraMakeRGBColor({ R, G, B }) mColor2 = ABS(INT( mDeltaSpectr + (360-mDeltaSpectr) * (mMaxInf2 - mIntInfMin) / (mIntInfMax - mIntInfMin) )) // Сделать нормировку значений по цветам спектра: MAX=Красный, MIN-фиолетовый ############################## R := INT( ma * (1 + COS( ( mColor2 + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( mColor2 + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( mColor2 + mW ) * GradRad ) ) ) fColor2 := GraMakeRGBColor({ R, G, B }) ***** Градиентная заливка треугольников *********************************** aClrs := {} AADD(aClrs, fColor1);AADD(aClrs, fColor1);AADD(aClrs, fColor2) GraGradient(oPS, {X1,Y1}, {{X2,Y2}, {X3,Y3}}, aClrs, GRA_GRADIENT_TRIANGLE) aClrs := {} AADD(aClrs, fColor1);AADD(aClrs, fColor2);AADD(aClrs, fColor2) GraGradient(oPS, {X2,Y2}, {{X3,Y3}, {X4,Y4}}, aClrs, GRA_GRADIENT_TRIANGLE) aClrs := {} AADD(aClrs, fColor1);AADD(aClrs, fColor1);AADD(aClrs, fColor2) GraGradient(oPS, {X1,Y1}, {{X2,Y2}, {X4,Y4}}, aClrs, GRA_GRADIENT_TRIANGLE) aClrs := {} AADD(aClrs, fColor1);AADD(aClrs, fColor2);AADD(aClrs, fColor2) GraGradient(oPS, {X1,Y1}, {{X3,Y3}, {X4,Y4}}, aClrs, GRA_GRADIENT_TRIANGLE) * GraSetColor( oPS, aColor[222], aColor[222] ) GraSetColor( oPS, GRA_CLR_RED, GRA_CLR_RED ) GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии GraLine( oPS, { X1, Y1 }, { X3, Y3 } ) // Нарисовать отрезок прямой линии GraLine( oPS, { X3, Y3 }, { X4, Y4 } ) // Нарисовать отрезок прямой линии GraLine( oPS, { X2, Y2 }, { X4, Y4 } ) // Нарисовать отрезок прямой линии NEXT ****** Визуализация спектра - легенды ************************ N_Line = 360 // Число линий в спектре D = 100 Delta = INT(360/ N_Line ) Kx = (X_MaxW-2*D) / N_Line * (1 + mDeltaSpectr/360) // Коэффициент масштабирования по оси X: преобразует аргумент функции в номер пикселя по оси X mColorZer = ABS(INT( mDeltaSpectr + (360-mDeltaSpectr) * (0 - mIntInfMin) / (mIntInfMax - mIntInfMin) )) // Сделать нормировку значений по цветам спектра: MAX=Красный, MIN-фиолетовый ############################## ma := 255/2 mb := 255/2 mc := 255/2 mU := 0 mV := 120 mW := 240 R := INT( ma * (1 + COS( ( mColorZer + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( mColorZer + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( mColorZer + mW ) * GradRad ) ) ) fColorZer := GraMakeRGBColor({ R, G, B }) Column = 0 mMinZer = +99999999 X1zer = 0 X2zer = 0 FOR n = 359 TO mDeltaSpectr STEP -Delta ma := 255/2 mb := 255/2 mc := 255/2 mU := 0 mV := 120 mW := 240 R := INT( ma * (1 + COS( ( n + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( n + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( n + mW ) * GradRad ) ) ) fColor := GraMakeRGBColor({ R, G, B }) ***** Закрасить фон прямоугольника *************** GraSetColor( oPS, fColor, fColor ) ++Column X1 := D + (Column-1) * Kx + mDeltaSpectr / 2 X2 := D + Column * Kx + mDeltaSpectr / 2 Y1 := 0 Y2 := 0 + 30 GraBox( oPS, { X1, Y1 }, { X2, Y2 }, GRA_FILL) mZer = ABS( fColor - fColorZer ) IF mZer < mMinZer mMinZer = mZer X1zer = X1 X2zer = X2 ENDIF NEXT ** Еще сделать надпись нуля, если он не совпадает с минимумом ################ * IF mMinZer <> +99999999 * GraSetColor( oPS, aColor[222], aColor[222] ) * GraStringAt( oPS, { X1zer, Y2+10 }, ALLTRIM(STR(0,15,3))) * GraBox( oPS, { X1zer, Y1 }, { X2zer, Y2 }, GRA_OUTLINE ) * ENDIF ****** Надписи на легенде oFont := XbpFont():new():create('10.Arial') aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю относительно точки начала вывода aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты Column = 0 FOR n = 360 TO mDeltaSpectr STEP -Delta ++Column NEXT X1 := D + mDeltaSpectr / 2 X2 := D + mDeltaSpectr / 2 + Column * Kx - 10 GraStringAt( oPS, { X1, Y2+10 }, ALLTRIM(STR(mIntInfMax,15,3))) aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_RIGHT // Выравнивание символов по горизонтали по правому краю относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraStringAt( oPS, { X2, Y2+10 }, ALLTRIM(STR(mIntInfMin,15,3))) **** Написать заголовок диаграммы aFonts := XbpFont():new():list() // Все доступные шрифты oFont := XbpFont():new():create('22.Arial Bold') GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты mTitle = 'СИСТЕМА ОПИСАТЕЛЬНЫХ ШКАЛ И ГРАДАЦИЙ' aTxtPar = DC_GraQueryTextbox(mTitle, oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox("Длина текста в пикселях="+ALLTRIM(STR(aTxtPar[1]))+". Высота текста в пикселях="+ALLTRIM(STR(aTxtPar[2]))) GraStringAt( oPS, { X_MaxW/2, Y_MaxW+aTxtPar[2]+5 }, mTitle) oFont := XbpFont():new():create('14.Arial Bold') GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты mTitle = 'Стиль: "Прозрачная сеть (невод). Наиболее значимые градации описательных шкал закрашены цветом, соответствующим значимости"' aTxtPar = DC_GraQueryTextbox(mTitle, oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox("Длина текста в пикселях="+ALLTRIM(STR(aTxtPar[1]))+". Высота текста в пикселях="+ALLTRIM(STR(aTxtPar[2]))) GraStringAt( oPS, { X_MaxW/2, Y_MaxW+aTxtPar[2]-25 }, mTitle) ******** Запись изображения символа в папку с именем: "InpPortCHR" в виде файла с имененем: "Код и наименование класса" IF FILEDATE("InpPortCHR",16) = CTOD("//") DIRMAKE("InpPortCHR") Mess = L('В папке текущего приложения: "#" не было директории "InpPortCHR" для графических диаграмм нейронов и она была создана!') Mess = STRTRAN(Mess, "#", UPPER(ALLTRIM(M_PathAppl))) LB_Warning(Mess, L('АСК-анализ изображений в системе "ЭЙДОС-X++"' )) ENDIF cFileName = M_PathAppl+"\InpPortCHR\"+ConvToAnsiCP("Сист.оп.шк.и гр.-Сетка-"+M_Inf)+".bmp" // Чтобы в именах файлов можно было использовать русские символы ERASE(cFileName) DC_Scrn2ImageFile( oStatic, cFileName ) ENDIF * ################################################################################################################## * mRegim = 'Сетка' * mRegim = 'Витраж' * mRegim = 'Трианг' // В разработке IF mRegim = 'Витраж' ****** Визуализация описательных шкал и градаций в стиле: "Витраж" ******************************************** * aOpSc[mOpSc, 1] = Kod_OpSc * aOpSc[mOpSc, 2] = mVal * aOpSc[mOpSc, 3] = N_GROPSC * aOpSc[mOpSc, 4] = KODGR_MIN * aOpSc[mOpSc, 5] = KODGR_MAX * aGrOpSc[mGrOpSc, 1] = Kod_OpSc * aGrOpSc[mGrOpSc, 2] = Min_GrInt * aGrOpSc[mGrOpSc, 3] = Max_GrInt * aGrOpSc[mGrOpSc, 4] = Int_inf FOR mOpSc = 1 TO N_OpSc // Цикл по описательным шкалам FOR mGrOpSc = aOpSc[mOpSc,4] TO aOpSc[mOpSc,5] // Цикл по градациям текущей описательной шкал mMinGrInt1 = aGrOpSc[mGrOpSc, 2] mMaxGrInt1 = aGrOpSc[mGrOpSc, 3] mIntInf1 = aGrOpSc[mGrOpSc, 4] IF mOpSc < N_OpSc // Вроде это сделано прямо в массиве aGrOpSc, но почему-то не работает mGr = mGrOpSc+aOpSc[mOpSc,3] ELSE mGr = mGrOpSc-aOpSc[mOpSc,4]+1 ENDIF mMinGrInt2 = aGrOpSc[mGr, 2] mMaxGrInt2 = aGrOpSc[mGr, 3] mIntInf2 = aGrOpSc[mGr, 4] ********* Фильтр ******* mFlagView = .T. IF aWorkInf[11] > 0 mFlagView = .F. IF mIntInf1 >= mIntInfMax * aWorkInf[11] / 100 .AND.; mIntInf2 >= mIntInfMax * aWorkInf[11] / 100 mFlagView = .T. ENDIF ENDIF ***** Нарисовать четырехугольник ************* X1 := X0 + Ax * mMinGrInt1 * COS( aOpSc[mOpSc ,2] * GradRad ) Y1 := Y0 - Ay * mMinGrInt1 * SIN( aOpSc[mOpSc ,2] * GradRad ) X2 := X0 + Ax * mMaxGrInt1 * COS( aOpSc[mOpSc ,2] * GradRad ) Y2 := Y0 - Ay * mMaxGrInt1 * SIN( aOpSc[mOpSc ,2] * GradRad ) X3 := X0 + Ax * mMinGrInt2 * COS( aOpSc[mOpSc+1,2] * GradRad ) Y3 := Y0 - Ay * mMinGrInt2 * SIN( aOpSc[mOpSc+1,2] * GradRad ) X4 := X0 + Ax * mMaxGrInt2 * COS( aOpSc[mOpSc+1,2] * GradRad ) Y4 := Y0 - Ay * mMaxGrInt2 * SIN( aOpSc[mOpSc+1,2] * GradRad ) * GraArc( oPS, { X2, Y2 }, RS, ,,, GRA_OUTLINEFILL ) // Нарисовать точку контура IF mFlagView ********* Заграска четырехугольника градацией цвета **************************** ma := 127.5 mb := 127.5 mc := 127.5 mU := 0 mV := 120 mW := 240 mColor1 = ABS(INT( mDeltaSpectr + (360-mDeltaSpectr) * (mIntInf1 - mIntInfMin) / (mIntInfMax - mIntInfMin) )) // Сделать нормировку значений по цветам спектра: MAX=Красный, MIN-фиолетовый ############################## R := INT( ma * (1 + COS( ( mColor1 + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( mColor1 + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( mColor1 + mW ) * GradRad ) ) ) fColor1 := GraMakeRGBColor({ R, G, B }) mColor2 = ABS(INT( mDeltaSpectr + (360-mDeltaSpectr) * (mIntInf2 - mIntInfMin) / (mIntInfMax - mIntInfMin) )) // Сделать нормировку значений по цветам спектра: MAX=Красный, MIN-фиолетовый ############################## R := INT( ma * (1 + COS( ( mColor2 + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( mColor2 + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( mColor2 + mW ) * GradRad ) ) ) fColor2 := GraMakeRGBColor({ R, G, B }) ***** Градиентная заливка треугольников *********************************** ***** Попробовать залить сразу четырехугольник, задав в GraGradient два (четыре) цвета и четыре координаты aClrs := {} AADD(aClrs, fColor1);AADD(aClrs, fColor1);AADD(aClrs, fColor2) GraGradient(oPS, {X1,Y1}, {{X2,Y2}, {X3,Y3}}, aClrs, GRA_GRADIENT_TRIANGLE) aClrs := {} AADD(aClrs, fColor1);AADD(aClrs, fColor2);AADD(aClrs, fColor2) GraGradient(oPS, {X2,Y2}, {{X3,Y3}, {X4,Y4}}, aClrs, GRA_GRADIENT_TRIANGLE) aClrs := {} AADD(aClrs, fColor1);AADD(aClrs, fColor1);AADD(aClrs, fColor2) GraGradient(oPS, {X1,Y1}, {{X2,Y2}, {X4,Y4}}, aClrs, GRA_GRADIENT_TRIANGLE) aClrs := {} AADD(aClrs, fColor1);AADD(aClrs, fColor2);AADD(aClrs, fColor2) GraGradient(oPS, {X1,Y1}, {{X3,Y3}, {X4,Y4}}, aClrs, GRA_GRADIENT_TRIANGLE) ENDIF ******* Отобразить сетку GraSetColor( oPS, aColor[222], aColor[222] ) GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии GraLine( oPS, { X1, Y1 }, { X3, Y3 } ) // Нарисовать отрезок прямой линии GraLine( oPS, { X3, Y3 }, { X4, Y4 } ) // Нарисовать отрезок прямой линии GraLine( oPS, { X2, Y2 }, { X4, Y4 } ) // Нарисовать отрезок прямой линии NEXT NEXT **** Написать заголовок диаграммы aFonts := XbpFont():new():list() // Все доступные шрифты oFont := XbpFont():new():create('22.Arial Bold') GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты mTitle = 'СИСТЕМА ОПИСАТЕЛЬНЫХ ШКАЛ И ГРАДАЦИЙ' aTxtPar = DC_GraQueryTextbox(mTitle, oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox("Длина текста в пикселях="+ALLTRIM(STR(aTxtPar[1]))+". Высота текста в пикселях="+ALLTRIM(STR(aTxtPar[2]))) GraStringAt( oPS, { X_MaxW/2, Y_MaxW+aTxtPar[2]+5 }, mTitle) oFont := XbpFont():new():create('14.Arial Bold') GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты mTitle = 'Стиль: "Витраж." Показаны градации со значимостью не менее '+ALLTRIM(STR(aWorkInf[11]))+'% от максимальной. Модель: "'+M_Inf+'"' aTxtPar = DC_GraQueryTextbox(mTitle, oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox("Длина текста в пикселях="+ALLTRIM(STR(aTxtPar[1]))+". Высота текста в пикселях="+ALLTRIM(STR(aTxtPar[2]))) GraStringAt( oPS, { X_MaxW/2, Y_MaxW+aTxtPar[2]-25 }, mTitle) ****** Визуализация спектра - легенды ************************ N_Line = 360 // Число линий в спектре D = 100 Z = 60 Delta = INT(360/ N_Line ) Kx = (X_MaxW-2*D) / N_Line // Коэффициент масштабирования по оси X: преобразует аргумент функции в номер пикселя по оси X mColorZer = ABS(INT( mDeltaSpectr + (360-mDeltaSpectr) * (0 - mIntInfMin) / (mIntInfMax-mIntInfMin) )) // Сделать нормировку значений по цветам спектра: MAX=Красный, MIN-фиолетовый ############################## ma := 255/2 mb := 255/2 mc := 255/2 mU := 0 mV := 120 mW := 240 R := INT( ma * (1 + COS( ( mColorZer + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( mColorZer + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( mColorZer + mW ) * GradRad ) ) ) fColorZer := GraMakeRGBColor({ R, G, B }) Column = 0 mMinZer = +99999999 X1zer = 0 X2zer = 0 FOR n = 359 TO mDeltaSpectr STEP -Delta ma := 255/2 mb := 255/2 mc := 255/2 mU := 0 mV := 120 mW := 240 R := INT( ma * (1 + COS( ( n + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( n + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( n + mW ) * GradRad ) ) ) fColor := GraMakeRGBColor({ R, G, B }) ***** Закрасить фон прямоугольника *************** GraSetColor( oPS, fColor, fColor ) ++Column X1 := D + (Column-1) * Kx + mDeltaSpectr + Z X2 := D + Column * Kx + mDeltaSpectr + Z Y1 := 0 Y2 := 0 + 30 GraBox( oPS, { X1, Y1 }, { X2, Y2 }, GRA_FILL) mZer = ABS( fColor - fColorZer ) IF mZer < mMinZer mMinZer = mZer X1zer = X1 X2zer = X2 ENDIF NEXT ** Еще сделать надпись нуля, если он не совпадает с минимумом ################ * IF mMinZer <> +99999999 * GraSetColor( oPS, aColor[222], aColor[222] ) * GraStringAt( oPS, { X1zer, Y2+10 }, ALLTRIM(STR(0,15,3))) * GraBox( oPS, { X1zer, Y1 }, { X2zer, Y2 }, GRA_OUTLINE ) * ENDIF ****** Надписи на легенде oFont := XbpFont():new():create('10.Arial') aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю относительно точки начала вывода aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты Column = 0 FOR n = 359 TO mDeltaSpectr STEP -Delta ++Column NEXT X1 := D + mDeltaSpectr + Z X2 := D + mDeltaSpectr + Column * Kx + Z GraStringAt( oPS, { X1, Y2+10 }, ALLTRIM(STR(mIntInfMax,15,3))) aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_RIGHT // Выравнивание символов по горизонтали по правому краю относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraStringAt( oPS, { X2, Y2+10 }, ALLTRIM(STR(mIntInfMin,15,3))) ******** Запись изображения символа в папку с именем: "InpPortCHR" в виде файла с имененем: "Код и наименование класса" IF FILEDATE("InpPortCHR",16) = CTOD("//") DIRMAKE("InpPortCHR") Mess = L('В папке текущего приложения: "#" не было директории "InpPortCHR" для графических диаграмм нейронов и она была создана!') Mess = STRTRAN(Mess, "#", UPPER(ALLTRIM(M_PathAppl))) LB_Warning(Mess, L('АСК-анализ изображений в системе "ЭЙДОС-X++"' )) ENDIF cFileName = M_PathAppl+"\InpPortCHR\"+ConvToAnsiCP("Сист.оп.шк.и гр.-Витраж-"+M_Inf)+".bmp" // Чтобы в именах файлов можно было использовать русские символы ERASE(cFileName) DC_Scrn2ImageFile( oStatic, cFileName ) ENDIF * ################################################################################################################## * mRegim = 'Сетка' * mRegim = 'Витраж' * mRegim = 'Трианг' // В разработке IF mRegim = 'Трианг' // В разработке ############################################## ****** Визуализация описательных шкал и градаций в стиле: "Витраж" ******************************************** ****** Отображать просто сетку и с цветовым кодированием инт.инфорамативности просто по сетке и с триангуляцией ********************* **** Д Е Л О Н Е **** ********************* ****** 1. Создать БД для координат X,Y,Z точек облака aStructure := { { "Num" , "N", 15, 0 }, ; { "pX" , "N", 19, 7 }, ; { "pY" , "N", 19, 7 }, ; { "pZ" , "N", 19, 7 }, ; { "pRed" , "N", 3, 0 }, ; { "pGreen", "N", 3, 0 }, ; { "pBlue" , "N", 3, 0 } } DbCreate( 'Points_XYZ', aStructure ) USE Points_XYZ EXCLUSIVE NEW SELECT Points_XYZ mNum = 0 *** Цикл по шкалам и градациям **************************************************************************** * aOpSc[mOpSc, 1] = Kod_OpSc * aOpSc[mOpSc, 2] = mVal * aOpSc[mOpSc, 3] = N_GROPSC * aOpSc[mOpSc, 4] = KODGR_MIN * aOpSc[mOpSc, 5] = KODGR_MAX * aGrOpSc[mGrOpSc, 1] = Kod_OpSc * aGrOpSc[mGrOpSc, 2] = Min_GrInt * aGrOpSc[mGrOpSc, 3] = Max_GrInt * aGrOpSc[mGrOpSc, 4] = Int_inf FOR mOpSc = 1 TO N_OpSc // Цикл по описательным шкалам FOR mGrOpSc = aOpSc[mOpSc, 4] TO aOpSc[mOpSc, 5] // Цикл по градациям текущей описательной шкал ****** Выборка данных для отображения ******** mMinGrInt = aGrOpSc[mGrOpSc, 2] // Точка 1: 1-я шкала, нижнее значение интервала mMaxGrInt = aGrOpSc[mGrOpSc, 3] // Точка 2: 1-я шкала, верхнее значение интервала mIntInf = aGrOpSc[mGrOpSc, 4] ********* Фильтр ******* mFlagView = .T. IF aWorkInf[11] > 0 mFlagView = .F. IF mIntInf1 >= mIntInfMax * aWorkInf[11] / 100 mFlagView = .T. ENDIF ENDIF * IF mFlagView ***** Нарисовать прямоугольник *************** mX1 := X0 + Ax * mMinGrInt * COS( aOpSc[mOpSc ,2] * GradRad ) mY1 := Y0 - Ay * mMinGrInt * SIN( aOpSc[mOpSc ,2] * GradRad ) mZ1 := mIntInf mX2 := X0 + Ax * mMaxGrInt * COS( aOpSc[mOpSc ,2] * GradRad ) mY2 := Y0 - Ay * mMaxGrInt * SIN( aOpSc[mOpSc ,2] * GradRad ) mZ2 := mIntInf APPEND BLANK REPLACE Num WITH ++mNum REPLACE pX WITH mX1 REPLACE pY WITH mY1 REPLACE pZ WITH mZ1 APPEND BLANK REPLACE Num WITH ++mNum REPLACE pX WITH mX2 REPLACE pY WITH mY2 REPLACE pZ WITH mZ2 * ENDIF NEXT NEXT ****** Рисование изображений **** Написать заголовок диаграммы aFonts := XbpFont():new():list() // Все доступные шрифты oFont := XbpFont():new():create('22.Arial Bold') GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты mTitle = 'СИСТЕМА ОПИСАТЕЛЬНЫХ ШКАЛ И ГРАДАЦИЙ' aTxtPar = DC_GraQueryTextbox(mTitle, oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox("Длина текста в пикселях="+ALLTRIM(STR(aTxtPar[1]))+". Высота текста в пикселях="+ALLTRIM(STR(aTxtPar[2]))) GraStringAt( oPS, { X_MaxW/2, Y_MaxW+aTxtPar[2]+5 }, mTitle) oFont := XbpFont():new():create('14.Arial Bold') GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты mTitle = 'Стиль: "Триангуляция." Показаны градации со значимостью не менее '+ALLTRIM(STR(aWorkInf[11]))+'% от максимальной. Модель: "'+M_Inf+'"' * mTitle = 'Стиль: "Триангуляция." Показаны градации со значимостью не менее '+ALLTRIM(STR(0))+'% от максимальной. Модель: "M_Inf"' aTxtPar = DC_GraQueryTextbox(mTitle, oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox("Длина текста в пикселях="+ALLTRIM(STR(aTxtPar[1]))+". Высота текста в пикселях="+ALLTRIM(STR(aTxtPar[2]))) GraStringAt( oPS, { X_MaxW/2, Y_MaxW+aTxtPar[2]-25 }, mTitle) ****** Визуализация описательных шкал и градаций в стиле: "Витраж" ******************************************** ****** Отображать просто сетку и с цветовым кодированием инт.инфорамативности просто по сетке и с триангуляцией ********************* **** Д Е Л О Н Е **** ********************* * Triangulation(.T.) // Сделать вариант для этого режима и этой функции, и всех, к которым она обращается ##################################### CLOSE Points_XYZ ****** Визуализация спектра - легенды ************************ N_Line = 360 // Число линий в спектре D = 100 Z = 60 Delta = INT(360/ N_Line ) Kx = (X_MaxW-2*D) / N_Line // Коэффициент масштабирования по оси X: преобразует аргумент функции в номер пикселя по оси X mColorZer = ABS(INT( mDeltaSpectr + (360-mDeltaSpectr) * (0 - mIntInfMin) / (mIntInfMax-mIntInfMin) )) // Сделать нормировку значений по цветам спектра: MAX=Красный, MIN-фиолетовый ############################## ma := 255/2 mb := 255/2 mc := 255/2 mU := 0 mV := 120 mW := 240 R := INT( ma * (1 + COS( ( mColorZer + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( mColorZer + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( mColorZer + mW ) * GradRad ) ) ) fColorZer := GraMakeRGBColor({ R, G, B }) Column = 0 mMinZer = +99999999 X1zer = 0 X2zer = 0 FOR n = 359 TO mDeltaSpectr STEP -Delta ma := 255/2 mb := 255/2 mc := 255/2 mU := 0 mV := 120 mW := 240 R := INT( ma * (1 + COS( ( n + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( n + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( n + mW ) * GradRad ) ) ) fColor := GraMakeRGBColor({ R, G, B }) ***** Закрасить фон прямоугольника *************** GraSetColor( oPS, fColor, fColor ) ++Column X1 := D + (Column-1) * Kx + mDeltaSpectr + Z X2 := D + Column * Kx + mDeltaSpectr + Z Y1 := 0 Y2 := 0 + 30 GraBox( oPS, { X1, Y1 }, { X2, Y2 }, GRA_FILL) mZer = ABS( fColor - fColorZer ) IF mZer < mMinZer mMinZer = mZer X1zer = X1 X2zer = X2 ENDIF NEXT ** Еще сделать надпись нуля, если он не совпадает с минимумом ################ * IF mMinZer <> +99999999 * GraSetColor( oPS, GRA_CLR_BLACK, GRA_CLR_BLACK ) * GraStringAt( oPS, { X1zer, Y2+10 }, ALLTRIM(STR(0,15,3))) * GraBox( oPS, { X1zer, Y1 }, { X2zer, Y2 }, GRA_OUTLINE ) * ENDIF ****** Надписи на легенде GraSetColor( oPS, GRA_CLR_BLACK, GRA_CLR_BLACK ) oFont := XbpFont():new():create('10.Arial') aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю относительно точки начала вывода aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты Column = 0 FOR n = 359 TO mDeltaSpectr STEP -Delta ++Column NEXT X1 := D + mDeltaSpectr + Z X2 := D + mDeltaSpectr + Column * Kx + Z GraStringAt( oPS, { X1, Y2+10 }, ALLTRIM(STR(mIntInfMax,15,3))) aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_RIGHT // Выравнивание символов по горизонтали по правому краю относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraStringAt( oPS, { X2, Y2+10 }, ALLTRIM(STR(mIntInfMin,15,3))) ******** Запись изображения символа в папку с именем: "InpPortCHR" в виде файла с имененем: "Код и наименование класса" IF FILEDATE("InpPortCHR",16) = CTOD("//") DIRMAKE("InpPortCHR") Mess = L('В папке текущего приложения: "#" не было директории "InpPortCHR" для графических диаграмм нейронов и она была создана!') Mess = STRTRAN(Mess, "#", UPPER(ALLTRIM(M_PathAppl))) LB_Warning(Mess, L('АСК-анализ изображений в системе "ЭЙДОС-X++"' )) ENDIF cFileName = M_PathAppl+"\InpPortCHR\"+ConvToAnsiCP("Сист.оп.шк.и гр.-Триангуляция Делоне-"+M_Inf)+".bmp" // Чтобы в именах файлов можно было использовать русские символы ERASE(cFileName) DC_Scrn2ImageFile( oStatic, cFileName ) ENDIF RETURN NIL ***************************** ***************************** ***************************** ******************************************************************************** ******** СПЕКТР В ФОРМЕ СПИРАЛИ АРХИМЕДА ******************************************************************************** FUNCTION Spiral1() LOCAL GetList[0], GetOptions, nColor, oMessageBox, oMenuWords, oDlg, ; oMenuBar,oMenu1,oMenu2,oMenu3,oMenu4,oMenu5,oMenu6,oMenu7,; oMenu3_3, nKey := 0 *DC_IconDefault(1000) p = 32 mNGrad = 3600 // Число точек Ax = 1 Ay = 1 Delta = 0.1 // Шаг аргумента RS = 7 // Радиус цветного кружочка @0,0 DCGROUP oGroup1 CAPTION L('Задайте параметры:') SIZE 45.0, 6.5 @ 1, 2 DCSAY L('Число точек:') PARENT oGroup1 @ 1, p DCGET mNGrad PARENT oGroup1 PICTURE "#########" @ 2, 2 DCSAY L('Амплитуда по X:') PARENT oGroup1 @ 2, p DCGET Ax PARENT oGroup1 PICTURE "###.#####" @ 3, 2 DCSAY L('Амплитуда по Y:') PARENT oGroup1 @ 3, p DCGET Ay PARENT oGroup1 PICTURE "###.#####" @ 4, 2 DCSAY L('Шаг аргумента:') PARENT oGroup1 @ 4, p DCGET Delta PARENT oGroup1 PICTURE "###.#####" @ 5, 2 DCSAY L('радиус точки:') PARENT oGroup1 @ 5, p DCGET RS PARENT oGroup1 PICTURE "###.#####" DCREAD GUI; TO lExit ; FIT; ADDBUTTONS; MODAL; TITLE L("Спектр в системе ЭЙДОС-X++") ******************************************************************** IF lExit ** Button Ok ELSE RETURN NIL ENDIF ******************************************************************** DrawSpectr(mNGrad) RETURN NIL ******************************************************************************* * Calculates a RGB color value from RGB color intensities ******************************************************************************* FUNCTION GraMakeRGBColor( aRGB ) IF Valtype( aRGB ) <> "A" .OR. ; Len( aRGB ) < 3 .OR. ; AScan( aRGB, {|n| Valtype(n) <> "N" }, 1, 3 ) > 0 RETURN NIL ENDIF aRGB[1] := Max( 0, Min( aRGB[1], 255 ) ) aRGB[2] := Max( 0, Min( aRGB[2], 255 ) ) aRGB[3] := Max( 0, Min( aRGB[3], 255 ) ) RETURN (aRGB[1] + (aRGB[2] * 256) + (aRGB[3] * 65536) + 16777216) ******************************************************************************* * Check if a numeric value is equivalent to a RGB-color value ******************************************************************************* FUNCTION GraIsRGBColor( nRGBColor ) IF Valtype( nRGBColor ) <> "N" RETURN .F. ENDIF RETURN ( nRGBColor > GRA_NUMCLR_RESERVED .AND. nRGBColor - 16777216 >= 0 ) ******************************************************************************* * Check if a numeric value is equivalent to a RGB-color value ******************************************************************************* FUNCTION GraGetRGBIntensity( nRGBColor ) LOCAL aRGB[3] IF .NOT. GraIsRGBColor( nRGBColor ) RETURN NIL ENDIF aRGB[1] := nRGBColor - 16777216 aRGB[3] := Int(aRGB[1] / 65536) aRGB[1] -= aRGB[3] * 65536 aRGB[2] := Int(aRGB[1] / 256) aRGB[1] -= aRGB[2] * 256 RETURN aRGB ********************************************** ******** ВИЗУАЛИЗАЦИЯ СПЕКТРА **************** ********************************************** FUNCTION DrawSpectr(mNGrad) PRIVATE nEvent, mp1, mp2, oXbp // Переменные анализа событий PUBLIC X_MaxW := 1313, Y_MaxW := 640 // Размер графического окна для самого графика в пикселях @ 2,1 DCSTATIC TYPE XBPSTATIC_TYPE_RECESSEDBOX SIZE X_MaxW+11, Y_MaxW+20 PIXEL; // Размер окна в пикселях (от Тома) OBJECT oStatic; EVAL {|| _PresSpaceSpectr(oStatic, mNGrad) } DCREAD GUI ; TITLE L("Рисование спектра в системе ЭЙДОС-X++"); // Надпись на окне графика FIT ; BUTTONS DCGUI_BUTTON_EXIT RETURN NIL ************************************************* STATIC FUNCTION _PresSpaceSpectr( oStatic, mNGrad ) LOCAL oPS, oDevice PUBLIC X_MaxW := 1313, Y_MaxW := 640 // Размер графического окна для самого графика в пикселях oPS := XbpPresSpace():new() // Create a PS oDevice := oStatic:winDevice() // Get the device context oPS:create( oDevice ) // Link device context to PS oPS:SetViewPort( { 0, 0, X_MaxW, Y_MaxW } ) oStatic:paint := {|mp1,mp2,obj| mp1 := LC_DrawSpectr( oPS, mNGrad ) } RETURN NIL ******************************************************* STATIC FUNCTION LC_DrawSpectr(oPS, mNGrad ) PRIVATE X0 := 0 + X_MaxW/2 PRIVATE Y0 := 5 + Y_MaxW/2 // Начало координат по осям X и Y PRIVATE W_Wind := X_MaxW - X0 // Ширина окна для самого графика PRIVATE H_Wind := Y_MaxW - Y0 // Высота окна для самого графика PRIVATE Kx := W_Wind / ( mNGrad ) // Коэффициент масштабирования по оси X: преобразует аргумент функции в номер пикселя по оси X PRIVATE Ky := H_Wind / ( mNGrad ) // Коэффициент масштабирования по оси Y: преобразует значение функции в номер пикселя по оси Y **** Написать заголовок диаграммы aFonts := XbpFont():new():list() // Все доступные шрифты oFont := XbpFont():new():create("14.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты mTitle = 'СПЕКТР ИЗ '+ALLTRIM(STR(mNGrad))+' ЦВЕТОВ В ФОРМЕ СПИРАЛИ АРХИМЕДА' aTxtPar = DC_GraQueryTextbox(mTitle, oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox("Длина текста в пикселях="+ALLTRIM(STR(aTxtPar[1]))+". Высота текста в пикселях="+ALLTRIM(STR(aTxtPar[2]))) GraStringAt( oPS, { X_MaxW/2, Y_MaxW+aTxtPar[2]+5 }, mTitle) ******* Гармонические последовательности цветов Column = 0 FOR n = mNGrad TO mNGrad * 60 / 360 STEP -Delta ma := 127.5 mb := 127.5 mc := 127.5 mU := 0 mV := 120 mW := 240 mColor = INT( n / mNGrad * 360 ) R := INT( ma * (1 + COS( ( mColor + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( mColor + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( mColor + mW ) * GradRad ) ) ) fColor := GraMakeRGBColor({ R, G, B }) ***** Закрасить фон прямоугольника *************** GraSetColor( oPS, fColor, fColor ) Column = Column + Delta X1 := X0 + Ax * Column * COS((Column-1) * GradRad ) * Kx Y1 := Y0 - Ay * Column * SIN((Column-1) * GradRad ) * Ky GraArc( oPS, { X1, Y1 }, RS, ,,, GRA_OUTLINEFILL ) NEXT cFileName = ConvToAnsiCP("Спектр в форме спирали.bmp") // Чтобы в именах можно было использовать русские буквы DC_Scrn2ImageFile( oStatic, cFileName ) RETURN NIL ************************************************************************************* ******** Визуализация информационных портретов символов в стилях: "Контур", "Пиксель" ************************************************************************************* FUNCTION InfPortSimbPix() * LB_Warning(L('Данный режим в процессе доработки') mPuthSystem = ApplChange("") // Перейти в папку текущего приложения IF .NOT. FILE("Abs.txt") // БД абс.частот LB_Warning(L("Проведите рассчет матрицы абсолютных частот Abs.txt в режиме 3.1!")) RETURN NIL ENDIF IF .NOT. FILE("Prc1.txt") .OR.; // БД процентных распределений .NOT. FILE("Prc2.txt") LB_Warning(L("Проведите рассчет матриц условных и безусловных процентных распределений Prc1 и Prc2 в режиме 3.2 !")) RETURN NIL ENDIF IF .NOT. FILE("Inf1.txt") // БЗ-1 LB_Warning(L("Проведите рассчет заданных баз знаний Inf1.txt - Inf7.dbf в режиме 3.3!")) RETURN NIL ENDIF PUBLIC aWorkInf[10] IF .NOT. FILE('_WorkInf.arx') AFILL(aWorkInf, .F.) aWorkInf[4] = .T. ELSE aWorkInf = DC_ARestore("_WorkInf.arx") ENDIF ********************************************************************************************************************** // Диалог задания моделей для верификации @ 0, 0 DCGROUP oGroup1 CAPTION L('Задайте стат.модели и модели знаний для работы') SIZE 87,13.5 @ 1,1 DCSAY L('Статистические базы:' ) PARENT oGroup1 @ 2,3 DCCHECKBOX aWorkInf[ 1] PROMPT L('1. ABS - частный критерий: количество встреч сочетаний: "класс-признак" у объектов обуч.выборки') PARENT oGroup1 @ 3,3 DCCHECKBOX aWorkInf[ 2] PROMPT L('2. PRC1 - частный критерий: усл. вероятность i-го признака среди признаков объектов j-го класса ') PARENT oGroup1 @ 4,3 DCCHECKBOX aWorkInf[ 3] PROMPT L('3. PRC2 - частный критерий: условная вероятность i-го признака у объектов j-го класса ') PARENT oGroup1 @ 5.2,1 DCSAY L('Системно-когнитивные модели (Базы знаний):' ) PARENT oGroup1 @ 6,3 DCCHECKBOX aWorkInf[ 4] PROMPT L('4. INF1 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC1 ') PARENT oGroup1 @ 7,3 DCCHECKBOX aWorkInf[ 5] PROMPT L('5. INF2 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC2 ') PARENT oGroup1 @ 8,3 DCCHECKBOX aWorkInf[ 6] PROMPT L('6. INF3 - частный критерий: Xи-квадрат, разности между фактическими и ожидаемыми абс.частотами ') PARENT oGroup1 @ 9,3 DCCHECKBOX aWorkInf[ 7] PROMPT L('7. INF4 - частный критерий: ROI (Return On Investment); вероятности из PRC1 ') PARENT oGroup1 @10,3 DCCHECKBOX aWorkInf[ 8] PROMPT L('8. INF5 - частный критерий: ROI (Return On Investment); вероятности из PRC2 ') PARENT oGroup1 @11,3 DCCHECKBOX aWorkInf[ 9] PROMPT L('9. INF6 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC1 ') PARENT oGroup1 @12,3 DCCHECKBOX aWorkInf[10] PROMPT L('10.INF7 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC2 ') PARENT oGroup1 ************ Сюда добавить возможность ввода фильтра значимости ###################################################################################### DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; OPTIONS GetOptions ; ADDBUTTONS; MODAL ; TITLE L('АСК-анализ изображений') ******************************************************************** IF lExit ** Button Ok ELSE RETURN NIL ENDIF FOR z=1 TO LEN(Ar_Model) IF .NOT. FILE(Ar_Model[z]+'.txt') aWorkInf[z] = .F. ENDIF NEXT DC_ASave(aWorkInf, "_WorkInf.arx") ***** Преобразовать выбранные модели: txt => dbf mLenNameMax = CreateStructAll() // Создание файлов структур баз данных всех моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() // Количество классов (градаций классификационных шкал) USE Attributes EXCLUSIVE NEW;N_Gos = RECCOUNT() // Количество признаков (градаций описательных шкал) USE Gr_OpSc EXCLUSIVE NEW;N_Gos = RECCOUNT() // Количество признаков (градаций описательных шкал) USE Opis_Sc EXCLUSIVE NEW ***** Копирование основных БД всех моделей из txt в dbf формат с числом полей до 2035 IF N_Cls > 2035 LB_Warning(L("Будут показаны только первые 2035 колонок"), L('АСК-анализ изображений' )) ENDIF * ########################################################################### // Открытие текстовых баз данных ******************************************** *** Создание баз данных в dbf-формате с найденной максимальной длиной наименования шкалы + строки и столбцы, как в Inf# GenDbfAbsOld(mLenNameMax) GenDbfPrcOld(mLenNameMax) GenDbfInfOld(mLenNameMax) *DC_ASave(aInfStruct, "_InfStruct.arx") // Когда БД создается - записывать структуру, когда открывается - считывать aInfStruct = DC_ARestore("_InfStruct.arx") *DC_ASave(aStrEmpty, "_aStrEmpty.arx") // Записывать только после расчета Abs.txt, а при расчете остальных БД только считывать *DC_ASave(aColEmpty, "_aColEmpty.arx") aStrEmpty = DC_ARestore("_aStrEmpty.arx") aColEmpty = DC_ARestore("_aColEmpty.arx") ************************************************* ***** Формирование пустой записи N_Col = N_Cls+6 // Число полей CrLf = CHR(13)+CHR(10) // Конец строки (записи) Lc_buf = "" FOR j=1 TO N_Col * S = IF(j=2*INT(j/2),"#","X") // Для отладки S = " " // Для работы Lc_buf = Lc_buf + REPLICATE(S, aInfStruct[j,3]) NEXT Lc_buf = Lc_buf + CrLf PUBLIC Len_LcBuf := LEN(Lc_buf) ****** Создаем стат.базы и базы знаний (7 по частным критериям знаний) Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } PUBLIC nHandle[LEN(Ar_Model)] FOR z=1 TO LEN(Ar_Model) nHandle[z] := FOpen( Ar_Model[z]+".txt", FO_READWRITE ) // Открыть все текстовые базы данных ######################################## NEXT **** Рассчет массива начальных позиций полей в строке PUBLIC aPos[N_Col] aPos[1] = 1 FOR j=2 TO N_Col aPos[j] = aPos[j-1] + aInfStruct[j-1,3] NEXT * ########################################################################### ***** Открытие основных БД.dbf всех созданных моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() // Количество классов (градаций классификационных шкал) mNModels = 0 FOR z=1 TO LEN(Ar_Model) IF aWorkInf[z] M_Inf = Ar_Model[z] USE (M_Inf) EXCLUSIVE NEW // А dbf-файлы уже есть? Ведь вроде они только должны быть созданы ++mNModels ENDIF NEXT ******** Сделать и записать массивы aInfMin и aInfMax для каждой модели ******** и потом при отображении символов в этих моделях использовать их для расчета градаций цвета ******** Это сделать по всей БД (M_Inf) во время преобразования БД txt => dbf ##################### N_Mod = LEN(Ar_Model) PUBLIC aInfMin[N_Mod] PUBLIC aInfMax[N_Mod] AFILL(aInfMin, +999999999) // Для шкалирования цвета AFILL(aInfMax, -999999999) // Для шкалирования цвета ***************************** nMax = (N_Gos + 4 + ( N_Gos + 3 ) * 9) * mNModels/10 Mess = L('Копирование основных баз данных моделей: Abs, Prc#, Inf#: txt=>dbf') @ 4,5 DCPROGRESS oProgr SIZE 80,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 DCREAD GUI TITLE Mess PARENT @oDial FIT EXIT oDial:show() nTime = 0 DC_GetProgress(oProgr,0,nMax) ***************************** *** Копирование БД.txt => БД.dbf ************** (но не более 2035 полей классов) mNCls = IF(N_Cls<=2035,N_Cls,2035) FOR z=1 TO LEN(Ar_Model) IF aWorkInf[z] M_Inf = Ar_Model[z] SELECT(M_Inf) FOR i=1 TO N_Gos * IF aStrEmpty[i] DBGOTO(i) Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], i, 1 ));FIELDPUT(1, Fv) Fv = LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], i, 2 ) ;FIELDPUT(2, Fv) FOR j=1 TO mNCls * IF aColEmpty[j] Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], i, 2+j ));FIELDPUT(2+j, Fv) aInfMin[z] = MIN(aInfMin[z], Fv) aInfMax[z] = MAX(aInfMax[z], Fv) * ENDIF NEXT FOR j=1 TO 3 Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], i, mNCls+2+j ));FIELDPUT(mNCls+2+j, Fv) NEXT * ENDIF DC_GetProgress(oProgr, ++nTime, nMax) NEXT FOR i=1 TO 4 DBGOTO(N_Gos+i) Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], N_Gos+i, 1 ));FIELDPUT(1, Fv) Fv = LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], N_Gos+i, 2 ) ;FIELDPUT(2, Fv) FOR j=1 TO mNCls * IF aColEmpty[j] Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], N_Gos+i, 2+j ));FIELDPUT(2+j, Fv) * ENDIF NEXT FOR j=1 TO 3 Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], N_Gos+i, mNCls+2+j ));FIELDPUT(mNCls+2+j, Fv) NEXT DC_GetProgress(oProgr, ++nTime, nMax) NEXT ENDIF NEXT DC_GetProgress(oProgr,nMax,nMax) oDial:Destroy() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций FOR z=1 TO LEN(nHandle) FClose( nHandle[z] ) // Закрытие dbf и txt баз данных ###################################### NEXT ***** Открытие необходимых баз данных ***** Открыть выбранные модели Ar_Model := {"Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Opis_Sc EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW FOR mNumMod=1 TO LEN(Ar_Model) // Начало цикла по стат.моделям и моделям знаний IF aWorkInf[mNumMod] M_Inf = Ar_Model[mNumMod] USE (M_Inf) EXCLUSIVE NEW ENDIF NEXT ******************************************************************************** ****** Нарисовать систему описательных шкал и градаций в форме четырехугольников ******************************************************************************** * DrawOpScGr() ************************************************************* ****** Процесс рисования информационных портретов изображений ************************************************************* PUBLIC aKodCls := {} // Массив кодов классов PUBLIC aNameCls := {} // Массив наименований классов SELECT Classes DBGOTOP() DO WHILE .NOT. EOF() AADD(aKodCls , Kod_Cls) AADD(aNameCls, DelZeroNameGr(Name_cls) ) DBSKIP(1) ENDDO Ar_Model := {"Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } FOR mSimb = 1 TO N_Cls // Начало цикла по символам (классам) ERASE('_Simb.txt') StrFile(ALLTRIM(STR(mSimb)), '_Simb.txt') // Запись текстового файла с номером символа FOR mNumMod=1 TO LEN(Ar_Model) // Начало цикла по стат.моделям и моделям знаний IF aWorkInf[mNumMod] ERASE('_NumMod.txt') StrFile(ALLTRIM(STR(mNumMod)), '_NumMod.txt') // Запись текстового файла с номером модели M_Inf = Ar_Model[mNumMod] SELECT(M_Inf) SET FILTER TO Kod_pr <> 0 DBGOTOP();DBGOBOTTOM();DBGOTOP() DrawIPSimbPix() ENDIF NEXT NEXT ***** Восстановить состояние среды на момент запуска режима 1.3. ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ************************************************************************************ ******** Визуализация информационного портрета символа в стилях: "Контур", "Пиксель" ************************************************************************************ FUNCTION DrawIPSimbPix() LOCAL GetList := {}, oStatic PRIVATE nEvent, mp1, mp2, oXbp // Переменные анализа событий PUBLIC X_MaxW := 1313, Y_MaxW := 640 // Размер графического окна для самого графика в пикселях @ 2,1 DCSTATIC TYPE XBPSTATIC_TYPE_RECESSEDBOX SIZE X_MaxW+11, Y_MaxW+20 PIXEL; // Размер окна в пикселях (от Тома) OBJECT oStatic; EVAL {|| _PresSpaceIPSimbPix( oStatic ) } DCREAD GUI ; TITLE L('Визуализация информационного портрета изображения в системе "Эйдос-X++"'); // Надпись на окне графика FIT ; BUTTONS DCGUI_BUTTON_EXIT RETURN NIL ************************************************* STATIC FUNCTION _PresSpaceIPSimbPix( oStatic ) LOCAL oPS, oDevice PUBLIC X_MaxW := 1313, Y_MaxW := 640 // Размер графического окна для самого графика в пикселях oPS := XbpPresSpace():new() // Create a PS oDevice := oStatic:winDevice() // Get the device context oPS:create( oDevice ) // Link device context to PS oPS:SetViewPort( { 0, 0, X_MaxW, Y_MaxW } ) oStatic:paint := {|mp1,mp2,obj| mp1 := LC_DrawIPSimbPix( oPS, oStatic ) } RETURN NIL ******************************************************* STATIC FUNCTION LC_DrawIPSimbPix( oPS, oStatic ) LOCAL oBitmap mSimbol = VAL(FileStr('_Simb.txt')) mNumMod = VAL(FileStr('_NumMod.txt')) *** Размер изображения в пикселях по осям X и Y DX_pict = 320 DY_pict = 480 *** Расчет позиций ЦЕНТРОВ изображений в стилях "Контур" и "Витраж" X0kont = X_MaxW / 4 // В стиле "Контур" X0vitr = X_MaxW * 3/4 // В стиле "Витраж" изображение сдвинуто вправо Y0 = Y_MaxW / 2 *** Расчет координат левого нижнего угла изображений в стилях "Контур" и "Витраж" X_LowLeftCornCont = X0kont - DX_pict/2 X_LowLeftCornVitr = X0vitr - DX_pict/2 Y_LowCorn = Y0 + DY_pict/2 * MsgBox('X_MaxW='+ALLTRIM(STR(X_MaxW,15,1))+'; Y_MaxW='+ALLTRIM(STR(Y_MaxW,15,1))+'; X0kont='+ALLTRIM(STR(X0kont,15,1))+'; X0vitr='+ALLTRIM(STR(X0vitr,15,1))+'; Y0='+ALLTRIM(STR(Y0,15,1))+'; X_LowLeftCornCont='+ALLTRIM(STR(X_LowLeftCornCont,15,1))+'; X_LowLeftCornVitr='+ALLTRIM(STR(X_LowLeftCornVitr,15,1))+'; Y_LowCorn='+ALLTRIM(STR(Y_LowCorn,15,1))) **** Написать заголовок диаграммы aFonts := XbpFont():new():list() // Все доступные шрифты oFont := XbpFont():new():create('16.Arial Bold') GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты mTitle = 'ИНФОРМАЦИОННЫЙ ПОРТРЕТ: ['+ALLTRIM(STR(aKodCls[mSimbol]))+']-"'+aNameCls[mSimbol]+'" В МОДЕЛИ: "'+Ar_Model[mNumMod]+'"' GraStringAt( oPS, { X_MaxW/2, Y_MaxW+10 }, mTitle) ****** Надписи стилей oFont := XbpFont():new():create('14.Arial') GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraStringAt( oPS, { X0kont, Y_MaxW-30 }, 'Стиль: "Контур"') // ################################################### GraStringAt( oPS, { X0vitr, Y_MaxW-30 }, 'Стиль: "Витраж"') ******** ############################################################################################################ ******** Визуализация информационного портрета символа в стиле: "Контур" ******************************************** ******** ############################################################################################################ aX := {} // Массив координат X пикселей aY := {} // Массив координат Y пикселей aInf := {} // Массив значений информативностей пикселей aCol := {} // Массив интервальных значений цветов пикселей SELECT(M_Inf) DBGOTOP() DO WHILE .NOT. EOF() * IF FIELDGET(2+mSimbol) <> 0 * PIXEL(8,2)-2/2-{25178970.5000000, 33554431.0000000} * 123456789012345678901234567890123456789012345678901234567890 * 10 20 30 40 50 mNameSc = ALLTRIM(FIELDGET(2)) p1 = AT('(', mNameSc) p2 = AT(',', mNameSc) p3 = AT(')', mNameSc) * MsgBox(STR(RECNO())+' '+SUBSTR(mNameSc, p1+1, p2-p1-1)+' '+SUBSTR(mNameSc, p2+1, p3-p2-1)) AADD(aX , VAL(SUBSTR(mNameSc, p1+1, p2-p1-1))) AADD(aY , VAL(SUBSTR(mNameSc, p2+1, p3-p2-1))) AADD(aInf, FIELDGET(2+mSimbol)) p4 = AT('{', mNameSc) p6 = AT('}', mNameSc) p5 = p4 + AT(',', SUBSTR(mNameSc, p4, p6-1)) * MsgBox(STR(RECNO())+' '+SUBSTR(mNameSc, p4+1, p5-p4-1)+' '+SUBSTR(mNameSc, p5+1, p6-p5-1)) c1 = VAL(SUBSTR(mNameSc, p4+1, p5-p4-1)) c2 = VAL(SUBSTR(mNameSc, p5+1, p6-p5-1)) AADD(aCol, (c1+c2)/2) // Цвет - среднее значение интервала цветов * ENDIF DBSKIP(1) ENDDO ******** Поиск минимальных и максимальных значений aX и aY mXMin = +99999999 mXMax = -99999999 FOR j=1 TO LEN(aX) mXMin = MIN(mXMin, aX[j]) mXMax = MAX(mXMax, aX[j]) NEXT mYMin = +99999999 mYMax = -99999999 FOR j=1 TO LEN(aY) mYMin = MIN(mYMin, aY[j]) mYMax = MAX(mYMax, aY[j]) NEXT mWidthSimb = mXMax - mXMin + 1 // Фактическая ширина символа в пикселях mHeightSimb = mYMax - mYMin + 1 // Фактическая высота символа в пикселях * MsgBox(STR(mWidthSimb)+STR(mHeightSimb)) // Не совпадает с размером изображения, включая фон *** Сжимать изображение при отображении надо, если оно больше, чем 320х480 pix. *** А если меньше, то получается, что надо его растягивать или ничего не делать?? Kx = DX_pict / mWidthSimb // Размеры пикселя изображения при отображении в масштабе Ky = DY_pict / mHeightSimb // Размеры пикселя изображения при отображении в масштабе dx = 0.136*mWidthSimb - 47 // Поправка - сдвиг изображения символа право-влево dy = -0.72*mHeightSimb + 182 // Поправка - сдвиг изображения символа вверх-вниз ******** Залить цветом нуля всю область отображения символа mColorZer = ABS(INT( mDeltaSpectr + (360-mDeltaSpectr) * (0 - aInfMin[mNumMod]) / (aInfMax[mNumMod]-aInfMin[mNumMod]) )) // Сделать нормировку значений по цветам спектра: MAX=Красный, MIN-фиолетовый ############################## ma := 255/2 mb := 255/2 mc := 255/2 mU := 0 mV := 120 mW := 240 R := INT( ma * (1 + COS( ( mColorZer + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( mColorZer + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( mColorZer + mW ) * GradRad ) ) ) fColorZer := GraMakeRGBColor({ R, G, B }) * GraBox( oPS, { X_LowLeftCornCont+dx-1, Y_LowCorn+dy+1 }, { X_LowLeftCornCont+dx+DX_pict+1, Y_LowCorn+dy-DY_pict-1 }, GRA_OUTLINEFILL ) // <<<===################ * GraBox( oPS, { X_LowLeftCornVitr+dx-1, Y_LowCorn+dy+1 }, { X_LowLeftCornVitr+dx+DX_pict+1, Y_LowCorn+dy-DY_pict-1 }, GRA_OUTLINEFILL ) // <<<===################ ***** Задать цвет и толщину линии границы прямоугольника aAttrL := Array( GRA_AL_COUNT ) // атрибуты линии IF mWidthSimb <= 50 aAttrL [ GRA_AL_COLOR ] := GRA_CLR_YELLOW ELSE aAttrL [ GRA_AL_COLOR ] := fColorZer ENDIF aAttrL [ GRA_AL_WIDTH ] := 1 aAttrL [ GRA_AL_TYPE ] := GRA_LINETYPE_SOLID graSetAttrLine( oPS, aAttrL ) ***** Задать цвет заливки переднего плана aAttrA := Array( GRA_AA_COUNT ) // определить атрибуты заполнения aAttrA [ GRA_AA_COLOR ] := fColorZer GraSetAttrArea( oPS, aAttrA ) FOR x=mXMin TO mXMax FOR y=mYMin TO mYMax GraBox( oPS, { X_LowLeftCornCont+dx+x*Kx, Y_LowCorn+dy-y*Ky }, { X_LowLeftCornCont+dx+(x+1)*Kx, Y_LowCorn+dy-(y+1)*Ky }, GRA_OUTLINEFILL ) // <<<===################ NEXT NEXT ***** Задать цвет и толщину линии границы прямоугольника aAttrL := Array( GRA_AL_COUNT ) // атрибуты линии IF mWidthSimb <= 50 aAttrL [ GRA_AL_COLOR ] := GRA_CLR_BLACK ELSE aAttrL [ GRA_AL_COLOR ] := fColorZer ENDIF aAttrL [ GRA_AL_WIDTH ] := 1 aAttrL [ GRA_AL_TYPE ] := GRA_LINETYPE_SOLID graSetAttrLine( oPS, aAttrL ) ***** Задать цвет заливки переднего плана aAttrA := Array( GRA_AA_COUNT ) // определить атрибуты заполнения aAttrA [ GRA_AA_COLOR ] := fColorZer GraSetAttrArea( oPS, aAttrA ) FOR x=mXMin TO mXMax FOR y=mYMin TO mYMax GraBox( oPS, { X_LowLeftCornVitr+dx+x*Kx, Y_LowCorn+dy-y*Ky }, { X_LowLeftCornVitr+dx+(x+1)*Kx, Y_LowCorn+dy-(y+1)*Ky }, GRA_OUTLINEFILL ) // <<<===################ NEXT NEXT ******** Визуализация информационного портрета символа в стиле: "Контур" ******************************************** aAttr := ARRAY( GRA_AM_COUNT ) // Массив для атрибутов маркеров aAttr[ GRA_AM_SYMBOL ] := GRA_MARKSYM_DOT aAttr[ GRA_AM_COLOR ] := aColor[222] // Задать цвет точки GraSetAttrMarker( oPS, aAttr ) mLENaInf = LEN(aInf) FOR j=1 TO mLENaInf IF aInf[j] > 0 * GraMarker( oPS, { X0kont+aX[j], Y0-aY[j] } ) // Нарисовать точку черным цветом ***** Задать цвет и толщину линии границы прямоугольника aAttrL := Array( GRA_AL_COUNT ) // атрибуты линии IF mWidthSimb <= 50 aAttrL [ GRA_AL_COLOR ] := GRA_CLR_YELLOW ELSE aAttrL [ GRA_AL_COLOR ] := GRA_CLR_BLACK ENDIF aAttrL [ GRA_AL_WIDTH ] := 1 aAttrL [ GRA_AL_TYPE ] := GRA_LINETYPE_SOLID graSetAttrLine( oPS, aAttrL ) ***** Задать цвет заливки переднего плана aAttrA := Array( GRA_AA_COUNT ) // определить атрибуты заполнения * aAttrA [ GRA_AA_COLOR ] := aCol[j] aAttrA [ GRA_AA_COLOR ] := GRA_CLR_BLACK GraSetAttrArea( oPS, aAttrA ) GraBox( oPS, { X_LowLeftCornCont+dx+aX[j]*Kx, Y_LowCorn+dy-aY[j]*Ky }, { X_LowLeftCornCont+dx+(aX[j]+1)*Kx, Y_LowCorn+dy-(aY[j]+1)*Ky }, GRA_OUTLINEFILL ) // <<<===################ ENDIF NEXT ******** ############################################################################################################ ******** Визуализация информационного портрета символа в стиле: "Витраж" ******************************************** ******** ############################################################################################################ mNGrad = aInfMax[mNumMod] - aInfMin[mNumMod] // Диапазон изменения цвета * MsgBox(STR(mNGrad)) FOR j=1 TO mLENaInf ma := 255/2 mb := 255/2 mc := 255/2 mU := 0 mV := 120 mW := 240 ****** Может быть нормировку цвета не делать или делать иначе? А то при визуализации получается что-то вроде негатива mColor = ABS(INT( mDeltaSpectr + (360-mDeltaSpectr) * (aInf[j] - aInfMin[mNumMod]) / (aInfMax[mNumMod]-aInfMin[mNumMod]) )) // Сделать нормировку значений по цветам спектра: MAX=Красный, MIN-фиолетовый ############################## * mColor = ABS(INT( (aInfMax[mNumMod]-aInf[j]) / mNGrad * 360 )) // Сделать нормировку значений по цветам спектра: MAX=Красный, MIN-фиолетовый (до 270°) * mColor = ABS(INT( aInf[j] / mNGrad * 360 )) // Сделать нормировку значений по цветам спектра: MAX=Красный, MIN-фиолетовый (до 270°) R := INT( ma * (1 + COS( ( mColor + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( mColor + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( mColor + mW ) * GradRad ) ) ) fColor := GraMakeRGBColor({ R, G, B }) GraSetColor( oPS, fColor, fColor ) * GraMarker( oPS, { X0vitr+aX[j], Y0-aY[j] } ) // Нарисовать точку в цвете ********************************************************* ** Задание цвета прямоугольника-пикселя и его отображение ********************************************************* ***** Задать цвет и толщину линии границы прямоугольника aAttrL := Array( GRA_AL_COUNT ) // атрибуты линии IF mWidthSimb <= 50 aAttrL [ GRA_AL_COLOR ] := GRA_CLR_BLACK ELSE aAttrL [ GRA_AL_COLOR ] := fColor ENDIF aAttrL [ GRA_AL_WIDTH ] := 1 aAttrL [ GRA_AL_TYPE ] := GRA_LINETYPE_SOLID graSetAttrLine( oPS, aAttrL ) ***** Задать цвет заливки переднего плана aAttrA := Array( GRA_AA_COUNT ) // определить атрибуты заполнения aAttrA [ GRA_AA_COLOR ] := fColor GraSetAttrArea( oPS, aAttrA ) GraBox( oPS, { X_LowLeftCornVitr+dx+aX[j]*Kx, Y_LowCorn+dy-aY[j]*Ky }, { X_LowLeftCornVitr+dx+(aX[j]+1)*Kx, Y_LowCorn+dy-(aY[j]+1)*Ky }, GRA_OUTLINEFILL ) // <<<===################ NEXT ****** Визуализация спектра - легенды ************************ N_Line = 360 // Число линий в спектре Delta = INT(360/ N_Line ) Kx = X_MaxW / N_Line // Коэффициент масштабирования по оси X: преобразует аргумент функции в номер пикселя по оси X mColorZer = ABS(INT( mDeltaSpectr + (360-mDeltaSpectr) * (0 - aInfMin[mNumMod]) / (aInfMax[mNumMod]-aInfMin[mNumMod]) )) // Сделать нормировку значений по цветам спектра: MAX=Красный, MIN-фиолетовый ############################## ma := 255/2 mb := 255/2 mc := 255/2 mU := 0 mV := 120 mW := 240 R := INT( ma * (1 + COS( ( mColorZer + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( mColorZer + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( mColorZer + mW ) * GradRad ) ) ) fColorZer := GraMakeRGBColor({ R, G, B }) Column = 0 mMinZer = +99999999 X1zer = 0 X2zer = 0 FOR n = 359 TO mDeltaSpectr STEP -Delta ma := 255/2 mb := 255/2 mc := 255/2 mU := 0 mV := 120 mW := 240 R := INT( ma * (1 + COS( ( n + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( n + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( n + mW ) * GradRad ) ) ) fColor := GraMakeRGBColor({ R, G, B }) ***** Закрасить фон прямоугольника *************** GraSetColor( oPS, fColor, fColor ) ++Column X1 := X_LowLeftCornCont + (Column-1) * Kx X2 := X_LowLeftCornCont + Column * Kx Y1 := 1 Y2 := 1 + 20 GraBox( oPS, { X1, Y1 }, { X2, Y2 }, GRA_FILL) mZer = ABS( fColor - fColorZer ) IF mZer < mMinZer mMinZer = mZer X1zer = X1 X2zer = X2 ENDIF NEXT ** Еще сделать надпись нуля, если он достаточно далеко от правого и левого краев спектра ################ GraSetColor( oPS, aColor[222], aColor[222] ) GraBox( oPS, { X1zer, Y1 }, { X2zer, Y2 }, GRA_OUTLINE ) IF 240 <= X1zer .AND. X1zer <= 1070 GraStringAt( oPS, { X1zer+3, Y2+10 }, ALLTRIM(STR(mMinZer,15,1))) ENDIF ****** Надписи на легенде oFont := XbpFont():new():create('10.Arial') aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю относительно точки начала вывода aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты Column = 0 FOR n = 359 TO mDeltaSpectr STEP -Delta ++Column NEXT X1 := 170 X2 := 170 + Column * Kx GraStringAt( oPS, { X1, Y2+10 }, ALLTRIM(STR(aInfMax[mNumMod],15,3))) aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_RIGHT // Выравнивание символов по горизонтали по правому краю относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraStringAt( oPS, { X2, Y2+10 }, ALLTRIM(STR(aInfMin[mNumMod],15,3))) ******** Запись изображения символа в папку с именем: "InpPortCHR" в виде графического файла IF FILEDATE("InpPortCHR",16) = CTOD("//") DIRMAKE("InpPortCHR") Mess = L('В папке текущего приложения: "#" не было директории "InpPortCHR" для изображений и она была создана!') Mess = STRTRAN(Mess, "#", UPPER(ALLTRIM(M_PathAppl))) LB_Warning(Mess, L('АСК-анализ изображений в системе "ЭЙДОС-X++"' )) ENDIF DIRCHANGE("InpPortCHR") // Перейти в папку "InpPortCHR" cFileName = M_PathAppl+"\InpPortCHR\"+ConvToAnsiCP(STRTRAN(aNameCls[mSimbol],'/',' из '))+'-'+Ar_Model[mNumMod]+".bmp" // Чтобы в именах файлов можно было использовать русские символы * MsgBox(cFileName) ERASE(cFileName);DC_Scrn2ImageFile( oStatic, cFileName ) DIRCHANGE("..") RETURN NIL ***************************** ***************************** ***************************** **************************************************************************************************************************************** ******** Из файла исходных данных "Inp_data.dbf" стандарта программного интерфейса 2.3.2.2 удаляются объекты обучающей выборки с уровнем ******** сходства с классом, к которому они относятся, ниже заданного порога. В данном режиме используются результаты распознавания. **************************************************************************************************************************************** FUNCTION F3_7_6() LOCAL GetList := {} *Razrab() *Running(.F.) *RETURN NIL Running(.T.) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF *IF ApplChange("3.7.6()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения * Running(.F.) * RETURN NIL *ENDIF IF ApplChange("") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF mKod_appl = 0 mApplName = '' SELECT Appls DBGOTOP() DO WHILE .NOT. EOF() IF LEN(ALLTRIM(BY_DEFAULT )) > 0 FlagAppl = .F. mKod_appl = KOD_APPL mApplName = ALLTRIM(Name_Appl) M_NewAppl = ALLTRIM(PATH_APPL) ENDIF DBSKIP(1) ENDDO ***** Проверки на наличие необходимых баз данных и сообщения, если их нет IF .NOT. FILE(Disk_dir + "\AID_DATA\Inp_data\Inp_data.dbf") LB_Warning(L('В папке: нет базы данных: "Inp_data.dbf"!'), L('3.6. Обнаружение, удаление и типизация артефактов')) Running(.F.) RETURN NIL ENDIF IF .NOT. FILE(Disk_dir + "\_2_3_2_2.arx") LB_Warning(L("Необходимо создать модель в режиме 2.3.2.2."), L('3.6. Обнаружение, удаление и типизация артефактов' )) Running(.F.) RETURN NIL ELSE aSoftInt = DC_ARestore(M_PathAppl+"\_2_3_2_2.arx") aSoftInt[ 2] = 1 // Нули и пробелы считать отсутствием данных aSoftInt[27] = 3 // Использовать Inp_data.dbf DC_ASave(aSoftInt , M_PathAppl+"\_2_3_2_2.arx") DC_ASave(aSoftInt , Disk_dir +"\_2_3_2_2.arx") ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Inp_data EXCLUSIVE NEW mFlagTXT = .T. FOR mClSc = aSoftInt[3] TO aSoftInt[4] // Цикл по классификационным шкалам IF FIELDTYPE(mClSc)="C" // Символьные столбцы mFlagTXT = .F. EXIT ENDIF NEXT IF mFlagTXT // Нет текстовых классификационных шкал aMess := {} AADD(aMess, L('В файле исходных данных "Inp_data" нет текстовых классификационных шкал,')) AADD(aMess, L('а данный режим работает только с текстовыми классификационными шкалами. ')) AADD(aMess, L('Числовые классификационные шкалы можно преобразовать в текстовые в системе')) AADD(aMess, L('"Эйдос" или средствами MS Excel. ')) LB_Warning(aMess, L('3.6. Обнаружение, удаление и типизация артефактов' )) Running(.F.) RETURN NIL ENDIF *** Определение пути на приложение и его кода и наименования *MsgBox(M_PathAppl+"Rsp2i.dbf") IF .NOT. FILE(M_PathAppl+"Rsp2i.dbf") .OR.; .NOT. FILE(M_PathAppl+"Rsp2k.dbf") aMess := {} AADD(aMess, L('В папке: ')+ALLTRIM(M_PathAppl)+L(' нет базы данных: "Rsp2i.dbf"!')) AADD(aMess, L('Необходимо выполнить режим 3.5, чтобы сформировать ее.')) LB_Warning(aMess, L('3.6. Обнаружение, удаление и типизация артефактов' )) Running(.F.) RETURN NIL ENDIF ************************************************************************************** mIntKrit = 1 IF .NOT. FILE(Disk_dir + '\_DelObj.txt') StrFile(ALLTRIM(STR(mIntKrit)), Disk_dir + '\_IntKrit.txt') // Запись текстового файла _mIntKrit.txt ENDIF mIntKrit = VAL(FileStr(Disk_dir + '\_IntKrit.txt')) // Загрузка текстового файла _mIntKrit.txt mDelObj = 1 IF .NOT. FILE(Disk_dir + '\_DelObj.txt') StrFile(ALLTRIM(STR(mDelObj)), Disk_dir + '\_DelObj.txt') // Запись текстового файла _DelObj.txt ENDIF mDelObj = VAL(FileStr(Disk_dir + '\_DelObj.txt')) // Загрузка текстового файла _DelObj.txt mPorog = 10 IF .NOT. FILE(Disk_dir + '\_Porog.txt') StrFile(ALLTRIM(STR(mPorog,11,7)), Disk_dir + '\_Porog.txt') // Запись текстового файла _Porog.txt ENDIF mPorog = VAL(FileStr(Disk_dir + '\_Porog.txt')) // Загрузка текстового файла _DelObj.txt IF FILE("_CurrInf.arx") // Файл с информацией о том, какая модель задана текущей M_CurrInf = DC_ARestore("_CurrInf.arx") ELSE DC_ASave(M_CurrInf, "_CurrInf.arx") ENDIF PUBLIC Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } @ 1, 0 DCGROUP oGroup1 CAPTION L('Какой интегральный критерий использовать? ') SIZE 75.0, 6.5 @ 1, 2 DCSAY L('Распознавание проводилось в модели:')+' '+Ar_Model[M_CurrInf]+L('. Эта модель и будет корректироваться.') PARENT oGroup1 @ 2, 2 DCSAY L('Достоверность моделей видно в режиме 3.4. Задать другую модель в качестве текущей') PARENT oGroup1 @ 3, 2 DCSAY L('можно в режиме 5.6. Провести распознавание в текущей модели можно в режиме в 4.1.2.') PARENT oGroup1 @ 4, 2 DCRADIO mIntKrit VALUE 1 PROMPT L('1. Резонанс знаний ') PARENT oGroup1 @ 5, 2 DCRADIO mIntKrit VALUE 2 PROMPT L('2. Сумма знаний ') PARENT oGroup1 @4.2,50 DCPUSHBUTTON CAPTION L("Пояснение") SIZE 15, 1.5 ACTION {||Help376(), DC_GetRefresh(GetList)} PARENT oGroup1 @ 9, 0 DCGROUP oGroup2 CAPTION L('Как обрабатывать артефакты и нетипичные объекты обучающей выборки:') SIZE 75.0, 3.5 @ 1, 2 DCRADIO mDelObj VALUE 1 PROMPT L('Удалять артефакты объекты из "Inp_data.dbf" ') PARENT oGroup2 @ 2, 2 DCRADIO mDelObj VALUE 2 PROMPT L('Создавать новые классы для нетипичных объектов ') PARENT oGroup2 @13, 0 DCGROUP oGroup3 CAPTION L('Задайте ПОРОГОВЫЙ уровень сходства (%):') SIZE 75.0, 4.5 @ 1, 2 DCSAY L('Если по результатам распознавания уровень сходства объекта обучающей выборки с классом') PARENT oGroup3 @ 2, 2 DCSAY L('окажется меньше заданного порога, то этот объект будет считаться нетипичным (артефактом)') PARENT oGroup3 @ 3, 2 DCSAY L("===>>>") GET mPorog PICTURE "###.#######" PARENT oGroup3 DCREAD GUI; TO lExit ; FIT; ADDBUTTONS; MODAL; TITLE L("3.6. Обнаружение, удаление и типизация артефактов") ******************************************************************** IF lExit ** Button Ok ELSE ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ******************************************************************** ERASE(Disk_dir + '\_IntKrit.txt');StrFile(ALLTRIM(STR(mIntKrit)) , Disk_dir + '\_IntKrit.txt') // Запись текстового файла _IntKrit.txt ERASE(Disk_dir + '\_DelObj.txt') ;StrFile(ALLTRIM(STR(mDelObj)) , Disk_dir + '\_DelObj.txt') // Запись текстового файла _DelObj.txt ERASE(Disk_dir + '\_Porog.txt') ;StrFile(ALLTRIM(STR(mPorog,11,7)), Disk_dir + '\_Porog.txt') // Запись текстового файла _Porog.txt ************************************************************************************** aSoftInt = DC_ARestore(M_PathAppl+"\_2_3_2_2.arx") // Если в объектах обучающей выборки, приведших к FN-решениям, удалять классы, то допустимы только равные интервалы, // а если для таких решений классы добавлять, то можно использовать и адаптивные интервалы IF mDelObj = 1 // Удалять нетипичные объекты из "Inp_data.dbf aSoftInt[ 2] = 1 // Нули и пробелы считать отсутствием данных aSoftInt[15] = 1 // 1-равные интервалы, 2-адаптивные интервалы (с примерно равным количеством наблюдений, по Котельникову) <<<===################## ENDIF aSoftInt[27] = 3 // Использовать Inp_data.dbf DC_ASave(aSoftInt , M_PathAppl+"\_2_3_2_2.arx") DC_ASave(aSoftInt , Disk_dir +"\_2_3_2_2.arx") CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций COPY FILE ("Inp_data.dbf") TO ("ObjFalseNeg.dbf") COPY FILE ("Inp_data.dbf") TO ("InpDataSource.dbf") CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Inp_data EXCLUSIVE NEW USE ObjFalseNeg EXCLUSIVE NEW;ZAP DO CASE CASE mIntKrit=1 USE Rsp2k EXCLUSIVE NEW CASE mIntKrit=2 USE Rsp2i EXCLUSIVE NEW ENDCASE nMax = RECCOUNT() Mess = L('3.6. Обнаружение, удаление и типизация артефактов') @ 4,5 DCPROGRESS oProgress SIZE 70,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 DCREAD GUI TITLE Mess PARENT @oDialog FIT EXIT oDialog:show() nTime = 0 DC_GetProgress(oProgress,0,nMax) mNObjFN = 0 DBGOTOP() DO WHILE .NOT. EOF() mKodObj = KOD_OBJ mKodClSc = KOD_CLSC mNameClsOld = ALLTRIM(NAME_CLS) mPos = RAT('-', mNameClsOld) mNameCls = SUBSTR(mNameClsOld, mPos+1, LEN(mNameClsOld)-mPos) IF LEN(ALLTRIM(Fakt)) > 0 IF IF(mIntKrit=1, KORR, SUM_INF) < mPorog * MsgBox('Kod_obj='+ALLTRIM(STR(KOD_OBJ))+' '+ALLTRIM(NAME_OBJ)+' '+ALLTRIM(STR(KOD_CLS))+' '+ALLTRIM(NAME_CLS)+' '+ALLTRIM(STR(KOD_CLSC))+' '+ALLTRIM(STR(KORR))+' '+ALLTRIM(STR(SUM_INF))+' '+ALLTRIM(FAKT)) SELECT Inp_data DBGOTO(mKodObj) * MsgBox('Kod_obj='+ALLTRIM(FIELDGET(1))+' '+ALLTRIM(FIELDGET(2))+' '+ALLTRIM(FIELDGET(3))) mNumClSc = aSoftInt[3]+mKodClSc-1 // Номер колонки классификационной шкалы в БД Inp_data IF FIELDTYPE(mNumClSc) = "C" // Текстовые классификационые шкалы mNObjFN++ IF mDelObj = 1 // Удалять объекты обучающей выборки FIELDPUT(mNumClSc, '' ) // Класс - отсутствие данных DELETE ELSE FIELDPUT(mNumClSc, mNameCls+'_'+ALLTRIM(STR(mKod_appl)) ) // Класс - старое наименование класса + код приложения ENDIF aObj := {} FOR j=1 TO FCOUNT() AADD(aObj, FIELDGET(j)) NEXT SELECT ObjFalseNeg // БД с НЕТИПИЧНЫМИ объектами обучающей выборки (АРТЕФАКТАМИ) APPEND BLANK FOR j=1 TO LEN(aObj) FIELDPUT(j, aObj[j]) NEXT ENDIF ENDIF ENDIF DO CASE CASE mIntKrit=1 SELECT Rsp2k CASE mIntKrit=2 SELECT Rsp2i ENDCASE DC_GetProgress(oProgress, ++nTime, nMax) DBSKIP(1) ENDDO SELECT Inp_data IF mDelObj = 1 // Удалять объекты обучающей выборки * FIELDPUT(mNumClSc, '' ) // Класс - отсутствие данных * DELETE FOR LEN(ALLTRIM(FIELDGET(mNumClSc)))=0 PACK ENDIF *MsgBox('STOP') DC_GetProgress(oProgress,nMax,nMax) oDialog:Destroy() **** После корректировки файла Inp_data.dbf в папке приложения записать его в ..\AID_DATA\Inp_data\ *MsgBox(M_ApplsPath+"\Inp_data\Inp_data.dbf") CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций COPY FILE ("Inp_data.dbf") TO (M_ApplsPath+"\Inp_data\Inp_data.dbf") COPY FILE ("ObjFalseNeg.dbf") TO (M_ApplsPath+"\Inp_data\ObjFalseNeg.dbf") COPY FILE ("ObjFalseNeg.dbf") TO (M_ApplsPath+"\Inp_data\ObjFalseNeg.xls") aMess := {} IF mDelObj = 1 AADD(aMess, L('Удалено:')+' '+ALLTRIM(STR(mNObjFN))+' '+L('нетипичных объектов обучающей выборки.')) ENDIF IF mDelObj = 2 AADD(aMess, L('Назначено на новые классы:')+' '+ALLTRIM(STR(mNObjFN))+' '+L('нетипичных объектов обучающей выборки.')) ENDIF AADD(aMess, L('БД с объектами обучающей выборки, имеющими сходство с классами <')+' '+ALLTRIM(STR(mPorog,11,7)+'%')) AADD(aMess, M_ApplsPath+'\Inp_data\ObjFalseNeg.xls') AADD(aMess, L(' ')) IF mNObjFN > 0 // если обнаружены новые артефакты AADD(aMess, L('Далее нужно выполнить режим 2.3.2.2 с параметрами, заданными по умолчанию. ')) AADD(aMess, L('Этот режим будет запущен автоматически по нажатию клавиши: "OK". После него ')) AADD(aMess, L('нужно ВРУЧНУЮ запустить режим 3.5 и затем в режиме 3.4 необходимо определить')) AADD(aMess, L('модель и интегральный критерий, при которых есть максимальная достоверность,')) AADD(aMess, L('в режиме 5.6 сделать текущей наиболее достоверную модель и в режиме 4.1.2 ')) AADD(aMess, L('провести в ней распознавание ')) ENDIF AADD(aMess, L(' ')) AADD(aMess, L('Итерации ПРЕКРАТИТЬ, если выполнилось одно или несколько условий: ')) AADD(aMess, L('- назначено на новые классы 0 объектов обучающей выборки; ')) AADD(aMess, L('- достоверность модели достигает приемлемого уровня; ')) AADD(aMess, L('- достоверность модели не меняется в итерациях; ')) AADD(aMess, L('- в итерациях одни и те же объекты назначаются на новые классы ("зацикливание")')) LB_Warning(aMess, L('3.6. Обнаружение, удаление и типизация артефактов')) *************************************************************************** ******** ЗАПИСАТЬ ПАРАМЕТРЫ ДЛЯ 2.3.2.2, ЧТОБЫ ЗАГРУЗКА ШЛА ИЗ INP_DATA.DBF *************************************************************************** IF FILE("_2_3_2_2.arx") aSoftInt = DC_ARestore(Disk_dir +"\_2_3_2_2.arx") aSoftInt[ 2] = 1 aSoftInt[27] = 3 DC_ASave(aSoftInt , Disk_dir +"\_2_3_2_2.arx") ENDIF IF mNObjFN > 0 // если обнаружены новые артефакты *********************************************** ***** Запустить 2.3.2.2, 3.5, 3.4, 5.6, 4.1.2. *********************************************** F2_3_2_2("","3.6()") // Возникает ошибка в отображении хода исполнения. Так и не смог разобраться. Похоже надо восстанавливать среду исполнения <<<===################## * F3_5('CPU','SintRec','3.5','ALL') // Какая модель? * F3_4() * F5_6() * F4_1_2() aMess := {} AADD(aMess, L('Далее необходимо в режиме 3.5 создать и верифицировать модели: Abs, Prc1, Prc2, Inf1, Inf2, Inf3, Inf4, Inf5, Inf6, Inf7, ')) AADD(aMess, L('затем в режиме 3.4 необходимо определить модель и интегральный критерий, при которых достигается максимальная достоверность,')) AADD(aMess, L('в режиме 5.6 сделать текущей наиболее достоверную модель и в режиме 4.1.2 провести в ней распознавание. ')) AADD(aMess, L(' ')) AADD(aMess, L('Режим 3.6 можно повторять много раз до достижения необходимого достаточно высокого уровня достоверности моделей или до тех ')) // <<<===######## при повторном запуске 3.6 возникает ошибка AADD(aMess, L('пор, пока достоверность модели перестанет изменяться или перестанут обнаруживаться новые нетипичные объекты обучающей выборки.')) AADD(aMess, L(' ')) AADD(aMess, L('Если достоверность модели достаточно высока, то в ней корректно можно решать задачи идентификации и прогнозирования (4.1.2),')) AADD(aMess, L('принятия решений (4.4.8) и исследования объекта моделирования путем исследования его модели (режимы: 4.4.9, 4.4.10, 4.4.11, ')) AADD(aMess, L('4.4.12, 4.2.1, 4.2.2.1, 4.2.2.2, 4.2.2.3, 4.2.3, 4.3.2.1, 4.3.2.2, 4.3.2.3, 4.5, 3.7.5, 3.7.4., 3.7.3, 3.7.9 и т.д.) ')) LB_Warning(aMess, L('3.6. Обнаружение, удаление и типизация артефактов')) ENDIF ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL **************************************************************************************************** *Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time *nMax = N_InpFiles *Mess = L('2.3.2.6. Объединение нескольких файлов исходных данных в один' *@ 4,5 DCPROGRESS oProgress SIZE 70,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 *DCREAD GUI TITLE Mess PARENT @oDialog FIT EXIT *oDialog:show() *nTime = 0 *DC_GetProgress(oProgress,0,nMax) *FOR ff=1 TO N_InpFiles * DC_GetProgress(oProgress, ++nTime, nMax) *NEXT **MsgBox('STOP') *DC_GetProgress(oProgress,nMax,nMax) *oDialog:Destroy() *Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time **************************************************************************************************** ************************************************************************************************** ******** Помощь по режиму обработки нетипичных объектов обучающей выборки ************************************************************************************************** FUNCTION Help376() aHelp := {} AADD(aHelp, L('Данный режим работает с базой исходных данных стандарта интерфейса 2.3.2.2: "Inp_data.dbf" и предполагает, что: ')) AADD(aHelp, L('1. Текущее Эйдос-приложение ТОЛЬКО ЧТО создано путем ввода данных из внешней базы исходных данных "Inp_data.xls{x}" в режиме 2.3.2.2. ')) AADD(aHelp, L('2. Классификационные шкалы являются текстовыми. Если же они являются числовыми, то их можно в MS Excel свести к текстовым диапазонам. ')) AADD(aHelp, L('')) AADD(aHelp, L('В любой обучающей (тренировочной) выборке (исходных данных) всегда есть не только истинная информация о моделируемой предметной области,')) AADD(aHelp, L('но и дезинформация, да и просто шум. Понятно, что шум и дезинформация в исходных данных приводят к понижению достоверности моделей, ')) AADD(aHelp, L('созданных на основе этих исходных данных. Поэтому необходимо иметь критерии, позволяющие отличить шум от дезинформации и от истинной ')) AADD(aHelp, L('информации, а также основанные на этих критериях математические и программные инструменты для выявления и подавления шума в исходных ')) AADD(aHelp, L('данных, а также для выявления в исходных данных дезинформации и восстановления истинной информации путем анализа дезинформации. ')) AADD(aHelp, L('АРТЕФАКТАМИ будем называть объекты обучающей выборки, у которых и/или признаки случайны, и/или классы случайны, и/или связь признаков ')) AADD(aHelp, L('этих объектов с принадлежностью этих объектов к классам также случайна. В этом и состоит шум в исходных данных. ')) AADD(aHelp, L('НЕТИПИЧНЫМИ будем называть объекты обучающей выборки, у которых и признаки, и классы не случайны, и связь признаков (этих объектов) ')) AADD(aHelp, L('с принадлежностью (этих объектов) к классам, указанная в обучающей выборке, также не случайна, а вполне закономерна, но не та, которая ')) AADD(aHelp, L('указана в обучающей выборке, а другая, т.е. в обучающей выборке неверно указана принадлежность объектов к классам. В этом и заключается')) AADD(aHelp, L('дезинформация в исходных данных. Нетипичные объекты в действительности могут относиться как к тем классам, которые указаны в обучающей ')) AADD(aHelp, L('выборке, так и к новым классам, которых там нет. Основным критерием, позволяющим отличить шум и дезинформацию от истинной информации ')) AADD(aHelp, L('является уровень сходства объекта с классами, к которым он относится по данным обучающей выборки. При увеличении уровня сходства зако- ')) AADD(aHelp, L('номерно расчет доля истинных решений среди всех решений. Низкий уровень сходства и, особенно, ложно-отрицательные решения при решении ')) AADD(aHelp, L('задачи идентификации, являются признаками шума и дезинформации в описании объектов обучающей выборки. Отличить шум и дезинформацию ')) AADD(aHelp, L('друг от друга можно по следующему критерию: если гипотеза о том, что объект нетипичный не подтверждается при итерационном назначении ')) AADD(aHelp, L('его на новые специально создаваемые для этого классы, т.е. этот процесс "зацикливается" (приводит к повторению ситуации) без повышения ')) AADD(aHelp, L('достоверности моделей, то описание этого объекта не содержит закономерностей и является шумом, т.е. он является артефактом. Такие объекты')) AADD(aHelp, L('надо просто удалять из обучающей выборки. Но если вместе с артефактами удалить и нетипичные объекты, то это приведет к уменьшению ')) AADD(aHelp, L('количества информации в модели, ее обеднению (что называется: "вылить из ванны вместе с водой и ребенка"). Поэтому в автоматизированном')) AADD(aHelp, L(' системно-когнитивном анализе (АСК-анализ) и его программном инструментарии интеллектуальной системе "Эйдос" реализованы оба механизма ')) AADD(aHelp, L('на основе двух приведенных критериев, позволяющие сначала разделять классы на типичную и нетипичную части с созданием новых классов для')) AADD(aHelp, L('нетипичных объектов, т.е. восстанавливать истинную информацию путем анализа дезинформации, а затем эффективно подавлять шум в исходных ')) AADD(aHelp, L('данных. В работе приводятся подробные численные примеры, демонстрирующие эти подходы на модельных исходных данных. ')) AADD(aHelp, L('')) AADD(aHelp, L('Некоторые публикации по теме: ')) AADD(aHelp, L('1. Луценко Е.В. Выявление нетипичных объектов и артефактов в исходных данных, назначение на новые классы нетипичных объектов и удаление')) AADD(aHelp, L('артефактов в математических моделях автоматизированного системно-когнитивного анализа /Е.В.Луценко//Политематический сетевой электрон- ')) AADD(aHelp, L('ный научный журнал Кубанского государственного аграрного университета (Научный журнал КубГАУ) [Электронный ресурс].-Краснодар: КубГАУ,2022.')) AADD(aHelp, L('- №10(184). - Режим доступа: http://ej.kubagro.ru/2022/10/pdf/12.pdf, 3,750 у.п.л. - http://dx.doi.org/10.21515/1990-4665-184-012 ')) AADD(aHelp, L('2. Луценко Е.В. Повышение адекватности спектрального анализа личности по астросоциотипам путем их разделения на типичную и нетипичную ')) AADD(aHelp, L('части / Е.В. Луценко, А.П. Трунев // Политематический сетевой электронный научный журнал Кубанского государственного аграрного универ-')) AADD(aHelp, L('ситета (Научный журнал КубГАУ) [Электронный ресурс]. - Краснодар: КубГАУ, 2008. - №02(036). С. 153 - 174. - Шифр Информрегистра: ')) AADD(aHelp, L('0420800012\0017, IDA [article ID]: 0360802010. - Режим доступа: http://ej.kubagro.ru/2008/02/pdf/10.pdf, 1,375 у.п.л. ')) AADD(aHelp, L('3. Луценко Е.В. Повышение качества моделей путем разделения классов на типичную и нетипичную части /Е.В.Луценко,')) AADD(aHelp, L('Е.А. Лебедев, В.Н. Лаптев // Политематический сетевой электронный научный журнал Кубанского государственного аграрного университета ')) AADD(aHelp, L('(Научный журнал КубГАУ) [Электронный ресурс]. - Краснодар: КубГАУ, 2009. - №10(054). С. 78-93. - Шифр Информрегистра: 0420900012\0109, ')) AADD(aHelp, L('IDA [article ID]: 0540910005. - Режим доступа: http://ej.kubagro.ru/2009/10/pdf/05.pdf, 1 у.п.л. ')) AADD(aHelp, L('4. Луценко Е.В.Прогнозирование рисков невозврата ссуды с применением интеллектуального итерационного алгоритма учета нетипичных случаев')) AADD(aHelp, L('/ Е.В.Луценко // Политематический сетевой электронный научный журнал Кубанского государственного аграрного университета (Научный журнал')) AADD(aHelp, L('КубГАУ) [Электронный ресурс]. - Краснодар: КубГАУ, 2021. - №06(170). С. 141 - 202. - IDA [article ID]: 1702106010. - Режим доступа: ')) AADD(aHelp, L('http://ej.kubagro.ru/2021/06/pdf/10.pdf, 3,875 у.п.л. ')) AADD(aHelp, L('5. Луценко Е.В., Лебедев Е.А., Подсистема автоматического формирования двоичного дерева классов семантической информационной модели ')) AADD(aHelp, L('(Подсистема "Эйдос-Tree"). Пат. № 2008610096 РФ. Заяв. № 2007613721 РФ. Опубл. от 09.01.2008. - Режим доступа: ')) AADD(aHelp, L('http://lc.kubagro.ru/aidos/2008610096.jpg, 3,125 / 2,500 у.п.л. ')) mHelpMax = -999;FOR h=1 TO LEN(aHelp);mHelpMax = MAX(mHelpMax, LEN(ALLTRIM(aHelp[h])));NEXT s=1;d=0.8;@0,0 DCGROUP oGroup1 CAPTION L(' ') SIZE mHelpMax-25, LEN(aHelp)*d+1.5 FOR h=1 TO LEN(aHelp);@s,2 DCSAY aHelp[h] SIZE 0 PARENT ogroup1;s=s+d;NEXT DCREAD GUI TO lExit FIT TITLE L('3.6. Обнаружение, удаление и типизация артефактов') RETURN NIL ************************************************************************************************** ************************************************************************************************* ************************************************************************************************* ****** Нарисовать систему описательных шкал и градаций в форме четырехугольников ОТЛАДОЧНЫЙ РЕЖИМ ************************************************************************************************* FUNCTION DrawOpScGrDebug() LOCAL GetList := {}, oStatic PRIVATE nEvent, mp1, mp2, oXbp // Переменные анализа событий PUBLIC X_MaxW := 1313, Y_MaxW := 640 // Размер графического окна для самого графика в пикселях @ 2,1 DCSTATIC TYPE XBPSTATIC_TYPE_RECESSEDBOX SIZE X_MaxW+11, Y_MaxW+20 PIXEL; // Размер окна в пикселях (от Тома) OBJECT oStatic; EVAL {|| _PresSpaceOpScGrD( oStatic ) } DCREAD GUI ; TITLE L("Визуализация информационного портрета символа в системе ЭЙДОС-X++"); // Надпись на окне графика FIT ; BUTTONS DCGUI_BUTTON_EXIT RETURN NIL ************************************************* STATIC FUNCTION _PresSpaceOpScGrD( oStatic ) LOCAL oPS, oDevice PUBLIC X_MaxW := 1313, Y_MaxW := 640 // Размер графического окна для самого графика в пикселях oPS := XbpPresSpace():new() // Create a PS oDevice := oStatic:winDevice() // Get the device context oPS:create( oDevice ) // Link device context to PS oPS:SetViewPort( { 0, 0, X_MaxW, Y_MaxW } ) oStatic:paint := {|mp1,mp2,obj| mp1 := LC_DrawOpScGrD( oPS, oStatic ) } RETURN NIL ***************************************************** ****** Рисование системы описательных шкал и градаций ***************************************************** STATIC FUNCTION LC_DrawOpScGrD( oPS, oStatic ) ***** Поиск минимальных и максимальных значений, масштабирование изображения CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Inp_data EXCLUSIVE NEW Xmin = +99999999 Xmax = -99999999 Ymin = +99999999 Ymax = -99999999 mIntInfMin = +99999999 mIntInfMax = -99999999 SELECT Inp_data DBGOTOP() DO WHILE .NOT. EOF() Xmin = MIN(Xmin, X1) Xmin = MIN(Xmin, X2) Xmin = MIN(Xmin, X3) Xmin = MIN(Xmin, X4) Xmax = MAX(Xmax, X1) Xmax = MAX(Xmax, X2) Xmax = MAX(Xmax, X3) Xmax = MAX(Xmax, X4) Ymin = MIN(Ymin, Y1) Ymin = MIN(Ymin, Y2) Ymin = MIN(Ymin, Y3) Ymin = MIN(Ymin, Y4) Ymax = MAX(Ymax, Y1) Ymax = MAX(Ymax, Y2) Ymax = MAX(Ymax, Y3) Ymax = MAX(Ymax, Y4) mIntInfMin = MIN(mIntInfMin, Z1) mIntInfMin = MIN(mIntInfMin, Z2) mIntInfMin = MIN(mIntInfMin, Z3) mIntInfMin = MIN(mIntInfMin, Z4) mIntInfMax = MAX(mIntInfMax, Z1) mIntInfMax = MAX(mIntInfMax, Z2) mIntInfMax = MAX(mIntInfMax, Z3) mIntInfMax = MAX(mIntInfMax, Z4) DBSKIP(1) ENDDO *** Расчет коэффициентов масштабирования изображения PRIVATE Dx := 10 PRIVATE Dy := 35 // Отступ области рисунка со всех сторон по X и Y PRIVATE X0 := Dx - 60 // Начало координат по осям X и Y PRIVATE Y0 := Dy - 15 PRIVATE W_Wind := X_MaxW - 2*Dx - 30 // Ширина окна для самого графика PRIVATE H_Wind := Y_MaxW - 2*Dy - 20 // Высота окна для самого графика mSizeX = Xmax - Xmin mSizeY = Ymax - Ymin Ax = W_Wind / mSizeX Ay = H_Wind / mSizeY RS = 3 ****** Рисование изображений **** Написать заголовок диаграммы aFonts := XbpFont():new():list() // Все доступные шрифты oFont := XbpFont():new():create('22.Arial Bold') GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты mTitle = 'СИСТЕМА ОПИСАТЕЛЬНЫХ ШКАЛ И ГРАДАЦИЙ' aTxtPar = DC_GraQueryTextbox(mTitle, oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox("Длина текста в пикселях="+ALLTRIM(STR(aTxtPar[1]))+". Высота текста в пикселях="+ALLTRIM(STR(aTxtPar[2]))) GraStringAt( oPS, { X_MaxW/2, Y_MaxW+aTxtPar[2]+5 }, mTitle) oFont := XbpFont():new():create('14.Arial Bold') GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты mTitle = 'Стиль: "Триангуляция." Показаны градации со значимостью не менее '+ALLTRIM(STR(aWorkInf[11]))+'% от максимальной. Модель: "'+M_Inf+'"' * mTitle = 'Стиль: "Триангуляция." Показаны градации со значимостью не менее '+ALLTRIM(STR(0))+'% от максимальной. Модель: "M_Inf"' aTxtPar = DC_GraQueryTextbox(mTitle, oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox("Длина текста в пикселях="+ALLTRIM(STR(aTxtPar[1]))+". Высота текста в пикселях="+ALLTRIM(STR(aTxtPar[2]))) GraStringAt( oPS, { X_MaxW/2, Y_MaxW+aTxtPar[2]-25 }, mTitle) ****** Визуализация описательных шкал и градаций в стиле: "Витраж" ******************************************** ****** Отображать просто сетку и с цветовым кодированием инт.инфорамативности просто по сетке и с триангуляцией ********************* **** Д Е Л О Н Е **** ********************* ****** 1. Создать БД четырехугольников и треугольников: 2 смежные шкалы, 2 смежные градации ****** Цикл по четырехугольникам SELECT Inp_data DBGOTOP() DO WHILE .NOT. EOF() ****************************************************************************************** ***** Расчет координат точки пересечения диагоналей четырехугольника в пространстве: (x,y,z) ****************************************************************************************** ***** В прямоугольнике: ***** -------------------------------- ***** |2 4| ***** | | ***** | | ***** |Шкала 1 0 Шкала 2| ***** | | ***** | | ***** |1 3| ***** -------------------------------- ***** две диагонали: ***** 1-я соединяет вершины 1-4; ***** 2-я соединяет вершины 2-3. ***** Соответственно канонические уравнения 1-й и 2-й диагоналей имеют вид: ***** (x-x1)/(x4-x1)=(y-y1)/(y4-y1)=(z-z1)/(z4-z1) ***** (x-x2)/(x3-x2)=(y-y2)/(y3-y2)=(z-z2)/(z3-z2) ***** Запишем эти уравнения в виде: ***** (x-x1)/p1=(y-y1)/q1=(z-z1)/r1 ***** (x-x2)/p2=(y-y2)/q2=(z-z2)/r2 ***** где: ***** p1=x4-x1, q1=y4-y1, r1=z4-z1 ***** p2=x3-x2, q2=y3-y2, r2=z3-z2 ***** Тогда координаты точки пересечения диагоналей (x,y,z) будут: ***** x=(x1*q1*p2-x2*q2*p1-y1*p1*p2+y2*p1*p2)/(q1*p2-q2*p1) ***** y=(y1*p1*q2-y2*p2*q1-x1*q1*q2+x2*q1*q2)/(p1*q2-p2*q1) ***** z=(z1*q1*r2-z2*q2*r1-y1*r1*r2+y2*r1*r2)/(q1*r2-q2*r1) ****************************************************************************************** p1=x4-x1;q1=y4-y1;r1=z4-z1 p2=x3-x2;q2=y3-y2;r2=z3-z2 x=(x1*q1*p2-x2*q2*p1-y1*p1*p2+y2*p1*p2)/(q1*p2-q2*p1) y=(y1*p1*q2-y2*p2*q1-x1*q1*q2+x2*q1*q2)/(p1*q2-p2*q1) z=(z1*q1*r2-z2*q2*r1-y1*r1*r2+y2*r1*r2)/(q1*r2-q2*r1) ********* Расчет параметров заливки градиентным цветом для всех треугольников ***************** ma := 127.5 mb := 127.5 mc := 127.5 mU := 0 mV := 120 mW := 240 ****** Цвет 1-й вершины четырехугольника mColor1 = ABS(INT( mDeltaSpectr + (360-mDeltaSpectr) * (Z1 - mIntInfMin) / (mIntInfMax-mIntInfMin) )) R := INT( ma * (1 + COS( ( mColor1 + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( mColor1 + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( mColor1 + mW ) * GradRad ) ) ) fColor1 := GraMakeRGBColor({ R, G, B }) ****** Цвет 2-й вершины четырехугольника mColor2 = ABS(INT( mDeltaSpectr + (360-mDeltaSpectr) * (Z2 - mIntInfMin) / (mIntInfMax-mIntInfMin) )) R := INT( ma * (1 + COS( ( mColor2 + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( mColor2 + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( mColor2 + mW ) * GradRad ) ) ) fColor2 := GraMakeRGBColor({ R, G, B }) ****** Цвет 3-й вершины четырехугольника mColor3 = ABS(INT( mDeltaSpectr + (360-mDeltaSpectr) * (Z3 - mIntInfMin) / (mIntInfMax-mIntInfMin) )) R := INT( ma * (1 + COS( ( mColor3 + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( mColor3 + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( mColor3 + mW ) * GradRad ) ) ) fColor3 := GraMakeRGBColor({ R, G, B }) ****** Цвет 4-й вершины четырехугольника mColor4 = ABS(INT( mDeltaSpectr + (360-mDeltaSpectr) * (Z4 - mIntInfMin) / (mIntInfMax-mIntInfMin) )) R := INT( ma * (1 + COS( ( mColor2 + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( mColor2 + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( mColor2 + mW ) * GradRad ) ) ) fColor4 := GraMakeRGBColor({ R, G, B }) ****** Цвет точки пересечения диагоналей четырехугольника mColor = ABS(INT( mDeltaSpectr + (360-mDeltaSpectr) * (Z - mIntInfMin) / (mIntInfMax-mIntInfMin) )) R := INT( ma * (1 + COS( ( mColor + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( mColor + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( mColor + mW ) * GradRad ) ) ) fColor := GraMakeRGBColor({ R, G, B }) ***** Градиентная заливка четырех треугольников в прямоугольнике, образуемых сторонами и половинками диагоналей ***** Позиционирование и масштабирование Px = -0 // Поправки для позиционирования изображения Py = -0 mX = X0 + X * Ax + Px mY = Y0 + Y * Ay + Py mX1 = X0 + X1 * Ax + Px mX2 = X0 + X2 * Ax + Px mX3 = X0 + X3 * Ax + Px mX4 = X0 + X4 * Ax + Px mY1 = Y0 + Y1 * Ay + Py mY2 = Y0 + Y2 * Ay + Py mY3 = Y0 + Y3 * Ay + Py mY4 = Y0 + Y4 * Ay + Py aClrs := {} // 1-й треугольник: 0, 1, 2 AADD(aClrs, fColor);AADD(aClrs, fColor1);AADD(aClrs, fColor2) GraGradient(oPS, {mX,mY}, {{mX1,mY1}, {mX2,mY2}}, aClrs, GRA_GRADIENT_TRIANGLE) aClrs := {} // 2-й треугольник: 0, 2, 4 AADD(aClrs, fColor);AADD(aClrs, fColor2);AADD(aClrs, fColor4) GraGradient(oPS, {mX,mY}, {{mX2,mY2}, {mX4,mY4}}, aClrs, GRA_GRADIENT_TRIANGLE) aClrs := {} // 3-й треугольник: 0, 3, 4 AADD(aClrs, fColor);AADD(aClrs, fColor3);AADD(aClrs, fColor4) GraGradient(oPS, {mX,mY}, {{mX3,mY3}, {mX4,mY4}}, aClrs, GRA_GRADIENT_TRIANGLE) aClrs := {} // 4-й треугольник: 0, 1, 3 AADD(aClrs, fColor);AADD(aClrs, fColor1);AADD(aClrs, fColor3) GraGradient(oPS, {mX,mY}, {{mX1,mY1}, {mX3,mY3}}, aClrs, GRA_GRADIENT_TRIANGLE) *** Нарисовать четырехугольник GraSetColor( oPS, GRA_CLR_BLACK, GRA_CLR_BLACK ) GraLine( oPS, { mX1, mY1 }, { mX2, mY2 } ) // Нарисовать отрезок прямой линии GraLine( oPS, { mX1, mY1 }, { mX3, mY3 } ) // Нарисовать отрезок прямой линии GraLine( oPS, { mX3, mY3 }, { mX4, mY4 } ) // Нарисовать отрезок прямой линии GraLine( oPS, { mX2, mY2 }, { mX4, mY4 } ) // Нарисовать отрезок прямой линии *** Нарисовать диагонали GraSetColor( oPS, GRA_CLR_RED, GRA_CLR_RED ) GraLine( oPS, { mX1, mY1 }, { mX4, mY4 } ) // Нарисовать отрезок прямой линии GraLine( oPS, { mX2, mY2 }, { mX3, mY3 } ) // Нарисовать отрезок прямой линии GraStringAt( oPS, { mX, mY }, ALLTRIM(STR(RECNO(),1))) // Отобразить номер четырехугольника // Отобразить номер вершин 1-го четырехугольника GraSetColor( oPS, GRA_CLR_BLACK, GRA_CLR_BLACK ) GraStringAt( oPS, { mX1+10, mY1+10 }, "1") // Отобразить номер вершины четырехугольника GraStringAt( oPS, { mX2+10, mY2-10 }, "2") // Отобразить номер вершины четырехугольника GraStringAt( oPS, { mX3-10, mY3+10 }, "3") // Отобразить номер вершины четырехугольника GraStringAt( oPS, { mX4-10, mY4-10 }, "4") // Отобразить номер вершины четырехугольника DBSKIP(1) ENDDO CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций ****** Визуализация спектра - легенды ************************ N_Line = 360 // Число линий в спектре D = 100 Z = 60 Delta = INT(360/ N_Line ) Kx = (X_MaxW-2*D) / N_Line // Коэффициент масштабирования по оси X: преобразует аргумент функции в номер пикселя по оси X mColorZer = ABS(INT( mDeltaSpectr + (360-mDeltaSpectr) * (0 - mIntInfMin) / (mIntInfMax-mIntInfMin) )) // Сделать нормировку значений по цветам спектра: MAX=Красный, MIN-фиолетовый ############################## ma := 255/2 mb := 255/2 mc := 255/2 mU := 0 mV := 120 mW := 240 R := INT( ma * (1 + COS( ( mColorZer + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( mColorZer + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( mColorZer + mW ) * GradRad ) ) ) fColorZer := GraMakeRGBColor({ R, G, B }) Column = 0 mMinZer = +99999999 X1zer = 0 X2zer = 0 FOR n = 359 TO mDeltaSpectr STEP -Delta ma := 255/2 mb := 255/2 mc := 255/2 mU := 0 mV := 120 mW := 240 R := INT( ma * (1 + COS( ( n + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( n + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( n + mW ) * GradRad ) ) ) fColor := GraMakeRGBColor({ R, G, B }) ***** Закрасить фон прямоугольника *************** GraSetColor( oPS, fColor, fColor ) ++Column X1 := D + (Column-1) * Kx + mDeltaSpectr + Z X2 := D + Column * Kx + mDeltaSpectr + Z Y1 := 0 Y2 := 0 + 30 GraBox( oPS, { X1, Y1 }, { X2, Y2 }, GRA_FILL) mZer = ABS( fColor - fColorZer ) IF mZer < mMinZer mMinZer = mZer X1zer = X1 X2zer = X2 ENDIF NEXT ** Еще сделать надпись нуля, если он не совпадает с минимумом ################ * IF mMinZer <> +99999999 * GraSetColor( oPS, GRA_CLR_BLACK, GRA_CLR_BLACK ) * GraStringAt( oPS, { X1zer, Y2+10 }, ALLTRIM(STR(0,15,3))) * GraBox( oPS, { X1zer, Y1 }, { X2zer, Y2 }, GRA_OUTLINE ) * ENDIF ****** Надписи на легенде GraSetColor( oPS, GRA_CLR_BLACK, GRA_CLR_BLACK ) oFont := XbpFont():new():create('10.Arial') aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю относительно точки начала вывода aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты Column = 0 FOR n = 359 TO mDeltaSpectr STEP -Delta ++Column NEXT X1 := D + mDeltaSpectr + Z X2 := D + mDeltaSpectr + Column * Kx + Z GraStringAt( oPS, { X1, Y2+10 }, ALLTRIM(STR(mIntInfMax,15,3))) aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_RIGHT // Выравнивание символов по горизонтали по правому краю относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraStringAt( oPS, { X2, Y2+10 }, ALLTRIM(STR(mIntInfMin,15,3))) ******** Запись изображения символа в папку с именем: "InpPortCHR" в виде файла с имененем: "Код и наименование класса" IF FILEDATE("InpPortCHR",16) = CTOD("//") DIRMAKE("InpPortCHR") Mess = L('В папке текущего приложения: "#" не было директории "InpPortCHR" для графических диаграмм нейронов и она была создана!') Mess = STRTRAN(Mess, "#", UPPER(ALLTRIM(M_PathAppl))) LB_Warning(Mess, L('АСК-анализ изображений в системе "ЭЙДОС-X++"' )) ENDIF cFileName = M_PathAppl+"\InpPortCHR\"+ConvToAnsiCP("Сист.оп.шк.и гр.-Триангуляция (отладка)-")+".bmp" // Чтобы в именах файлов можно было использовать русские символы * cFileName = ConvToAnsiCP("Сист.оп.шк.и гр.-Триангуляция (отладка).bmp") // Чтобы в именах файлов можно было использовать русские символы ERASE(cFileName) DC_Scrn2ImageFile( oStatic, cFileName ) RETURN NIL ***************************** ***************************** ***************************** ******************************************** ******** Поменять местами пары слов в тексте ******************************************** FUNCTION F1_12() LOCAL GetList := {}, aPres, oBrowse, oToolBar, aColors, bColor, GetOptions LOCAL oProgress, oDialog, oStatic, oPS, oDevice, oDlg, oProgr, oDial Running(.T.) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!"),L('2.3.2.1. Импорт данных из текстовых файлов')) Running(.F.) RETURN NIL ENDIF *************** ДИАЛОГ ЗАДАНИЯ ПАРАМЕТРОВ ПРЕОБРАЗОВАНИЯ ********************************** * Формат текстовых файлов: DOC, TXT * Если задан TXT, то выбрать кодировку исходных файлов: ANSI (Windows), OEM (DOS) // Если ранее параметры были заданы - скачать массив, иначе сформировать и записать в папке приложения IF .NOT. FILE("_1_12.arx") PUBLIC aPar[3] aPar[1] = 1 // Формат текстовых файлов: 1 = TXT, 2 = DOC, 3 = Internet aPar[2] = 1 // Кодировка исходных файлов: 1 = ANSI (Windows), 2 = OEM (DOS) aPar[3] = 1 // вероятность инвертирования мемов DC_ASave(aPar, "_1_12.arx") ELSE aPar = DC_ARestore("_1_12.arx") ENDIF R = 70 D = 27 @ 1, 1 DCGROUP oGroup1 CAPTION L('Укажите Формат текстовых файлов:') SIZE R, 2.5 @ 1, 2 DCRADIO aPar[1] VALUE 1 PROMPT L('TXT' ) PARENT oGroup1 @ 1, D*1 DCRADIO aPar[1] VALUE 2 PROMPT L('DOC' ) PARENT oGroup1 @ 1, D*2 DCRADIO aPar[1] VALUE 3 PROMPT L('Internet') PARENT oGroup1 @ 4, 1 DCGROUP oGroup2 CAPTION L('Укажите кодировку исходных файлов:') SIZE R, 2.5 HIDE {|| .NOT.aPar[1]=1} @ 1, 2 DCRADIO aPar[2] VALUE 1 PROMPT L('ANSI (Windows)' ) PARENT oGroup2 EDITPROTECT {|| .NOT.aPar[1]=1 } HIDE {|| .NOT.aPar[1]=1 } @ 1, D DCRADIO aPar[2] VALUE 2 PROMPT L('ASCII-OEM (DOS)') PARENT oGroup2 EDITPROTECT {|| .NOT.aPar[1]=1 } HIDE {|| .NOT.aPar[1]=1 } @ 7, 1 DCGROUP oGroup3 CAPTION L('Задайте вероятность инвертирования мемов:') SIZE R, 2.5 @ 1, 2 DCSAY L(" ") GET aPar[3] PARENT oGroup3 PICTURE "#.####" DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; OPTIONS GetOptions ; ADDBUTTONS; MODAL ; TITLE L('1_12. Режим специального назначения') *************************************************** IF lExit ** Button Ok ELSE ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF *************************************************** ******************************************************************************************* DC_ASave(aPar, "_1_12.arx") // Записать параметры, заданные в диалоге IF aPar[1] > 1 LB_Warning(L("Данная опция режима в процессе разработки!"), L('2.3.2.1. Импорт данных из текстовых файлов')) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) ReTURN nil ENDIF mDelta = 2^10 mLcBuf = SPACE(mDelta) CrLf = CHR(13)+CHR(10) // Конец строки (абзаца) (CrLf) CSETSAFETY(.F.) ******* РЕКОГНОСЦИРОВКА ******************* DIRCHANGE(Disk_dir+"\AID_DATA\Inp_data\") // Перейти в папку Inp_data mCountTxt = ADIR("*.TXT") // Кол-во TXT-файлов IF mCountTxt = 0 Mess = L("В папке: # отсутствуют TXT-файлы!") Mess = STRTRAN(Mess, "#", Disk_dir+"\AID_DATA\Inp_data\") LB_Warning(Mess, L('2.3.2.1. Импорт данных из текстовых файлов')) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) ReTURN nil ENDIF PRIVATE aFileName[mCountTxt], aFileSize[mCountTxt] // Имена и размеры файлов ADIR("*.txt", aFileName, aFileSize) *** Преобразование имен файлов в кодировку OEM и удаление расширения *IF aPar[1] = 1 * FOR j=1 TO LEN(aFileName) ** aFileName[j] = STRTRAN(ALLTRIM(ConvToOemCP(aFileName[j])),".txt","") * aFileName[j] = STRTRAN(ALLTRIM(aFileName[j]),".txt","") * NEXT *ENDIF ***** Получить текст с сайта ********* *cURL = 'http://lc.kubagro.ru/' *cResponse := LoadFromURL( cURL ) *cResponse := DC_ReadHtml ( cURL ) *StrFile(cResponse, '_MySite.txt') // Запись текстового файла с именем _MySite.txt ************************************** ****** 1. Скачивать исходные файлы по очереди ****** 2. Искать все предложения по очереди ****** 3. Менять местами слова в предложениях (возможно, кроме первого и последнего) DIRCHANGE(Disk_dir+"\AID_DATA\Inp_data\") // Перейти в папку Inp_data FOR mFile=1 TO LEN(aFileName) // Цикл по TXT-файлам в дирректории Inp_data **** Загрузка текстового файла *** mFileBuf = "" mPos = 0 DO WHILE mPos < aFileSize[mFile] mLcBuf = ALLTRIM(FILESTR(aFileName[mFile], mDelta, mPos )) // Загрузка сегмента файла mLcBuf=STRTRAN(mLcBuf,"-"+CrLf, "") // Удаление DOS-переносов mPos = mPos + mDelta mFileBuf = mFileBuf + mLcBuf ENDDO mFileName = STRTRAN(ALLTRIM(aFileName[mFile]),".txt","_out.txt") *** Цикл по предложениям *** x = 0 FOR s=1 TO NUMTOKEN(mFileBuf, ".") // Разделитель между предложениями - точка mSentence = TOKEN(mFileBuf, ".", s) FOR w=2 TO NUMTOKEN(mSentence)-1 STEP 2 // Цикл по парам слов *** Менять местами слова в паре с заданной вероятностью mWord1 = ALLTRIM(TOKEN(mSentence, w )) mWord2 = ALLTRIM(TOKEN(mSentence, w+1)) ***** Запись пары слов в обратном порядке Len_x = STRFILE(" "+mWord2+" "+mWord1+" ", mFileName, .T., x, .F.) x = x + Len_x NEXT Len_x = STRFILE(". ", mFileName, .T., x, .F.) // Конец предложения x = x + Len_x NEXT NEXT LB_Warning(L('Работа режима 1.12 успешно завершена'),L('1.12. Режим специального назначения')) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ************************************************************************************************* ******** Асимптотический информационный критерий качества шума ******** Данный режим обеспечивает расчет асимптотического информационного критерия качества шума ******** - критерия степени выраженности закономерностей в модели. Результат в БД "Znach_Mod.dbf" ************************************************************************************************* FUNCTION InfKritRnd() PUBLIC Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } PUBLIC aZnachMod[LEN(Ar_Model)] IF .NOT. FILE("Abs.txt") .OR.; .NOT. FILE("Prc1.txt") .OR.; .NOT. FILE("Prc2.txt") .OR.; .NOT. FILE("Inf1.txt") .OR.; .NOT. FILE("Inf2.txt") .OR.; .NOT. FILE("Inf3.txt") .OR.; .NOT. FILE("Inf4.txt") .OR.; .NOT. FILE("Inf5.txt") .OR.; .NOT. FILE("Inf6.txt") .OR.; .NOT. FILE("Inf7.txt") aMess := {} AADD(aMess, L('Перед запуском данного режима необходимо выполнить режим 3.5')) AADD(aMess, L('с созданием всех статистических и интеллектуальных моделей !')) LB_Warning(aMess) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF IF .NOT. FILE("Dost_mod.dbf") .OR.; .NOT. FILE("Abs.dbf") .OR.; .NOT. FILE("Prc1.dbf") .OR.; .NOT. FILE("Prc2.dbf") .OR.; .NOT. FILE("Inf1.dbf") .OR.; .NOT. FILE("Inf2.dbf") .OR.; .NOT. FILE("Inf3.dbf") .OR.; .NOT. FILE("Inf4.dbf") .OR.; .NOT. FILE("Inf5.dbf") .OR.; .NOT. FILE("Inf6.dbf") .OR.; .NOT. FILE("Inf7.dbf") *************************************************************************************************** ***** Копировать txt=>dbf mLenNameMax = CreateStructAll() // Создание файлов структур баз данных всех моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() // Количество классов (градаций классификационных шкал) USE Attributes EXCLUSIVE NEW;N_Gos = RECCOUNT() // Количество признаков (градаций описательных шкал) USE Gr_OpSc EXCLUSIVE NEW;N_Gos = RECCOUNT() // Количество признаков (градаций описательных шкал) USE Opis_Sc EXCLUSIVE NEW ***** Копирование основных БД всех моделей из txt в dbf формат с числом полей до 2035 IF N_Cls > 2035 LB_Warning( L("Будут показаны только первые 2035 колонок", '5.5. Просмотр основных БД всех моделей' )) ENDIF * ########################################################################### // Открытие текстовых баз данных ******************************************** *** Создание баз данных в dbf-формате с найденной максимальной длиной наименования шкалы + строки и столбцы, как в Inf# GenDbfAbsOld(mLenNameMax) GenDbfPrcOld(mLenNameMax) GenDbfInfOld(mLenNameMax) *DC_ASave(aInfStruct, "_InfStruct.arx") // Когда БД создается - записывать структуру, когда открывается - считывать aInfStruct = DC_ARestore("_InfStruct.arx") *DC_ASave(aStrEmpty, "_aStrEmpty.arx") // Записывать только после расчета Abs.txt, а при расчете остальных БД только считывать *DC_ASave(aColEmpty, "_aColEmpty.arx") aStrEmpty = DC_ARestore("_aStrEmpty.arx") aColEmpty = DC_ARestore("_aColEmpty.arx") ************************************************* ***** Формирование пустой записи N_Col = N_Cls+6 // Число полей CrLf = CHR(13)+CHR(10) // Конец строки (записи) Lc_buf = "" FOR j=1 TO N_Col * S = IF(j=2*INT(j/2),"#","X") // Для отладки S = " " // Для работы Lc_buf = Lc_buf + REPLICATE(S, aInfStruct[j,3]) NEXT Lc_buf = Lc_buf + CrLf PUBLIC Len_LcBuf := LEN(Lc_buf) ****** Создаем стат.базы и базы знаний (7 по частным критериям знаний) Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } PUBLIC nHandle[LEN(Ar_Model)] FOR z=1 TO LEN(Ar_Model) nHandle[z] := FOpen( Ar_Model[z]+".txt", FO_READWRITE ) // Открыть все текстовые базы данных ######################################## NEXT **** Рассчет массива начальных позиций полей в строке PUBLIC aPos[N_Col] aPos[1] = 1 FOR j=2 TO N_Col aPos[j] = aPos[j-1] + aInfStruct[j-1,3] NEXT * ########################################################################### ***** Открытие основных БД.dbf всех моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() // Количество классов (градаций классификационных шкал) FOR z=1 TO LEN(Ar_Model) M_Inf = Ar_Model[z] USE (M_Inf) EXCLUSIVE NEW NEXT ***************************** nMax = N_Gos + 4 + ( N_Gos + 3 ) * 9 Mess = L('Копирование основных баз данных моделей: Abs, Prc#, Inf#: txt=>dbf') @ 4,5 DCPROGRESS oProgr SIZE 80,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 DCREAD GUI TITLE Mess PARENT @oDial FIT EXIT oDial:show() nTime = 0 DC_GetProgress(oProgr,0,nMax) ***************************** *** Копирование БД.txt => БД.dbf ************** (но не более 2035 полей классов) mNCls = IF(N_Cls<=2035,N_Cls,2035) FOR z=1 TO LEN(Ar_Model) M_Inf = Ar_Model[z] SELECT(M_Inf) FOR i=1 TO N_Gos * IF aStrEmpty[i] DBGOTO(i) Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], i, 1 ));FIELDPUT(1, Fv) Fv = LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], i, 2 ) ;FIELDPUT(2, Fv) FOR j=1 TO mNCls * IF aColEmpty[j] Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], i, 2+j ));FIELDPUT(2+j, Fv) * ENDIF NEXT FOR j=1 TO 3 Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], i, mNCls+2+j ));FIELDPUT(mNCls+2+j, Fv) NEXT * ENDIF DC_GetProgress(oProgr, ++nTime, nMax) NEXT FOR i=1 TO 4 DBGOTO(N_Gos+i) Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], N_Gos+i, 1 ));FIELDPUT(1, Fv) Fv = LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], N_Gos+i, 2 ) ;FIELDPUT(2, Fv) FOR j=1 TO mNCls * IF aColEmpty[j] Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], N_Gos+i, 2+j ));FIELDPUT(2+j, Fv) * ENDIF NEXT FOR j=1 TO 3 Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], N_Gos+i, mNCls+2+j ));FIELDPUT(mNCls+2+j, Fv) NEXT DC_GetProgress(oProgr, ++nTime, nMax) NEXT NEXT DC_GetProgress(oProgr,nMax,nMax) oDial:Destroy() *************************************************************************************************** ENDIF ********* Создать БД Znach_mod.dbf cFileName := "Znach_mod" aStructure := { { "Type_model", "C",250, 0 }, ; { "Int_krit" , "C", 40, 0 }, ; { "P_T_Ident" , "N", 15, 7 }, ; // Вероятность верной идентификации объекта с классом с использованием модели { "P_T_NIdent", "N", 15, 7 }, ; // Вероятность верной не идентификации объекта с классом с использованием модели { "P_Avr_T" , "N", 15, 7 }, ; // Средняя вероятность верной идентификации или неидентификации объекта с классом с использованием модели { "Date" , "C", 10, 0 }, ; { "Time" , "C", 8, 0 }, ; { "Znach_Mod" , "N", 15, 7 } } // Значимость модели DbCreate( cFileName, aStructure, "DBFNTX" ) nMax = LEN(Ar_Model) Mess = L('Расчет асимпт.информационного критерия качества шума') @ 4,5 DCPROGRESS oProgress SIZE 70,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 DCREAD GUI TITLE Mess PARENT @oDialog FIT EXIT oDialog:show() nTime = 0 DC_GetProgress(oProgress,0,nMax) FOR mMod = 1 TO LEN(Ar_Model) aZnachMod[mMod] = GenZnachdMod(mMod) DC_GetProgress(oProgress, ++nTime, nMax) NEXT *MsgBox('STOP') DC_GetProgress(oProgress,nMax,nMax) oDialog:Destroy() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Dost_Mod EXCLUSIVE NEW USE Znach_Mod EXCLUSIVE NEW SELECT Dost_Mod DBGOTOP() DO WHILE .NOT. EOF() mMod = VAL(SUBSTR(Type_model, 1, AT('.', Type_model)-1)) Ar := {} FOR j=1 TO FCOUNT() AADD(Ar, FIELDGET(j)) NEXT SELECT Znach_Mod APPEND BLANK FOR j=1 TO LEN(Ar) FIELDPUT(j, Ar[j]) NEXT REPLACE Znach_Mod WITH aZnachMod[mMod] SELECT Dost_Mod DBSKIP(1) ENDDO aMess := {} AADD(aMess, L('Расчет асимптотического информационного критерия качества шума')) AADD(aMess, L('- критерия степени выраженности закономерностей в модели, завершен')) AADD(aMess, L('Результат в БД: ')+M_PathAppl+"Znach_Mod.dbf") LB_Warning(aMess) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ******** Расчет БД значимости модели - ср.кв.откл. значений информативностей или др., ******** асимптотический информационный критерий качества шума, критерий наличия закономерностей в модели FUNCTION GenZnachdMod(M_NumMod) PUBLIC Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } mModel = Ar_Model[M_NumMod] CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mModel) EXCLUSIVE NEW USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Attributes EXCLUSIVE NEW;N_Atr = RECCOUNT() SELECT (mModel) SET FILTER TO Kod_pr <> 0 ****** Расчет суммы и среднего mSumma = 0 mSredn = 0 mNZnach = 0 mDisp = 0 DBGOTOP() DO WHILE .NOT. EOF() FOR j=1 TO N_Cls mSumma = mSumma + FIELDGET(2+j) NEXT DBSKIP(1) ENDDO mSredn = mSumma / (N_cls * N_Atr) ****** Расчет ср.кв.откл. по всем элементам матрицы DBGOTOP() DO WHILE .NOT. EOF() FOR j=1 TO N_Cls mDisp = mDisp + ( mSredn - FIELDGET(2+j) ) ^ 2 NEXT DBSKIP(1) ENDDO mDisp = SQRT(mDisp /(N_cls * N_Atr - 1)) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций RETURN(mDisp) ******************************************************************************************************************* ******** 2.3.2.6. Сценарный АСК-анализ символьных и числовых рядов. ******** Режим обеспечивает импорт данных из DOS-TXT-рядов чисел (цифр) и слов (букв), а также генерацию рядов ******** для расчета асимптотического информационного критерия качества шума, отражающего степень выраженности ******** закономерностей в предметной области. Это позволяет применить сценарный метод АСК-анализа для исследования ******** временных рядов и каузальные зависимостей будущих сценариев изменения величины от прошлых ******************************************************************************************************************* FUNCTION F2_3_2_6() LOCAL GetList[0] Running(.T.) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF PUBLIC aSay[30], Mess97, Mess98, Mess99 // Массив сообщений отображаемых стадий исполнения (до 30 на экране) PUBLIC Time_progress, Wsego, oProgress, lOk PUBLIC nEvery := 100 // Количество корректировок прогресс-бар *********************************************************************************************************************** mInsElem = .T. P1 = 45 P2 = 60 N1 = 1 N2 = N1+99 D = 1 Q = 1.1 R1 = 100 R2 = 1 g = 0 s = 0 mRegim = 1 @g , 0 DCGROUP oGroup1 CAPTION L('Задайте вариант использования режима:' ) SIZE 80.0, 7.5 @++s, 2 DCRADIO mRegim VALUE 1 PROMPT L('Загрузка символьного ряда из файла') PARENT oGroup1 @++s, 2 DCRADIO mRegim VALUE 2 PROMPT L('Расчет арифметической прогрессии' ) PARENT oGroup1 @++s, 2 DCRADIO mRegim VALUE 3 PROMPT L('Расчет геометрической прогрессии' ) PARENT oGroup1 @++s, 2 DCRADIO mRegim VALUE 4 PROMPT L('Расчет ряда Фибоначчи' ) PARENT oGroup1 @++s, 2 DCRADIO mRegim VALUE 5 PROMPT L('Расчет ряда случайных чисел' ) PARENT oGroup1 // Загрузка символьного ряда из файла ************************************* s = 1 cFile = 'Inp_data.txt' nElement = 2 mUpper = .F. mBlank = .T. @0.5,35 DCGROUP oGroup2 CAPTION L('Загрузка файла:') SIZE 43, 6.5 HIDE {||.NOT.mRegim=1} PARENT oGroup1 @ 1+0.1, 4.5 DCSAY L("Имя файла:") EDITPROTECT {||.NOT.mRegim=1} HIDE {||.NOT.mRegim=1} PARENT oGroup2 @ 1,15 DCSAY L(" ") GET cFile PICTURE "XXXXXXXXXXXX" EDITPROTECT {||.NOT.mRegim=1} HIDE {||.NOT.mRegim=1} PARENT oGroup2 @ 2, 2 DCRADIO nElement VALUE 1 PROMPT L('Элементы-слова (числа)' ) EDITPROTECT {||.NOT.mRegim=1} HIDE {||.NOT.mRegim=1} PARENT oGroup2 @ 3, 2 DCRADIO nElement VALUE 2 PROMPT L('Элементы-символы (цифры)') EDITPROTECT {||.NOT.mRegim=1} HIDE {||.NOT.mRegim=1} PARENT oGroup2 @ 4, 2 DCCHECKBOX mUpper PROMPT L('Перевести в заглавные' ) EDITPROTECT {||.NOT.mRegim=1} HIDE {||.NOT.mRegim=1} PARENT oGroup2 @ 5, 2 DCCHECKBOX mBlank PROMPT L('Убрать подряд идущие пробелы') EDITPROTECT {||.NOT.mRegim=1} HIDE {||.NOT.mRegim=1} PARENT oGroup2 // Расчет арифметической прогрессии *************************************** @0.5, 35 DCGROUP oGroup3 CAPTION L('Параметры арифметической прогрессии:') SIZE 43, 6.5 HIDE {||.NOT.mRegim=2} PARENT oGroup1 @1.2, 2 DCSAY L("Номер начального элемента ряда:") EDITPROTECT {||.NOT.mRegim=2} HIDE {||.NOT.mRegim=2} PARENT oGroup3 @1.0, 27 DCSAY L(" ") GET N1 PICTURE "##########" EDITPROTECT {||.NOT.mRegim=2} HIDE {||.NOT.mRegim=2} PARENT oGroup3 @2.2, 2 DCSAY L("Номер конечного элемента ряда:") EDITPROTECT {||.NOT.mRegim=2} HIDE {||.NOT.mRegim=2} PARENT oGroup3 @2.0, 27 DCSAY L(" ") GET N2 PICTURE "##########" EDITPROTECT {||.NOT.mRegim=2} HIDE {||.NOT.mRegim=2} PARENT oGroup3 @3.2, 2 DCSAY L("Шаг прогрессии:" ) EDITPROTECT {||.NOT.mRegim=2} HIDE {||.NOT.mRegim=2} PARENT oGroup3 @3.0, 27 DCSAY L(" ") GET D PICTURE "##########" EDITPROTECT {||.NOT.mRegim=2} HIDE {||.NOT.mRegim=2} PARENT oGroup3 @4.0, 2 DCCHECKBOX mInsElem PROMPT L('Вставлять пробел за элементом') EDITPROTECT {||.NOT.mRegim=2} HIDE {||.NOT.mRegim=2} PARENT oGroup3 // Расчет геометрической прогрессии *************************************** @0.5, 35 DCGROUP oGroup4 CAPTION L('Параметры геометрической прогрессии:') SIZE 43, 6.5 HIDE {||.NOT.mRegim=3} PARENT oGroup1 @1.2, 2 DCSAY L("Номер начального элемента ряда:") EDITPROTECT {||.NOT.mRegim=3} HIDE {||.NOT.mRegim=3} PARENT oGroup4 @1.0, 27 DCSAY L(" ") GET N1 PICTURE "##########" EDITPROTECT {||.NOT.mRegim=3} HIDE {||.NOT.mRegim=3} PARENT oGroup4 @2.2, 2 DCSAY L("Номер конечного элемента ряда:") EDITPROTECT {||.NOT.mRegim=3} HIDE {||.NOT.mRegim=3} PARENT oGroup4 @2.0, 27 DCSAY L(" ") GET N2 PICTURE "##########" EDITPROTECT {||.NOT.mRegim=3} HIDE {||.NOT.mRegim=3} PARENT oGroup4 @3.2, 2 DCSAY L("Знаменатель прогрессии:" ) EDITPROTECT {||.NOT.mRegim=3} HIDE {||.NOT.mRegim=3} PARENT oGroup4 @3.0, 27 DCSAY L(" ") GET Q PICTURE "###.######" EDITPROTECT {||.NOT.mRegim=3} HIDE {||.NOT.mRegim=3} PARENT oGroup4 @4.0, 2 DCCHECKBOX mInsElem PROMPT L('Вставлять пробел за элементом') EDITPROTECT {||.NOT.mRegim=3} HIDE {||.NOT.mRegim=3} PARENT oGroup4 // Расчет ряда Фибоначчи ************************************************** @0.5, 35 DCGROUP oGroup5 CAPTION L('Параметры ряда Фибоначчи:') SIZE 43, 6.5 HIDE {||.NOT.mRegim=4} PARENT oGroup1 @1.2, 2 DCSAY L("Номер начального элемента ряда:") EDITPROTECT {||.NOT.mRegim=4} HIDE {||.NOT.mRegim=4} PARENT oGroup5 @1.0, 27 DCSAY L(" ") GET N1 PICTURE "##########" EDITPROTECT {||.NOT.mRegim=4} HIDE {||.NOT.mRegim=4} PARENT oGroup5 @2.2, 2 DCSAY L("Номер конечного элемента ряда:") EDITPROTECT {||.NOT.mRegim=4} HIDE {||.NOT.mRegim=4} PARENT oGroup5 @2.0, 27 DCSAY L(" ") GET N2 PICTURE "##########" EDITPROTECT {||.NOT.mRegim=4} HIDE {||.NOT.mRegim=4} PARENT oGroup5 @3.2, 2 DCCHECKBOX mInsElem PROMPT L('Вставлять пробел за элементом') EDITPROTECT {||.NOT.mRegim=4} HIDE {||.NOT.mRegim=4} PARENT oGroup5 // Расчет ряда случайного ряда чисел ************************************** @0.5, 35 DCGROUP oGroup6 CAPTION L('Параметры случайного ряда чисел:') SIZE 43, 6.5 HIDE {||.NOT.mRegim=5} PARENT oGroup1 @1.2, 2 DCSAY L("Количество элементов ряда:" ) EDITPROTECT {||.NOT.mRegim=5} HIDE {||.NOT.mRegim=5} PARENT oGroup6 @1.0, 27 DCSAY L(" ") GET R1 PICTURE "##########" EDITPROTECT {||.NOT.mRegim=5} HIDE {||.NOT.mRegim=5} PARENT oGroup6 @2.2, 2 DCSAY L("Число разрядов в элементе:" ) EDITPROTECT {||.NOT.mRegim=5} HIDE {||.NOT.mRegim=5} PARENT oGroup6 @2.0, 27 DCSAY L(" ") GET R2 PICTURE "##########" EDITPROTECT {||.NOT.mRegim=5} HIDE {||.NOT.mRegim=5} PARENT oGroup6 @3.2, 2 DCCHECKBOX mInsElem PROMPT L('Вставлять пробел за элементом') EDITPROTECT {||.NOT.mRegim=5} HIDE {||.NOT.mRegim=5} PARENT oGroup6 s = 8.0 @ s, 4.5 DCPUSHBUTTON CAPTION L("Помощь") SIZE 15, 1.5 ACTION {||Help2326(), DC_GetRefresh(GetList)} P1 = 21.5 P2 = 62 mGroupPast = 2 mGroupFuture = 1 @ s+0.0,P1 DCSAY L("Глубина предыстории (число прошлых элементов):") @ s ,P2 DCSAY L(" ") GET mGroupPast PICTURE "##########" @ s+1.0,P1 DCSAY L("Горизонт прогнозирования (число будущих элементов):") @ s+1.0,P2 DCSAY L(" ") GET mGroupFuture PICTURE "##########" DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; OPTIONS GetOptions ; ADDBUTTONS; MODAL ; TITLE L('2.3.2.6. Сценарный АСК-анализ символьных и числовых рядов') ******************************************************************** IF lExit ** Button Ok ELSE ADS_SERVER_QUIT() QUIT ENDIF ******************************************************************** ****** Проверки корректности заданных параметров cFile = ALLTRIM(cFile) mError = .F. IF N1 > N2 mError = .T. LB_Warning(L("Конечное значение должно быть больше начального!"), L('2.3.2.6. АСК-анализ символьных и числовых рядов')) ENDIF IF D = 0 mError = .T. LB_Warning(L("Шаг арифметической прогрессии не должен быть равным нулю!"), L('2.3.2.6. АСК-анализ символьных и числовых рядов')) ENDIF IF Q = 1 mError = .T. LB_Warning(L("Знаменатель геометрической прогрессии не должен быть равным единице!"), L('2.3.2.6. АСК-анализ символьных и числовых рядов')) ENDIF IF R1 < 2 mError = .T. LB_Warning(L("Количество псевдослучайных чисел должно быть больше 1!"), L('2.3.2.6. АСК-анализ символьных и числовых рядов')) ENDIF IF R2 < 1 mError = .T. LB_Warning(L("Разрядность псевдослучайных чисел должна быть больше 0!"), L('2.3.2.6. АСК-анализ символьных и числовых рядов')) ENDIF IF mError ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF *********************************************************************************************************************** *********************************************************************************************************************** T_Mess1 = L("Начало:")+" "+TIME() // Начало Sec_1 = (DOY(DATE())-1)*86400+SECONDS() PUBLIC T1 := (DOY(DATE())-1)*86400+SECONDS() // Время предыдущей индикации процесса исполнения PUBLIC T2 := (DOY(DATE())-1)*86400+SECONDS()+1 // Текущее время (1-й раз оно заметно больше T1 чтобы было отображение) PUBLIC T1tp := T1 PUBLIC T2tp := T2 ****** Подготовка наименования создаваемого приложения ************** aRegim := {} AADD(aRegim, L('Загрузка символьного ряда из файла')) AADD(aRegim, L('арифметической прогрессии' )) AADD(aRegim, L('геометрической прогрессии' )) AADD(aRegim, L('ряда Фибоначчи' )) AADD(aRegim, L('ряда случайных чисел' )) DO CASE CASE mRegim = 1 // Загрузка символьного ряда из файла mInsElem = IF(nElement=1,.T.,.F.) IF nElement=1 mMess = '2.3.2.6. Сценарный АСК-анализ рядов слов (чисел). Загрузка ряда из файла: "'+cFile+'". Предыстория='+ALLTRIM(STR(mGroupPast))+'. Горизонт='+ALLTRIM(STR(mGroupFuture)) ELSE mMess = '2.3.2.6. Сценарный АСК-анализ рядов символов (цифр). Загрузка ряда из файла: "'+cFile+'". Предыстория='+ALLTRIM(STR(mGroupPast))+'. Горизонт='+ALLTRIM(STR(mGroupFuture)) ENDIF CASE mRegim <>1 // Генерация символьного ряда nElement = IF(mInsElem, 1, 2) IF nElement=1 mMess = '2.3.2.6. Сценарный АСК-анализ рядов слов (чисел). Генерация '+aRegim[mRegim]+'. Предыстория='+ALLTRIM(STR(mGroupPast))+'. Горизонт='+ALLTRIM(STR(mGroupFuture)) ELSE mMess = '2.3.2.6. Сценарный АСК-анализ рядов символов (цифр). Генерация '+aRegim[mRegim]+'. Предыстория='+ALLTRIM(STR(mGroupPast))+'. Горизонт='+ALLTRIM(STR(mGroupFuture)) ENDIF ENDCASE mApplName = L(mMess) ************************************************************************* ******** Формирование текстовой переменной с символами ****************** ************************************************************************* mInpData := "" // Текстовая переменная для загрузки текстового файла DO CASE CASE mRegim = 1 // Загрузка символьного ряда из файла: DIRCHANGE(Disk_dir+'\AID_DATA\Inp_data\') IF .NOT. FILE(cFile) Mess = L('В папке для исходных данных: "@" нет файла: "#"') Mess = STRTRAN(Mess, "@", M_ApplsPath+"\Inp_data\") Mess = STRTRAN(Mess, "#", cFile) LB_Warning(Mess, L('2.3.2.6. АСК-анализ рядов. Загрузка ряда')) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций *MsgBox('STOP') ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF mInpData = ALLTRIM(FILESTR(cFile)) // Загрузка текстового файла: cFile с исходными данными IF mUpper // Перевести все символы в заглавные mInpData = UPPER(mInpData) ELSE mInpData = LOWER(mInpData) ENDIF IF mBlank mInpData = CharOne(' ', mInpData) // Заменить любое количество подряд идущих пробелов на один пробел ENDIF mOptions = L('Загрузка символьного ряда из файла: "#". Количество элементов: прошлых-@1, будущих-@2"') mOptions = STRTRAN(mOptions, "#", cFile) mOptions = STRTRAN(mOptions, "@1", ALLTRIM(STR(mGroupPast))) mOptions = STRTRAN(mOptions, "@2", ALLTRIM(STR(mGroupFuture))) CASE mRegim = 2 // Расчет арифметической прогрессии FOR n = N1 TO N2 Xn = ROUND(N1+D*(n-1), 0) mInpData = mInpData + ALLTRIM(STR(Xn)) + IF(mInsElem,' ','') // Текстовая переменная для загрузки текстового файла NEXT mOptions = 'Расчет элементов арифметической прогрессии от: "#" до "@" с шагом "D".' mOptions = STRTRAN(mOptions, "#", ALLTRIM(STR(N1))) mOptions = STRTRAN(mOptions, "@", ALLTRIM(STR(N2))) mOptions = STRTRAN(mOptions, "D", ALLTRIM(STR(D))) CASE mRegim = 3 // Расчет геометрической прогрессии FOR n = N1 TO N2 Xn = ROUND(N1*Q^(n-1), 0) mInpData = mInpData + ALLTRIM(STR(Xn)) + IF(mInsElem,' ','') // Текстовая переменная для загрузки текстового файла NEXT mOptions = 'Расчет элементов геометрической прогрессии от: "#" до "@" со знаменталем "Q".' mOptions = STRTRAN(mOptions, "#", ALLTRIM(STR(N1))) mOptions = STRTRAN(mOptions, "@", ALLTRIM(STR(N2))) mOptions = STRTRAN(mOptions, "Q", ALLTRIM(STR(Q))) CASE mRegim = 4 // Расчет ряда Фибоначчи FOR n = N1 TO N2 SQRT5 = SQRT(5) Xn = 1/SQRT5*((1+SQRT5)/2)^n-1/SQRT5*((1-SQRT5)/2)^n Xn = ROUND(Xn, 0) mInpData = mInpData + ALLTRIM(STR(Xn)) + IF(mInsElem,' ','') // Текстовая переменная для загрузки текстового файла NEXT mOptions = 'Расчет элементов ряда Фибоначчи от: "#" до "@".' mOptions = STRTRAN(mOptions, "#", ALLTRIM(STR(N1))) mOptions = STRTRAN(mOptions, "@", ALLTRIM(STR(N2))) CASE mRegim = 5 // Расчет ряда случайных чисел (с равномерным рапределением) N1 = 1 N2 = R1 FOR j = N1 TO N2 Xn = SUBSTR(ALLTRIM(STR(RANDOM())),1,R2) mInpData = mInpData + ALLTRIM(Xn) + IF(mInsElem,' ','') // Текстовая переменная для загрузки текстового файла NEXT mOptions = 'Расчет # элементов ряда $-разрядных случайных чисел (с равномерным рапределением).' mOptions = STRTRAN(mOptions, "#", ALLTRIM(STR(R1))) mOptions = STRTRAN(mOptions, "$", ALLTRIM(STR(R2))) ENDCASE STRFILE(mOptions, 'Options.txt') STRFILE(mInpData, 'Inp_data.txt') *MsgBox('STOP') *################################################################################################### ******** Формирование БД Inp_data.dbf на основе текстовой переменной **** ################## CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * IF nElement=2 // элементы - СИМВОЛЫ <<<===##################### mCardinality = LEN(mInpData) IF mCardinality >= mGroupPast + mGroupFuture + 1 // <<<===########### ************************************************************************* ***** Создание БД Inp_data.dbf ****************************************** ************************************************************************* CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций CrLf = CHR(13)+CHR(10) // Конец строки (записи) mInpName := "" // TXT-переменная с наименованиями полей aStructure := { { "ObjName", "C", 19 , 0 }, ; { "Futur" , "C", mGroupFuture, 0 }, ; // Размер поля можно сделать меньше, чтобы БД Inp_data была меньше 2 Гб <<<===################## { "Past" , "C", mGroupPast , 0 } } // Размер поля можно сделать меньше, чтобы БД Inp_data была меньше 2 Гб <<<===################## DbCreate( "Inp_data.dbf" , aStructure ) DbCreate( "Inp_data_tmp.dbf", aStructure ) mInpName = mInpName + "Futur" + CrLf + "Past" + CrLf STRFILE(mInpName, "Inp_name.txt") CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Inp_data EXCLUSIVE NEW USE Inp_data_tmp EXCLUSIVE NEW nMax = mCardinality - ( mGroupPast + mGroupFuture ) Mess = L('2.3.2.6. АСК-анализ рядов символов. Формирование БД "Inp_data.dbf"') @ 4,5 DCPROGRESS oProgress2 SIZE 100,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 DCREAD GUI TITLE Mess PARENT @oDialog2 FIT EXIT oDialog2:show() nTime = 0 DC_GetProgress(oProgress,0,nMax) *** Начало цикла по элементам - СИМВОЛАМ (nElement=2) ******* * 3.14159265358979323846264338327950... это исходный текстовый файл mInpData * 123456789 * ffpp * ffpp * ffpp * ffpp * ffpp * ffpp ****************************************** ****** Обработка ошибки ****************** bError := ErrorBlock( {|e| Break(e)} ) // установить новый кодовый блок обработки ошибок BEGIN SEQUENCE // код нормального исполнения *** код нормального исполнения FOR t=1 TO mCardinality - ( mGroupPast + mGroupFuture ) + 1 // Цикл по текущим элементам mWordF = SUBSTR(mInpData, t, mGroupFuture) mWordP = SUBSTR(mInpData, t+ mGroupFuture, mGroupPast) SELECT Inp_data_tmp APPEND BLANK // Ошибка переполнения базы данных <<<===######################################## FIELDPUT(1, ALLTRIM(STR(t))) // Если при попытке добавлении записи в БД Inp_data_tmp возникает ошибка, то происходит выход из цикла, а БД Inp_data получается работоспособной FIELDPUT(2, mWordF) FIELDPUT(3, mWordP) SELECT Inp_data APPEND BLANK // Ошибка переполнения базы данных <<<===######################################## FIELDPUT(1, ALLTRIM(STR(t))) FIELDPUT(2, mWordF) FIELDPUT(3, mWordP) DC_GetProgress(oProgress2, ++nTime, nMax) NEXT RECOVER // код обработки ошибки aMess := {} AADD(aMess, L('При вводе исходных данных была попытка превышения максимального допустимого объема базы данных: 2 Гб.')) // НАПРИМЕР AADD(aMess, L('При продолжении будут обрабатываться данные максимально-возможного фактически достигнутого объема. ')) LB_Warning(aMess) * EXIT ENDSEQUENCE ErrorBlock( bError ) // переустановить старый кодовый ****************************************** ****************************************** * MsgBox('STOP') DC_GetProgress(oProgress2,nMax,nMax) oDialog2:Destroy() ENDIF * ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * QUIT * ################################################################################################## * ВСЕ РАСЧЕТЫ СДЕЛАТЬ В МАССИВЫ И ПОТОМ ФОРМИРОВАТЬ mInpData ИЗ МАССИВОВ <<<===##################### * Размер полей в БД Inp_data.dbf опрделить на основе массивов IF mInsElem // элементы - СЛОВА <<<===##################### CrLf = CHR(13)+CHR(10) // Конец строки (записи) mInpData = STRTRAN(mInpData,'.',' ') // Замена всех раздлелителей на пробелы mInpData = STRTRAN(mInpData,',',' ') mInpData = STRTRAN(mInpData,';',' ') mInpData = STRTRAN(mInpData,'!',' ') mInpData = STRTRAN(mInpData,'?',' ') mInpData = STRTRAN(mInpData,'(',' ') mInpData = STRTRAN(mInpData,')',' ') mInpData = STRTRAN(mInpData,CrLf,' ') IF mUpper // Перевести все символы в заглавные mInpData = UPPER(mInpData) ELSE mInpData = LOWER(mInpData) ENDIF IF mBlank mInpData = CharOne(' ', mInpData) // Заменить любое количество подряд идущих пробелов на один пробел ENDIF *** Формирование массива слов текста aWords := {} // Массив слов mCardinality = LEN(mInpData) mWord = '' FOR j=1 TO mCardinality mChar = SUBSTR(mInpData, j, 1) IF mChar <> ' ' mWord = mWord + mChar ELSE AADD(aWords, ALLTRIM(mWord)) mWord = mChar ENDIF NEXT AADD(aWords, ALLTRIM(mWord)) ****** Печать списка слов (отладка) <<<===### mWords = '' FOR j=1 TO LEN(aWords) mWords = mWords + aWords[j] + CrLf NEXT STRFILE(mWords, "_Words.txt") *** Формирование массивов предшествующих и последущих сочетаний слов текста *** Поиск максимальной длины предшествующих и последующих сочетаний слов aWordsPast := {} // Массив предшествующих слов aWordsFutur := {} // Массив предшествующих слов mWordsPastLen = -9999999 mWordsFuturLen = -9999999 mCardinality = LEN(aWords) IF mCardinality >= mGroupPast + mGroupFuture + 1 // <<<===########### nMax = mCardinality - ( mGroupPast + mGroupFuture ) Mess = L('2.3.2.6. АСК-анализ рядов слов. Формирование БД "Inp_data.dbf"') @ 4,5 DCPROGRESS oProgress2 SIZE 100,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 DCREAD GUI TITLE Mess PARENT @oDialog2 FIT EXIT oDialog2:show() nTime = 0 DC_GetProgress(oProgress,0,nMax) *** Начало цикла по элементам - СИМВОЛАМ (nElement=2) ******* * 3.14159265358979323846264338327950... это исходный текстовый файл mInpData * 123456789 * ffpp * ffpp * ffpp * ffpp * ffpp * ffpp FOR t=1 TO mCardinality - ( mGroupPast + mGroupFuture ) + 1 // Цикл по текущим элементам mWordsF = '' FOR j=1 TO mGroupFuture mWordsF = mWordsF + aWords[t+j-1] + ' ' NEXT AADD(aWordsFutur, ALLTRIM(mWordsF)) mWordsFuturLen = MAX(mWordsFuturLen, LEN(mWordsF)) mWordsP = '' FOR j=1 TO mGroupPast mWordsP = mWordsP + aWords[mGroupFuture+t+j-1] + ' ' NEXT AADD(aWordsPast, ALLTRIM(mWordsP)) mWordsPastLen = MAX(mWordsPastLen, LEN(mWordsP)) DC_GetProgress(oProgress2, ++nTime, nMax) NEXT ****** Печать списка предшествующих сочетаний слов (отладка) <<<===### mWordsPast = '' FOR j=1 TO LEN(aWordsPast) mWordsPast = mWordsPast + aWordsPast[j] + CrLf NEXT STRFILE(mWordsPast, "_WordsPast.txt") ****** Печать списка последующих сочетаний слов (отладка) <<<===### mWordsFutur = '' FOR j=1 TO LEN(aWordsFutur) mWordsFutur = mWordsFutur + aWordsFutur[j] + CrLf NEXT STRFILE(mWordsFutur, "_WordsFutur.txt") * MsgBox(STR(mWordsFuturLen)+STR(mWordsPastLen)) ************************************************************************* ***** Создание БД Inp_data.dbf ****************************************** ************************************************************************* CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций CrLf = CHR(13)+CHR(10) // Конец строки (записи) mInpName := "" // TXT-переменная с наименованиями полей aStructure := { { "ObjName", "C", 19 , 0 }, ; { "Futur" , "C", mWordsFuturLen, 0 }, ; // Размер поля можно сделать меньше, чтобы БД Inp_data была меньше 2 Гб <<<===################## { "Past" , "C", mWordsPastLen , 0 } } // Размер поля можно сделать меньше, чтобы БД Inp_data была меньше 2 Гб <<<===################## DbCreate( "Inp_data.dbf", aStructure ) mInpName = mInpName + "Futur" + CrLf + "Past" + CrLf STRFILE(mInpName, "Inp_name.txt") *** Запись БД Inp_data.dbf CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций СДЕЛАТЬ ОБРАБОТКУ ОШИБОК АНАЛОГИЧНО КАК С СИМВОЛАМИ USE Inp_data EXCLUSIVE NEW FOR j=1 TO LEN(aWordsFutur) APPEND BLANK FIELDPUT(1, ALLTRIM(STR(j))) FIELDPUT(2, aWordsFutur[j]) FIELDPUT(3, aWordsPast[j]) NEXT * MsgBox('STOP') DC_GetProgress(oProgress2,nMax,nMax) oDialog2:Destroy() ENDIF ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * QUIT *################################################################################################### // Создать файл параметров для режима 2.3.2.2. Regim = 1 // Формализации ПО или ген.расп.выб. Flag_zer = 1 // Считать нули и пробелы отсутствием данных? [1]-да, [2]-нет N_Chast = 1 // На сколько частей N разбивать обучающую или распознаваемую выборку (в зависимости от Regim) M_ClSc1 = 2 // Номер начального столбца диапазона классификационных шкал M_ClSc2 = 2 // Номер конечного столбца диапазона классификационных шкал M_OpSc1 = 3 // Номер начального столбца диапазона описательных шкал M_OpSc2 = 3 // Номер конечного столбца диапазона описательных шкал M_ObAnk = 3 // Создавать анкеты исходной выборки по строкам Inp_data-[1], по классам-[2], и 1-е, и 2-е [3] M_Interval = 1 // 1-равные интервалы, 2-адаптивные интервалы (с примерно равным количеством наблюдений, по Котельникову) N_SKGrCl = 30 N_SKGrPr = 30 K_N_ClSc = 1 K_N_OpSc = 1 K_N_GrClSc = 30 K_N_GrOpSc = 30 M_Scenario = .F. mGorizMin = 5 mGorizMax = 5 mGlubMin = 5 mGlubMax = 5 K_GradNClSc = 30 K_GradNOpSc = 30 M_ChastObi = .F. M_ChastRso = .F. N_ChastObi = 1 N_ChastRso = 1 M_XlsDbf = 3 // DBF - DBASE IV * mTxtCSField = 1 // Значения рассматриваются как: 1 - значения ячейки целиком; 2 - из элементов, разделенных разделителем (слов или чисел); 3 - состоящие из элементов - символов mTxtCSField = 1 // Способ интерпретации значений текстовых полей - классификационных шкал файла исходных данных mTxtOSField = 1 // Способ интерпретации значений текстовых полей - описательных шкал файла исходных данных mTxtCSSep = " " // Разделитель элементов классификационных шкал, если mTxtCSField=3 mTxtOSSep = " " // Разделитель элементов описательных шкал, если mTxtOSField=3 * mScenario = 1 // mScenario=1 Не применять сценарный метод АСК-анализа и спец.интерпретацию TXT-полей (старый вариант) mScenario = 1 // Не применять сценарный метод АСК-анализа mSpecInterprCls = .F. // Не применять спец.интерпретацию текстовых полей классов .F. mSpecInterprAtr = .F. // Не применять спец.интерпретацию текстовых полей признаков .F. mNameGrNumSc= 1 // Какие наименования ГРАДАЦИЙ числовых шкал использовать mClsAvr = .F. // .F. - делать модель из Inp_data, .T. - делать модель из Inp_data_avr mSortUnqCls = 1 // Выделять уникальные значения классов и сортировать, 1-да, 2-нет mLemmatCls = 2 // Проводить лемматизацию классов, 1-да, 2-нет mSortUnqGos = 1 // Выделять уникальные значения признаков и сортировать, 1-да, 2-нет mLemmatGos = 2 // Проводить лемматизацию признаков, 1-да, 2-нет // Сохранить файл с информацией о заданых параметрах программного интерфейса в текущей директории системы PRIVATE aSoftInt[40] aSoftInt[ 1] = Regim aSoftInt[ 2] = Flag_zer aSoftInt[ 3] = M_ClSc1 aSoftInt[ 4] = M_ClSc2 aSoftInt[ 5] = M_OpSc1 aSoftInt[ 6] = M_OpSc2 aSoftInt[ 7] = N_SKGrCl aSoftInt[ 8] = N_SKGrPr aSoftInt[ 9] = K_N_ClSc aSoftInt[10] = K_N_OpSc aSoftInt[11] = K_N_GrClSc aSoftInt[12] = K_N_GrOpSc aSoftInt[13] = M_ObAnk aSoftInt[14] = N_Chast aSoftInt[15] = M_Interval aSoftInt[16] = M_Scenario aSoftInt[17] = K_GradNClSc // Количество градаций в числовой классификационной шкале aSoftInt[18] = K_GradNOpSc // Количество градаций в числовой описательной шкале aSoftInt[19] = mGorizMin aSoftInt[20] = mGorizMax aSoftInt[21] = mGlubMin aSoftInt[22] = mGlubMax aSoftInt[23] = M_ChastObi aSoftInt[24] = M_ChastRso aSoftInt[25] = N_ChastObi aSoftInt[26] = N_ChastRso aSoftInt[27] = M_XlsDbf aSoftInt[28] = mTxtCSField aSoftInt[29] = mTxtOSField aSoftInt[30] = mTxtCSSep aSoftInt[31] = mTxtOSSep * aSoftInt[32] = mScenario // mScenario=1 Не применять сценарный метод АСК-анализа и спец.интерпретацию TXT-полей (старый вариант) aSoftInt[32] = mScenario // mScenario=1 Не применять сценарный метод АСК-анализа aSoftInt[33] = mSpecInterprCls // .T. - Применить спец.интерпретацию текстовых полей классов, .F. - не применять aSoftInt[34] = mSpecInterprAtr // .T. - Применить спец.интерпретацию текстовых полей признаков, .F. - не применять aSoftInt[35] = mNameGrNumSc // Какие наименования ГРАДАЦИЙ числовых шкал использовать aSoftInt[36] = mClsAvr // .F. = модель без усреднения по классам aSoftInt[37] = mSortUnqCls // Выделять уникальные значения классов и сортировать, 1-да, 2-нет aSoftInt[38] = IF(mSpecInterprCls,mLemmatCls,2) // Проводить лемматизацию классов, 1-да, 2-нет aSoftInt[39] = mSortUnqGos // Выделять уникальные значения признаков и сортировать, 1-да, 2-нет aSoftInt[40] = IF(mSpecInterprAtr,mLemmatGos,2) // Проводить лемматизацию признаков, 1-да, 2-нет DC_ASave(aSoftInt , Disk_dir +"\_2_3_2_2.arx") ***** Прошло секунд с начала процесса *********** Sec_2 = (DOY(DATE())-1)*86400+SECONDS() - Sec_1 Sec_2 = (DOY(DATE())-1)*86400+SECONDS() - Sec_1 ch2 = INT(Sec_2/3600) // Часы mm2 = INT(Sec_2/60)-ch2*60 // Минуты cc2 = Sec_2-ch2*3600-mm2*60 // Секунды Mess = L('Процесс создания БД "Inp_data.dbf" и "Inp_name.txt" завершился успешно! Время исполнения # секунд!') Mess = STRTRAN(Mess,"#",STRTRAN(STR(cc2,2)," ","0")) LB_Warning(Mess, L('2.3.2.6. АСК-анализ символьных и числовых рядов')) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** ************************************************************************ // Информация о типе используемого API для интеллектуальных облачных Эйдос-приложений, чтобы при их загрузке сразу запускать нужный API StrFile('API_type=2.3.2.6.', Disk_dir+'\AID_DATA\Inp_data\API_type.txt') ************************************************************************ // Создать новое приложение так же, как лабораторную работу *************************** M_NewAppl = ADD_ZAPPL(mApplName) * MsgBox(M_NewAppl) // Создать основные БД нового приложения ********************************************** DIRCHANGE(M_NewAppl) // Перейти в папку с БД новой модели и создать БД формализации предметной области: GenDbfClSc(.F.) // Классификационные шкалы GenDbfGrClSc(.F.) // Градации классификационных шкал GenDbfClass(.F.) // Классификационные шкалы и градации GenDbfOpSc(.F.) // Описательные шкалы GenDbfGrOpSc(.F.) // Градации описательных шкал GenDbfAttr(.F.) // Описательные шкалы и градации GenDbfObiZag() // Заголовки объектов обучающей выборки GenDbfObiKcl() // Коды классов объектов обучающей выборки GenDbfObiKpr() // Коды признаков объектов обучающей выборки GenDbfRsoZag() // Заголовки объектов распознаваемой выборки GenDbfRsoKcl() // Коды классов объектов распознаваемой выборки GenDbfRsoKpr() // Коды признаков объектов распознаваемой выборки *************************************************************************************** F2_3_2_2(L('2.3.2.6. АСК-анализ символьных и числовых рядов'),"2.3.2.6()") Running(.F.) RETURN NIL ************************************************************************************************** ************************************************************************************************** FUNCTION Help2326() aHelp := {} AADD(aHelp, L('Помощь по режиму: "2.3.2.6. Сценарный АСК-анализ символьных и числовых рядов". Режим обеспечивает импорт данных из ')) AADD(aHelp, L('DOS-TXT-рядов чисел (цифр) и слов (букв), а также генерацию рядов для расчета асимптотического информационного ')) AADD(aHelp, L('критерия качества шума, отражающего степень выраженности причинно-следственных закономерностей в предметной области.')) AADD(aHelp, L('Это позволяет применить сценарный метод АСК-анализа для исследования временных рядов и каузальные зависимостей ')) AADD(aHelp, L('будущих сценариев изменения величины от прошлых ')) AADD(aHelp, L(' ')) AADD(aHelp, L('1. Загрузить из папки исходных данных ../Inp_data/ DOS-TXT-файл с числами или словами (на любом языке), разделенными')) AADD(aHelp, L('пробелами или другими стандартными разделителями. Затем этот файл может быть обработан со следующим опциями: ')) AADD(aHelp, L('- элементы-слова (числа); ')) AADD(aHelp, L('- элементы-символы (цифры) (формируются путем программной обработки, если их не было); ')) AADD(aHelp, L('- перевести все символы в заглавные (чтобы не играл роль регистр); ')) AADD(aHelp, L('- убрать пробелы (заменить любое количество подряд идущих пробелов на один пробел). ')) AADD(aHelp, L(' ')) AADD(aHelp, L('2. Сформировать различные прогрессии и ряды псевдослучайных чисел с различными параметрами, которые затем ')) AADD(aHelp, L('используются точно также, как если бы они были загружены из внешнего файла. При этом внешний файл с этими данными ')) AADD(aHelp, L('также формируется и записывается в папку исходных данных: ../Aid_data/Inp_data/Inp_data.txt. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Параметр "Количество прошлых элементов:" задает количество элементов предыстории. Параметр "Количество будущих ')) AADD(aHelp, L('элементов:" задает количество элементов горизонта прогнозирования. Предшествующие элементы образуют описательные ')) AADD(aHelp, L('шкалы и градации сценариев-факторов, а последующие - классификационные шкалы и градации сценариев-классов. В моделях')) AADD(aHelp, L('вычисляется количество информации в предшествующих сценариях о наблюдении последующих сценариев. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Статья автора, в которой подробно описывается применение данного режима (версии, на момент написания статьи): ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Луценко Е.В. Асимптотический информационный критерий качества шума / Луценко Е.В., Орлов А.И. // Политематический ')) AADD(aHelp, L('сетевой электронный научный журнал Кубанского государственного аграрного университета (Научный журнал КубГАУ) ')) AADD(aHelp, L('[Электронный ресурс]. - Краснодар: КубГАУ, 2016. - №02(116). - IDA [article ID]: 1161602100. - Режим доступа: ')) AADD(aHelp, L('http://ej.kubagro.ru/2016/02/pdf/100.pdf, 3,125 у.п.л. ')) mHelpMax = -999;FOR h=1 TO LEN(aHelp);mHelpMax = MAX(mHelpMax, LEN(ALLTRIM(aHelp[h])));NEXT s=1;d=0.9;@0,0 DCGROUP oGroup1 CAPTION L(' ') SIZE mHelpMax-15, LEN(aHelp)*d+1.5 FOR h=1 TO LEN(aHelp);@s,2 DCSAY aHelp[h] SIZE 0 PARENT oGroup1;s=s+d;NEXT DCREAD GUI TO lExit FIT TITLE L('2.3.2.6. Импорт данных из DOS-TXT-рядов чисел (цифр) и слов (букв)') RETURN NIL ************************************************************************************************** ************************************************************************************************** ******** Помощь по режиму 4.7. ************************************************************************************************** FUNCTION Help47() aHelp := {} AADD(aHelp, L('Помощь по режиму: 4.7. АСК-анализ изображений по их спектрам в системе "Эйдос" ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Благодаря данному режиму система "Эйдос" может: ')) AADD(aHelp, L('1. Измерять спектры графических объектов (т.е. очень точно определять цвета, присутствующие в изображении). ')) AADD(aHelp, L('2. Формировать обобщенные спектры классов. При этом рассчитывается количество информации в каждом цвете обобщенного спектра класса ')) AADD(aHelp, L('о принадлежности конкретного объекта с этим цветом в спектре к данному классу. ')) AADD(aHelp, L('3. Сравнивать конкретные объекты с классами по их спектрам. При этом рассчитывается суммарное количество информации в цветах спектра ')) AADD(aHelp, L('конкретного объекта о его принадлежности к обобщенному образу класса. ')) AADD(aHelp, L('4. Сравнивать классы друг с другом по их спектрам. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('В качестве спектра изображения в системе рассматривается доля пикселей разных цветов в общем числе пикселей изображения. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Данный режим обеспечивает: ')) AADD(aHelp, L('- ввод изображений в систему по пикселям (для этого выполнить первые два режима подготовки данных); ')) AADD(aHelp, L('- измерение спектров изображений с заданным числом цветовых диапазонов (цветовых интервалов) (выполнить 4-й режим подготовки данных); ')) AADD(aHelp, L('- рассмотрение характеристик спектра конкретных изображений как их признаков при формировании моделей (наряду с пикселями); ')) AADD(aHelp, L('- вывод исходных изображения с их спектрами на экран и запись в виде файлов в папку: ..\AID_DATA\InpSpectrPix\. ')) AADD(aHelp, L('- формирование обобщенных спектров изображений, относящихся к различным группам, классам (обобщенные спектры классов); ')) AADD(aHelp, L('- количественное сравнение конкретных изображений по их спектрам с обобщенными спектрами классов, т.е. решение задачу идентификации ')) AADD(aHelp, L('(классификации, диагностики, распознавания, прогнозирования); ')) AADD(aHelp, L('- количественное сравнение обобщенных спектров классов друг с другом и решение задач кластерно-конструктивного анализа; ')) AADD(aHelp, L('- другие стандартные возможности работы системы "Эйдос" с созданными моделями, отражающими спектры изображений. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Исходные изображения должны быть в формате jpg или bmp и находиться непосредственно в папке: ../Aid_data/Inp_data/, если ставится ')) AADD(aHelp, L('формализации предметной области и синтеза модели, ../Aid_data/Inp_rasp/, если ставится цель формирования распознаваемой выборки. ')) AADD(aHelp, L('Для режимов спектрального анализа изображений не важно, как они масштабированы и повернуты, но желательно, чтобы они были без фона. ')) AADD(aHelp, L('Пакетные on-line сервисы, обеспечивающие "оконтуриване и удаление фона" изображений можно найти в Internet по запросу, который в кавычках.')) AADD(aHelp, L(' ')) AADD(aHelp, L('Порядок работы в системе "Эйдос" для создания и верификации моделей описан в режиме 6.4. ')) AADD(aHelp, L(' 1. Исходные изображения должны быть в папке: ../AID_DATA/INP_DATA/ без поддиректорий. Часть имени файла до тире: ')) AADD(aHelp, L('"-" , если оно есть, используется как имя класса, для формирования которого используется данное изображение. Если тире нет, то как имя ')) AADD(aHelp, L('класса используется имя файла изображения целиком. ')) AADD(aHelp, L(' 2. Для создания модели нужно в режиме 2.3.2.5 или "Подготовка данных" сбросить БД "Image.dbf" и ввести в нее исходные изображения, затем ')) AADD(aHelp, L('создать базу "Inp_data". ')) AADD(aHelp, L(' 3. После ввода изображений в систему (режим подготовки данных) необходимо создать модель в 3-м режиме АСК-анализа изображений ')) AADD(aHelp, L('по пикселям (режим 2.3.2.3 с параметрами по умолчанию). ')) AADD(aHelp, L(' 4. Посмотреть на классификационные шкалы и градации в режиме 2.1. ')) AADD(aHelp, L(' 5. Посмотреть на описательные шкалы и градации в режиме 2.2. ')) AADD(aHelp, L(' 6. Посмотреть на обучающую выборку в режиме 2.3.1. ')) AADD(aHelp, L(' 7. Посмотреть файл исходных данных Inp_data.xls или Inp_rasp.xls в папке: ../AID_DATA/INP_DATA/. ')) AADD(aHelp, L(' 8. Запустить режим синтеза и верификации моделей с параметрами по умолчанию (режим 3.5). ')) AADD(aHelp, L(' 9. Посмотреть сформированные модели в режиме 5.5. ')) AADD(aHelp, L('10. Посмотреть достоверность моделей в режиме 3.4. ')) AADD(aHelp, L('11. Посмотреть частотные распределения уровней сходства при истинно и ложно положительных и отрицательных решениях (режим 3.4). ')) AADD(aHelp, L('12. Сделать текущей наиболее достоверную модель по L2-критерию (в режиме 5.6). ')) AADD(aHelp, L('13. Провести распознавание в наиболее достоверной модели в режиме 4.1.2. ')) AADD(aHelp, L('14. Посмотреть результаты распознавания в режимах 4.1.3.1, 4.1.3.2 и других в 4.1.3. ')) AADD(aHelp, L('15. Провести анализ наиболее достоверной модели в 4-й подсистеме, в которой, в частности, можно сравнить классы по их обобщенным спектрам.')) AADD(aHelp, L(' ')) AADD(aHelp, L('При распознавании изображений по их спектрам в ранее созданной модели необходимо в режиме 2.3.2.5 или "Подготовка данных" сбросить ')) AADD(aHelp, L('БД "Image.dbf" и ввести в нее изображения из папки: ../Aid_data/Inp_rasp/, затем создать базу "Inp_rasp", ввести ее в систему в режиме ')) AADD(aHelp, L('2.3.2.3 и провести распознавание в режиме 4.1.2. Результаты распознавания будут в различных выходных формах режима 4.1.3. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Желательно, чтобы изображения были не более 640 на 480 пикселей, а лучше 400 pix - 300 pix по ширине или еще меньше, например 200 pix. ')) AADD(aHelp, L('Статьи автора, в которых подробно описывается применение данного режима, находятся в процессе подготовки к печати. Пакетное пребразование ')) AADD(aHelp, L('форматов графических файлов, их размеров и наименований обеспеxивает программа ACDSee. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Луценко Е.В. Автоматизированный системно-когнитивный спектральный анализ конкретных и обобщенных изображений в системе "Эйдос" (применение')) AADD(aHelp, L('теории информации и когнитивных технологий в спектральном анализе) / Е.В. Луценко // Политематический сетевой электронный научный журнал ')) AADD(aHelp, L('Кубанского государственного аграрного университета (Научный журнал КубГАУ) [Электронный ресурс]. - Краснодар: КубГАУ, 2017. - №04(128). ')) AADD(aHelp, L('С. 1 - 64. - IDA [article ID]: 1281704001. - Режим доступа: http://ej.kubagro.ru/2017/04/pdf/01.pdf, 4 у.п.л. ')) mHelpMax = -999;FOR h=1 TO LEN(aHelp);mHelpMax = MAX(mHelpMax, LEN(ALLTRIM(aHelp[h])));NEXT s=1;d=0.7;@0,0 DCGROUP oGroup1 CAPTION L(' ') SIZE mHelpMax-18, LEN(aHelp)*d+1.5 FOR h=1 TO LEN(aHelp);@s,2 DCSAY aHelp[h] SIZE 0 PARENT ogroup1;s=s+d;NEXT DCREAD GUI TO lExit FIT TITLE L('Помощь по режиму: 4.7. АСК-анализ изображений по их изобраениям в системе "Эйдос"') RETURN NIL ************************************************************************************************** ******** Help по когн.функциям FUNCTION Help48CognFun() LOCAL GetList := {}, aPres, oBrowse, oToolBar, aColors, bColor, GetOptions s=1 @s,1 DCSAY L('Визуализация прямых, обратных, позитивных, негативных, полностью и частично редуцированных когнитивных функций ') SAYSIZE 0;s=s+0.8 @s,1 DCSAY L('Когнитивная функция представляет собой графическое отображение силы и направления влияния различных значений ') SAYSIZE 0;s=s+0.8 @s,1 DCSAY L('некоторого фактора на переходы объекта управления в будущие состояния, соответствующие классам. Когнитивные ') SAYSIZE 0;s=s+0.8 @s,1 DCSAY L('функции представляют собой новый перспективный инструмент отражения и наглядной визуализации закономерностей ') SAYSIZE 0;s=s+0.8 @s,1 DCSAY L('и эмпирических законов. Разработка содержательной научной интерпретации когнитивных функций представляет собой ') SAYSIZE 0;s=s+0.8 @s,1 DCSAY L('способ познания природы, общества и человека. Когнитивные функции могут быть: прямые, отражающие зависимость ') SAYSIZE 0;s=s+0.8 @s,1 DCSAY L('классов от признаков, обобщающие информационные портреты признаков; обратные, отражающие зависимость признаков ') SAYSIZE 0;s=s+0.8 @s,1 DCSAY L('от классов, обобщающие информационные портреты классов; позитивные, показывающие чему способствуют система ') SAYSIZE 0;s=s+0.8 @s,1 DCSAY L('детерминации; негативные, отражающие чему препятствуют система детерминации; средневзвешенные, отражающие ') SAYSIZE 0;s=s+0.8 @s,1 DCSAY L('совокупное влияние всех значений факторов на поведение объекта (причем в качестве весов наблюдений используется ') SAYSIZE 0;s=s+0.8 @s,1 DCSAY L('количество информации в значении аргумента о значениях функции) различной степенью редукции или степенью ') SAYSIZE 0;s=s+0.8 @s,1 DCSAY L('детерминации, которая отражает в графической форме (в форме полосы) количество знаний в аргументе о значении ') SAYSIZE 0;s=s+0.8 @s,1 DCSAY L('функции и является аналогом и обобщением доверительного интервала. Если отобразить подматрицу матрицы знания, ') SAYSIZE 0;s=s+0.8 @s,1 DCSAY L('отображая цветом силу и направление влияния каждой градации некоторой описательной шкалы на переход объекта ') SAYSIZE 0;s=s+0.8 @s,1 DCSAY L('в состояния, соответствующие классам некоторой классификационной шкалы, то получим нередуцированную когнитивную ') SAYSIZE 0;s=s+0.8 @s,1 DCSAY L('функцию. Когнитивные функции являются наиболее развитым средством изучения причинно-следственных зависимостей ') SAYSIZE 0;s=s+0.8 @s,1 DCSAY L('в моделируемой предметной области, предоставляемым системой "Эйдос". Необходимо отметить, что на вид функций ') SAYSIZE 0;s=s+0.8 @s,1 DCSAY L('влияния математической моделью АСК-анализа не накладывается никаких ограничений, в частности, они могут быть и не ') SAYSIZE 0;s=s+0.8 @s,1 DCSAY L('дифференцируемые. См.: Луценко Е.В. Метод визуализации когнитивных функций - новый инструмент исследования ') SAYSIZE 0;s=s+0.8 @s,1 DCSAY L('эмпирических данных большой размерности / Е.В. Луценко, А.П. Трунев, Д.К. Бандык // Политематический сетевой ') SAYSIZE 0;s=s+0.8 @s,1 DCSAY L('электронный научный журнал Кубанского государственного аграрного университета (Научный журнал КубГАУ) ') SAYSIZE 0;s=s+0.8 @s,1 DCSAY L('[Электронный ресурс]. - Краснодар: КубГАУ, 2011. - №03(67). С. 240 - 282. - Шифр Информрегистра: 0421100012\0077.,') SAYSIZE 0;s=s+0.8 @s,1 DCSAY L('2,688 у.п.л. - Режим доступа: ') SAYSIZE 0;s=s+0.8 @s,1 DCSAY L('http://ej.kubagro.ru/2011/03/pdf/18.pdf') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://ej.kubagro.ru/2011/03/pdf/18.pdf', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} DCREAD GUI FIT MODAL TITLE L('Пояснение по когнитивным функциям') ReTURN nil ************************************************************************************************************************ FUNCTION GetPoints(oBitmap, oPS) PUBLIC GetList[0], mRegim := 0, nModel := 1, nRasp := 1, nKrit := 1, mNumColumn := 3, mTrend := 1 PUBLIC PointsCount := 100, TurnovCount := 5, MarkPoints := 1, OutRadius:=100, InnRadius:=10 // Параметры по умолчанию ******* Узнать разрешение экрана и не показывать изображений большой размерности **************** nWidth := AppDeskTop():currentSize()[1] // current screen size width in pixels nHeight := AppDeskTop():currentSize()[2] // current screen size height in pixels * nWidth = 1366 // <<<===########################## * nHeight = 768 * F4_8('L('4.7. АСК-анализ изображений по пикселям, спектрам и контурам')') // Если F4_8() запускается не из главного меню, а из F4_7(), то может работать на любом экране * IF mTitle = L('4.8. Геокогнитивная подсистема') // 4.8. Геокогнитивная подсистема работает только на экранах с разрешением 1920 x 1080 и более IF nWidth < 1800 aMess := {} AADD(aMess, L("Для правильного отображения графической формы")) AADD(aMess, L("необходимо разрешение экрана 1800 pix по горизонтали,")) AADD(aMess, L("а фактически установлено: ")+ALLTRIM(STR(nWidth))+" pix") LB_Warning(aMess ) Running(.F.) ReTURN NIL ENDIF IF nHeight < 850 aMess := {} AADD(aMess, L("Для правильного отображения графической формы")) AADD(aMess, L("необходимо разрешение экрана 850 pix по вертикали,")) AADD(aMess, L("а фактически установлено: ")+ALLTRIM(STR(nHeight))+" pix") LB_Warning(aMess ) Running(.F.) ReTURN NIL ENDIF * ENDIF ************************************************************************************************* s = 1 d = 0.85 @0, 0 DCGROUP oGroup1 CAPTION L('Задайте способ формирования базы облака точек:) "Points_XYZ"') SIZE 135.0, 22.0 @s, 2 DCRADIO mRegim VALUE 0 PROMPT L('Когнитивные функции, данные из моделей приложения') PARENT oGroup1;s1=s-1;s=s+d // Стереть файлы: _ColumnNames.arx и _482.txt s=s+d @s, 2 DCRADIO mRegim VALUE 1 PROMPT L('Генерация случайным образом' ) PARENT oGroup1;s1=s-1;s=s+d // Стереть файлы: _ColumnNames.arx и _482.txt @s, 2 DCRADIO mRegim VALUE 2 PROMPT L('Цветовое кольцо (круг)' ) PARENT oGroup1;s2=s-1;s=s+d // Стереть файлы: _ColumnNames.arx и _482.txt @s, 2 DCRADIO mRegim VALUE 3 PROMPT L('Цветовая обобщенная спираль Архимеда' ) PARENT oGroup1;s3=s-1;s=s+d // Стереть файлы: _ColumnNames.arx и _482.txt @s, 2 DCRADIO mRegim VALUE 4 PROMPT L('Цветовая логарифмическая спираль' ) PARENT oGroup1;s4=s-1;s=s+d // Стереть файлы: _ColumnNames.arx и _482.txt s=s+d @s, 2 DCRADIO mRegim VALUE 5 PROMPT L('Координаты и цвета точек из графического файла' ) PARENT oGroup1;s5=s-1;s=s+d // Стереть файлы: _ColumnNames.arx и _482.txt s=s+d @s, 2 DCRADIO mRegim VALUE 6 PROMPT L('Из 1d Excel-таблицы исходных данных: "Inp_map1.xls"') PARENT oGroup1;s6=s-1;s=s+d // Записать файлы: _ColumnNames.arx и _482.txt @s, 2 DCRADIO mRegim VALUE 7 PROMPT L('Из распознаваемой 1d Excel-таблицы: "Rsp_map1.xls"') PARENT oGroup1;s7=s-1;s=s+d // Записать файлы: _ColumnNames.arx и _482.txt s=s+d @s, 2 DCRADIO mRegim VALUE 8 PROMPT L('Из 2d Excel-таблицы исходных данных: "Inp_map2.dbf"') PARENT oGroup1;s8=s-1;s=s+d // Стереть файлы: _ColumnNames.arx и _482.txt @s, 2 DCRADIO mRegim VALUE 9 PROMPT L('Из распознаваемой 2d Excel-таблицы: "Rsp_map2.dbf"') PARENT oGroup1;s9=s-1;s=s+d // Стереть файлы: _ColumnNames.arx и _482.txt s=s+d @s, 2 DCRADIO mRegim VALUE 10 PROMPT L('Из базы исходных данных: "Inp_data.dbf"' ) PARENT oGroup1;s10=s-1;s=s+d // Записать файл: _482.txt @s, 2 DCRADIO mRegim VALUE 11 PROMPT L('Из распознаваемой выборки: "Inp_rasp.dbf"' ) PARENT oGroup1;s11=s-1;s=s+d // Записать файл: _482.txt @s, 2 DCRADIO mRegim VALUE 12 PROMPT L('Из итоговых результатов распознавания: "Rsp_IT.dbf"') PARENT oGroup1;s12=s-1;s=s+d // Записать файл: _483.txt s=s+d @s, 2 DCCHECKBOX mFlagCircle PROMPT L('Рисовать окружности?' ) PARENT oGroup1;s=s+d @s, 2 DCCHECKBOX mFlagRibs PROMPT L('Рисовать ребра в цветовой заливке?' ) PARENT oGroup1;s=s+d @s, 2 DCCHECKBOX mFlagsQuare PROMPT L('Квадратное поле рисования (Xmax=Ymax)?' ) PARENT oGroup1;s=s+d ***** Параметры **************************************************************************************************************** *------------------------------------------------------------------------------------------------------------------------------- IF ApplChange("") // Перейти в папку выбранного приложения или выйти из системы LB_Warning(L("Необходимо задать (выбрать) хотя бы одно текущее приложение !!!")) Running(.F.) RETURN NIL ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Class_Sc EXCLUSIVE NEW USE Opis_Sc EXCLUSIVE NEW SELECT Class_Sc DBGOTOP() ;mKodClSc1 = Kod_ClSc DBGOBOTTOM();mKodClSc2 = Kod_ClSc SELECT Opis_Sc DBGOTOP() ;mKodOpSc1 = Kod_OpSc DBGOBOTTOM();mKodOpSc2 = Kod_OpSc d1 = 48 d2 = 62 PUBLIC mCurrInf := 6 @s1-1,50 DCGROUP oGroup2 CAPTION L('Задайте модель и диапазоны шкал когнитивных функций:') SIZE 83,20.5 HIDE {||.NOT.mRegim=0} PARENT oGroup1 s=1 d=0.85 @ s,2 DCRADIO mCurrInf VALUE 1 PROMPT L('1. ABS - частный критерий: количество встреч сочетаний: "класс-признак" у объектов обуч.выборки') EDITPROTECT {||.NOT.mRegim=0} HIDE {||.NOT.mRegim=0} PARENT oGroup2;s=s+d @ s,2 DCRADIO mCurrInf VALUE 2 PROMPT L('2. PRC1 - частный критерий: усл. вероятность i-го признака среди признаков объектов j-го класса ') EDITPROTECT {||.NOT.mRegim=0} HIDE {||.NOT.mRegim=0} PARENT oGroup2;s=s+d @ s,2 DCRADIO mCurrInf VALUE 3 PROMPT L('3. PRC2 - частный критерий: условная вероятность i-го признака у объектов j-го класса ') EDITPROTECT {||.NOT.mRegim=0} HIDE {||.NOT.mRegim=0} PARENT oGroup2;s=s+1.2*d @ s,2 DCRADIO mCurrInf VALUE 4 PROMPT L('4. INF1 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC1 ') EDITPROTECT {||.NOT.mRegim=0} HIDE {||.NOT.mRegim=0} PARENT oGroup2;s=s+d @ s,2 DCRADIO mCurrInf VALUE 5 PROMPT L('5. INF2 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC2 ') EDITPROTECT {||.NOT.mRegim=0} HIDE {||.NOT.mRegim=0} PARENT oGroup2;s=s+d @ s,2 DCRADIO mCurrInf VALUE 6 PROMPT L('6. INF3 - частный критерий: Xи-квадрат, разности между фактическими и ожидаемыми абс.частотами ') EDITPROTECT {||.NOT.mRegim=0} HIDE {||.NOT.mRegim=0} PARENT oGroup2;s=s+d @ s,2 DCRADIO mCurrInf VALUE 7 PROMPT L('7. INF4 - частный критерий: ROI (Return On Investment); вероятности из PRC1 ') EDITPROTECT {||.NOT.mRegim=0} HIDE {||.NOT.mRegim=0} PARENT oGroup2;s=s+d @ s,2 DCRADIO mCurrInf VALUE 8 PROMPT L('8. INF5 - частный критерий: ROI (Return On Investment); вероятности из PRC2 ') EDITPROTECT {||.NOT.mRegim=0} HIDE {||.NOT.mRegim=0} PARENT oGroup2;s=s+d @ s,2 DCRADIO mCurrInf VALUE 9 PROMPT L('9. INF6 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC1 ') EDITPROTECT {||.NOT.mRegim=0} HIDE {||.NOT.mRegim=0} PARENT oGroup2;s=s+d @ s,2 DCRADIO mCurrInf VALUE 10 PROMPT L('10.INF7 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC2 ') EDITPROTECT {||.NOT.mRegim=0} HIDE {||.NOT.mRegim=0} PARENT oGroup2;s=s+1.7*d @ s , 5 DCSAY L('Коды начальной и конечной классификационных шкал:') HIDE {||.NOT.mRegim=0} PARENT oGroup2 @ s ,d1 DCGET mKodClSc1 PICTURE "#########" EDITPROTECT {||.NOT.mRegim=0} HIDE {||.NOT.mRegim=0} PARENT oGroup2 @ s ,d2 DCGET mKodClSc2 PICTURE "#########" EDITPROTECT {||.NOT.mRegim=0} HIDE {||.NOT.mRegim=0} PARENT oGroup2;s=s+1.2*d @ s , 5 DCSAY L('Код начальной и конечной описательных шкал:') HIDE {||.NOT.mRegim=0} PARENT oGroup2 @ s ,d1 DCGET mKodOpSc1 PICTURE "#########" EDITPROTECT {||.NOT.mRegim=0} HIDE {||.NOT.mRegim=0} PARENT oGroup2 @ s ,d2 DCGET mKodOpSc2 PICTURE "#########" EDITPROTECT {||.NOT.mRegim=0} HIDE {||.NOT.mRegim=0} PARENT oGroup2;s=s+1.7*d str1 = L('Пояснение по когнитивным функциям' ) str2 = L('Ссылки на публикации по когн.функциям') str3 = L('Подборка публ.по когнит. функциям' ) str4 = L('Подборку публ.по управл. знаниями' ) @ s, 5 DCPUSHBUTTON CAPTION str1 SIZE LEN(str2), 1.1 HIDE {||.NOT.mRegim=0} PARENT oGroup2 ACTION {||Help48CognFun()} @ s, 45 DCPUSHBUTTON CAPTION str3 SIZE LEN(str3), 1.1 HIDE {||.NOT.mRegim=0} PARENT oGroup2 ACTION {||ShellOpenFile("http://lc.kubagro.ru/Install_Aidos-X/PublCognFun.rar")};s=s+1.3*d @ s, 5 DCPUSHBUTTON CAPTION str2 SIZE LEN(str2), 1.1 HIDE {||.NOT.mRegim=0} PARENT oGroup2 ACTION {||Publ_CognFun()} @ s, 45 DCPUSHBUTTON CAPTION str4 SIZE LEN(str4), 1.1 HIDE {||.NOT.mRegim=0} PARENT oGroup2 ACTION {||ShellOpenFile("http://lc.kubagro.ru/Install_Aidos-X/PublUprZn.rar")};s=s+1.7*d a=1 mCognFun = 3 @ s,2 DCGROUP oGroup3 CAPTION L('Какие когнитивные функции отображать:') SIZE 79,4.5 HIDE {||.NOT.mRegim=0} PARENT oGroup2 @ a,2 DCRADIO mCognFun VALUE 1 PROMPT L('1. Только позитивные (точки максимума кол-ва информации в знач.аргумента о знач.функции)') EDITPROTECT {||.NOT.mRegim=0} HIDE {||.NOT.mRegim=0} PARENT oGroup3;a=a+d @ a,2 DCRADIO mCognFun VALUE 2 PROMPT L('2. Только негативные (точки минимума кол-ва информации в знач.аргумента о знач.функции)') EDITPROTECT {||.NOT.mRegim=0} HIDE {||.NOT.mRegim=0} PARENT oGroup3;a=a+d @ a,2 DCRADIO mCognFun VALUE 3 PROMPT L('3. И позитивные, и негативные когнитивные функции на одной экранной форме' ) EDITPROTECT {||.NOT.mRegim=0} HIDE {||.NOT.mRegim=0} PARENT oGroup3;a=a+1.2*d *------------------------------------------------------------------------------------------------------------------------------------------ @s1 ,50 DCGROUP oGroup2 CAPTION L('Количество точек:') SIZE 26, 2.5 HIDE {||.NOT.mRegim=1} PARENT oGroup1 @ 1 , 1 DCSAY L(" ") GET PointsCount PICTURE "##########" EDITPROTECT {||.NOT.mRegim=1} HIDE {||.NOT.mRegim=1} PARENT oGroup2 *------------------------------------------------------------------------------------------------------------------------------------------ t1 = L("Точек: ") t2 = L("Max радиус:") t3 = L("Min радиус:") @s2 ,50 DCGROUP oGroup2 CAPTION L('Задайте параметры:') SIZE 26, 4.5 HIDE {||.NOT.mRegim=2} PARENT oGroup1 @ 1 , 1 DCSAY t1 GET PointsCount PICTURE "#########" EDITPROTECT {||.NOT.mRegim=2} HIDE {||.NOT.mRegim=2} PARENT oGroup2 @ 2 , 1 DCSAY t2 GET OutRadius PICTURE "#########" EDITPROTECT {||.NOT.mRegim=2} HIDE {||.NOT.mRegim=2} PARENT oGroup2 @ 3 , 1 DCSAY t3 GET InnRadius PICTURE "#########" EDITPROTECT {||.NOT.mRegim=2} HIDE {||.NOT.mRegim=2} PARENT oGroup2 *------------------------------------------------------------------------------------------------------------------------------------------ t1 = L("Точек: ") t2 = L("Витков: ") @s3 ,50 DCGROUP oGroup2 CAPTION L('Задайте параметры:') SIZE 26, 5.5 HIDE {||.NOT.mRegim=3} PARENT oGroup1 @ 1 , 1 DCSAY t1 GET PointsCount PICTURE "#########" EDITPROTECT {||.NOT.mRegim=3} HIDE {||.NOT.mRegim=3} PARENT oGroup2 @ 2 , 1 DCSAY t2 GET TurnovCount PICTURE "#########" EDITPROTECT {||.NOT.mRegim=3} HIDE {||.NOT.mRegim=3} PARENT oGroup2 @ 3 , 2 DCRADIO mTrend VALUE 1 PROMPT L('Возрастание') EDITPROTECT {||.NOT.mRegim=3} HIDE {||.NOT.mRegim=3} PARENT oGroup2 @ 4 , 2 DCRADIO mTrend VALUE 2 PROMPT L('Убывание' ) EDITPROTECT {||.NOT.mRegim=3} HIDE {||.NOT.mRegim=3} PARENT oGroup2 *------------------------------------------------------------------------------------------------------------------------------------------ t1 = L("Точек: ") t2 = L("Витков: ") @s4 ,50 DCGROUP oGroup2 CAPTION L('Задайте параметры:') SIZE 26, 3.5 HIDE {||.NOT.mRegim=4} PARENT oGroup1 @ 1 , 1 DCSAY t1 GET PointsCount PICTURE "#########" EDITPROTECT {||.NOT.mRegim=4} HIDE {||.NOT.mRegim=4} PARENT oGroup2 @ 2 , 1 DCSAY t2 GET TurnovCount PICTURE "#########" EDITPROTECT {||.NOT.mRegim=4} HIDE {||.NOT.mRegim=4} PARENT oGroup2 *------------------------------------------------------------------------------------------------------------------------------------------ @s5 ,50 DCGROUP oGroup2 CAPTION L('Отмечать точки?' ) SIZE 26, 3.5 HIDE {||.NOT.mRegim=5} PARENT oGroup1 @ 1 , 2 DCRADIO MarkPoints VALUE 1 PROMPT L('Нет') EDITPROTECT {||.NOT.mRegim=5} HIDE {||.NOT.mRegim=5} PARENT oGroup2 @ 2 , 2 DCRADIO MarkPoints VALUE 2 PROMPT L('Да' ) EDITPROTECT {||.NOT.mRegim=5} HIDE {||.NOT.mRegim=5} PARENT oGroup2 *------------------------------------------------------------------------------------------------------------------------------------------ @s6 ,50 DCGROUP oGroup2 CAPTION L('Задайте параметры:') SIZE 26, 5.5 HIDE {||.NOT.mRegim=6} PARENT oGroup1 @ 1 , 2 DCRADIO nModel VALUE 1 PROMPT L('Визуализация знач.шкалы') EDITPROTECT {||.NOT.mRegim=6} HIDE {||.NOT.mRegim=6} PARENT oGroup2 @ 2 , 2 DCRADIO nModel VALUE 2 PROMPT L('Виз.шкалы+синтез модели') EDITPROTECT {||.NOT.mRegim=6} HIDE {||.NOT.mRegim=6} PARENT oGroup2 @ 3.2 ,0.7 DCSAY L(" ") GET mNumColumn PICTURE "#####" EDITPROTECT {||.NOT.mRegim=6} HIDE {||.NOT.mRegim=6} PARENT oGroup2 @ 3.2 ,11 DCSAY L("№ отобр. колонки" ) EDITPROTECT {||.NOT.mRegim=6} HIDE {||.NOT.mRegim=6} PARENT oGroup2 @ 4.2 ,11 DCSAY L('в "Inp_map1.xls"' ) EDITPROTECT {||.NOT.mRegim=6} HIDE {||.NOT.mRegim=6} PARENT oGroup2 *------------------------------------------------------------------------------------------------------------------------------------------ @s7 ,50 DCGROUP oGroup2 CAPTION L('Задайте параметры:') SIZE 26, 5.5 HIDE {||.NOT.mRegim=7} PARENT oGroup1 @ 1 , 2 DCRADIO nModel VALUE 1 PROMPT L('Визуализация знач.шкалы') EDITPROTECT {||.NOT.mRegim=7} HIDE {||.NOT.mRegim=7} PARENT oGroup2 @ 2 , 2 DCRADIO nModel VALUE 2 PROMPT L('Виз.шкалы+распознавание') EDITPROTECT {||.NOT.mRegim=7} HIDE {||.NOT.mRegim=7} PARENT oGroup2 @ 3.2 ,0.7 DCSAY L(" ") GET mNumColumn PICTURE "#####" EDITPROTECT {||.NOT.mRegim=7} HIDE {||.NOT.mRegim=7} PARENT oGroup2 @ 3.2 ,11 DCSAY L("№ отобр. колонки") EDITPROTECT {||.NOT.mRegim=7} HIDE {||.NOT.mRegim=7} PARENT oGroup2 @ 4.2 ,11 DCSAY L('в "Rsp_map1.xls"') EDITPROTECT {||.NOT.mRegim=7} HIDE {||.NOT.mRegim=7} PARENT oGroup2 *------------------------------------------------------------------------------------------------------------------------------------------ @s8 ,50 DCGROUP oGroup2 CAPTION L('Формировать модель?') SIZE 26, 3.5 HIDE {||.NOT.mRegim=8} PARENT oGroup1 @ 1 , 2 DCRADIO nModel VALUE 1 PROMPT L('Нет') EDITPROTECT {||.NOT.mRegim=8} HIDE {||.NOT.mRegim=8} PARENT oGroup2 @ 2 , 2 DCRADIO nModel VALUE 2 PROMPT L('Да' ) EDITPROTECT {||.NOT.mRegim=8} HIDE {||.NOT.mRegim=8} PARENT oGroup2 *------------------------------------------------------------------------------------------------------------------------------------------ @s9 ,50 DCGROUP oGroup2 CAPTION L('Распознавать?') SIZE 26, 3.5 HIDE {||.NOT.mRegim=9} PARENT oGroup1 @ 1 , 2 DCRADIO nRasp VALUE 1 PROMPT L('Нет') EDITPROTECT {||.NOT.mRegim=9} HIDE {||.NOT.mRegim=9} PARENT oGroup2 @ 2 , 2 DCRADIO nRasp VALUE 2 PROMPT L('Да' ) EDITPROTECT {||.NOT.mRegim=9} HIDE {||.NOT.mRegim=9} PARENT oGroup2 *--------------------------------------------------------------------------------------------------------------------------------------- @s10 ,50 DCGROUP oGroup2 CAPTION L('Задать № отображаемой шкалы:') SIZE 26, 3.5 HIDE {||.NOT.mRegim=10} PARENT oGroup1 @ 1 , 2 DCSAY L('в файле: "Inp_data.dbf"') EDITPROTECT {||.NOT.mRegim=10} HIDE {||.NOT.mRegim=10} PARENT oGroup2 @ 2.2 , 1 DCSAY L(" ") GET mNumColumn PICTURE "##########" EDITPROTECT {||.NOT.mRegim=10} HIDE {||.NOT.mRegim=10} PARENT oGroup2 *------------------------------------------------------------------------------------------------------------------------------------------ @s11 ,50 DCGROUP oGroup2 CAPTION L('Задать № отображаемой шкалы:') SIZE 26, 3.5 HIDE {||.NOT.mRegim=11} PARENT oGroup1 @ 1 , 2 DCSAY L('в файле: "Inp_rasp.dbf"') EDITPROTECT {||.NOT.mRegim=11} HIDE {||.NOT.mRegim=11} PARENT oGroup2 @ 2.2 , 1 DCSAY L(" ") GET mNumColumn PICTURE "##########" EDITPROTECT {||.NOT.mRegim=11} HIDE {||.NOT.mRegim=11} PARENT oGroup2 *------------------------------------------------------------------------------------------------------------------------------------------ @s12 ,50 DCGROUP oGroup2 CAPTION L('Интегральный критерий:') SIZE 26, 3.5 HIDE {||.NOT.mRegim=12} PARENT oGroup1 @ 1 , 2 DCRADIO nKrit VALUE 1 PROMPT L('Резонанс знаний' ) EDITPROTECT {||.NOT.mRegim=12} HIDE {||.NOT.mRegim=12} PARENT oGroup2 @ 2 , 2 DCRADIO nKrit VALUE 2 PROMPT L('Сумма знаний' ) EDITPROTECT {||.NOT.mRegim=12} HIDE {||.NOT.mRegim=12} PARENT oGroup2 ******************************************************************************************************************************************* DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; OPTIONS GetOptions ; ADDBUTTONS; MODAL ; TITLE L('4.8. Геокогнитивная подсистема "Эйдос"') ******************************************************************** IF lExit ** Button Ok ELSE RETURN NIL ENDIF ******************************************************************** ************ Проверки на корректность введенных параметров ********* ******************************************************************** IF PointsCount < 3 LB_Warning(L('Число точек должно быть больше 2'),L('4.8. Геокогнитивная подсистема "Эйдос"')) RETURN NIL ENDIF IF mNumColumn < 1 LB_Warning( L('Номер отображаемой колонки должен быть не меньше 1'),L('4.8. Геокогнитивная подсистема "Эйдос"' )) RETURN NIL ENDIF ** Проверка числа колонок на превышение * IF mRegim = 6 .OR. mRegim = 7 .OR. mRegim = 10 .OR. mRegim = 1 ** F480('Inp_map1.', mNumColumn) // Записать файлы: _ColumnNames.arx и _482.txt ** F482('Inp_map1.', mNumColumn) // Записать файлы: _ColumnNames.arx и _482.txt * aFile ='' * IF mRegim = 6;aFile = 'Inp_map1.xls';ENDIF * IF mRegim = 7;aFile = 'Rsp_map1.xls';ENDIF * IF mRegim =10;aFile = 'Inp_data.dbf';ENDIF * IF mRegim =11;aFile = 'Inp_rasp.dbf';ENDIF * DIRCHANGE(Disk_dir+"\AID_DATA\Inp_data\") * IF .NOT. FILE(aFile) * LB_Warning( L('В папке: ')+Disk_dir+L('\AID_DATA\Inp_data\ должен быть файл: "')+aFile+'"',L('4.8. Геокогнитивная подсистема "Эйдос"' )) * RETURN NIL * ENDIF * M_NewAppl = M_ApplsPath+"\Inp_data\" * DIRCHANGE(M_NewAppl) ** MsgBox(M_NewAppl) * IF AT('xls', aFile) > 0 // ПРЕОБРАЗОВАНИЕ: XLS => DBF * ENDIF * bFile = SUBSTR(aFile,1,AT('.', aFile)-1) * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * USE (bFile) EXCLUSIVE NEW * SELECT(bFile) * IF mNumColumn > FCOUNT() * aMess := {} * AADD(aMess, L('Номер отображаемой колонки: ')+ALLTRIM(STR(mNumColumn))) * AADD(aMess, L('не должен быть больше: ')+ALLTRIM(STR(FCOUNT()))) * AADD(aMess, L('числа колонок в файле: ')+aFile) * LB_Warning( aMess, L('4.8. Геокогнитивная подсистема "Эйдос"' )) * RETURN NIL * ENDIF * ENDIF ******* Вызов функций ************************************************************************ DIRCHANGE(Disk_dir) IF mFlagsQuare PUBLIC X_MaxW := 910, Y_MaxW := 910 // Размер графического окна для самого графика в пикселях ELSE PUBLIC X_MaxW := 1800, Y_MaxW := 850 // Размер графического окна для самого графика в пикселях ENDIF PUBLIC nXSize := X_MaxW-50 // Размер изображения в пикселях PUBLIC nYSize := Y_MaxW-50 DO CASE CASE mRegim = 0 // Визуализация когнитивных функций * MsgBox(STR(M_CurrInf)+STR(mKodClSc1)+STR(mKodClSc2)+STR(mKodOpSc1)+STR(mKodOpSc2)) *** Загрузить базы моделей ******************************************************* IF ApplChange("") // Перейти в папку выбранного приложения или выйти из системы LB_Warning(L("Необходимо задать (выбрать) хотя бы одно текущее приложение !!!")) Running(.F.) RETURN NIL ENDIF Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } M_Inf = Ar_Model[mCurrInf] IF .NOT. FILE(M_Inf+'.txt') LB_Warning(L("Необходимо выполнить режим 3.5 для создания и верификации моделей !!!")) // <<<===######### Пишет, хотя модели есть Running(.F.) * DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения DIRCHANGE(Disk_dir) // Перейти в папку с системой RETURN NIL ENDIF ConvTXTtoDBF() // Преобразование Abs, Prc#, Inf# из TXT в DBF ClearImageTr() // Очистка изображения ******************************************** *** Отображение заданных когнитивных функций ******************************************** IF FILEDATE("Cogn_fun",16) = CTOD("//") DIRMAKE("Cogn_fun") Mess = L('В папке текущего приложения: "#" не было директории "Cogn_fun" для когнитивных функций и она была создана!') Mess = STRTRAN(Mess, "#", UPPER(ALLTRIM(M_PathAppl))) LB_Warning(Mess, L('4.5. Визуализация когнитивных функций системы "Эйдос-Х++"' )) ENDIF nRun = 0 FOR mOpSc = mKodOpSc1 TO mKodOpSc2 FOR mClSc = mKodClSc1 TO mKodClSc2 nRun++ LC_CognFun(mCurrInf, mOpSc, mClSc, mCognFun, oBitmap, oPS ) // Отображение заданной когнитивной функции NEXT NEXT ***************************************************************************************** ***************************************************************************************** ***************************************************************************************** CASE mRegim = 1 // Генерация случайным образом RndGenPoints() // Стереть файлы: _ColumnNames.arx и _482.txt CASE mRegim = 2 // Цветовой круг CircleColor() // Стереть файлы: _ColumnNames.arx и _482.txt CASE mRegim = 3 // Цветовая спираль Архимеда ArchimSpiral() // Стереть файлы: _ColumnNames.arx и _482.txt CASE mRegim = 4 // Цветовая логарифмическая спираль LogarSpiral() // Стереть файлы: _ColumnNames.arx и _482.txt CASE mRegim = 5 // Координаты и цвета точек из графического файла CoordPointsFile() // Стереть файлы: _ColumnNames.arx и _482.txt CASE mRegim = 6 // Из исходной 1d Excel-таблицы исходных данных: "Inp_map1.dbf" F480('Inp_map1.', mNumColumn, 6) // Записать файлы: _ColumnNames.arx и _482.txt CASE mRegim = 7 // Из распознаваемой 1d Excel-таблицы: "Rsp_map1.dbf" F480('Rsp_map1.', mNumColumn, 7) // Записать файлы: _ColumnNames.arx и _482.txt CASE mRegim = 8 // Из 2d Excel-таблицы исходных данных: "Inp_map2.dbf" <################################ F481('Inp_map2.') // Стереть файлы: _ColumnNames.arx и _482.txt CASE mRegim = 9 // Из распознаваемой 2d Excel-таблицы: "Rsp_map2.dbf" <################################ F481('Rsp_map2.') // Стереть файлы: _ColumnNames.arx и _482.txt CASE mRegim = 10 // Из базы исходных данных: "Inp_data.dbf" F482('Inp_map1.', mNumColumn, 10) // Записать файлы: _ColumnNames.arx и _482.txt CASE mRegim = 11 // Из распознаваемой выборки: "Inp_rasp.dbf" F482('Rsp_map1.', mNumColumn, 10) // Записать файлы: _ColumnNames.arx и _482.txt CASE mRegim = 12 // Из итоговых результатов распознавания: "Rsp_IT.dbf" F483(nKrit) // Записать файлы: _ColumnNames.arx и _483.txt <################################ ENDCASE RETURN NIL *********************************************************** ******** Отображение заданной когнитивной функции *********************************************************** FUNCTION LC_CognFun(mCurrInf, mOpSc, mClSc, mCognFun, oBitmap, oPS ) LOCAL GetList[0], GetOptions, oSay, oDevice, aMatrix LOCAL aX[100000], aY[100000], aZ[100000] // Координаты X,Y,Z точек облака *** АЛГОРИТМ: ************************************************************************************************************** *** 1. Создать БД облака точек: Points_XYZ.DBF из заданной модели M_CurrInf и заданных описательной и классификационной шкал *** 2. Провести триангуляцию *** 3. Провести заливку цветом *** 4. Нарисовать редуцированную когн.функцию y=f(x) по максимумам информации *** 5. Нарисовать оси и сетку по интервальным значениям *** 6. Сделать заголовок и надписи по осям и по легенде *** 7. Записать файл изображения с именем: "Модель-код опис.шкалы-код клас.шкалы" **************************************************************************************************************************** IF ApplChange("") // Перейти в папку выбранного приложения или выйти из системы LB_Warning(L("Необходимо задать (выбрать) хотя бы одно текущее приложение !!!")) Running(.F.) RETURN NIL ENDIF Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } M_Inf = Ar_Model[mCurrInf] IF .NOT. FILE(M_Inf+'.dbf') LB_Warning(L("Необходимо выполнить режим 3.5 для создания и верификации моделей !!!")) Running(.F.) * DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения DIRCHANGE(Disk_dir) // Перейти в папку с системой RETURN NIL ENDIF *** 1. Создать БД облака точек: Points_XYZ.DBF из заданной модели M_CurrInf и заданных описательной и классификационной шкал AFILL(aX,0) AFILL(aY,0) AFILL(aZ,0) * ClearImageTr() // Очистка изображения DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } DO CASE CASE mCognFun = 1 cFileName = Ar_Model[mCurrInf]+'-'+STRTRAN(STR(mOpSc,4),' ','0')+'-'+STRTRAN(STR(mClSc,4),' ','0')+'-Pos.bmp' CASE mCognFun = 2 cFileName = Ar_Model[mCurrInf]+'-'+STRTRAN(STR(mOpSc,4),' ','0')+'-'+STRTRAN(STR(mClSc,4),' ','0')+'-Neg.bmp' CASE mCognFun = 3 cFileName = Ar_Model[mCurrInf]+'-'+STRTRAN(STR(mOpSc,4),' ','0')+'-'+STRTRAN(STR(mClSc,4),' ','0')+'-PosNeg.bmp' ENDCASE oScrn := DC_WaitOn(L('Расчет когнитивной функции: "')+cFileName+'"',,,,,,,,,,,.F.) M_Inf = Ar_Model[mCurrInf] CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (M_Inf) EXCLUSIVE NEW USE Classes EXCLUSIVE NEW USE Class_Sc EXCLUSIVE NEW USE Gr_ClSc EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW USE Opis_Sc EXCLUSIVE NEW USE Gr_OpSc EXCLUSIVE NEW SELECT Class_Sc DBGOTO(mClSc) mNameClSc = ALLTRIM(Name_ClSc) mKodGrClSc1 = KodGr_Min mKodGrClSc2 = KodGr_Max SELECT Opis_Sc DBGOTO(mOpSc) mNameOpSc = ALLTRIM(Name_OpSc) mKodGrOpSc1 = KodGr_Min mKodGrOpSc2 = KodGr_Max aNameCls := {} SELECT Gr_ClSc SET FILTER TO Kod_ClSc=mClSc DBGOTOP() DO WHILE .NOT. EOF() AADD(aNameCls, DelZeroNameGr(Name_GrCS) ) DBSKIP(1) ENDDO aNameAtr := {} SELECT Gr_OpSc SET FILTER TO Kod_OpSc=mOpSc DBGOTOP() DO WHILE .NOT. EOF() AADD(aNameAtr, DelZeroNameGr(Name_GrOS) ) DBSKIP(1) ENDDO SELECT Classes SET FILTER TO Kod_ClSc=mClSc DBGOTOP() IF SUBSTR(Name_cls,1,12) = 'SPECTRINTERV' aRGBCls := {} // Массив цветов признаков, если спектр ENDIF DO WHILE .NOT. EOF() IF SUBSTR(Name_cls,1,12) = 'SPECTRINTERV' * SpectrInterv: 999/999-{123,123,123} * 123456789012 R G B mPosR1 = AT('{', Name_cls)+1 mPosR2 = mPosR1+2 mPosG1 = mPosR2+2 mPosG2 = mPosG1+2 mPosB1 = mPosG2+2 mPosB2 = mPosB1+2 mRed = VAL(SUBSTR(Name_cls, mPosR1, mPosR2-mPosR1+1)) mGreen = VAL(SUBSTR(Name_cls, mPosG1, mPosG2-mPosG1+1)) mBlue = VAL(SUBSTR(Name_cls, mPosB1, mPosB2-mPosB1+1)) * MsgBox(Name_cls+' '+STR(mRed)+','+STR(mGreen)+','+STR(mBlue)) fColor := GraMakeRGBColor({ mRed, mGreen, mBlue}) * SetPixel(hDC1, x, y, AutomationTranslateColor(fColor,.f.) ) * AADD(aRGBCls, AutomationTranslateColor(fColor,.f.)) AADD(aRGBCls, fColor) ENDIF DBSKIP(1) ENDDO SELECT Attributes SET FILTER TO Kod_OpSc=mOpSc DBGOTOP() IF SUBSTR(Name_atr,1,12) = 'SPECTRINTERV' aRGBAtr := {} // Массив цветов признаков, если спектр ENDIF DO WHILE .NOT. EOF() IF SUBSTR(Name_atr,1,12) = 'SPECTRINTERV' * SpectrInterv: 999/999-{123,123,123} * 123456789012 R G B mPosR1 = AT('{', Name_atr)+1 mPosR2 = mPosR1+2 mPosG1 = mPosR2+2 mPosG2 = mPosG1+2 mPosB1 = mPosG2+2 mPosB2 = mPosB1+2 mRed = VAL(SUBSTR(Name_atr, mPosR1, mPosR2-mPosR1+1)) mGreen = VAL(SUBSTR(Name_atr, mPosG1, mPosG2-mPosG1+1)) mBlue = VAL(SUBSTR(Name_atr, mPosB1, mPosB2-mPosB1+1)) * MsgBox(Name_atr+' '+STR(mRed)+','+STR(mGreen)+','+STR(mBlue)) fColor := GraMakeRGBColor({ mRed, mGreen, mBlue}) * SetPixel(hDC1, x, y, AutomationTranslateColor(fColor,.f.) ) * AADD(aRGBAtr, AutomationTranslateColor(fColor,.f.)) AADD(aRGBAtr, fColor) ENDIF DBSKIP(1) ENDDO aMinGrIntCls := {} aMaxGrIntCls := {} aAvrGrIntCls := {} SELECT Classes SET FILTER TO Kod_ClSc=mClSc DBGOTOP() DO WHILE .NOT. EOF() mNameGr = Name_cls IF Min_GrInt+Max_GrInt+Avr_GrInt > 0 .AND. NUMTOKEN(mNameGr,',')=1 .AND. NUMTOKEN(mNameGr,'{')=1 .AND. NUMTOKEN(mNameGr,'}')=1 // Если классификационная шкала числовая AADD(aMinGrIntCls, Min_GrInt) AADD(aMaxGrIntCls, Max_GrInt) AADD(aAvrGrIntCls, Avr_GrInt) ELSE // Если классификационная шкала текстовая AADD(aMinGrIntCls, Kod_cls-1.0) AADD(aMaxGrIntCls, Kod_cls ) AADD(aAvrGrIntCls, Kod_cls-0.5) ENDIF DBSKIP(1) ENDDO aMinGrIntAtr := {} aMaxGrIntAtr := {} aAvrGrIntAtr := {} SELECT Attributes SET FILTER TO Kod_OpSc=mOpSc DBGOTOP() DO WHILE .NOT. EOF() mNameGr = Name_atr IF Min_GrInt+Max_GrInt+Avr_GrInt > 0 .AND. NUMTOKEN(mNameGr,',')=1 .AND. NUMTOKEN(mNameGr,'{')=1 .AND. NUMTOKEN(mNameGr,'}')=1 // Если описательная шкала числовая AADD(aMinGrIntAtr, Min_GrInt) AADD(aMaxGrIntAtr, Max_GrInt) AADD(aAvrGrIntAtr, Avr_GrInt) ELSE // Если описательная шкала текстовая AADD(aMinGrIntAtr, Kod_atr-1.0) AADD(aMaxGrIntAtr, Kod_atr ) AADD(aAvrGrIntAtr, Kod_atr-0.5) ENDIF DBSKIP(1) ENDDO SELECT (M_Inf) PointsCount = 0 // Количество точек **** Координаты точек позитивных и негативных редуцированных когнитивных функций aXcfPos := {} aYcfPos := {} aZcfPos := {} aXcfNeg := {} aYcfNeg := {} aZcfNeg := {} Krnd2 = 0 FOR mKodGrOpSc = mKodGrOpSc1 TO mKodGrOpSc2 DBGOTO(mKodGrOpSc) mXcfPos = -9999999 mYcfPos = -9999999 mZcfPos = -9999999 mXcfNeg = +9999999 mYcfNeg = +9999999 mZcfNeg = +9999999 FOR mKodGrClSc = mKodGrClSc1 TO mKodGrClSc2 PointsCount++ IF aMinGrIntAtr[mKodGrOpSc-mKodGrOpSc1+1]+aMaxGrIntAtr[mKodGrOpSc-mKodGrOpSc1+1]+aAvrGrIntAtr[mKodGrOpSc-mKodGrOpSc1+1] > 0 // Если описательная шкала числовая aX[PointsCount] = aAvrGrIntAtr[mKodGrOpSc-mKodGrOpSc1+1] * (1+IF(RANDOM(.T.)>0,1,-1)*Krnd2) // Если шкалы числовые, то брать среднее числового интервального значения ELSE aX[PointsCount] = mKodGrOpSc * (1+IF(RANDOM(.T.)>0,1,-1)*Krnd2) // Если шкалы текстовые, то брать код градации описательной шкалы ENDIF IF aMinGrIntCls[mKodGrClSc-mKodGrClSc1+1]+aMaxGrIntCls[mKodGrClSc-mKodGrClSc1+1]+aAvrGrIntCls[mKodGrClSc-mKodGrClSc1+1] > 0 // Если классификационная шкала числовая aY[PointsCount] = aAvrGrIntCls[mKodGrClSc-mKodGrClSc1+1] * (1+IF(RANDOM(.T.)>0,1,-1)*Krnd2) // Если шкалы числовые, то брать среднее числового интервального значения ELSE aY[PointsCount] = mKodGrClSc * (1+IF(RANDOM(.T.)>0,1,-1)*Krnd2) // Если шкалы текстовые, то брать код градации описательной шкалы ENDIF aZ[PointsCount] = FIELDGET(2+mKodGrClSc) IF aZ[PointsCount] > mZcfPos mXcfPos = aX[PointsCount] mYcfPos = aY[PointsCount] mZcfPos = aZ[PointsCount] ENDIF IF aZ[PointsCount] < mZcfNeg mXcfNeg = aX[PointsCount] mYcfNeg = aY[PointsCount] mZcfNeg = aZ[PointsCount] ENDIF NEXT AADD(aXcfPos, mXcfPos) AADD(aYcfPos, mYcfPos) AADD(aZcfPos, mZcfPos) AADD(aXcfNeg, mXcfNeg) AADD(aYcfNeg, mYcfNeg) AADD(aZcfNeg, mZcfNeg) NEXT ************* Визуализация облака точек когнитивной функции X_Max := 1800 Y_Max := 850 // Размер графического окна для самого графика в пикселях ***** Задать атрибуты линии aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT graSetAttrLine( oPS, aAttr ) * PointsCount // число точек **** Поиск минимальных и максимальных X и Y и нормирование mMinXcf = +99999999999 mMaxXcf = -99999999999 mMinYcf = +99999999999 mMaxYcf = -99999999999 FOR p=1 TO PointsCount mMinXcf = MIN(mMinXcf, aX[p]) mMaxXcf = MAX(mMaxXcf, aX[p]) mMinYcf = MIN(mMinYcf, aY[p]) mMaxYcf = MAX(mMaxYcf, aY[p]) NEXT Kx = 0.6 Ky = 0.6 dXcf = (X_Max-Kx*X_Max)/2 - 120 // По сути это 0 по оси X dYcf = (Y_Max-Ky*Y_Max)/2 + 70 // По сути это 0 по оси Y FOR p=1 TO PointsCount aX[p] = Kx * X_Max * ( aX[p] - mMinXcf) / (mMaxXcf - mMinXcf) + dXcf aY[p] = Ky * Y_Max * ( aY[p] - mMinYcf) / (mMaxYcf - mMinYcf) + dYcf NEXT FOR p=1 TO LEN(aXcfPos) aXcfPos[p] = Kx * X_Max * ( aXcfPos[p] - mMinXcf) / (mMaxXcf - mMinXcf) + dXcf aYcfPos[p] = Ky * Y_Max * ( aYcfPos[p] - mMinYcf) / (mMaxYcf - mMinYcf) + dYcf NEXT FOR p=1 TO LEN(aXcfNeg) aXcfNeg[p] = Kx * X_Max * ( aXcfNeg[p] - mMinXcf) / (mMaxXcf - mMinXcf) + dXcf aYcfNeg[p] = Ky * Y_Max * ( aYcfNeg[p] - mMinYcf) / (mMaxYcf - mMinYcf) + dYcf NEXT FOR p=1 TO LEN(aMinGrIntAtr) aMinGrIntAtr[p] = Kx * X_Max * ( aMinGrIntAtr[p] - mMinXcf) / (mMaxXcf - mMinXcf) + dXcf aMaxGrIntAtr[p] = Kx * X_Max * ( aMaxGrIntAtr[p] - mMinXcf) / (mMaxXcf - mMinXcf) + dXcf aAvrGrIntAtr[p] = Kx * X_Max * ( aAvrGrIntAtr[p] - mMinXcf) / (mMaxXcf - mMinXcf) + dXcf NEXT FOR p=1 TO LEN(aMinGrIntCls) aMinGrIntCls[p] = Ky * Y_Max * ( aMinGrIntCls[p] - mMinYcf) / (mMaxYcf - mMinYcf) + dYcf aMaxGrIntCls[p] = Ky * Y_Max * ( aMaxGrIntCls[p] - mMinYcf) / (mMaxYcf - mMinYcf) + dYcf aAvrGrIntCls[p] = Ky * Y_Max * ( aAvrGrIntCls[p] - mMinYcf) / (mMaxYcf - mMinYcf) + dYcf NEXT **** Макс.значения координат по X и Y p = LEN(aAvrGrIntCls) mMaxYcf = aAvrGrIntCls[p] p = LEN(aAvrGrIntAtr) mMaxXcf = aAvrGrIntAtr[p] DIRCHANGE(Disk_dir) // Перейти в папку с системой Эйдос ***** Создать БД для координат X,Y,Z точек облака aStructure := { { "Num" , "N", 15, 0 }, ; { "pX" , "N", 19, 7 }, ; { "pY" , "N", 19, 7 }, ; { "pZ" , "N", 19, 7 }, ; { "pRed" , "N", 3, 0 }, ; { "pGreen", "N", 3, 0 }, ; { "pBlue" , "N", 3, 0 } } DbCreate( 'Points_XYZ', aStructure ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Points_XYZ EXCLUSIVE NEW SELECT Points_XYZ FOR p=1 TO PointsCount APPEND BLANK REPLACE Num WITH p REPLACE pX WITH aX[p] REPLACE pY WITH aY[p] REPLACE pZ WITH aZ[p] NEXT CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * LB_Warning(L('Построение точек завершено','4.8. Когнитивные функции системы "Эйдос"' ) *** 2. Провести триангуляцию Triangulation(.F.) * Triangulation(.T.) *** 3. Провести заливку цветом ClearImageTr() // Очистка изображения DC_Impl(oScrn) StrFile('Нормировать цвет', '_NormColor.txt') * M_CurrInf = FileStr('_NormColor.txt') Shading(.F.) *** 4. Нарисовать редуцированную когн.функцию y=f(x) ** Нарисовать позитивную редуцированную когн.функцию y=f(x) по максимумам информации и точки значений нередуцированной когн.функции IF mCognFun = 1 .OR. mCognFun = 3 FOR j=1 TO LEN(aXcfPos)-1 aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := aCOLOR[192] // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 5 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты GraLine( oPS, {aXcfPos[j], aYcfPos[j]}, {aXcfPos[j+1], aYcfPos[j+1]} ) aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := aCOLOR[193] // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты GraLine( oPS, {aXcfPos[j], aYcfPos[j]}, {aXcfPos[j+1], aYcfPos[j+1]} ) aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := aCOLOR[190] // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты GraLine( oPS, {aXcfPos[j], aYcfPos[j]}, {aXcfPos[j+1], aYcfPos[j+1]} ) ***** Нарисовать опорные точки aAttr [ GRA_AL_COLOR ] := GRA_CLR_BLUE // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 2 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraArc ( oPS, { aXcfPos[j], aYcfPos[j] }, 3 ) // Рисует круг стилем линии aAttr [ GRA_AL_COLOR ] := GRA_CLR_DARKGRAY // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraArc ( oPS, { aXcfPos[j], aYcfPos[j] }, 4 ) // Рисует круг стилем линии NEXT ***** Нарисовать последнюю опорную точку j = LEN(aXcfPos) aAttr [ GRA_AL_COLOR ] := GRA_CLR_BLUE // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 2 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraArc ( oPS, { aXcfPos[j], aYcfPos[j] }, 3 ) // Рисует круг стилем линии aAttr [ GRA_AL_COLOR ] := GRA_CLR_DARKGRAY // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraArc ( oPS, { aXcfPos[j], aYcfPos[j] }, 4 ) // Рисует круг стилем линии ENDIF ** Нарисовать негативную редуцированную когн.функцию y=f(x) по минимума информации и точки значений нередуцированной когн.функции IF mCognFun = 2 .OR. mCognFun = 3 FOR j=1 TO LEN(aXcfNeg)-1 aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := aCOLOR[12] // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 5 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты GraLine( oPS, {aXcfNeg[j], aYcfNeg[j]}, {aXcfNeg[j+1], aYcfNeg[j+1]} ) aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := aCOLOR[9] // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты GraLine( oPS, {aXcfNeg[j], aYcfNeg[j]}, {aXcfNeg[j+1], aYcfNeg[j+1]} ) aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := aCOLOR[34] // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты GraLine( oPS, {aXcfNeg[j], aYcfNeg[j]}, {aXcfNeg[j+1], aYcfNeg[j+1]} ) ***** Нарисовать опорные точки aAttr [ GRA_AL_COLOR ] := GRA_CLR_RED // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 2 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraArc ( oPS, { aXcfNeg[j], aYcfNeg[j] }, 3 ) // Рисует круг стилем линии aAttr [ GRA_AL_COLOR ] := GRA_CLR_DARKGRAY // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraArc ( oPS, { aXcfNeg[j], aYcfNeg[j] }, 4 ) // Рисует круг стилем линии NEXT ***** Нарисовать последнюю опорную точку j = LEN(aXcfNeg) aAttr [ GRA_AL_COLOR ] := GRA_CLR_RED // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 2 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraArc ( oPS, { aXcfNeg[j], aYcfNeg[j] }, 3 ) // Рисует круг стилем линии aAttr [ GRA_AL_COLOR ] := GRA_CLR_DARKGRAY // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraArc ( oPS, { aXcfNeg[j], aYcfNeg[j] }, 4 ) // Рисует круг стилем линии ENDIF * FOR p=1 TO PointsCount * aAttr [ GRA_AL_COLOR ] := GRA_CLR_RED // Задать цвет линии * aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии * graSetAttrLine( oPS, aAttr ) * GraArc ( oPS, { aX[p], aY[p] }, 2 ) // Рисует круг стилем линии * aAttr [ GRA_AL_COLOR ] := GRA_CLR_DARKGRAY // Задать цвет линии * aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии * graSetAttrLine( oPS, aAttr ) * GraArc ( oPS, { aX[p], aY[p] }, 3 ) // Рисует круг стилем линии * NEXT *** 5. Нарисовать оси и сетку по числовым интервальным значениям или текстовым градациям aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты *** Горизонтальные линии FOR j=2 TO LEN(aMinGrIntCls)-1 GraLine( oPS, { dXcf, aMinGrIntCls[j] }, { Kx*X_Max+dXcf, aMinGrIntCls[j] } ) GraLine( oPS, { dXcf, aMaxGrIntCls[j] }, { Kx*X_Max+dXcf, aMaxGrIntCls[j] } ) NEXT *** Вертикальные линии FOR j=2 TO LEN(aMinGrIntAtr)-1 GraLine( oPS, { aMinGrIntAtr[j], dYcf }, { aMinGrIntAtr[j], Ky*Y_Max+dYcf } ) GraLine( oPS, { aMaxGrIntAtr[j], dYcf }, { aMaxGrIntAtr[j], Ky*Y_Max+dYcf } ) NEXT *********** Рамка вокруг изображения aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT // Тонкая сплошная линия aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты d = 2 GraSetColor( oPS, aColor[14], aColor[14] ) GraBox( oPS, { dXcf-d, dYcf-d }, { Kx*X_Max+dXcf+d, Ky*Y_Max+dYcf+d }, GRA_OUTLINE ) d = 3 GraSetColor( oPS, aColor[123], aColor[123] ) GraBox( oPS, { dXcf-d, dYcf-d }, { Kx*X_Max+dXcf+d, Ky*Y_Max+dYcf+d }, GRA_OUTLINE ) *** 6. Сделать заголовок и надписи по осям и по легенде **** Написать заголовок диаграммы aFonts := XbpFont():new():list() // Все доступные шрифты oFont := XbpFont():new():create("22.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты DO CASE CASE mCognFun = 1 cFileName = Ar_Model[mCurrInf]+'-'+STRTRAN(STR(mOpSc,4),' ','0')+'-'+STRTRAN(STR(mClSc,4),' ','0')+'-Pos.bmp' CASE mCognFun = 2 cFileName = Ar_Model[mCurrInf]+'-'+STRTRAN(STR(mOpSc,4),' ','0')+'-'+STRTRAN(STR(mClSc,4),' ','0')+'-Neg.bmp' CASE mCognFun = 3 cFileName = Ar_Model[mCurrInf]+'-'+STRTRAN(STR(mOpSc,4),' ','0')+'-'+STRTRAN(STR(mClSc,4),' ','0')+'-PosNeg.bmp' ENDCASE GraStringAt( oPS, { X_Max/2, Y_Max-25 }, 'КОГНИТИВНАЯ ФУНКЦИЯ: "'+cFileName+'"' ) oFont := XbpFont():new():create("18.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) GraStringAt( oPS, { X_Max/2, Y_Max- 55 }, 'Приложение: "'+ALLTRIM(M_NameAppl)+'"' ) * GraStringAt( oPS, { X_Max/2, Y_Max- 80 }, 'Классиф.шкала: ['+ALLTRIM(STR(mClSc))+']-'+mNameClSc ) * GraStringAt( oPS, { X_Max/2, Y_Max-105 }, 'Описат. шкала: ['+ALLTRIM(STR(mOpSc))+']-'+mNameOpSc ) ***************************************************************************************************** *** Легенда ***************************************************************************************************** oFont := XbpFont():new():create("12.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты s = 0.5 d1 = 20 d2 = 400 GraStringAt( oPS, { mMaxXcf+d1, mMaxYcf-s*20 }, 'Пояснения:' ) oFont := XbpFont():new():create("9.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты ***************************************************************************************************** s++ s++ ***************************************************************************************************** GraStringAt( oPS, { mMaxXcf+d1, mMaxYcf-s*20}, 'Позитивная редуцированная когнитивная функция:' ) s = s + 0.85 aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := aCOLOR[192] // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 5 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты GraLine( oPS, {mMaxXcf+d1, mMaxYcf-s*20}, {mMaxXcf+d2, mMaxYcf-s*20} ) aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := aCOLOR[193] // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты GraLine( oPS, {mMaxXcf+d1, mMaxYcf-s*20}, {mMaxXcf+d2, mMaxYcf-s*20} ) aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := aCOLOR[190] // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты GraLine( oPS, {mMaxXcf+d1, mMaxYcf-s*20}, {mMaxXcf+d2, mMaxYcf-s*20} ) ***************************************************************************************************** s++ s++ ***************************************************************************************************** GraStringAt( oPS, { mMaxXcf+d1, mMaxYcf-s*20}, 'Негативная редуцированная когнитивная функция:' ) s = s + 0.85 aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := aCOLOR[12] // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 5 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты GraLine( oPS, {mMaxXcf+d1, mMaxYcf-s*20}, {mMaxXcf+d2, mMaxYcf-s*20} ) aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := aCOLOR[9] // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты GraLine( oPS, {mMaxXcf+d1, mMaxYcf-s*20}, {mMaxXcf+d2, mMaxYcf-s*20} ) aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := aCOLOR[34] // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты GraLine( oPS, {mMaxXcf+d1, mMaxYcf-s*20}, {mMaxXcf+d2, mMaxYcf-s*20} ) ***************************************************************************************************** s++ s++ ***************************************************************************************************** GraStringAt( oPS, { mMaxXcf+d1, mMaxYcf-s*20}, 'Шкала соответствия цветов спектра и количества информации' ) s = s + 0.85 GraStringAt( oPS, { mMaxXcf+d1, mMaxYcf-s*20}, 'в значениях аргумента когнитивной функции о ее значениях:' ) s = s - 1.15 ****** Визуализация спектра - легенды ************************ N_Line = 360 // Число линий в спектре D = 0 Delta = INT(360/ N_Line ) Kx = 327 / N_Line * (1 + mDeltaSpectr/360) // Коэффициент масштабирования по оси Y: преобразует аргумент функции в номер пикселя по оси Y * mColorZer = ABS(INT( mDeltaSpectr + (360-mDeltaSpectr) * (0 - mInfMin) / (mInfMax-mInfMin) )) // Сделать нормировку значений по цветам спектра: MAX=Красный, MIN-фиолетовый ############################## * aAvrGrIntCls[p] = Ky * Y_Max * ( aAvrGrIntCls[p] - mMinYcf) / (mMaxYcf - mMinYcf) + dYcf mColorZer = ABS(INT( mDeltaSpectr + (360-mDeltaSpectr) * ( 0 - mZcfNeg) / (mZcfPos - mZcfNeg) )) // Сделать нормировку значений по цветам спектра: MAX=Красный, MIN-фиолетовый ############################## ma := 255/2 mb := 255/2 mc := 255/2 mU := 0 mV := 120 mW := 240 R := INT( ma * (1 + COS( ( mColorZer + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( mColorZer + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( mColorZer + mW ) * GradRad ) ) ) fColorZer := GraMakeRGBColor({ R, G, B }) Column = 0 mMinZer = +99999999 X1zer = 0 X2zer = 0 FOR n = 359 TO mDeltaSpectr STEP -Delta ma := 255/2 mb := 255/2 mc := 255/2 mU := 0 mV := 120 mW := 240 R := INT( ma * (1 + COS( ( n + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( n + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( n + mW ) * GradRad ) ) ) fColor := GraMakeRGBColor({ R, G, B }) ***** Закрасить фон прямоугольника *************** GraSetColor( oPS, fColor, fColor ) ++Column * X1 := (Column-1) * Kx + mDeltaSpectr / 2 * X2 := Column * Kx + mDeltaSpectr / 2 * Y1 := 0 * Y2 := 0 + 30 * GraStringAt( oPS, { mMaxXcf+d1, mMaxYcf-s*20}, 'Негативная редуцированная когнитивная функция:' ) X1 := mMaxXcf+d1 X2 := mMaxXcf+d1+30 Y1 := mMaxYcf-s*20 - ( (Column-1) * Kx + mDeltaSpectr / 2 ) Y2 := mMaxYcf-s*20 - ( Column * Kx + mDeltaSpectr / 2 ) GraBox( oPS, { X1, Y1 }, { X2, Y2 }, GRA_FILL) mZer = ABS( fColor - fColorZer ) IF mZer < mMinZer mMinZer = mZer X1zer = X1 X2zer = X2 Y1zer = Y1 Y2zer = Y2 ENDIF NEXT ** Еще сделать надпись нуля, если минимум меньше нуля IF mZcfNeg < 0 oFont := XbpFont():new():create('9.Arial') aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю относительно точки начала вывода aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraSetColor( oPS, aColor[222], aColor[222] ) GraStringAt( oPS, { X2zer+10, Y1zer }, '0.000') ENDIF GraBox( oPS, { X1zer, Y1zer }, { X2zer, Y2zer }, GRA_OUTLINE ) ****** Надписи на легенде Column = 0 FOR n = 360 TO mDeltaSpectr STEP -Delta ++Column NEXT Y1 := mMaxYcf-s*20 - mDeltaSpectr / 2 Y2 := mMaxYcf-s*20 - ( Column * Kx + mDeltaSpectr / 2 ) oFont := XbpFont():new():create("9.Arial") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты mFlagZer = .T. GraStringAt( oPS, { X2+10, Y1 }, ALLTRIM(STR(mZcfPos,15,3))) GraStringAt( oPS, { X2+90, Y1 }, 'Значения когнитивной функции,') IF ABS(Y1zer - Y1) < 20;mFlagZer = .F.;ENDIF GraStringAt( oPS, { X2+90, Y1-14 }, 'характерные для значений аргумента') IF ABS(Y1zer - Y1-14) < 20;mFlagZer = .F.;ENDIF GraStringAt( oPS, { X2+10, Y2 }, ALLTRIM(STR(mZcfNeg,15,3))) IF ABS(Y1zer - Y2) < 20;mFlagZer = .F.;ENDIF GraStringAt( oPS, { X2+90, Y2 }, 'Значения когнитивной функции,') GraStringAt( oPS, { X2+90, Y2-14 }, 'нехарактерные для значений аргумента') IF ABS(Y1zer - Y2-14) < 20;mFlagZer = .F.;ENDIF IF mFlagZer // Надпись около нуля делать только если она далеко от надписей на минимуме и максимуме GraStringAt( oPS, { X2+90, Y1zer+7 }, 'Значения когнитивной функции, почти') GraStringAt( oPS, { X2+90, Y1zer-7 }, 'не связанные со значенями аргумента') ENDIF ************************************************ **** Параметры формирования когнитивных функций: ************************************************ oFont := XbpFont():new():create("12.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты aModel = {'1. ABS -кол-во наблюдений пар: "класс-признак" в исх.данных ',; '2. PRC1-усл.вероятность i-го признака в признаках j-го класса',; '3. PRC2-усл.вероятность i-го признака у объектов j-го класса ',; '4. INF1-количество знаний по А.Харкевичу; вероятности из PRC1',; '5. INF2-количество знаний по А.Харкевичу; вероятности из PRC2',; '6. INF3-Xи-квадрат, разности между факт.и теор.абс.частотами ',; '7. INF4-ROI (Return On Investment); вероятности из PRC1 ',; '8. INF5-ROI (Return On Investment); вероятности из PRC2 ',; '9. INF6-разн.усл.и безусл.вероятностей; вероятности из PRC1 ',; '10.INF7-разн.усл.и безусл.вероятностей; вероятности из PRC2 ' } s = 4 GraStringAt( oPS, { X2+10, dYcf-s*20 }, 'Параметры формирования когнитивных функций:') s++ oFont := XbpFont():new():create("9.Arial") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraStringAt( oPS, { X2+10, dYcf-s*20 }, 'Модель: '+ALLTRIM(aModel[mCurrInf])) s++ GraStringAt( oPS, { X2+10, dYcf-s*20 }, 'Диапазон кодов классификационных шкал: '+ALLTRIM(STR(mKodClSc1))+' - '+ALLTRIM(STR(mKodClSc2))) s++ GraStringAt( oPS, { X2+10, dYcf-s*20 }, 'Диапазон кодов описательных шкал: '+ALLTRIM(STR(mKodOpSc1))+' - '+ALLTRIM(STR(mKodOpSc2))) s++ GraStringAt( oPS, { X2+10, dYcf-s*20 }, 'Дата и время создания данной формы: '+DTOC(DATE())+' - '+TIME()) **** Надписи градаций по оси классов oFont := XbpFont():new():create("9.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_RIGHT // Выравнивание символов по горизонтали по правому краю относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты FOR j=1 TO LEN(aMinGrIntCls) IF SUBSTR(mNameClSc,1,12) = 'SPECTRINTERV' GraSetColor( oPS, aRGBCls[j], aRGBCls[j] ) // Цвет текста наименования градации - цвет цветового диапазона ENDIF GraStringAt( oPS, { dXcf-20, aAvrGrIntCls[j] }, '['+ALLTRIM(STR(j))+']-'+aNameCls[j] ) // Надпись градации по оси Y GraSetColor( oPS, GRA_CLR_BLACK, GRA_CLR_BLACK ) NEXT ***** Надписи наименований шкал Y и X oFont := XbpFont():new():create("12.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты AxName = '['+ALLTRIM(STR(mOpSc))+']-'+mNameOpSc aTxtPar = DC_GraQueryTextbox(AxName, oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов IF LEN(AxName) < 140 // Длина наименования оси X меньше ширины изображения aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraStringAt( oPS, { dXcf+(mMaxXcf-dXcf)/2, 10}, AxName ) // Надпись оси Х ELSE aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraStringAt( oPS, { 50, 10}, AxName ) // Надпись оси Х ENDIF oFont := XbpFont():new():create("12.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты AyName = '['+ALLTRIM(STR(mClSc))+']-'+mNameClSc aTxtPar = DC_GraQueryTextbox(AyName, oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов aMatrix := GraInitMatrix() IF LEN(AyName) < 70 // Длина наименования оси Y меньше высоты изображения aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraRotate( oPS, aMatrix, 90, { 15, dYcf+(mMaxYcf-dYcf)/2 }, GRA_TRANSFORM_ADD ) // <<<########## oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) // <<<########## GraStringAt( oPS, { 15, dYcf+(mMaxYcf-dYcf)/2 }, AyName ) // Надпись оси Y ELSE // Писать наименование с начала изображения aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraRotate( oPS, aMatrix, 90, { 15, 10 }, GRA_TRANSFORM_ADD ) // <<<########## oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) // <<<########## GraStringAt( oPS, { 15, 10 }, AyName ) // Надпись оси Y ENDIF *** Наименования значений фактора писать с поворотом на 90 градусов oFont := XbpFont():new():create("9.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_RIGHT // Выравнивание символов по горизонтали по правому краю относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты * DC_DebugQout(aRGBAtr) FOR j=1 TO LEN(aAvrGrIntAtr) AxName = '['+ALLTRIM(STR(j))+']-'+DelZeroNameGr(aNameAtr[j]) aMatrix := GraInitMatrix() // <<<########## IF SUBSTR(mNameOpSc,1,12) = 'SPECTRINTERV' GraRotate( oPS, aMatrix, 90, { aAvrGrIntAtr[j], dYcf-20 }, GRA_TRANSFORM_REPLACE ) // <<<########## oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) // <<<########## GraSetColor( oPS, aRGBAtr[j], aRGBAtr[j] ) // Цвет текста наименования градации - цвет цветового диапазона GraStringAt( oPS, { aAvrGrIntAtr[j], dYcf-20 }, AxName ) // Надпись градации по оси X GraSetColor( oPS, GRA_CLR_BLACK, GRA_CLR_BLACK ) ELSE GraRotate( oPS, aMatrix, 90, { aAvrGrIntAtr[j], dYcf-20 }, GRA_TRANSFORM_REPLACE ) // <<<########## oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) // <<<########## GraStringAt( oPS, { aAvrGrIntAtr[j], dYcf-20 }, AxName ) // Надпись градации по оси X ENDIF NEXT ****** Не получается отключить режим вращения изображения ****** Вместо отключения можно докрутить до 360 градусов X_Max := 1800 Y_Max := 850 // Размер графического окна для самого графика в пикселях aMatrix := GraInitMatrix() // <<<########## GraRotate( oPS, aMatrix, 0, {900, 425}, GRA_TRANSFORM_REPLACE ) // <<<########## oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) // <<<########## *** Масштабирование: Kx = 1920/1280, Ky = 1080/720: GraScale( oPS, aMatrix, {Kx,Ky}, {X_Max/2, X_Max/2} ) * GraScale( oPS, aMatrix, {1920/1280,1080/720}, {X_Max/2, X_Max/2} ) *** 7. Записать файл изображения с именем: "Модель-код опис.шкалы-код клас.шкалы" DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения IF FILEDATE("Cogn_fun",16) = CTOD("//") DIRMAKE("Cogn_fun") Mess = L('В папке текущего приложения: "#" не было директории "Cogn_fun" для когнитивных функций и она была создана!') Mess = STRTRAN(Mess, "#", UPPER(ALLTRIM(M_PathAppl))) LB_Warning(Mess, L('4.8. Когнитивные функции. (C) Система "Эйдос-Х++"' )) ENDIF DIRCHANGE(M_PathAppl+"\Cogn_fun\") // Перейти в папку Cogn_fun * cFileName = Ar_Model[mCurrInf]+'-'+STRTRAN(STR(mOpSc,4),' ','0')+'-'+STRTRAN(STR(mClSc,4),' ','0')+'.bmp' DO CASE CASE mCognFun = 1 cFileName = Ar_Model[mCurrInf]+'-'+STRTRAN(STR(mOpSc,4),' ','0')+'-'+STRTRAN(STR(mClSc,4),' ','0')+'-Pos.bmp' CASE mCognFun = 2 cFileName = Ar_Model[mCurrInf]+'-'+STRTRAN(STR(mOpSc,4),' ','0')+'-'+STRTRAN(STR(mClSc,4),' ','0')+'-Neg.bmp' CASE mCognFun = 3 cFileName = Ar_Model[mCurrInf]+'-'+STRTRAN(STR(mOpSc,4),' ','0')+'-'+STRTRAN(STR(mClSc,4),' ','0')+'-PosNeg.bmp' ENDCASE * ERASE(cFileName) * WTF oStatic1:status() * WTF oStatic, oStatic1 * oStatic1:unlockPS() FERASE( cFileName ) DC_Scrn2ImageFile( oStatic1, cFileName ) * oBitmap:saveFile(cFileName, XBPBMP_FORMAT_JPG) * oStatic1:Setcaption(oBitmap) DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения * DIRCHANGE(Disk_dir) // Перейти в папку с системой RETURN NIL ************************************************************************************************** ******** Помощь по режиму 4.8. ************************************************************************************************** FUNCTION Help48() aHelp := {} AADD(aHelp, L('Помощь по режиму: 4.8. Геокогнитивная подсистема "Эйдос" ')) AADD(aHelp, L('(Восстановление значений функций по признакам аргумента) ')) AADD(aHelp, L(' ')) AADD(aHelp, L('В данном режиме пользователь может сформировать облако точек и провести его триангуляцию Делоне с выводом результатов в форме ребер ')) AADD(aHelp, L('треугольников в стиле сетки и в форме градиентной заливки треугольников цветом, отражающим значения функции в вершинах треугольников. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Сгенерировать облако точек для триангуляции пользователь может многими различными способами. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Для освоения геокогнитивной подсистемы предназначены режимы генерации облака точек со случайными координатами, а также облака точек ')) AADD(aHelp, L('для визуализации цветового круга с заданным числом секторов, спирали Архимеда и логарифмической спирали с заданными параметрами. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Для реальной работы предназначены следующие способы формирования базы облака точек: "Points_XYZ": ')) AADD(aHelp, L(' ')) AADD(aHelp, L(' ')) AADD(aHelp, L('1. Координаты и цвета точек из графического файла: "Delone.bmp". Он должен быть в папке: "../AID_DATA/INP_DATA/". ')) AADD(aHelp, L('2. Из 1d Excel-таблицы исходных данных: "Inp_map1.dbf". ')) AADD(aHelp, L('3. Из распознаваемой 1d Excel-таблицы: "Rsp_map1.dbf". ')) AADD(aHelp, L('4. Из 2d Excel-таблицы исходных данных: "Inp_map2.dbf". ')) AADD(aHelp, L('5. Из распознаваемой 2d Excel-таблицы: "Rsp_map2.dbf". ')) AADD(aHelp, L('6. Из базы исходных данных: "Inp_data.dbf". ')) AADD(aHelp, L('7. Из распознаваемой выборки: "Inp_rasp.dbf". ')) AADD(aHelp, L('8. Из итоговых результатов распознавания: "Rsp_IT.dbf". ')) AADD(aHelp, L('9. Из базы для построения изображения: "Points_XYZ.dbf". ')) AADD(aHelp, L('10.Из статистических и системно-когнитивных моделей текущего приложения (Abs, Prc#, Inf#) ')) AADD(aHelp, L(' ')) AADD(aHelp, L('При этом при проведении триангуляции Делоне можно рисовать или не рисовать окружности и ребра в градиентной цветовой заливке. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Требования к файлу: "Inp_data.xls": (должен быть в папке: "../AID_DATA/INP_DATA/Inp_data.xls"): ')) AADD(aHelp, L('----------------------------------------------------------------------------------------------- ')) AADD(aHelp, L('- 1-я колонка должна содержать исходные координаты точек в формате: X=#######.#######, Y=#######.####### и далее любой текст; ')) AADD(aHelp, L('- 2-я колонка должна содержать значения функции в точках с координатами (X, Y); ')) AADD(aHelp, L('- последующие колонки должны содержать признаки точек с координатами (X, Y). ')) AADD(aHelp, L('Для того, чтобы сформировать такой файл можно воспользоваться режимом 4.8 системы "Эйдос": запустить формирование облака точек ')) AADD(aHelp, L('из файла: "Inp_map1.xls" с формированием модели, выполнить рекомендуемые действия. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Требования к файлу "INP_MAP1.XLS" с 1d Excel-таблицей: (файл должен быть в папке: "../AID_DATA/INP_DATA/INP_MAP1.XLS"): ')) AADD(aHelp, L('----------------------------------------------------------------------------------------------- ')) AADD(aHelp, L('- первая строка должна содержать наименования колонок: "X","Y","Z","Z1","Z2",...,"ZN"; ')) AADD(aHelp, L('- последующие строки содержат числовые исходные значения координат точек (X,Y,Z) и признаки аргумента: Z1,Z2,...,ZN, которые могут ')) AADD(aHelp, L('быть числовыми или текстовыми. Количество признаков аргумента N ограничено только возможностями MS Excel; ')) AADD(aHelp, L('- 1-я колонка: исходное значение X; 2-я: исходное значение Y; 3-я: Z, последующие - признаки точки: (X,Y,Z). ')) AADD(aHelp, L('- в файле исходных данных должна быть координаты и признаки аргумента не менее 3 точек. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Требования к файлу "INP_MAP2.XLS" с 2d Excel-таблицей: (должна быть в папке: "../AID_DATA/INP_DATA/INP_MAP2.XLS") ')) AADD(aHelp, L('----------------------------------------------------------------------------------------------- ')) AADD(aHelp, L('- 1-я строка должна содержать наименования колонок вида: "N1", "N2",... ')) AADD(aHelp, L('- 2-я строка должна быть с числовыми значениями координаты X; ')) AADD(aHelp, L('- 1-я колонка должна быть с числовыми значениями координаты Y; ')) AADD(aHelp, L('- в ячейках с координатами (X,Y) должно содержаться числовое значение функции Z; ')) AADD(aHelp, L('- значением ячейки A1 должен быть 0. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('При оконтуривании файлы должны быть не больше, чем 450 пикселей по ширине и не более 800 по высоте. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Статьи автора, в которых подробно описывается применение данного режима: ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Луценко Е.В. Система "Эйдос" как геокогнитивная система (ГКС) для восстановления неизвестных значений пространственно-распределенных ')) AADD(aHelp, L('функций на основе описательной информации картографических баз данных / Е.В. Луценко, Д.К. Бандык // Политематический сетевой электрон- ')) AADD(aHelp, L('ный научный журнал Кубанского государственного аграрного университета (Научный журнал КубГАУ) [Электронный ресурс]. - Краснодар: КубГАУ,')) AADD(aHelp, L('2016. - №03(117). С. 1 - 51. - IDA [article ID]: 1171603001. - Режим доступа: http://ej.kubagro.ru/2016/03/pdf/01.pdf, 3,188 у.п.л. ')) mHelpMax = -999;FOR h=1 TO LEN(aHelp);mHelpMax = MAX(mHelpMax, LEN(ALLTRIM(aHelp[h])));NEXT s=1;d=0.8;@0,0 DCGROUP oGroup1 CAPTION L(' ') SIZE mHelpMax-25, LEN(aHelp)*d+1.5 FOR h=1 TO LEN(aHelp);@s,2 DCSAY aHelp[h] SIZE 0 PARENT ogroup1;s=s+d;NEXT DCREAD GUI TO lExit FIT TITLE L('4.8. Геокогнитивная подсистема "Эйдос"') RETURN NIL ************************************************************************************************** ********************************************************************************************************************** ******** 4.8.1. Преобразование 2D Excel-таблицы в Inp_data.xls (X,Y,Z) точек ******** Режим преобразует 2D Excel-таблицу с именем "Inp_map2.xls" в файл "Inp_data.xls", ******** Режим преобразует 2D Excel-таблицу с именем "Rsp_map2.xls" в файл "Inp_rasp.xls", ******** содержащий координаты X,Y,Z точек и их признаки (модель описательной информации картографической базы данных) ********************************************************************************************************************** FUNCTION F481(mFile) LOCAL oProgress, oDialog, mFlag1, mFlag2, nTime, nMax LOCAL aX[100000], aY[100000], aZ[100000] // Координаты X,Y,Z точек облака IF M_KodAdmAppls = 0 // Выйти из сстемы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) RETURN NIL ENDIF ERASE('_ColumnNames.arx');ERASE('_482.txt') // Стереть файлы: _ColumnNames.arx и _482.txt // Определить, есть ли в папке: AID_DATA/Inp_data файл: Inp_map2.xls или Inp_map2.xlsx DIRCHANGE(M_ApplsPath+"\Inp_data\") mFlag1 = 'err' DO CASE CASE mFile = 'Inp_map2.' DO CASE CASE FILE("Inp_map2.xls") mFlag1 = 'xls' CASE FILE("Inp_map2.xlsx") mFlag1 = 'xlsx' ENDCASE CASE mFile = 'Rsp_map2.' DO CASE CASE FILE("Rsp_map2.xls") mFlag1 = 'xls' CASE FILE("Rsp_map2.xlsx") mFlag1 = 'xlsx' ENDCASE ENDCASE IF mFlag1 = 'err' Mess = L('В папке: "#" должен быть файл: "')+mFile+mFlag1+'"' Mess = STRTRAN(Mess, "#", M_ApplsPath+"\Inp_data\") LB_Warning(Mess) Help48() // Пояснение о назначении режима ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF *** ПРЕОБРАЗОВАНИЕ EXCEL-ФАЙЛА Inp_map2 в БД: Inp_data.dbf *** и файл наименований классификационных и описательных шкал: Inp_name.txt cExcelFile = mFile + mFlag1 M_NewAppl = M_ApplsPath+"\Inp_data\" mFlag2 = LC_Excel2WorkArea( cExcelFile, M_NewAppl ) IF .NOT. mFlag2 LB_Warning(L('Исправьте файл исходных данных !'), L('4.8. Геокогнитивная подсистема "Эйдос"')) Help48() // Пояснение о назначении режима ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ***** Преобразование Excel-таблицы в Inp_data.xls (X,Y,Z) точек DO CASE CASE mFile = 'Inp_map2.' cFileName := "Inp_data.dbf" CASE mFile = 'Rsp_map2.' cFileName := "Inp_rasp.dbf" ENDCASE aStructure := { { "Coord_XY", "C", 36, 0 },; // Координаты X,Y точек { "pZ" , "N", 15, 7 },; // Тип данных в шкале: N - числовой, С - символьный { "Attr1" , "N", 15, 7 },; // 1-й признак аргумента { "Attr2" , "N", 15, 7 },; // 2-й признак аргумента { "Attr3" , "N", 15, 7 },; // 3-й признак аргумента { "Attr4" , "N", 15, 7 },; // 4-й признак аргумента { "Attr5" , "N", 15, 7 },; // 5-й признак аргумента { "Attr6" , "N", 15, 7 },; // 6-й признак аргумента { "Attr7" , "N", 15, 7 } } // 7-й признак аргумента (их может быть сколько угодно, но здесь для примера взято 7) DbCreate( cFileName, aStructure ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DO CASE CASE mFile = 'Inp_map2.' USE Inp_map2 EXCLUSIVE NEW USE Inp_data EXCLUSIVE NEW SELECT Inp_map2 CASE mFile = 'Rsp_map2.' USE Rsp_map2 EXCLUSIVE NEW USE Inp_rasp EXCLUSIVE NEW SELECT Rsp_map2 ENDCASE DBGOTOP() aX := {} FOR j=2 TO FCOUNT() AADD(aX, FIELDGET(j)) NEXT nMax = (RECCOUNT()-1)*(FCOUNT()-1) DO CASE CASE mFile = 'Inp_map2.' Mess = L('Преобразование: Inp_map2 => Inp_data') CASE mFile = 'Rsp_map2.' Mess = L('Преобразование: Rsp_map2 => Inp_rasp') ENDCASE @ 4,5 DCPROGRESS oProgress SIZE 70,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 DCREAD GUI TITLE Mess PARENT @oDialog FIT EXIT oDialog:show() nTime = 0 DC_GetProgress(oProgress,0,nMax) DBSKIP(1) DO WHILE .NOT. EOF() mY = FIELDGET(1) aZ := {} // Значения функции FOR j=2 TO FCOUNT() AADD(aZ, FIELDGET(j)) NEXT DO CASE CASE mFile = 'Inp_map2.' SELECT Inp_data CASE mFile = 'Rsp_map2.' SELECT Inp_rasp ENDCASE FOR j=1 TO LEN(aZ) APPEND BLANK REPLACE Coord_XY WITH 'X=' + STR(aX[j],15,7) + " Y=" + STR(mY,15,7) REPLACE pZ WITH aZ[j] REPLACE Attr1 WITH aZ[j]^2 REPLACE Attr2 WITH aZ[j]^3 REPLACE Attr3 WITH aZ[j]^4 REPLACE Attr4 WITH aZ[j]^5 REPLACE Attr5 WITH aZ[j]^6 REPLACE Attr6 WITH aZ[j]^7 REPLACE Attr7 WITH aZ[j]^8 DC_GetProgress(oProgress, ++nTime, nMax) NEXT DO CASE CASE mFile = 'Inp_map2.' SELECT Inp_map2 CASE mFile = 'Rsp_map2.' SELECT Rsp_map2 ENDCASE DBSKIP(1) ENDDO *MsgBox('STOP') DC_GetProgress(oProgress,nMax,nMax) oDialog:Destroy() ***** Записать новые файлы: Inp_name.txt и Inp_nameALL.txt для БД Inp_data.dbf CrLf = CHR(13)+CHR(10) // Конец строки (записи) String = "Coord_XY" + CrLf +; "pZ" + CrLf +; "Attr1" + CrLf +; "Attr2" + CrLf +; "Attr3" + CrLf +; "Attr4" + CrLf +; "Attr5" + CrLf +; "Attr6" + CrLf +; "Attr7" + CrLf StrFile(String, "Inp_nameAll.txt") // Запись текстового файла "Inp_nameAll.txt" String = "pZ" + CrLf +; "Attr1" + CrLf +; "Attr2" + CrLf +; "Attr3" + CrLf +; "Attr4" + CrLf +; "Attr5" + CrLf +; "Attr6" + CrLf +; "Attr7" + CrLf StrFile(String, "Inp_name.txt") // Запись текстового файла "Inp_name.txt" *ERASE('_ColumnNames.arx') *ERASE('_Inp_name.arx') *********** сформировать файл параметров режима 2.3.2.2() // Сохранить файл с информацией о заданых параметрах программного интерфейса в текущей директории системы // и в папке приложения, чтобы можно было потом узнать при каких параметрах оно создано DO CASE CASE mFile = 'Inp_map2.' Regim = 1 // Формализации ПО или ген.расп.выб. CASE mFile = 'Rsp_map2.' Regim = 2 // Формализации ПО или ген.расп.выб. ENDCASE Flag_zer = 1 // Считать нули и пробелы отсутствием данных? [1]-да, [2]-нет N_Chast = 1 // На сколько частей N разбивать обучающую или распознаваемую выборку (в зависимости от Regim) M_ClSc1 = 2 // Номер начального столбца диапазона классификационных шкал M_ClSc2 = 2 // Номер конечного столбца диапазона классификационных шкал M_OpSc1 = 3 // Номер начального столбца диапазона описательных шкал M_OpSc2 = 9 // Номер конечного столбца диапазона описательных шкал M_ObAnk = 3 // Создавать анкеты исходной выборки по строкам Inp_data-[1], по классам-[2], и 1-е, и 2-е [3] M_Interval = 1 // 1-равные интервалы, 2-адаптивные интервалы (с примерно равным количеством наблюдений, по Котельникову) N_SKGrCl = 10 N_SKGrPr = 10 K_N_ClSc = 1 K_N_OpSc = 1 K_N_GrClSc = 10 K_N_GrOpSc = 10 M_Scenario = .F. mGorizMin = 5 mGorizMax = 5 mGlubMin = 5 mGlubMax = 5 K_GradNClSc = 10 K_GradNOpSc = 10 M_ChastObi = .F. M_ChastRso = .F. N_ChastObi = 1 N_ChastRso = 1 M_XlsDbf = 3 mTxtCSField = 1 // Способ интерпретации значений текстовых полей - классификационных шкал файла исходных данных mTxtOSField = 1 // Способ интерпретации значений текстовых полей - описательных шкал файла исходных данных mTxtCSSep = " " // Разделитель элементов классификационных шкал, если mTxtCSField=3 mTxtOSSep = " " // Разделитель элементов описательных шкал, если mTxtOSField=3 * mScenario = 1 // mScenario=1 Не применять сценарный метод АСК-анализа и спец.интерпретацию TXT-полей (старый вариант) mScenario = 1 // Не применять сценарный метод АСК-анализа mSpecInterprCls = .F. // Не применять спец.интерпретацию текстовых полей классов mSpecInterprAtr = .F. // Не применять спец.интерпретацию текстовых полей признаков mNameGrNumSc= 1 // Какие наименования ГРАДАЦИЙ числовых шкал использовать mClsAvr = .F. // .F. - делать модель из Inp_data, .T. - делать модель из Inp_data_avr mSortUnqCls = 1 // Выделять уникальные значения классов и сортировать, 1-да, 2-нет mLemmatCls = 2 // Проводить лемматизацию классов, 1-да, 2-нет mSortUnqGos = 1 // Выделять уникальные значения признаков и сортировать, 1-да, 2-нет mLemmatGos = 2 // Проводить лемматизацию признаков, 1-да, 2-нет // Сохранить файл с информацией о заданых параметрах программного интерфейса в текущей директории системы PRIVATE aSoftInt[40] aSoftInt[ 1] = Regim aSoftInt[ 2] = Flag_zer aSoftInt[ 3] = M_ClSc1 aSoftInt[ 4] = M_ClSc2 aSoftInt[ 5] = M_OpSc1 aSoftInt[ 6] = M_OpSc2 aSoftInt[ 7] = N_SKGrCl aSoftInt[ 8] = N_SKGrPr aSoftInt[ 9] = K_N_ClSc aSoftInt[10] = K_N_OpSc aSoftInt[11] = K_N_GrClSc aSoftInt[12] = K_N_GrOpSc aSoftInt[13] = M_ObAnk aSoftInt[14] = N_Chast aSoftInt[15] = M_Interval aSoftInt[16] = M_Scenario aSoftInt[17] = K_GradNClSc // Количество градаций в числовой классификационной шкале aSoftInt[18] = K_GradNOpSc // Количество градаций в числовой описательной шкале aSoftInt[19] = mGorizMin aSoftInt[20] = mGorizMax aSoftInt[21] = mGlubMin aSoftInt[22] = mGlubMax aSoftInt[23] = M_ChastObi aSoftInt[24] = M_ChastRso aSoftInt[25] = N_ChastObi aSoftInt[26] = N_ChastRso aSoftInt[27] = M_XlsDbf aSoftInt[28] = mTxtCSField aSoftInt[29] = mTxtOSField aSoftInt[30] = mTxtCSSep aSoftInt[31] = mTxtOSSep * aSoftInt[32] = mScenario // mScenario=1 Не применять сценарный метод АСК-анализа и спец.интерпретацию TXT-полей (старый вариант) aSoftInt[32] = mScenario // mScenario=1 Не применять сценарный метод АСК-анализа aSoftInt[33] = mSpecInterprCls // .T. - Применить спец.интерпретацию текстовых полей классов, .F. - не применять aSoftInt[34] = mSpecInterprAtr // .T. - Применить спец.интерпретацию текстовых полей признаков, .F. - не применять aSoftInt[35] = mNameGrNumSc // Какие наименования ГРАДАЦИЙ числовых шкал использовать aSoftInt[36] = mClsAvr // .F. = модель без усреднения по классам aSoftInt[37] = mSortUnqCls // Выделять уникальные значения классов и сортировать, 1-да, 2-нет aSoftInt[38] = IF(mSpecInterprCls,mLemmatCls,2) // Проводить лемматизацию классов, 1-да, 2-нет aSoftInt[39] = mSortUnqGos // Выделять уникальные значения признаков и сортировать, 1-да, 2-нет aSoftInt[40] = IF(mSpecInterprAtr,mLemmatGos,2) // Проводить лемматизацию признаков, 1-да, 2-нет DC_ASave(aSoftInt , Disk_dir +"\_2_3_2_2.arx") * DC_ASave(aSoftInt , M_NewAppl+"\_2_3_2_2.arx") ************************************************************************************** F482(mFile, 2, 6) // Преобразование: Inp_data.dbf или Inp_rasp.dbf => Points_XYZ.dbf ************************************************************************************** aMess := {} DO CASE CASE mFile = 'Inp_map2.' AADD(aMess,L('Преобразование 2d Excel-таблицы: "Inp_map2.xls" в файл исходных данных: "Inp_data.dbf" завершено успешно!')) IF nModel = 2 AADD(aMess, L('Для создания модели будут выполнены режимы 2.3.2.2 и 3.5 с параметрами по умолчанию')) ENDIF AADD(aMess, L(' ')) LB_Warning(aMess, L('4.8. Геокогнитивная подсистема "Эйдос"' )) IF nModel = 2 F2_3_2_2("","") F3_5('CPU') ENDIF CASE mFile = 'Rsp_map2.' AADD(aMess, L('Преобразование 2d Excel-таблицы: "Rsp_map2.xls" в файл распознаваемой выборки: "Inp_rasp.dbf" завершено успешно!')) IF nRasp = 2 AADD(aMess, L('Для применения модели будут выполнены режимы 2.3.2.2 и 4.1.2 с параметрами по умолчанию')) ENDIF AADD(aMess, L(' ')) LB_Warning(aMess, L('4.8. Геокогнитивная подсистема "Эйдос"' )) IF nRasp = 2 F2_3_2_2("","") F4_1_2(0,.T.,"4_1_2",'CPU') ENDIF ENDCASE ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL *-------------------- ******** Задание количества точек FUNCTION NPoints() LOCAL GetList[0], GetOptions, oSay, mPointsCount := 100 @10,10 DCGROUP oGroup1 CAPTION L('Задайте количество точек:') SIZE 23.0, 2.5 @ 1, 1 DCSAY L(" ") GET mPointsCount PICTURE "##########" PARENT oGroup1 DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; OPTIONS GetOptions ; ADDBUTTONS; MODAL ; TITLE L('4.8. Геокогнитивная подсистема "Эйдос"') ******************************************************************** IF lExit ** Button Ok ELSE ADS_SERVER_QUIT() QUIT ENDIF ******************************************************************** PointsCount = mPointsCount RETURN(PointsCount) *-------------------- FUNCTION FRND(mMax) RETURN(1 + INT(RANDOM() / 65535 * mMax)) *-------------------- ******** RND-генерация и отображение облака точек FUNCTION RndGenPoints() LOCAL GetList[0], GetOptions, oSay, oDevice LOCAL aX[100000], aY[100000], aZ[100000] // Координаты X,Y,Z точек облака ERASE('_ColumnNames.arx');ERASE('_482.txt') // Стереть файлы: _ColumnNames.arx и _482.txt AFILL(aX,0) AFILL(aY,0) AFILL(aZ,0) IF PointsCount > 0 ClearImageTr() // Очистка изображения ENDIF *PointsCount = NPoints() // Задание количества точек X_Max := 1800 Y_Max := 850 // Размер графического окна для самого графика в пикселях ***** Задать атрибуты линии aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT graSetAttrLine( oPS, aAttr ) * PointsCount // число точек **** Поиск минимальных и максимальных X и Y и нормирование mMinX = +99999999999 mMaxX = -99999999999 mMinY = +99999999999 mMaxY = -99999999999 FOR p=1 TO PointsCount mX := FRND(X_Max) mY := FRND(Y_Max) mZ := p aX[p] = mX aY[p] = mY aZ[p] = mZ mMinX = MIN(mMinX, mX) mMaxX = MAX(mMaxX, mX) mMinY = MIN(mMinY, mY) mMaxY = MAX(mMaxY, mY) NEXT dX = (X_Max-0.8*Y_Max)/2 dY = (Y_Max-0.8*Y_Max)/2 - 200 FOR p=1 TO PointsCount aX[p] = 0.8 * Y_Max * ( aX[p] - mMinX) / (mMaxX - mMinX) + dX aY[p] = Y_Max - 0.8 * Y_Max * ( aY[p] - mMinY) / (mMaxY - mMinY) + dY aAttr [ GRA_AL_COLOR ] := GRA_CLR_RED // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraArc ( oPS, { aX[p], aY[p] }, 2 ) // Рисует круг стилем линии aAttr [ GRA_AL_COLOR ] := GRA_CLR_DARKGRAY // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraArc ( oPS, { aX[p], aY[p] }, 3 ) // Рисует круг стилем линии NEXT ***** Создать БД для координат X,Y,Z точек облака aStructure := { { "Num" , "N", 15, 0 }, ; { "pX" , "N", 19, 7 }, ; { "pY" , "N", 19, 7 }, ; { "pZ" , "N", 19, 7 }, ; { "pRed" , "N", 3, 0 }, ; { "pGreen", "N", 3, 0 }, ; { "pBlue" , "N", 3, 0 } } DbCreate( 'Points_XYZ', aStructure ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Points_XYZ EXCLUSIVE NEW SELECT Points_XYZ FOR p=1 TO PointsCount APPEND BLANK REPLACE Num WITH p REPLACE pX WITH aX[p] REPLACE pY WITH aY[p] REPLACE pZ WITH aZ[p] NEXT CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций StrFile('Нормировать цвет', '_NormColor.txt') * M_CurrInf = FileStr('_NormColor.txt') LB_Warning(L('Построение точек завершено'),L('4.8. Геокогнитивная подсистема "Эйдос"' )) RETURN nil * --------- ************************************************ ******** Градиентная заливка трегольников цветом ************************************************ FUNCTION Shading(mVIE) LOCAL aX[100000], aY[100000], aZ[100000] // Координаты X,Y,Z точек облака IF .NOT. FILE("Points_XYZ.dbf") GetPoints() ENDIF IF .NOT. FILE("Triang_Num.dbf") Triangulation(.F.) ENDIF ******* Узнать разрешение экрана и не показывать изображений большой размерности **************** nWidth := AppDeskTop():currentSize()[1] // current screen size width in pixels nHeight := AppDeskTop():currentSize()[2] // current screen size height in pixels * nWidth = 1366 // <<<===########################## * nHeight = 768 * F4_8('L('4.7. АСК-анализ изображений по пикселям, спектрам и контурам')') // Если F4_8() запускается не из главного меню, а из F4_7(), то может работать на любом экране * IF mTitle = L('4.8. Геокогнитивная подсистема') // 4.8. Геокогнитивная подсистема работает только на экранах с разрешением 1920 x 1080 и более IF nWidth < 1800 aMess := {} AADD(aMess, L("Для правильного отображения графической формы")) AADD(aMess, L("необходимо разрешение экрана 1800 pix по горизонтали,")) AADD(aMess, L("а фактически установлено: ")+ALLTRIM(STR(nWidth))+" pix") LB_Warning(aMess ) Running(.F.) ReTURN NIL ENDIF IF nHeight < 850 aMess := {} AADD(aMess, L("Для правильного отображения графической формы")) AADD(aMess, L("необходимо разрешение экрана 850 pix по вертикали,")) AADD(aMess, L("а фактически установлено: ")+ALLTRIM(STR(nHeight))+" pix") LB_Warning(aMess ) Running(.F.) ReTURN NIL ENDIF * ENDIF ************************************************************************************************* ClearImageTr() * StrFile('Нормировать цвет', '_NormColor.txt') M_CurrInf = FileStr('_NormColor.txt') ***** Расчет позиций для одного по X поля изображения шириной nXSizeAr ***** и двух равных промежутков между ними d и слева и справа от изображений до края окна X_Max := 1800 Y_Max := 850 // Размер графического окна для самого графика в пикселях IF .NOT. FILE('_XYSize.txt') * LB_Warning(L('Необходимо запустить режим генерации облака точек!','4.8. Геокогнитивная подсистема "Эйдос"' ) StrFile(STR(nXSize,9)+' '+STR(nYSize,9), '_XYSize.txt') // Запись текстового файла с параметрами nXSize, nYSize ELSE * StrFile(STR(nXSize,9)+' '+STR(nYSize,9), '_XYSize.txt') // Запись текстового файла с параметрами nXSize, nYSize nXSize = VAL(SUBSTR(FileStr('_XYSize.txt'), 1,9)) // Загрузка параметра nXSize из текстового файла nYSize = VAL(SUBSTR(FileStr('_XYSize.txt'),11,9)) // Загрузка параметра nYSize из текстового файла ENDIF **** Сформировать массивы координат точек AFILL(aX,0) AFILL(aY,0) AFILL(aZ,0) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Points_XYZ EXCLUSIVE NEW SELECT Points_XYZ PointsCount = RECCOUNT() p = 0 DBGOTOP() DO WHILE .NOT. EOF() p++ aX[p] = pX aY[p] = pY aZ[p] = pZ DBSKIP(1) ENDDO **** Сформировать массив номеров точек в треугольниках из БД AFILL(trianglesP1,0) AFILL(trianglesP2,0) AFILL(trianglesP3,0) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Triang_Num EXCLUSIVE NEW TrianglesCount = RECCOUNT() t = 0 DBGOTOP() DO WHILE .NOT. EOF() t++ trianglesP1[t] = p1 trianglesP2[t] = p2 trianglesP3[t] = p3 DBSKIP(1) ENDDO ******* Поиск минимального и максимального значений функции mInfMin = +999999999 mInfMax = -999999999 FOR j=1 TO TrianglesCount Z1 = aZ[trianglesP1[j]] Z2 = aZ[trianglesP2[j]] Z3 = aZ[trianglesP3[j]] mInfMin = MIN(Z1,mInfMin) mInfMin = MIN(Z2,mInfMin) mInfMin = MIN(Z3,mInfMin) mInfMax = MAX(Z1,mInfMax) mInfMax = MAX(Z2,mInfMax) mInfMax = MAX(Z3,mInfMax) NEXT **** Задать атрибуты линии aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := GRA_CLR_BLACK // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) *** Цикл по базе треугольников ma := 127.5 mb := 127.5 mc := 127.5 mU := 0 mV := 120 mW := 240 FOR j=1 TO TrianglesCount X1 = aX[trianglesP1[j]] Y1 = aY[trianglesP1[j]] Z1 = aZ[trianglesP1[j]] X2 = aX[trianglesP2[j]] Y2 = aY[trianglesP2[j]] Z2 = aZ[trianglesP2[j]] X3 = aX[trianglesP3[j]] Y3 = aY[trianglesP3[j]] Z3 = aZ[trianglesP3[j]] IF M_CurrInf = "Нормировать цвет" // Применить нормировку значений по цветовой шкале ********* Заграска треугольника градацией цвета **************************** mColor1 = ABS(INT( mDeltaSpectr + (360-mDeltaSpectr) * (Z1 - mInfMin) / (mInfMax-mInfMin) )) // Сделать нормировку значений по цветам спектра: MAX=Красный, MIN-фиолетовый ############################## R := INT( ma * (1 + COS( ( mColor1 + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( mColor1 + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( mColor1 + mW ) * GradRad ) ) ) fColor1 := GraMakeRGBColor({ R, G, B }) mColor2 = ABS(INT( mDeltaSpectr + (360-mDeltaSpectr) * (Z2 - mInfMin) / (mInfMax-mInfMin) )) // Сделать нормировку значений по цветам спектра: MAX=Красный, MIN-фиолетовый ############################## R := INT( ma * (1 + COS( ( mColor2 + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( mColor2 + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( mColor2 + mW ) * GradRad ) ) ) fColor2 := GraMakeRGBColor({ R, G, B }) mColor3 = ABS(INT( mDeltaSpectr + (360-mDeltaSpectr) * (Z3 - mInfMin) / (mInfMax-mInfMin) )) // Сделать нормировку значений по цветам спектра: MAX=Красный, MIN-фиолетовый ############################## R := INT( ma * (1 + COS( ( mColor3 + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( mColor3 + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( mColor3 + mW ) * GradRad ) ) ) fColor3 := GraMakeRGBColor({ R, G, B }) ELSE // M_CurrInf = "Не нормировать цвет" // Использовать собственный не нормированный цвет mCol1 = AutomationTranslateColor(Z1, .t.) mCol2 = AutomationTranslateColor(Z2, .t.) mCol3 = AutomationTranslateColor(Z3, .t.) DO CASE CASE mCol1=0 mCol1=16843009 CASE mCol1=16777215 mCol1=0 ENDCASE DO CASE CASE mCol2=0 mCol2=16843009 CASE mCol2=16777215 mCol2=0 ENDCASE DO CASE CASE mCol3=0 mCol3=16843009 CASE mCol3=16777215 mCol3=0 ENDCASE * mCol1 = IF(mCol1=0,16843009,IF(mCol1=16777215,0,mCol1)) * mCol2 = IF(mCol2=0,16843009,IF(mCol2=16777215,0,mCol2)) * mCol3 = IF(mCol3=0,16843009,IF(mCol3=16777215,0,mCol3)) aRGB1 = GraGetRGBIntensity(mCol1) // Взаимнообратные операции преобразования формы кодирования цвета в массиве RGB и одним числом aRGB2 = GraGetRGBIntensity(mCol2) // Взаимнообратные операции преобразования формы кодирования цвета в массиве RGB и одним числом aRGB3 = GraGetRGBIntensity(mCol3) // Взаимнообратные операции преобразования формы кодирования цвета в массиве RGB и одним числом fColor1 := GraMakeRGBColor({ aRGB1[1], aRGB1[2], aRGB1[3] }) // Точно также сделать определение цвета в вершинах треугольников ########### fColor2 := GraMakeRGBColor({ aRGB2[1], aRGB2[2], aRGB2[3] }) // Точно также сделать определение цвета в вершинах треугольников ########### fColor3 := GraMakeRGBColor({ aRGB3[1], aRGB3[2], aRGB3[3] }) // Точно также сделать определение цвета в вершинах треугольников ########### ENDIF aClrs := {} AADD(aClrs, fColor1);AADD(aClrs, fColor2);AADD(aClrs, fColor3) GraGradient(oPS, {X1,Y1}, {{X2,Y2}, {X3,Y3}}, aClrs, GRA_GRADIENT_TRIANGLE) IF mVIE IF mFlagRibs GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) GraLine( oPS, { X1, Y1 }, { X3, Y3 } ) GraLine( oPS, { X2, Y2 }, { X3, Y3 } ) ENDIF ENDIF NEXT IF mVIE ***** Сделать надпись изображения oFont := XbpFont():new():create("22.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты * GraStringAt( oPS, { X_Max, Y_Max-20 }, 'Триангуляция Делоне. Стиль: "Градиентная заливка цветом"' ) GraStringAt( oPS, { X_Max/2, Y_Max-20 }, 'Триангуляция Делоне. Стиль: "Градиентная заливка цветом"' ) ******* Сделать надпись изображения IF FILE('_482.txt') oFont := XbpFont():new():create("16.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты mPar=FileStr('_482.txt');mNumColumn=VAL(SUBSTR(mPar,1,6));mFile=SUBSTR(mPar,8,LEN(mPar)) IF FILE("_ColumnNames.arx") aColumnNames = DC_ARestore("_ColumnNames.arx") // Загрузка массива наименований шкал (колонок) из файла IF 1 <= mNumColumn .AND. mNumColumn <= LEN(aColumnNames) GraStringAt( oPS, { X_Max/2, Y_Max-60 }, 'Картографическая визуализация значений шкалы: "'+aColumnNames[mNumColumn]+IF(mFile='Rsp_it.','" файла результатов классификации: "','" файла исходных данных: "')+mFile+'xls"') ELSE GraStringAt( oPS, { X_Max/2, Y_Max-60 }, 'Картографическая визуализация значений шкалы №'+ALLTRIM(STR(mNumColumn))+IF(mFile='Rsp_it.','" файла результатов классификации: "','" файла исходных данных: "')+mFile+'xls"' ) ENDIF ELSE GraStringAt( oPS, { X_Max/2, Y_Max-60 }, 'Картографическая визуализация значений шкалы №'+ALLTRIM(STR(mNumColumn))+IF(mFile='Rsp_it.','" файла результатов классификации: "','" файла исходных данных: "')+mFile+'xls"' ) ENDIF ENDIF * MsgBox(STR(X_Max)) ***** Сделать шкалу соответствия цветов спектра и значений функции ****** Визуализация спектра - легенды ************************ N_Line = 360 // Число линий в спектре D = 300 Z = 0 Delta = INT(360/ N_Line ) mDeltaSpectr = 90 Kx = (X_Max-2*D) / N_Line * (1 + mDeltaSpectr/360) // Коэффициент масштабирования по оси X: преобразует аргумент функции в номер пикселя по оси X mColorZer = ABS(INT( mDeltaSpectr + (360-mDeltaSpectr) * (0 - mInfMin) / (mInfMax-mInfMin) )) // Сделать нормировку значений по цветам спектра: MAX=Красный, MIN-фиолетовый ############################## ma := 255/2 mb := 255/2 mc := 255/2 mU := 0 mV := 120 mW := 240 R := INT( ma * (1 + COS( ( mColorZer + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( mColorZer + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( mColorZer + mW ) * GradRad ) ) ) fColorZer := GraMakeRGBColor({ R, G, B }) Column = 0 FOR n = 359 TO mDeltaSpectr STEP -Delta R := INT( ma * (1 + COS( ( n + mU ) * GradRad ) ) ) G := INT( mb * (1 + COS( ( n + mV ) * GradRad ) ) ) B := INT( mc * (1 + COS( ( n + mW ) * GradRad ) ) ) fColor := GraMakeRGBColor({ R, G, B }) ***** Закрасить фон прямоугольника *************** GraSetColor( oPS, fColor, fColor ) ++Column X1 := D + (Column-1) * Kx + mDeltaSpectr / 2 + Z X2 := D + Column * Kx + mDeltaSpectr / 2 + Z Y1 := 0 Y2 := 0 + 30 GraBox( oPS, { X1, Y1 }, { X2, Y2 }, GRA_FILL) NEXT ****** Надписи на легенде aFonts := XbpFont():new():list() // Все доступные шрифты oFont := XbpFont():new():create("10.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт ****** Задать атрибуты шрифта aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) Column = 0 FOR n = 360 TO mDeltaSpectr STEP -Delta ++Column NEXT X1 := D + mDeltaSpectr / 2 + Z X2 := D + mDeltaSpectr / 2 + Column * Kx + Z GraStringAt( oPS, { X1, Y2+10 }, ALLTRIM(STR(mInfMax,15,3))) aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_RIGHT // Выравнивание символов по горизонтали по правому краю относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraStringAt( oPS, { X2, Y2+10 }, ALLTRIM(STR(mInfMin,15,3))) LB_Warning(L('Цветовая градиентная заливка треугольников завершена!'),L('4.8. Геокогнитивная подсистема "Эйдос"' )) ENDIF RETURN nil * --------- ************************************************* function Side(i,j,xo,yo) LOCAL x1,y1,x2,y2,dx,dy,a,b,v *DC_MsgBox(,,{'Side:','i='+ALLTRIM(STR(i)),'j='+ALLTRIM(STR(j)),'k='+ALLTRIM(STR(k))},'4.8. Геокогнитивная подсистема "Эйдос"',,,,,,,,,'20.Helvetica Bold') x1:=aX[i] y1:=aY[i] x2:=aX[j] y2:=aY[j] dx:=x2-x1 dy:=y2-y1 if abs(dx)>abs(dy) a:=dy/dx b:=y1-a*x1 v:=a*xo+b result = if(yo>v,0,1) else a:=dx/dy b:=x1-a*y1 v:=a*yo+b result = if(xo>v,0,1) endif ****** Задать атрибуты линии *aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии *aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT *aAttr [ GRA_AL_COLOR ] := GRA_CLR_RED // Задать цвет линии *aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии *graSetAttrLine( oPS, aAttr ) *GraLine( oPS, { x1,y1 }, { x2,y2 } ) *aAttr [ GRA_AL_COLOR ] := IF(result=1,GRA_CLR_BLACK,GRA_CLR_RED) // Задать цвет линии *aAttr [ GRA_AL_WIDTH ] := 2 // Задать толщину линии *graSetAttrLine( oPS, aAttr ) *GraArc ( oPS, { x1, y1 }, 1 ) // Рисует круг стилем линии RETURN(result) *-------------------- function TriangleExists(p1,p2,p3) LOCAL g IF TrianglesCount = 0 RETURN(.F.) ELSE for g:=TrianglesCount to 1 STEP -1 f1=.F.;if p1=trianglesP1[g] .or. p1=trianglesP2[g] .or. p1=trianglesP3[g];f1=.T.;endif f2=.F.;if p2=trianglesP1[g] .or. p2=trianglesP2[g] .or. p2=trianglesP3[g];f2=.T.;endif f3=.F.;if p3=trianglesP1[g] .or. p3=trianglesP2[g] .or. p3=trianglesP3[g];f3=.T.;endif IF f1 .and. f2 .and. f3 RETURN(.T.) ENDIF NEXT ENDIF RETURN(.F.) *-------------------- function RibExists(p1,p2) LOCAL i for i:=RibsCount to 1 step -1 if ((p1=RibsP1[i]) .or. (p1=RibsP2[i])) .and. ((p2=RibsP1[i]) .or. (p2=RibsP2[i])) RibsSide[i] := 255 RETURN(.T.) endif NEXT RETURN(.F.) *-------------------- function RibExistsOldNew(p1,p2) *LOCAL i LOCAL i,xa,ya,xb,yb,xc,yc,xd,yd,F1,F2,Flag1,Flag2,Flag3,Flag4 **** Проверка на пересечение с другими ребрами * F1=(yc-ya)/(xc-xa) * F2=(yd-yb)/(xd-xb) * x=(yb-ya+F1*xa-F2*xb)/(F1-F2) * y=ya+(x-xa)*F1 * y=yb+(x-xb)*F2 *** Координаты точек проверяемого ребра xa=aX[p1] ya=aY[p1] xb=aX[p2] yb=aY[p2] for i:=RibsCount to 1 step -1 if ((p1=RibsP1[i]) .or. (p1=RibsP2[i])) .and. ((p2=RibsP1[i]) .or. (p2=RibsP2[i])) RibsSide[i] := 255 RETURN(.T.) endif xc=aX[RibsP1[i]] yc=aY[RibsP1[i]] xd=aX[RibsP2[i]] yd=aY[RibsP2[i]] F1=(yc-ya)/(xc-xa) F2=(yd-yb)/(xd-xb) x=(yb-ya+F1*xa-F2*xb)/(F1-F2) y=ya+(x-xa)*F1 ** Наверное надо перед сравнением еще определять, что больше: ** xa или xb, ya или yb ** xc или xd, yc или yd ** и сравнивать по-разному * if (xa<=x .AND. x<=xb .AND. ya<=y .AND. y<=yb); // Если .T., то точка пересечения даигоналей находится внутри четыехугольника * (xc<=x .AND. x<=xd .AND. yc<=y .AND. y<=yd) * RibsSide[i] := 255 * RETURN(.T.) * endif Flag1 = .F. if xar1) .and. (i<>r2) .and. (.not. TriangleExists(r1,r2,i)) if side(r1,r2,aX[i],aY[i]) = ribsSide[rib] cr:=SolveCircle(aX[r1],aY[r1],aX[r2],aY[r2],aX[i],aY[i]) xo=cr[1] yo=cr[2] R =cr[3] x2:=xo-(aX[r1]+aX[r2])*0.5 y2:=yo-(aY[r1]+aY[r2])*0.5 l:=sqrt(x2*x2+y2*y2) OSide:=side(r1,r2,xo,yo) if OSide=ribsSide[rib] v:=R+l else v:=R-l endif if (v>1) .and. (vi .and. k<>j * DC_MsgBox(,,{'FindFirstRib-поиск:','i='+ALLTRIM(STR(i)),'j='+ALLTRIM(STR(j)),'k='+ALLTRIM(STR(k))},'4.8. Геокогнитивная подсистема "Эйдос"',,,,,,,,,'20.Helvetica Bold') n:=Side(i,j,aX[k],aY[k]) if n=1;st_1:=.T.;endif if n=0;st_0:=.T.;endif endif NEXT if st_1 <> st_0 RibsP1[1]:=i RibsP2[1]:=j RibsSide[1]:=n RibsCount:=1 IF mVIE GraLine( oPS, { aX[i], aY[i] }, { aX[j], aY[j] } ) ENDIF * DC_MsgBox(,,{'FindFirstRib-найдено:','i='+ALLTRIM(STR(i)),'j='+ALLTRIM(STR(j)),'k='+ALLTRIM(STR(k))},'4.8. Геокогнитивная подсистема "Эйдос"',,,,,,,,,'20.Helvetica Bold') RETURN NIL endif NEXT NEXT RETURN NIL *-------------------------------------------------- FUNCTION Triangulation(mVIE) LOCAL zz,p1,p2,nn,oProgress PUBLIC aX[100000], aY[100000], aZ[100000] // Координаты X,Y,Z точек облака IF .NOT. FILE('Points_XYZ.dbf') GetPoints() ENDIF IF mVIE ClearImageTr() ENDIF ******* Узнать разрешение экрана и не показывать изображений большой размерности **************** nWidth := AppDeskTop():currentSize()[1] // current screen size width in pixels nHeight := AppDeskTop():currentSize()[2] // current screen size height in pixels * nWidth = 1366 // <<<===########################## * nHeight = 768 * F4_8('L('4.7. АСК-анализ изображений по пикселям, спектрам и контурам')') // Если F4_8() запускается не из главного меню, а из F4_7(), то может работать на любом экране * IF mTitle = L('4.8. Геокогнитивная подсистема') // 4.8. Геокогнитивная подсистема работает только на экранах с разрешением 1920 x 1080 и более IF nWidth < 1800 aMess := {} AADD(aMess, L("Для правильного отображения графической формы")) AADD(aMess, L("необходимо разрешение экрана 1800 pix по горизонтали,")) AADD(aMess, L("а фактически установлено: ")+ALLTRIM(STR(nWidth))+" pix") LB_Warning(aMess ) Running(.F.) ReTURN NIL ENDIF IF nHeight < 850 aMess := {} AADD(aMess, L("Для правильного отображения графической формы")) AADD(aMess, L("необходимо разрешение экрана 850 pix по вертикали,")) AADD(aMess, L("а фактически установлено: ")+ALLTRIM(STR(nHeight))+" pix") LB_Warning(aMess ) Running(.F.) ReTURN NIL ENDIF * ENDIF ************************************************************************************************* ***** Сформировать массивы координат точек на основе БД и нарисовать точки CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Points_XYZ EXCLUSIVE NEW SELECT Points_XYZ PointsCount = RECCOUNT() ***** Поиск min и max по X и Y mMaxX = -99999999999 mMinX = +99999999999 mMaxY = -99999999999 mMinY = +99999999999 DBGOTOP() DO WHILE .NOT. EOF() mMaxX = MAX(mMaxX, pX) mMinX = MIN(mMinX, pX) mMaxY = MAX(mMaxY, pY) mMinY = MIN(mMinY, pY) DBSKIP(1) ENDDO ***** Расчет позиций для одного по X поля изображения шириной nXSizeAr ***** и двух равных промежутков между ними d и слева и справа от изображений до края окна nXSize = mMaxX - mMinX nYSize = mMaxY - mMinY X_Max := 1800 Y_Max := 850 // Размер графического окна для самого графика в пикселях IF .NOT. FILE('_XYSize.txt') * LB_Warning(L('Необходимо запустить режим генерации облака точек!','4.8. Геокогнитивная подсистема "Эйдос"' ) StrFile(STR(nXSize,9)+' '+STR(nYSize,9), '_XYSize.txt') // Запись текстового файла с параметрами nXSize, nYSize ELSE * StrFile(STR(nXSize,9)+' '+STR(nYSize,9), '_XYSize.txt') // Запись текстового файла с параметрами nXSize, nYSize nXSize = VAL(SUBSTR(FileStr('_XYSize.txt'), 1,9)) // Загрузка параметра nXSize из текстового файла nYSize = VAL(SUBSTR(FileStr('_XYSize.txt'),11,9)) // Загрузка параметра nYSize из текстового файла ENDIF nSize = MIN(nXSize, nYSize) mMax = MIN(mMaxX, mMaxY) mMin = MIN(mMinX, mMinY) **************************** dX = (X_Max-0.8*Y_Max)/2 dY = (Y_Max-0.8*Y_Max)/2 - 200 *************************** ** Массивы пиксельных (нормированных) координат и нормированных значений aX := {} aY := {} aZ := {} FOR p=1 TO PointsCount DBGOTO(p) AADD(aX, pX ) AADD(aY, pY ) AADD(aZ, pZ ) NEXT IF mVIE aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT graSetAttrLine( oPS, aAttr ) FOR j=1 TO PointsCount aAttr [ GRA_AL_COLOR ] := GRA_CLR_RED // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraArc ( oPS, { aX[j], aY[j] }, 2 ) // Рисует круг стилем линии aAttr [ GRA_AL_COLOR ] := GRA_CLR_DARKGRAY // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraArc ( oPS, { aX[j], aY[j] }, 3 ) // Рисует круг стилем линии NEXT ENDIF **************************** nSeconds := Seconds() // Начальное значение таймера FindFirstRib(mVIE) *DC_MsgBox(,,{"Кол-во ребер: "+ALLTRIM(STR(RibsCount))},'4.8. Геокогнитивная подсистема "Эйдос"',,,,,,,,, '20.Helvetica Bold') **** Задать атрибуты линии aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := GRA_CLR_BLACK // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты TrianglesCount:=0 zz:=1 DO WHILE zz < RibsCount+1 p1:=RibsP1[zz] p2:=RibsP2[zz] if RibsSide[zz] < 255 nn:=FindPoint(zz) else nn:=-1 endif * DC_MsgBox(,,{"Ребро: "+ALLTRIM(STR(zz)),"nn="+ALLTRIM(STR(nn)),'p1='+ALLTRIM(STR(p1)),'p2='+ALLTRIM(STR(p2))},'4.8. Геокогнитивная подсистема "Эйдос"',,,,,,,,, '20.Helvetica Bold') IF nn > 0 ********* Формирование ID ребер и тругольников RibsP1[RibsCount+1]=p1;RibsP2[RibsCount+1]=nn if .not. RibExists(p1,nn) //##################### RibsSide[RibsCount+1] = 1-Side(p1,nn,aX[p2],aY[p2]) AADD (aRibID,mRibID) // Ребра нет, добавить else RibsSide[RibsCount+1] = 255 endif RibsP1[RibsCount+2]=p2;RibsP2[RibsCount+2]=nn if .not. RibExists(p2,nn) RibsSide[RibsCount+2] = 1-Side(p2,nn,aX[p1],aY[p1]) AADD (aRibID,mRibID) // Ребра нет, добавить else RibsSide[RibsCount+2] = 255 endif RibsCount=RibsCount+2 AADD (aTriangleID,mTriangleID) // Треугольника нет, добавить trianglesP1[TrianglesCount+1] = p1 trianglesP2[TrianglesCount+1] = p2 trianglesP3[TrianglesCount+1] = nn TrianglesCount++ * GraArc ( oPS, { aX[p1], aY[p1] }, 3 ) // Отобразить найденную точку IF mVIE GraLine( oPS, { aX[p1], aY[p1] }, { aX[nn], aY[nn] } ) GraLine( oPS, { aX[p2], aY[p2] }, { aX[nn], aY[nn] } ) GraLine( oPS, { aX[p1], aY[p1] }, { aX[p2], aY[p2] } ) ENDIF * DC_MsgBox(,,{"Номер найденной точки: "+ALLTRIM(STR(nn)),"Номер текущего ребра: "+ALLTRIM(STR(zz)),'p1='+ALLTRIM(STR(p1)),'p2='+ALLTRIM(STR(p2))},'4.8. Геокогнитивная подсистема "Эйдос"',,,,,,,,, '20.Helvetica Bold') ENDIF zz++ ENDDO ***** Если задано рисование окружностей, то отобразить сеть красным цветом, чтобы было видно на их фоне IF mVIE IF mFlagCircle **** Задать атрибуты линии aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := GRA_CLR_RED // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) FOR j=1 TO TrianglesCount X1 = aX[trianglesP1[j]] Y1 = aY[trianglesP1[j]] X2 = aX[trianglesP2[j]] Y2 = aY[trianglesP2[j]] X3 = aX[trianglesP3[j]] Y3 = aY[trianglesP3[j]] GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) GraLine( oPS, { X1, Y1 }, { X3, Y3 } ) GraLine( oPS, { X2, Y2 }, { X3, Y3 } ) NEXT ENDIF ***** Сделать надпись изображения oFont := XbpFont():new():create("22.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты * GraStringAt( oPS, { X_Max, Y_Max-20 }, 'Триангуляция Делоне. Стиль: "Сетка"' ) GraStringAt( oPS, { X_Max/2, Y_Max-20 }, 'Триангуляция Делоне. Стиль: "Сетка"' ) ******* Сделать надпись изображения IF FILE('_482.txt') oFont := XbpFont():new():create("16.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты mPar=FileStr('_482.txt');mNumColumn=VAL(SUBSTR(mPar,1,6));mFile=SUBSTR(mPar,8,LEN(mPar)) IF FILE("_ColumnNames.arx") aColumnNames = DC_ARestore("_ColumnNames.arx") // Загрузка массива наименований шкал (колонок) из файла IF 1 <= mNumColumn .AND. mNumColumn <= LEN(aColumnNames) GraStringAt( oPS, { X_Max/2, Y_Max-60 }, 'Картографическая визуализация значений шкалы: "'+aColumnNames[mNumColumn]+IF(mFile='Rsp_it.','" файла результатов классификации: "','" файла исходных данных: "')+mFile+'xls"') ELSE GraStringAt( oPS, { X_Max/2, Y_Max-60 }, 'Картографическая визуализация значений шкалы №'+ALLTRIM(STR(mNumColumn))+IF(mFile='Rsp_it.','" файла результатов классификации: "','" файла исходных данных: "')+mFile+'xls"' ) ENDIF ELSE GraStringAt( oPS, { X_Max/2, Y_Max-60 }, 'Картографическая визуализация значений шкалы №'+ALLTRIM(STR(mNumColumn))+IF(mFile='Rsp_it.','" файла результатов классификации: "','" файла исходных данных: "')+mFile+'xls"' ) ENDIF ENDIF ENDIF *MsgBox(STR(X_Max)) **** Переписать массивы кординат ребер и треугольников в базы данных **** Создать БД для координат концов ребер aStructure := { { "Num" , "N", 15, 0 }, ; { "pX1" , "N", 15, 0 }, ; { "pY1" , "N", 15, 0 }, ; { "pX2" , "N", 15, 0 }, ; { "pY2" , "N", 15, 0 }, ; { "pID" , "C", 20, 0 } } DbCreate( 'Ribs_XY', aStructure ) **** Создать БД для координат вершин треугольников aStructure := { { "Num" , "N", 15, 0 }, ; { "pX1" , "N", 15, 0 }, ; { "pY1" , "N", 15, 0 }, ; { "pZ1" , "N", 15, 0 }, ; { "pX2" , "N", 15, 0 }, ; { "pY2" , "N", 15, 0 }, ; { "pZ2" , "N", 15, 0 }, ; { "pX3" , "N", 15, 0 }, ; { "pY3" , "N", 15, 0 }, ; { "pZ3" , "N", 15, 0 }, ; { "pID" , "C", 30, 0 } } DbCreate( 'Triang_XYZ', aStructure ) **** Создать БД для номеров точек вершин треугольников aStructure := { { "Num" , "N", 15, 0 }, ; { "p1" , "N", 15, 0 }, ; { "p2" , "N", 15, 0 }, ; { "p3" , "N", 15, 0 } } DbCreate( 'Triang_Num', aStructure ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Ribs_XY EXCLUSIVE NEW USE Triang_XYZ EXCLUSIVE NEW USE Triang_Num EXCLUSIVE NEW SELECT Ribs_XY FOR r=1 TO RibsCount ar := {} AADD(ar, RibsP1[r]) AADD(ar, RibsP2[r]) * ASORT(ar) mRibsID = STRTRAN(STR(ar[1])+STR(ar[2]),' ','_') APPEND BLANK REPLACE Num WITH r REPLACE pX1 WITH aX[RibsP1[r]] REPLACE pY1 WITH aY[RibsP1[r]] REPLACE pX2 WITH aX[RibsP2[r]] REPLACE pY2 WITH aY[RibsP2[r]] REPLACE pID WITH mRibsID NEXT SELECT Triang_XYZ FOR t=1 TO TrianglesCount ar := {} AADD(ar, trianglesP1[t]) AADD(ar, trianglesP2[t]) AADD(ar, trianglesP3[t]) * ASORT(ar) mTriangID = STRTRAN(STR(ar[1])+STR(ar[2])+STR(ar[3]),' ','_') APPEND BLANK REPLACE Num WITH t REPLACE pX1 WITH aX[trianglesP1[t]] REPLACE pY1 WITH aY[trianglesP1[t]] REPLACE pZ1 WITH aZ[trianglesP1[t]] REPLACE pX2 WITH aX[trianglesP2[t]] REPLACE pY2 WITH aY[trianglesP2[t]] REPLACE pZ2 WITH aZ[trianglesP2[t]] REPLACE pX3 WITH aX[trianglesP3[t]] REPLACE pY3 WITH aY[trianglesP3[t]] REPLACE pZ3 WITH aZ[trianglesP3[t]] REPLACE pID WITH mTriangID NEXT SELECT Triang_Num FOR t=1 TO TrianglesCount APPEND BLANK REPLACE Num WITH t REPLACE p1 WITH trianglesP1[t] REPLACE p2 WITH trianglesP2[t] REPLACE p3 WITH trianglesP3[t] NEXT CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций ********************************************************************************** ***** Вывести информацию о времени исполнения и числе точек, ребер и треугольников ********************************************************************************** IF mVIE mTime = Seconds()-nSeconds // Время исполнения в секундах aMess := {} AADD(aMess, L("Триангуляция завершена!")) AADD(aMess, L(" ")) AADD(aMess, L("Время исполнения:______") +ALLTRIM(STR(mTime))+" "+L("секунд")) AADD(aMess, L("Точек:__________________")+ALLTRIM(STR(PointsCount))) AADD(aMess, L("Ребер:__________________")+ALLTRIM(STR(RibsCount))) AADD(aMess, L("Треугольников:__________")+ALLTRIM(STR(TrianglesCount))) AADD(aMess, L("Треугольников/секунду:__")+ALLTRIM(STR(TrianglesCount/mTime,15,5))) DC_MsgBox(,,aMess,L('4.8. Геокогнитивная подсистема "Эйдос"'),,,,,,,,, '16.Helvetica Bold') ENDIF RETURN NIL ****************************************************************************************** ****************************************************************************************** ****************************************************************************************** FUNCTION ClearImageTr() ***** Закрасить фон прямоугольника *************** *GraSetColor( oPS, GRA_CLR_WHITE, GRA_CLR_WHITE ) GraSetColor( oPS, BD_LIGHTGREY, BD_LIGHTGREY ) GraBox( oPS, { 0, 0 }, { 1800, 850 }, GRA_FILL ) *LB_Warning(L('Очистка изображения завершена','4.8. Геокогнитивная подсистема "Эйдос"' ) RETURN nil *------------ *STATIC FUNCTION ShowColorTr( hDC, aCoords, oSay, oStatic ) FUNCTION ShowColorTr( hDC, aCoords, oSay, oStatic ) LOCAL nColor aCoords[2] := oStatic:currentSize()[2] - aCoords[2] nColor := GetPixel(hDC,aCoords[1],aCoords[2]) *oSay:SetCaption(L('Color: ' + DC_Array2String(GraGetRGBIntensity(AutomationTranslateColor(nColor,.T.))) + ' Coords: ' + DC_Array2String(aCoords)) RETURN nil * ---------- #command GDIFUNCTION ([]) ; => ; FUNCTION ([]);; STATIC scHCall := nil ;; IF scHCall == nil ;; IF snHdll == nil ;; snHDll := DllLoad('GDI32.DLL') ;; ENDIF ;; scHCall := DllPrepareCall(snHDll,DLL_STDCALL,<(Func)>) ;; ENDIF ;; RETURN DllExecuteCall(scHCall,) GDIFUNCTION GetPixel( nHDC, x, y) GDIFUNCTION SetPixel( nHDC, x, y, n ) DLLFUNCTION GetWindowDC( hwnd ) USING STDCALL FROM USER32.DLL DLLFUNCTION CreateCompatibleDC( nHDC ) USING STDCALL FROM GDI32.DLL DLLFUNCTION CreateCompatibleBitmap( nHDC, dw, dh ) USING STDCALL FROM GDI32.DLL DLLFUNCTION SelectObject(hMemoryDC,hBMP) USING STDCALL FROM GDI32.DLL DLLFUNCTION BitBlt( hDC,nXDest,nYDest,nXSize,nYSize,hDCSrc,nXSrc,nYSrc,dwROP ) ; USING STDCALL FROM GDI32.DLL * ----------- FUNCTION GraTest( oStatic ) PUBLIC oPS := oStatic:lockPs() ClearImage4223() // Очистка изображения ************************ *oFont := XbpFont():new( oPS ):create() *oFont:configure('16.Arial Bold') *GraSetFont( oPS, oFont ) ****** Задать атрибуты линии *aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии *aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT *aAttr [ GRA_AL_COLOR ] := GRA_CLR_RED // Задать цвет линии *aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии *graSetAttrLine( oPS, aAttr ) *GraBox( oPS, {30,80}, {200,130 } ) *GraLine( oPS, {30,80}, {200,130 } ) *GraStringAt( oPS, {50,100}, 'This is a test' ) *oStatic:unlockPs() RETURN nil **************************************************************************** ******** Подготовка данных из Inp_data.dbf или Inp_rasp.dbf ******** для картографической визуализации, т.е. формирование Points_XYZ.dbf **************************************************************************** FUNCTION F482(mFile, mNumColumn, mRegim) LOCAL aX[100000], aY[100000], aZ[100000] // Координаты X,Y,Z точек облака ****** Нормирование координат X,Y к размеру экрана IF PointsCount > 0 ClearImageTr() // Очистка изображения ENDIF **** Если файл Inp_data.dbf есть в папке Inp_data CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir+"\AID_DATA\Inp_data\") DO CASE CASE mFile = 'Inp_map1.' .OR. mFile = 'Inp_map2.' IF .NOT. FILE('Inp_data.dbf') aMess := {} AADD(aMess, L('В папке: ')+Disk_dir+L('/AID_DATA/Inp_data/ должен быть файл: "Inp_data.dbf"')) AADD(aMess, L('Этот файл формируется в режиме: "Inp_map1 => Inp_data" или "Inp_map2 => Inp_data"')) LB_Warning( aMess,L('4.8. Геокогнитивная подсистема "Эйдос"' )) RETURN NIL ENDIF CASE mFile = 'Rsp_map1.' .OR. mFile = 'Rsp_map2.' IF .NOT. FILE('Inp_rasp.dbf') aMess := {} AADD(aMess, L('В папке: ')+Disk_dir+L('/AID_DATA/Inp_data/ должен быть файл: "Inp_rasp.dbf"')) AADD(aMess, L('Этот файл формируется в режиме: "Rsp_map1 => Inp_rasp" или "Rsp_map2 => Inp_rasp"')) LB_Warning( aMess,L('4.8. Геокогнитивная подсистема "Эйдос"' )) RETURN NIL ENDIF ENDCASE DIRCHANGE(Disk_dir) DO CASE CASE mFile = 'Inp_map1.' .OR. mFile = 'Inp_map2.' Name_SS = Disk_dir+"\AID_DATA\Inp_data\Inp_data.dbf" Name_DD = Disk_dir +"\Inp_data.dbf" * MsgBox(Name_SS+' '+Name_DD) COPY FILE (Name_SS) TO (Name_DD) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Inp_data EXCLUSIVE NEW SELECT Inp_data CASE mFile = 'Rsp_map1.' .OR. mFile = 'Rsp_map2.' Name_SS = Disk_dir+"\AID_DATA\Inp_data\Inp_rasp.dbf" Name_DD = Disk_dir +"\Inp_rasp.dbf" * MsgBox(Name_SS+' '+Name_DD) COPY FILE (Name_SS) TO (Name_DD) USE Inp_rasp EXCLUSIVE NEW SELECT Inp_rasp ENDCASE *MsgBox(STR(mNumColumn)+STR(FCOUNT())) // Записать файлы: _ColumnNames.arx и _482.txt // Наименования шкал взяты из Inp_map1, а в нем на 1 колонку больше, чем в Inp_data // учесть это в F482 при выборке данных и выводе наименований форм с учетом значения mRegim DO CASE CASE mRegim = 6 IF mNumColumn < 3 LB_Warning(L('Номер отображаемой колонки должен быть не меньше 3'),L('4.8. Геокогнитивная подсистема "Эйдос"' )) RETURN NIL ENDIF IF mNumColumn > FCOUNT()+1 LB_Warning(L('Номер отображаемой колонки должен быть не больше: ')+ALLTRIM(STR(FCOUNT()+1)),L('4.8. Геокогнитивная подсистема "Эйдос"' )) RETURN NIL ENDIF mNumColumn-- StrFile(STR(mNumColumn,6)+' Inp_map1.', '_482.txt') // Запись текстового файла _482.txt *mPar=FileStr('_482.txt');mNumColumn=VAL(SUBSTR(mPar,1,6));mFile=SUBSTR(mPar,8,LEN(mPar)) CASE mRegim = 7 IF mNumColumn < 3 LB_Warning(L('Номер отображаемой колонки должен быть не меньше 3'),L('4.8. Геокогнитивная подсистема "Эйдос"' )) RETURN NIL ENDIF IF mNumColumn > FCOUNT()+1 LB_Warning(L('Номер отображаемой колонки должен быть не больше: ')+ALLTRIM(STR(FCOUNT()+1)),L('4.8. Геокогнитивная подсистема "Эйдос"' )) RETURN NIL ENDIF mNumColumn-- StrFile(STR(mNumColumn,6)+' Rsp_map1.', '_482.txt') // Запись текстового файла _482.txt *mPar=FileStr('_482.txt');mNumColumn=VAL(SUBSTR(mPar,1,6));mFile=SUBSTR(mPar,8,LEN(mPar)) CASE mRegim = 10 IF mNumColumn < 2 LB_Warning(L('Номер отображаемой колонки должен быть не меньше 2'),L('4.8. Геокогнитивная подсистема "Эйдос"' )) RETURN NIL ENDIF IF mNumColumn > FCOUNT() LB_Warning(L('Номер отображаемой колонки должен быть не больше: ')+ALLTRIM(STR(FCOUNT())),L('4.8. Геокогнитивная подсистема "Эйдос"' )) RETURN NIL ENDIF StrFile(STR(mNumColumn,6)+' Inp_data.', '_482.txt') // Запись текстового файла _482.txt *mPar=FileStr('_482.txt');mNumColumn=VAL(SUBSTR(mPar,1,6));mFile=SUBSTR(mPar,8,LEN(mPar)) CASE mRegim = 11 IF mNumColumn < 2 LB_Warning(L('Номер отображаемой колонки должен быть не меньше 2'),L('4.8. Геокогнитивная подсистема "Эйдос"' )) RETURN NIL ENDIF IF mNumColumn > FCOUNT() LB_Warning(L('Номер отображаемой колонки должен быть не больше: ')+ALLTRIM(STR(FCOUNT())),L('4.8. Геокогнитивная подсистема "Эйдос"' )) RETURN NIL ENDIF StrFile(STR(mNumColumn,6)+' Inp_rasp.', '_482.txt') // Запись текстового файла _482.txt *mPar=FileStr('_482.txt');mNumColumn=VAL(SUBSTR(mPar,1,6));mFile=SUBSTR(mPar,8,LEN(mPar)) ENDCASE PointsCount = RECCOUNT() // Задание количества точек ***** Поиск min и max по X и Y mMaxX = -99999999999 mMinX = +99999999999 mMaxY = -99999999999 mMinY = +99999999999 mMax = -99999999999 mMin = +99999999999 kX := {} // Массивы координат точек kY := {} mFlagErr = .F. DBGOTOP() DO WHILE .NOT. EOF() mF1 = FIELDGET(1) IF VALTYPE(mF1) <> 'C' aMess := {} AADD(aMess, L('В файле: "Inp_data.xls" в 1-й колонке должны быть координаты в формате:')) AADD(aMess, L('X=#######.#######, Y=#######.####### и далее может быть любой текст.')) AADD(aMess, L('Для того, чтобы сформировать такой файл можно воспользоваться режимом')) AADD(aMess, L('4.8 системы "Эйдос": запустить формирование облака точек из файла:')) AADD(aMess, L('"Inp_map1.xls" с формированием модели, выполнить рекомендуемые действия.')) LB_Warning(aMess) mFlagErr = .T. EXIT ELSE mPosX = AT("X=", mF1) mPosY = AT("Y=", mF1) IF mPosX * mPosY = 0 aMess := {} AADD(aMess, L('В файле: "Inp_data.xls" в 1-й колонке должны быть координаты в формате:')) AADD(aMess, L('X=#######.#######, Y=#######.####### и далее может быть любой текст.')) AADD(aMess, L('Для того, чтобы сформировать такой файл можно воспользоваться режимом')) AADD(aMess, L('4.8 системы "Эйдос": запустить формирование облака точек из файла:')) AADD(aMess, L('"Inp_map1.xls" с формированием модели, выполнить рекомендуемые действия.')) LB_Warning(aMess) mFlagErr = .T. EXIT ELSE mX = VAL(SUBSTR(mF1, mPosX+2, mPosY-3)) mY = VAL(SUBSTR(mF1, mPosY+2, 15)) * MsgBox(STR(mX)+'; '+STR(mY)) IF ASCAN(kX, mX) = 0 AADD (kX, mX) ENDIF IF ASCAN(kY, mY) = 0 AADD (kY, mY) ENDIF mMaxX = MAX(mMaxX, mX) mMinX = MIN(mMinX, mX) mMaxY = MAX(mMaxY, mY) mMinY = MIN(mMinY, mY) mMax = MAX(mMaxX, mX) mMin = MIN(mMinX, mX) mMax = MAX(mMaxY, mY) mMin = MIN(mMinY, mY) ENDIF ENDIF DBSKIP(1) ENDDO IF mFlagErr ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ***** Расчет позиций для одного по X поля изображения шириной nXSizeAr ***** и двух равных промежутков между ними d и слева и справа от изображений до края окна X_Max := 1800 Y_Max := 850 // Размер графического окна для самого графика в пикселях nXSize = mMaxX - mMinX nYSize = mMaxY - mMinY StrFile(STR(nXSize,9)+' '+STR(nYSize,9), '_XYSize.txt') // Запись текстового файла с параметрами nXSize, nYSize *nXSize = VAL(SUBSTR(FileStr('_XYSize.txt'), 1,9)) // Загрузка параметра nXSize из текстового файла *nYSize = VAL(SUBSTR(FileStr('_XYSize.txt'),11,9)) // Загрузка параметра nYSize из текстового файла nSize = MIN(nXSize, nYSize) dX = (X_Max-0.8*Y_Max)/2 dY = (Y_Max-0.8*Y_Max)/2 - 200 **************************** KPx = X_Max / nXSize KPy = Y_Max / nYSize *KP = 0.8 * MIN(X_Max, Y_Max) / nSize KP = 0.8 * MIN(X_Max, Y_Max) / Y_Max K = 0.85 * nYSize / (mMax - mMin + 1) ***** Задать атрибуты линии aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT graSetAttrLine( oPS, aAttr ) ** Массивы пиксельных (нормированных) координат и нормированных значений aX := {} aY := {} aZ := {} FOR p=1 TO PointsCount DBGOTO(p) *(mInf1 - mInfMin) / (mInfMax-mInfMin) * mX = VAL(SUBSTR(FIELDGET(1), 3,15)) * mY = VAL(SUBSTR(FIELDGET(1),22,15)) * mZ = FIELDGET(2) mF1 = FIELDGET(1) mPosX = AT("X=", mF1) mPosY = AT("Y=", mF1) IF mPosX * mPosY = 0 aMess := {} AADD(aMess, L('В файле: "Inp_data.xls" в 1-й колонке должны быть координаты в формате:')) AADD(aMess, L('X=#######.#######, Y=#######.####### и далее может быть любой текст.')) AADD(aMess, L('Для того, чтобы сформировать такой файл можно воспользоваться режимом')) AADD(aMess, L('4.8 системы "Эйдос": запустить формирование облака точек из файла:')) AADD(aMess, L('"Inp_map1.xls" с формированием модели, выполнить рекомендуемые действия.')) LB_Warning(aMess) ELSE mX = VAL(SUBSTR(mF1, mPosX+2, mPosY-3)) mY = VAL(SUBSTR(mF1, mPosY+2, 15)) mZ = FIELDGET(mNumColumn) AADD(aX, 0.8 * Y_Max * ( mX - mMinX) / (mMaxX - mMinX) + dX ) // Нормировка (СРАЗУ ПОЛУЧИТЬ ПИКСЕЛЬНЫЕ КООРДИНАТЫ) AADD(aY, Y_Max - 0.8 * Y_Max * ( mY - mMinY) / (mMaxY - mMinY) + dY ) AADD(aZ, mZ ) aAttr [ GRA_AL_COLOR ] := GRA_CLR_RED // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraArc ( oPS, { aX[p], aY[p] }, 2 ) // Рисует круг стилем линии aAttr [ GRA_AL_COLOR ] := GRA_CLR_DARKGRAY // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraArc ( oPS, { aX[p], aY[p] }, 3 ) // Рисует круг стилем линии ENDIF NEXT ******* Сделать надпись изображения IF FILE('_482.txt') oFont := XbpFont():new():create("16.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты mPar=FileStr('_482.txt');mNumColumn=VAL(SUBSTR(mPar,1,6));mFile=SUBSTR(mPar,8,LEN(mPar)) IF FILE("_ColumnNames.arx") aColumnNames = DC_ARestore("_ColumnNames.arx") // Загрузка массива наименований шкал (колонок) из файла IF 1 <= mNumColumn .AND. mNumColumn <= LEN(aColumnNames) GraStringAt( oPS, { X_Max/2, Y_Max-60 }, 'Картографическая визуализация значений шкалы: "'+aColumnNames[mNumColumn]+IF(mFile='Rsp_it.','" файла результатов классификации: "','" файла исходных данных: "')+mFile+'xls"') ELSE GraStringAt( oPS, { X_Max/2, Y_Max-60 }, 'Картографическая визуализация значений шкалы №'+ALLTRIM(STR(mNumColumn))+IF(mFile='Rsp_it.','" файла результатов классификации: "','" файла исходных данных: "')+mFile+'xls"' ) ENDIF ELSE GraStringAt( oPS, { X_Max/2, Y_Max-60 }, 'Картографическая визуализация значений шкалы №'+ALLTRIM(STR(mNumColumn))+IF(mFile='Rsp_it.','" файла результатов классификации: "','" файла исходных данных: "')+mFile+'xls"' ) ENDIF ENDIF ***** Создать БД для координат X,Y,Z точек облака aStructure := { { "Num" , "N", 15, 0 }, ; { "pX" , "N", 15, 7 }, ; { "pY" , "N", 15, 7 }, ; { "pZ" , "N", 15, 7 }, ; { "pRed" , "N", 3, 0 }, ; { "pGreen", "N", 3, 0 }, ; { "pBlue" , "N", 3, 0 } } DbCreate( 'Points_XYZ', aStructure ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Points_XYZ EXCLUSIVE NEW SELECT Points_XYZ FOR p=1 TO PointsCount APPEND BLANK REPLACE Num WITH p REPLACE pX WITH aX[p] REPLACE pY WITH aY[p] REPLACE pZ WITH aZ[p] NEXT **************************************************************************** **** Дополнительные точки для нарушения регулярности, если сетка регулярная **************************************************************************** ASORT(aX) dXmin = +999999999 dXmax = -999999999 FOR j=2 TO LEN(kX) dXmin = MIN(dXmin, ABS(kX[j]-kX[j-1])) dXmax = MAX(dXmax, ABS(kX[j]-kX[j-1])) NEXT ASORT(aY) dYmin = +999999999 dYmax = -999999999 FOR j=2 TO LEN(kY) dYmin = MIN(dYmin, ABS(kY[j]-kY[j-1])) dYmax = MAX(dYmax, ABS(kY[j]-kY[j-1])) NEXT *MsgBox(STR(dxmax)+STR(dxmin)+STR(dymax)+STR(dymin)) IF ABS(dXmax-dXmin) < 0.1 .AND. ABS(dYmax-dYmin) < 0.1 **** Определение координат фиктивных точек mMinX = +999999999 mMaxX = -999999999 FOR j=1 TO LEN(aX) mMinX = MIN(mMinX,aX[j]) mMaxX = MAX(mMaxX,aX[j]) NEXT mMinY = +999999999 mMaxY = -999999999 FOR j=1 TO LEN(aY) mMinY = MIN(mMinY,aY[j]) mMaxY = MAX(mMaxY,aY[j]) NEXT w = 3 x1 = mMinX-w y1 = mMinY-w x2 = mMinX-w y2 = mMaxY+w x3 = mMaxX+w y3 = mMinY-w x4 = mMaxX+w y4 = mMaxY+w **** Определение цветов точек, ближайших к фиктивным R1 = 999999999 R2 = 999999999 R3 = 999999999 R4 = 999999999 DBGOTOP() DO WHILE .NOT. EOF() R = SQRT((pX-x1)^2+(pY-y1)^2) IF R1 > R R1 = R n1 = RECNO() ENDIF R = SQRT((pX-x2)^2+(pY-y2)^2) IF R2 > R R2 = R n2 = RECNO() ENDIF R = SQRT((pX-x3)^2+(pY-y3)^2) IF R3 > R R3 = R n3 = RECNO() ENDIF R = SQRT((pX-x4)^2+(pY-y4)^2) IF R4 > R R4 = R n4 = RECNO() ENDIF DBSKIP(1) ENDDO DBGOTO(n1);c1 = pZ DBGOTO(n2);c2 = pZ DBGOTO(n3);c3 = pZ DBGOTO(n4);c4 = pZ APPEND BLANK REPLACE Num WITH 1 REPLACE pX WITH x1 REPLACE pY WITH y1 REPLACE pZ WITH c1 APPEND BLANK REPLACE Num WITH 2 REPLACE pX WITH x2 REPLACE pY WITH y2 REPLACE pZ WITH c2 APPEND BLANK REPLACE Num WITH 3 REPLACE pX WITH x3 REPLACE pY WITH y3 REPLACE pZ WITH c3 APPEND BLANK REPLACE Num WITH 4 REPLACE pX WITH x4 REPLACE pY WITH y4 REPLACE pZ WITH c4 aAttr [ GRA_AL_COLOR ] := GRA_CLR_RED // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraArc ( oPS, { x1, y1 }, 2 ) // Рисует круг стилем линии GraArc ( oPS, { x2, y2 }, 2 ) // Рисует круг стилем линии GraArc ( oPS, { x3, y3 }, 2 ) // Рисует круг стилем линии GraArc ( oPS, { x4, y4 }, 2 ) // Рисует круг стилем линии ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций StrFile('Нормировать цвет', '_NormColor.txt') * M_CurrInf = FileStr('_NormColor.txt') **************************************************************************** DO CASE CASE mFile = 'Inp_map1.' .OR. mFile = 'Inp_map2.' LB_Warning(L('Преобразование: "Inp_data.dbf" => "Points_XYZ.dbf" завершено!'),'4.8. Геокогнитивная подсистема "Эйдос"' ) CASE mFile = 'Rsp_map1.' .OR. mFile = 'Rsp_map2.' LB_Warning(L('Преобразование: "Inp_rasp.dbf" => "Points_XYZ.dbf" завершено!'),'4.8. Геокогнитивная подсистема "Эйдос"' ) ENDCASE ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN nil *********************************************************************************** ******** Картографическая визуализация результатов распознавания из БД Rsp_it.dbf ******** Сформировать 2d БД результатов распознавания: Out_map2.dbf *********************************************************************************** FUNCTION F483(mIntKrit) StrFile(STR(2,6)+' Rsp_it.', '_482.txt') // Запись текстового файла _482.txt *mPar=FileStr('_482.txt');mNumColumn=VAL(SUBSTR(mPar,1,6));mFile=SUBSTR(mPar,8,LEN(mPar)) IF ApplChange("") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF IF PointsCount > 0 ClearImageTr() // Очистка изображения ENDIF **** Если файл Rsp_it.dbf есть в папке текущего приложения IF .NOT. FILE('Rsp_it.dbf') aMess := {} AADD(aMess, L('В папке текущего приложения: ')+M_PathAppl) AADD(aMess, L('должен быть файл итогов распознавания: "Rsp_it.dbf".')) AADD(aMess, L('Для того, чтобы сформировать такой файл можно воспользоваться режимом')) AADD(aMess, L('4.8 системы "Эйдос": запустить формирование облака точек из файла:')) AADD(aMess, L('"Inp_map1.xls" с формированием модели, выполнить рекомендуемые действия.')) LB_Warning( aMess, L('4.8. Геокогнитивная подсистема "Эйдос"' )) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF *********************************** X_Max := 1800 Y_Max := 850 // Размер графического окна для самого графика в пикселях dX = (X_Max-0.8*Y_Max)/2 dY = (Y_Max-0.8*Y_Max)/2 - 200 *********************************** ***** Создать базу результатов распознавания Out_map2.dbf на основе Rsp_IT.dbf ***** универсальный вариант и для Rsp_map1.dbf, и для Rsp_map2.dbf ********* Прописывает для числовых шкал в БД Classes и Attributes минимальное, максимальное и среднее значение всех градаций MinMaxAvr() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rsp_it EXCLUSIVE NEW USE Classes EXCLUSIVE NEW ** Массивы пиксельных координат X,Y точек aX := {} aY := {} aZ := {} kX := {} kY := {} ***** Поиск min и max по X и Y mMaxX = -99999999999 mMinX = +99999999999 mMaxY = -99999999999 mMinY = +99999999999 mMax = -99999999999 mMin = +99999999999 PointsCount = 0 // Количество точек SELECT Rsp_it DBGOTOP() DO WHILE .NOT. EOF() IF mIntKrit = Int_Krit .AND. Kod_obj > 0 mF1 = FIELDGET(2) mPosX = AT("X=", mF1) mPosY = AT("Y=", mF1) IF mPosX * mPosY = 0 aMess := {} AADD(aMess, L('В файле: "Rsp_it.dbf" во 2-й колонке должны быть координаты в формате:')) AADD(aMess, L('X=#######.#######, Y=#######.####### и далее может быть любой текст.')) AADD(aMess, L('Для того, чтобы сформировать такой файл можно воспользоваться режимом')) AADD(aMess, L('4.8 системы "Эйдос": запустить формирование облака точек из файла:')) AADD(aMess, L('"Inp_map1.xls" с формированием модели, выполнить рекомендуемые действия.')) LB_Warning(aMess) ELSE mX = VAL(SUBSTR(mF1, mPosX+2, mPosY-3)) mY = VAL(SUBSTR(mF1, mPosY+2, 15)) IF ASCAN(kX, mX) = 0 AADD (kX, mX) ENDIF IF ASCAN(kY, mY) = 0 AADD (kY, mY) ENDIF PointsCount++ * mKodCls = KODC_MAXV * SELECT Classes * DBGOTO(mKodCls) * mZ = AVR_GRINT ** MsgBox(Name_obj+STR(mKodCls)+STR(mZ)) * SELECT Rsp_it mMaxX = MAX(mMaxX, mX) mMinX = MIN(mMinX, mX) mMaxY = MAX(mMaxY, mY) mMinY = MIN(mMinY, mY) mMax = MAX(mMaxX, mX) mMin = MIN(mMinX, mX) mMax = MAX(mMaxY, mY) mMin = MIN(mMinY, mY) ENDIF ENDIF DBSKIP(1) ENDDO ********** Создать Inp_rasp.dbf по размерности Rsp_map1 aStructure := { { "N1", "N", 15, 7 } } // Координата Y точек FOR j=1 TO LEN(kX)+1 // Координата X точек AADD(aStructure, { "N"+ALLTRIM(STR(j+1)), "N", 15, 7 } ) NEXT DbCreate( 'Out_map2', aStructure ) ******************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Out_map2 EXCLUSIVE NEW SELECT Out_map2 ASORT(kX) APPEND BLANK FIELDPUT(1, 0) FOR j=1 TO LEN(kX) FIELDPUT(j+1, kX[j]) NEXT ASORT(kY) FOR i=1 TO LEN(kY) APPEND BLANK FIELDPUT(1, kY[i]) FOR j=1 TO LEN(kX) FIELDPUT(j+1, 0) NEXT NEXT CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rsp_it EXCLUSIVE NEW USE Classes EXCLUSIVE NEW USE Out_map2 EXCLUSIVE NEW SELECT Rsp_it ***** Задать атрибуты линии aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT graSetAttrLine( oPS, aAttr ) ** Массивы пиксельных (нормированных) координат и нормированнх значений aX := {} aY := {} aZ := {} p = 0 DBGOTOP() DO WHILE .NOT. EOF() IF mIntKrit = Int_Krit .AND. Kod_obj > 0 p++ mF1 = FIELDGET(2) mPosX = AT("X=", mF1) mPosY = AT("Y=", mF1) IF mPosX * mPosY = 0 aMess := {} AADD(aMess, L('В файле: "Rsp_it.dbf" во 2-й колонке должны быть координаты в формате:')) AADD(aMess, L('X=#######.#######, Y=#######.####### и далее может быть любой текст.')) AADD(aMess, L('Для того, чтобы сформировать такой файл можно воспользоваться режимом')) AADD(aMess, L('4.8 системы "Эйдос": запустить формирование облака точек из файла:')) AADD(aMess, L('"Inp_map1.xls" с формированием модели, выполнить рекомендуемые действия.')) LB_Warning(aMess) ELSE mX = VAL(SUBSTR(mF1, mPosX+2, mPosY-3)) mY = VAL(SUBSTR(mF1, mPosY+2, 15)) mKodCls = KODC_MAXV SELECT Classes DBGOTO(mKodCls) mZ = AVR_GRINT ****** Перенос результатов распознавания из Rsp_it в БД Out_map2 nX = ASCAN(kX, mX) nY = ASCAN(kY, mY) IF nX * nY > 0 SELECT Out_map2 DBGOTO(nY+1) FIELDPUT(nX+1, mZ) ENDIF AADD(aX, 0.8 * Y_Max * ( mX - mMinX) / (mMaxX - mMinX) + dX ) // Нормировка (СРАЗУ ПОЛУЧИТЬ ПИКСЕЛЬНЫЕ КООРДИНАТЫ) AADD(aY, Y_Max - 0.8 * Y_Max * ( mY - mMinY) / (mMaxY - mMinY) + dY ) AADD(aZ, mZ ) aAttr [ GRA_AL_COLOR ] := GRA_CLR_RED // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraArc ( oPS, { aX[p], aY[p] }, 2 ) // Рисует круг стилем линии aAttr [ GRA_AL_COLOR ] := GRA_CLR_DARKGRAY // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraArc ( oPS, { aX[p], aY[p] }, 3 ) // Рисует круг стилем линии ENDIF ENDIF SELECT Rsp_it DBSKIP(1) ENDDO DIRCHANGE(Disk_dir) ***** Создать БД для координат X,Y,Z точек облака aStructure := { { "Num" , "N", 15, 0 }, ; { "pX" , "N", 15, 7 }, ; { "pY" , "N", 15, 7 }, ; { "pZ" , "N", 15, 7 }, ; { "pRed" , "N", 3, 0 }, ; { "pGreen", "N", 3, 0 }, ; { "pBlue" , "N", 3, 0 } } DbCreate( 'Points_XYZ', aStructure ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Points_XYZ EXCLUSIVE NEW SELECT Points_XYZ FOR p=1 TO LEN(aX) APPEND BLANK REPLACE Num WITH p REPLACE pX WITH aX[p] REPLACE pY WITH aY[p] REPLACE pZ WITH aZ[p] NEXT **************************************************************************** **** Дополнительные точки для нарушения регулярности, если сетка регулярная **************************************************************************** ASORT(aX) dXmin = +999999999 dXmax = -999999999 FOR j=2 TO LEN(kX) dXmin = MIN(dXmin, ABS(kX[j]-kX[j-1])) dXmax = MAX(dXmax, ABS(kX[j]-kX[j-1])) NEXT dX = ABS(dXmax-dXmin) ASORT(aY) dYmin = +999999999 dYmax = -999999999 FOR j=2 TO LEN(kY) dYmin = MIN(dYmin, ABS(kY[j]-kY[j-1])) dYmax = MAX(dYmax, ABS(kY[j]-kY[j-1])) NEXT dY = ABS(dYmax-dYmin) *MsgBox(STR(dxmax)+STR(dxmin)+STR(dymax)+STR(dymin)) IF dX < 0.1 .AND. dY < 0.1 **** Определение цветов точек, ближайших к фиктивным d = 10 R1 = 999999999 R2 = 999999999 R3 = 999999999 R4 = 999999999 x1 = A-d y1 = A-d x2 = A-d y2 = A+(nYSize-B)+d x3 = A+(nXSize-B)+d y3 = A-d x4 = A+(nXSize-B)+d y4 = A+(nYSize-B)+d DBGOTOP() DO WHILE .NOT. EOF() R = SQRT((pX-x1)^2+(pY-y1)^2) IF R1 > R R1 = R n1 = RECNO() ENDIF R = SQRT((pX-x2)^2+(pY-y2)^2) IF R2 > R R2 = R n2 = RECNO() ENDIF R = SQRT((pX-x3)^2+(pY-y3)^2) IF R3 > R R3 = R n3 = RECNO() ENDIF R = SQRT((pX-x4)^2+(pY-y4)^2) IF R4 > R R4 = R n4 = RECNO() ENDIF DBSKIP(1) ENDDO DBGOTO(n1);c1 = pZ DBGOTO(n2);c2 = pZ DBGOTO(n3);c3 = pZ DBGOTO(n4);c4 = pZ APPEND BLANK REPLACE Num WITH 1 REPLACE pX WITH x1 REPLACE pY WITH y1 REPLACE pZ WITH c1 GraArc ( oPS, { x1, y1 }, 2 ) // Рисует круг стилем линии APPEND BLANK REPLACE Num WITH 2 REPLACE pX WITH x2 REPLACE pY WITH y2 REPLACE pZ WITH c2 GraArc ( oPS, { x2, y2 }, 2 ) // Рисует круг стилем линии APPEND BLANK REPLACE Num WITH 3 REPLACE pX WITH x3 REPLACE pY WITH y3 REPLACE pZ WITH c3 GraArc ( oPS, { x3, y3 }, 2 ) // Рисует круг стилем линии APPEND BLANK REPLACE Num WITH 4 REPLACE pX WITH x4 REPLACE pY WITH y4 REPLACE pZ WITH c4 GraArc ( oPS, { x4, y4 }, 2 ) // Рисует круг стилем линии ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы StrFile('Нормировать цвет', '_NormColor.txt') * M_CurrInf = FileStr('_NormColor.txt') ******* Сделать надпись изображения IF FILE('_482.txt') oFont := XbpFont():new():create("16.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты mPar=FileStr('_482.txt');mNumColumn=VAL(SUBSTR(mPar,1,6));mFile=SUBSTR(mPar,8,LEN(mPar)) IF FILE("_ColumnNames.arx") aColumnNames = DC_ARestore("_ColumnNames.arx") // Загрузка массива наименований шкал (колонок) из файла IF 1 <= mNumColumn .AND. mNumColumn <= LEN(aColumnNames) GraStringAt( oPS, { X_Max/2, Y_Max-60 }, 'Картографическая визуализация значений шкалы: "'+aColumnNames[mNumColumn]+IF(mFile='Rsp_it.','" файла результатов классификации: "','" файла исходных данных: "')+mFile+'xls"') ELSE GraStringAt( oPS, { X_Max/2, Y_Max-60 }, 'Картографическая визуализация значений шкалы №'+ALLTRIM(STR(mNumColumn))+IF(mFile='Rsp_it.','" файла результатов классификации: "','" файла исходных данных: "')+mFile+'xls"' ) ENDIF ELSE GraStringAt( oPS, { X_Max/2, Y_Max-60 }, 'Картографическая визуализация значений шкалы №'+ALLTRIM(STR(mNumColumn))+IF(mFile='Rsp_it.','" файла результатов классификации: "','" файла исходных данных: "')+mFile+'xls"' ) ENDIF ENDIF **************************************************************************** aMess := {} AADD(aMess, L('Итоговые результаты распознавания "Rsp_IT.dbf"')) AADD(aMess, L('занесены в базу облака точек "Points_XYZ.DBF"')) AADD(aMess, L('и в 2d БД "Out_map2.DBF" для визуализации в Excel')) LB_Warning( aMess,L('4.8. Геокогнитивная подсистема "Эйдос"' )) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN nil *---------------------- FUNCTION CircleColor() LOCAL GetList[0], GetOptions, oSay, oDevice LOCAL aX[100000], aY[100000], aZ[100000] // Координаты X,Y,Z точек облака ERASE('_ColumnNames.arx');ERASE('_482.txt') // Стереть файлы: _ColumnNames.arx и _482.txt AFILL(aX,0) AFILL(aY,0) AFILL(aZ,0) IF PointsCount > 0 ClearImageTr() // Очистка изображения ENDIF *PointsCount = NPoints() // Задание количества точек ***** Задать атрибуты линии aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT graSetAttrLine( oPS, aAttr ) * PointsCount // число точек TurnovCount = 1 // число виктов спирали * OutRadius // Внешний радиус * InnRadius // Внутренний радиус u = 360 / PointsCount * TurnovCount // угол между точками **** Поиск минимальных и максимальных X и Y и нормирование mMinX = +99999999999 mMaxX = -99999999999 mMinY = +99999999999 mMaxY = -99999999999 i = 0 FOR p=1 TO PointsCount mX := OutRadius * COS( p*u * GradRad ) mY := OutRadius * SIN( p*u * GradRad ) mMinX = MIN(mMinX, mX) mMaxX = MAX(mMaxX, mX) mMinY = MIN(mMinY, mY) mMaxY = MAX(mMaxY, mY) mX := InnRadius * COS( p*u * GradRad ) mY := InnRadius * SIN( p*u * GradRad ) mMinX = MIN(mMinX, mX) mMaxX = MAX(mMaxX, mX) mMinY = MIN(mMinY, mY) mMaxY = MAX(mMaxY, mY) NEXT ***** Расчет позиций для одного по X поля изображения шириной nXSizeAr ***** и двух равных промежутков между ними d и слева и справа от изображений до края окна X_Max := 1800 Y_Max := 850 // Размер графического окна для самого графика в пикселях IF .NOT. FILE('_XYSize.txt') * LB_Warning(L('Необходимо запустить режим генерации облака точек!','4.8. Геокогнитивная подсистема "Эйдос"' ) StrFile(STR(nXSize,9)+' '+STR(nYSize,9), '_XYSize.txt') // Запись текстового файла с параметрами nXSize, nYSize ELSE * StrFile(STR(nXSize,9)+' '+STR(nYSize,9), '_XYSize.txt') // Запись текстового файла с параметрами nXSize, nYSize nXSize = VAL(SUBSTR(FileStr('_XYSize.txt'), 1,9)) // Загрузка параметра nXSize из текстового файла nYSize = VAL(SUBSTR(FileStr('_XYSize.txt'),11,9)) // Загрузка параметра nYSize из текстового файла ENDIF dX = (X_Max-0.8*Y_Max)/2 dY = (Y_Max-0.8*Y_Max)/2 - 200 i = 0 FOR p=1 TO PointsCount mX := OutRadius * COS( p*u * GradRad ) mY := OutRadius * SIN( p*u * GradRad ) mZ := p i++ aX[i] = 0.8 * Y_Max * ( mX - mMinX) / (mMaxX - mMinX) + dX aY[i] = Y_Max - 0.8 * Y_Max * ( mY - mMinY) / (mMaxY - mMinY) + dY aZ[i] = mZ aAttr [ GRA_AL_COLOR ] := GRA_CLR_RED // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraArc ( oPS, { aX[i], aY[i] }, 2 ) // Рисует круг стилем линии aAttr [ GRA_AL_COLOR ] := GRA_CLR_DARKGRAY // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraArc ( oPS, { aX[i], aY[i] }, 3 ) // Рисует круг стилем линии mX := InnRadius * COS( p*u * GradRad ) mY := InnRadius * SIN( p*u * GradRad ) mZ := p i++ aX[i] = 0.8 * Y_Max * ( mX - mMinX) / (mMaxX - mMinX) + dX aY[i] = Y_Max - 0.8 * Y_Max * ( mY - mMinY) / (mMaxY - mMinY) + dY aZ[i] = mZ aAttr [ GRA_AL_COLOR ] := GRA_CLR_RED // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraArc ( oPS, { aX[i], aY[i] }, 2 ) // Рисует круг стилем линии aAttr [ GRA_AL_COLOR ] := GRA_CLR_DARKGRAY // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraArc ( oPS, { aX[i], aY[i] }, 3 ) // Рисует круг стилем линии NEXT PointsCount = i ***** Создать БД для координат X,Y,Z точек облака aStructure := { { "Num" , "N", 15, 0 }, ; { "pX" , "N", 15, 7 }, ; { "pY" , "N", 15, 7 }, ; { "pZ" , "N", 15, 7 }, ; { "pRed" , "N", 3, 0 }, ; { "pGreen", "N", 3, 0 }, ; { "pBlue" , "N", 3, 0 } } DbCreate( 'Points_XYZ', aStructure ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Points_XYZ EXCLUSIVE NEW SELECT Points_XYZ FOR p=1 TO PointsCount APPEND BLANK REPLACE Num WITH p REPLACE pX WITH aX[p] REPLACE pY WITH aY[p] REPLACE pZ WITH aZ[p] NEXT CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций StrFile('Нормировать цвет', '_NormColor.txt') * M_CurrInf = FileStr('_NormColor.txt') LB_Warning(L('Построение точек завершено'),L('4.8. Геокогнитивная подсистема "Эйдос"' )) RETURN nil *---------------------- FUNCTION ArchimSpiral() LOCAL GetList[0], GetOptions, oSay, oDevice LOCAL aX[100000], aY[100000], aZ[100000] // Координаты X,Y,Z точек облака ERASE('_ColumnNames.arx');ERASE('_482.txt') // Стереть файлы: _ColumnNames.arx и _482.txt AFILL(aX,0) AFILL(aY,0) AFILL(aZ,0) IF PointsCount > 0 ClearImageTr() // Очистка изображения ENDIF *PointsCount = NPoints() // Задание количества точек ***** Задать атрибуты линии aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT graSetAttrLine( oPS, aAttr ) * PointsCount // число точек * TurnovCount // число виктов спирали u = 360 / PointsCount * TurnovCount // угол между точками **** Поиск минимальных и максимальных X и Y и нормирование mMinX = +99999999999 mMaxX = -99999999999 mMinY = +99999999999 mMaxY = -99999999999 i = 0 FOR p=1 TO PointsCount mX := i * COS( p*u * GradRad ) mY := i * SIN( p*u * GradRad ) i++ mMinX = MIN(mMinX, mX) mMaxX = MAX(mMaxX, mX) mMinY = MIN(mMinY, mY) mMaxY = MAX(mMaxY, mY) NEXT ***** Расчет позиций для одного по X поля изображения шириной nXSizeAr ***** и двух равных промежутков между ними d и слева и справа от изображений до края окна X_Max := 1800 Y_Max := 850 // Размер графического окна для самого графика в пикселях IF .NOT. FILE('_XYSize.txt') * LB_Warning(L('Необходимо запустить режим генерации облака точек!','4.8. Геокогнитивная подсистема "Эйдос"' ) StrFile(STR(nXSize,9)+' '+STR(nYSize,9), '_XYSize.txt') // Запись текстового файла с параметрами nXSize, nYSize ELSE * StrFile(STR(nXSize,9)+' '+STR(nYSize,9), '_XYSize.txt') // Запись текстового файла с параметрами nXSize, nYSize nXSize = VAL(SUBSTR(FileStr('_XYSize.txt'), 1,9)) // Загрузка параметра nXSize из текстового файла nYSize = VAL(SUBSTR(FileStr('_XYSize.txt'),11,9)) // Загрузка параметра nYSize из текстового файла ENDIF dX = (X_Max-0.8*Y_Max)/2 dY = (Y_Max-0.8*Y_Max)/2 - 200 i = 0 FOR p=1 TO PointsCount mX := i * COS( p*u * GradRad ) mY := i * SIN( p*u * GradRad ) IF mTrend = 1 mZ := p ENDIF IF mTrend = 2 mZ := 1+PointsCount-p ENDIF i++ aX[i] = 0.8 * Y_Max * ( mX - mMinX) / (mMaxX - mMinX) + dX aY[i] = Y_Max - 0.8 * Y_Max * ( mY - mMinY) / (mMaxY - mMinY) + dY aZ[i] = mZ aAttr [ GRA_AL_COLOR ] := GRA_CLR_RED // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraArc ( oPS, { aX[i], aY[i] }, 2 ) // Рисует круг стилем линии aAttr [ GRA_AL_COLOR ] := GRA_CLR_DARKGRAY // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraArc ( oPS, { aX[i], aY[i] }, 3 ) // Рисует круг стилем линии NEXT PointsCount = i ***** Создать БД для координат X,Y,Z точек облака aStructure := { { "Num" , "N", 15, 0 }, ; { "pX" , "N", 15, 7 }, ; { "pY" , "N", 15, 7 }, ; { "pZ" , "N", 15, 7 }, ; { "pRed" , "N", 3, 0 }, ; { "pGreen", "N", 3, 0 }, ; { "pBlue" , "N", 3, 0 } } DbCreate( 'Points_XYZ', aStructure ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Points_XYZ EXCLUSIVE NEW SELECT Points_XYZ FOR p=1 TO PointsCount APPEND BLANK REPLACE Num WITH p REPLACE pX WITH aX[p] REPLACE pY WITH aY[p] REPLACE pZ WITH aZ[p] NEXT CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций StrFile('Нормировать цвет', '_NormColor.txt') * M_CurrInf = FileStr('_NormColor.txt') LB_Warning(L('Построение точек завершено'),L('4.8. Геокогнитивная подсистема "Эйдос"' )) RETURN nil *---------------------- FUNCTION LogarSpiral() LOCAL GetList[0], GetOptions, oSay, oDevice LOCAL aX[100000], aY[100000], aZ[100000] // Координаты X,Y,Z точек облака ERASE('_ColumnNames.arx');ERASE('_482.txt') // Стереть файлы: _ColumnNames.arx и _482.txt AFILL(aX,0) AFILL(aY,0) AFILL(aZ,0) IF PointsCount > 0 ClearImageTr() // Очистка изображения ENDIF *PointsCount = NPoints() // Задание количества точек ***** Расчет позиций для одного по X поля изображения шириной nXSizeAr ***** и двух равных промежутков между ними d и слева и справа от изображений до края окна X_Max := 1800 Y_Max := 850 // Размер графического окна для самого графика в пикселях IF .NOT. FILE('_XYSize.txt') * LB_Warning(L('Необходимо запустить режим генерации облака точек!','4.8. Геокогнитивная подсистема "Эйдос"' ) StrFile(STR(nXSize,9)+' '+STR(nYSize,9), '_XYSize.txt') // Запись текстового файла с параметрами nXSize, nYSize ELSE * StrFile(STR(nXSize,9)+' '+STR(nYSize,9), '_XYSize.txt') // Запись текстового файла с параметрами nXSize, nYSize nXSize = VAL(SUBSTR(FileStr('_XYSize.txt'), 1,9)) // Загрузка параметра nXSize из текстового файла nYSize = VAL(SUBSTR(FileStr('_XYSize.txt'),11,9)) // Загрузка параметра nYSize из текстового файла ENDIF dX = (X_Max-0.8*Y_Max)/2 dY = (Y_Max-0.8*Y_Max)/2 - 200 ***** Задать атрибуты линии aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT graSetAttrLine( oPS, aAttr ) * PointsCount // число точек * TurnovCount // число виктов спирали u = 360 / PointsCount * TurnovCount // угол между точками **** Поиск минимальных и максимальных X и Y и нормирование mMinX = +99999999999 mMaxX = -99999999999 mMinY = +99999999999 mMaxY = -99999999999 b = 0.01 i = 0 FOR p=1 TO PointsCount mX := EXP(b*i) * COS( p*u * GradRad ) mY := EXP(b*i) * SIN( p*u * GradRad ) i++ mMinX = MIN(mMinX, mX) mMaxX = MAX(mMaxX, mX) mMinY = MIN(mMinY, mY) mMaxY = MAX(mMaxY, mY) NEXT i = 0 FOR p=1 TO PointsCount mX := EXP(b*i) * COS( p*u * GradRad ) mY := EXP(b*i) * SIN( p*u * GradRad ) mZ := p i++ aX[i] = 0.8 * Y_Max * ( mX - mMinX) / (mMaxX - mMinX) + dX aY[i] = Y_Max - 0.8 * Y_Max * ( mY - mMinY) / (mMaxY - mMinY) + dY aZ[i] = mZ aAttr [ GRA_AL_COLOR ] := GRA_CLR_RED // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraArc ( oPS, { aX[i], aY[i] }, 2 ) // Рисует круг стилем линии aAttr [ GRA_AL_COLOR ] := GRA_CLR_DARKGRAY // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraArc ( oPS, { aX[i], aY[i] }, 3 ) // Рисует круг стилем линии NEXT PointsCount = i ***** Создать БД для координат X,Y,Z точек облака aStructure := { { "Num" , "N", 15, 0 }, ; { "pX" , "N", 15, 7 }, ; { "pY" , "N", 15, 7 }, ; { "pZ" , "N", 15, 7 }, ; { "pRed" , "N", 3, 0 }, ; { "pGreen", "N", 3, 0 }, ; { "pBlue" , "N", 3, 0 } } DbCreate( 'Points_XYZ', aStructure ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Points_XYZ EXCLUSIVE NEW SELECT Points_XYZ FOR p=1 TO PointsCount APPEND BLANK REPLACE Num WITH p REPLACE pX WITH aX[p] REPLACE pY WITH aY[p] REPLACE pZ WITH aZ[p] NEXT CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций StrFile('Нормировать цвет', '_NormColor.txt') * M_CurrInf = FileStr('_NormColor.txt') LB_Warning(L('Построение точек завершено'),L('4.8. Геокогнитивная подсистема "Эйдос"' )) RETURN nil ************************************************************* ******** Взять координаты и цвета точек из графического файла ************************************************************* FUNCTION CoordPointsFile() LOCAL GetList[0], GetOptions, oSay, aPixel, hDC1, oDialog, oProgress, oScrn ClearImageTr() ERASE('_ColumnNames.arx');ERASE('_482.txt') // Стереть файлы: _ColumnNames.arx и _482.txt ***** Расчет позиций для одного по X поля изображения шириной nXSizeAr ***** и двух равных промежутков между ними d и слева и справа от изображений до края окна X_Max := 1800 Y_Max := 850 // Размер графического окна для самого графика в пикселях d = (X_Max-1*nXSize)/2 // Расстояние между правым и левым изображениями и слева и справа до края окна dY = (Y_Max-1*nYSize)/2 - 50 // Расстояние по Y до края поля изображения 1-го и 2-го контуров dX = d // Расстояние по X до края поля изображения 1-го контура **************************** *** Определение путей на файлы изображений символов *** Сформировать массив наименований папок и в каждой из них массив полных имен графических файлов cWorkPath = M_ApplsPath+"\Inp_data\" aAll := DIRECTORY( cWorkPath + "*.*", 'D' ) // Почему-то в массив попадает информация не только по директориям IF LEN(aAll) = 0 Mess = L(" В папке: "+cWorkPath+" нет файлов!") LB_Warning(Mess, L("2.3.2.5: Ввод изображений с учетом цвета пикселей")) RETURN nil ENDIF * DC_DebugQout( aAll ) aDir := {} FOR j = 1 TO LEN(aAll) IF aAll[j, 5] = "D" IF aAll[j, 5] <> '.' IF aAll[j, 5] <> '..' AADD(aDir, aAll[j, 1]) ENDIF ENDIF ENDIF NEXT * DC_DebugQout( aDIR ) aFileName := {} // Маиссив полных имен файлов изображений aFileNmSh := {} // Маиссив коротких имен файлов изображений IF LEN(aDIR) = 0 Mess = L(" В папке: "+cWorkPath+" нет поддиректорий!") LB_Warning(Mess, L("2.3.2.5: Ввод изображений с учетом цвета пикселей")) RETURN nil ENDIF FOR j = 1 TO LEN(aDIR) aFNbmp = DIRECTORY( cWorkPath + aDIR[j] + "\*.bmp" ) IF LEN(aFNbmp) > 0 FOR f = 1 TO LEN(aFNbmp) AADD(aFileName, cWorkPath + aDIR[j] + "\" + aFNbmp[f,1] ) AADD(aFileNmSh, aFNbmp[f,1] ) NEXT ENDIF aFNjpg = DIRECTORY( cWorkPath + aDIR[j] + "\*.jpg" ) IF LEN(aFNjpg) > 0 FOR f = 1 TO LEN(aFNjpg) AADD(aFileName, cWorkPath + aDIR[j] + "\" + aFNjpg[f,1] ) AADD(aFileNmSh, aFNjpg[f,1] ) NEXT ENDIF NEXT * DC_DebugQout( aFileName ) * DC_DebugQout( aFileNmSh ) IF LEN(aFileName) = 0 Mess = L(" В поддиректориях папки: "+cWorkPath+" нет bmp и jpg графических файлов!") LB_Warning(Mess, L("2.3.2.5: Ввод изображений с учетом цвета пикселей")) RETURN nil ENDIF *** Если БД "Image.dbf" нет, то создать ее IF .NOT. FILE("Image.dbf") GenDBFImage(.F.) ENDIF * Записать массив полных имен файлов изображений, а потом считать и использовать его DC_ASave(aFileName, "_FileName.arx") * DC_DebugQout( aFileNmSh ) * aFileName := DC_ARestore("_FileName.arx") * DC_DebugQout( aFileNmSh ) DC_ASave(aFileNmSh, "_FileNmSh.arx") * aFileNmSh := DC_ARestore("_FileNmSh.arx") * DC_DebugQout( aFileNmSh ) * MsgBox('STOP') ***************************************************************************************************** ** БЕЛЫЙ ЦВЕТ ПИКСЕЛЕЙ ИГНОРИРОВАТЬ, СЧИТАТЬ НЕ ЗНАЧИМЫМ (ФОНОМ), Т.Е. ЗНАЧИМЫЕ ТОЧКИ НЕ БЕЛОГО ЦВЕТА ***************************************************************************************************** ** Имя графического файла для рисования - источника исходных данных DO CASE CASE FILE('Delone.bmp') mFileName = 'Delone.bmp' CASE FILE('Delone.jpg') mFileName = 'Delone.jpg' // Нежелательно, т.к. изображение размыто OTHERWISE LB_Warning(L('В текущей папке системы: ')+Disk_dir+L(' должен быть файл: "Delone.bmp" или "Delone.jpg"'),L('4.8. Геокогнитивная подсистема "Эйдос"' )) RETURN nil ENDCASE GenDBFImage(.F.) // 1. Пересоздать (стереть) БД для изображений: "Image.Dbf" *CreateImages() // 2. Оцифровать изображения и записать их в БД "Image.Dbf" aFileName := DC_ARestore("_FileName.arx") *FOR i := 1 TO Len(aFileName) // Используется только первое изображение FOR i := 1 TO 1 // Используется только первое изображение oBitmap := DC_GetBitmap(aFileName[i]) @ 0,0 DCSTATIC TYPE XBPSTATIC_TYPE_BITMAP ; CAPTION oBitmap PREEVAL {|o|o:autoSize := .t.} ; EVAL {|o|hDC1 := GetWindowDC(o:getHWnd()), ; aPixel := Array(o:caption:xSize,o:caption:ySize)} DCREAD GUI FIT TITLE aFileName[i] ; EVAL {|o|LoadArray(hDC1,aPixel), ; Save2Dbf(aPixel,aFileName[i]), ; PostAppEvent(xbeP_Close,,,o)} NEXT nWidthMax = VAL(FileStr('_WidthMax.txt')) nHeightMax = VAL(FileStr('_HeightMax.txt')) ***** Создать БД для координат X,Y,Z точек облака aStructure := { { "Num" , "N", 15, 0 }, ; { "pX" , "N", 15, 7 }, ; { "pY" , "N", 15, 7 }, ; { "pZ" , "N", 15, 7 }, ; { "pRed" , "N", 3, 0 }, ; { "pGreen", "N", 3, 0 }, ; { "pBlue" , "N", 3, 0 } } DbCreate( 'Points_XYZ', aStructure ) ***** Определение максимального размера изображения CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Image VIA 'FOXCDX' EXCLUSIVE NEW nXSize = -999999999 nYSize = -999999999 aFileNmSh := {} DO WHILE !IMAGE->(Eof()) // Используется только первый файл aPixel := Bin2Var(IMAGE->array) // Загрузка массива из БД Image AADD(aFileNmSh, FIELDGET(2)) // Для формирования имен классов. Вместо записи и считывания массива использовать БД nXSize = MAX(nXSize, Len(aPixel)) nYSize = MAX(nYSize, Len(aPixel[1])) IMAGE->(dbSkip()) ENDDO oScrn := DC_WaitOn( L('Формирование исходной БД: "Points_XYZ.dbf"' ),,,,,,,,,,,.F.) StrFile(STR(nXSize,9)+' '+STR(nYSize,9), '_XYSize.txt') // Запись текстового файла с параметрами nXSize, nYSize *nXSize = VAL(SUBSTR(FileStr('_XYSize.txt'), 1,9)) // Загрузка параметра nXSize из текстового файла *nYSize = VAL(SUBSTR(FileStr('_XYSize.txt'),11,9)) // Загрузка параметра nYSize из текстового файла CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Points_XYZ EXCLUSIVE NEW SELECT Points_XYZ p = 0 FOR y := 1 TO nYSize FOR x := 1 TO nXSize APPEND BLANK REPLACE Num WITH ++p REPLACE pX WITH x REPLACE pY WITH y REPLACE pZ WITH 0 NEXT NEXT DC_Impl(oScrn) ***** Ввод в БД Points_XYZ оцифрованных изображений из БД Image CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Image VIA 'FOXCDX' EXCLUSIVE NEW;N_Rec = RECCOUNT() USE Points_XYZ EXCLUSIVE NEW ***** Задать атрибуты линии aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT *aAttr [ GRA_AL_COLOR ] := fColor // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) aInp_name := {} SELECT Image DBGOTOP() DO WHILE !IMAGE->(Eof()) // Используется только первый файл ClearImageTr() aPixel := Bin2Var(IMAGE->array) // Загрузка массива из БД Image nXSizeAr = Len(aPixel) nYSizeAr = Len(aPixel[1]) AADD(aInp_name, ALLTRIM(IMAGE->image_name)) SELECT Image mNumImage = RECNO() ****** Ввод в БД Points_XYZ оцифрованного изображения SELECT Points_XYZ FOR y := 1 TO nYSize FOR x := 1 TO nXSize IF x <= nXSizeAr .AND. y <= nYSizeAr nColor = AutomationTranslateColor(aPixel[x, y], .t.) IF GraIsRGBColor(nColor) // Это цвет? aRGB = GraGetRGBIntensity(nColor) // Взаимнообратные операции преобразования формы кодирования цвета в массиве RGB и одним числом * nColorPix = GraMakeRGBColor(aRGB) * MsgBox(STR(nColor)+STR(nColorPix)) // nColor === nColorPix mCol = aPixel[x, y] // Цвет пикселя DO CASE // Вместо этого лучше вывести символы на черном фоне белым цветом CASE mCol = 0 mCol = 16843009 // Кодирование черного цвета на символах не как отсутствия цвета, а как на истинно-черного цвета RGB(1,1,1)=16843009 CASE mCol = 16777215 mCol = 0 // Кодирование белого цвета на символах как отсутствия цвета RGB(0,0,0)=0 ENDCASE DBGOTO(x+(y-1)*nXSize) // Выйти на нужную запись в БД Points_XYZ.dbf REPLACE pZ WITH mCol // Запись цвета пикселя REPLACE pRed WITH aRGB[1] // Запись яркости R-луча REPLACE pGreen WITH aRGB[2] // Запись яркости G-луча REPLACE pBlue WITH aRGB[3] // Запись яркости B-луча ***** Отображение обработанной точки так, чтобы было видно, если она не белая IF mCol > 0 fColor := GraMakeRGBColor({ aRGB[1], aRGB[2], aRGB[3] }) // Точно также сделать определение цвета в вершинах треугольников ########### ***** Рисование маркеров ***** aAttr := Array( GRA_AM_COUNT ) // Создать массив атрибутов aAttr[ GRA_AM_COLOR ] := fColor // Задать цвет маркера aAttr[ GRA_AM_SYMBOL ] := GRA_MARKSYM_DOT // Задать стиль маркера GraSetAttrMarker( oPS, aAttr ) // Установить атрибуты GraMarker ( oPS,{ x+dX, nYSize-y+dY } ) ** Отметка найденных точек окружностями IF MarkPoints = 2 GraSetColor( oPS, fColor, fColor ) aAttr [ GRA_AL_COLOR ] := fColor // Задать цвет линии * aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraArc ( oPS, { x+dX, nYSize-y+dY }, 2 ) // Рисует круг стилем и цветом линии GraArc ( oPS, { x+dX, nYSize-y+dY }, 3 ) // Рисует круг стилем и цветом линии GraArc ( oPS, { x+dX, nYSize-y+dY }, 4 ) // Рисует круг стилем и цветом линии ENDIF ENDIF ENDIF ENDIF NEXT NEXT SELECT Image DBSKIP(1) ENDDO SELECT Points_XYZ DELETE FOR pZ=0 PACK CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций StrFile(STR(nXSize,9)+' '+STR(nYSize,9), '_XYSize.txt') // Запись текстового файла с параметрами nXSize, nYSize *nXSize = VAL(SUBSTR(FileStr('_XYSize.txt'), 1,9)) // Загрузка параметра nXSize из текстового файла *nYSize = VAL(SUBSTR(FileStr('_XYSize.txt'),11,9)) // Загрузка параметра nYSize из текстового файла StrFile('Не нормировать цвет', '_NormColor.txt') * M_CurrInf = FileStr('_NormColor.txt') LB_Warning(L('Построение точек завершено'),L('4.8. Геокогнитивная подсистема "Эйдос"' )) RETURN nil *--------------- FUNCTION LoadArrayTr() LOCAL i, j, oScrn, nXSize := Len(aPixel), nYSize := Len(aPixel[1]) LOCAL hMemoryDC := CreateMemoryDC( hDC1, nXSize, nYSize ) // Для ускорения работы GetPixel() примерно в 50 раз IF !aPixel[1,1] == nil DCMSGBOX 'Массив уже загружен!' RETURN nil ENDIF oScrn := DC_WaitOn('',,,,,,,,,,,.F.) FOR i := 1 TO nXSize FOR j := 1 TO nYSize aPixel[i,j] := GetPixel(hMemoryDC,i-1,j-1) NEXT NEXT DC_Impl(oScrn) RETURN(aPixel) *------------------ ********************************************************************************************************************** ******** 480. Преобразование 1D Excel-таблицы в Inp_data.xls (X,Y,Z) точек ******** Режим преобразует 1D Excel-таблицу с именем "Inp_map1.xls" в файл "Inp_data.xls", ******** Режим преобразует 1D Excel-таблицу с именем "Rsp_map1.xls" в файл "Inp_rasp.xls", ******** содержащий координаты X,Y,Z точек и их признаки (модель описательной информации картографической базы данных) ********************************************************************************************************************** FUNCTION F480(mFile, mNumColumn, mRegim) LOCAL oProgress, oDialog, mFlag1, mFlag2, nTime, nMax LOCAL aX[100000], aY[100000], aZ[100000] // Координаты X,Y,Z точек облака IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) RETURN NIL ENDIF // Определить, есть ли в папке: AID_DATA/Inp_data файл: Inp_map2.xls или Inp_map2.xlsx DIRCHANGE(M_ApplsPath+"\Inp_data\") mFlag1 = 'err' DO CASE CASE mFile = 'Inp_map1.' DO CASE CASE FILE("Inp_map1.xls") mFlag1 = 'xls' CASE FILE("Inp_map1.xlsx") mFlag1 = 'xlsx' ENDCASE CASE mFile = 'Rsp_map1.' DO CASE CASE FILE("Rsp_map1.xls") mFlag1 = 'xls' CASE FILE("Rsp_map1.xlsx") mFlag1 = 'xlsx' ENDCASE ENDCASE // Записать файлы: _ColumnNames.arx и _482.txt DIRCHANGE(Disk_dir) StrFile(STR(mNumColumn,6)+' '+mFile, '_482.txt') // Запись текстового файла _482.txt *mPar=FileStr('_482.txt');mNumColumn=VAL(SUBSTR(mPar,1,6));mFile=SUBSTR(mPar,8,LEN(mPar)) DIRCHANGE(M_ApplsPath+"\Inp_data\") IF mFlag1 = 'err' Mess = L('Нет файла: ')+M_ApplsPath+'\Inp_data\'+ mFile + '.xls' LB_Warning(Mess) Help48() // Пояснение о назначении режима ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF *** ПРЕОБРАЗОВАНИЕ EXCEL-ФАЙЛА Inp_map1 в БД: Inp_data.dbf *** и файл наименований классификационных и описательных шкал: Inp_name.txt cExcelFile = mFile + mFlag1 M_NewAppl = M_ApplsPath+"\Inp_data\" *MsgBox(cExcelFile+', '+M_NewAppl+cExcelFile) mFlag2 = LC_Excel2WorkArea( cExcelFile, M_NewAppl ) *MsgBox("Преобразование Excel->dbf завершено") IF .NOT. mFlag2 LB_Warning(L('Исправьте файл исходных данных !'), L('4.8. Геокогнитивная подсистема "Эйдос"')) Help48() // Пояснение о назначении режима ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ******* Преобразование Excel-таблицы в Inp_data.dbf (X,Y,Z) точек DO CASE CASE mFile = 'Inp_map1.' cFileName := "Inp_data.dbf" CASE mFile = 'Rsp_map1.' cFileName := "Inp_rasp.dbf" ENDCASE CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DO CASE CASE mFile = 'Inp_map1.' USE Inp_map1 EXCLUSIVE NEW SELECT Inp_map1 CASE mFile = 'Rsp_map1.' USE Rsp_map1 EXCLUSIVE NEW SELECT Rsp_map1 ENDCASE N_RecMap = RECCOUNT() N_ColMap = FCOUNT() IF N_ColMap < 4 Mess = L('В файле исходных данных: "')+M_ApplsPath+"\Inp_data\"+mFile+mFlag1 Mess = L('кроме координат X,Y,Z точек должны быть еще признаки аргумента: Z1,Z2,...,ZN') LB_Warning(Mess) Help48() // Пояснение о назначении режима ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF IF N_RecMap < 4 Mess = L('В файле исходных данных: "')+M_ApplsPath+"\Inp_data\"+mFile+mFlag1 Mess = L('должны быть координаты и признаки аргумента хотя бы 3 точек!') LB_Warning(Mess) Help48() // Пояснение о назначении режима ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ********** Создать Inp_data.dbf по размерности Inp_map1 или ********** Создать Inp_rasp.dbf по размерности Rsp_map1 aStructure := { { "Coord_XY", "C", 40, 0 },; // Координаты X,Y точек { "Coord_Z" , "N", 15, 7 } } // Координата Z точек FOR j=4 TO N_ColMap // Признаки аргумента Z1,Z2,...,ZN точек AADD(aStructure, { "Z"+ALLTRIM(STR(j-3)), FIELDTYPE(j), FIELDSIZE(j), FIELDDECI(j) } ) NEXT DbCreate( cFileName, aStructure ) ****************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DO CASE CASE mFile = 'Inp_map1.' USE Inp_data EXCLUSIVE NEW USE Inp_map1 EXCLUSIVE NEW SELECT Inp_map1 CASE mFile = 'Rsp_map1.' USE Inp_rasp EXCLUSIVE NEW USE Rsp_map1 EXCLUSIVE NEW SELECT Rsp_map1 ENDCASE DBGOTOP() nMax = N_Recmap DO CASE CASE mFile = 'Inp_map1.' Mess = L('Преобразование: Inp_map1 => Inp_data') CASE mFile = 'Rsp_map1.' Mess = L('Преобразование: Rsp_map1 => Inp_rasp') ENDCASE @ 4,5 DCPROGRESS oProgress SIZE 70,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 DCREAD GUI TITLE Mess PARENT @oDialog FIT EXIT oDialog:show() nTime = 0 DC_GetProgress(oProgress,0,nMax) DBGOTOP() DO WHILE .NOT. EOF() aP := {} FOR j=1 TO FCOUNT() AADD(aP, FIELDGET(j)) NEXT DO CASE CASE mFile = 'Inp_map1.' SELECT Inp_data CASE mFile = 'Rsp_map1.' SELECT Inp_rasp ENDCASE APPEND BLANK REPLACE Coord_XY WITH 'X=' + STR(aP[1],15,7) + ", Y=" + STR(aP[2],15,7) // ???????????? REPLACE Coord_Z WITH aP[3] FOR j=4 TO LEN(aP) FIELDPUT(j-1,aP[j]) NEXT DC_GetProgress(oProgress, ++nTime, nMax) DO CASE CASE mFile = 'Inp_map1.' SELECT Inp_map1 // В 1-й колонке X, во 2-й колонке Y CASE mFile = 'Rsp_map1.' SELECT Rsp_map1 ENDCASE DBSKIP(1) ENDDO *MsgBox('STOP') DC_GetProgress(oProgress,nMax,nMax) oDialog:Destroy() *ERASE('_ColumnNames.arx') // Файлы сформированы при преобразовании Inp_map1.xls в Inp_map1.dbf *ERASE('_Inp_name.arx') aColumnNames = DC_ARestore("_ColumnNames.arx") // Загрузка массива наименований шкал (колонок) из файла // Преобразовать файл _ColumnNames.arx, сформированный из Inp_map1.xls, как он получился бы из Inp_data.xls, чтобы в F482 не надо было ничего выдумывать aR := {} *AADD(aR, 'X=' + STR(aColumnNames[1],15,7) + " Y=" + STR(aColumnNames[2],15,7)) AADD(aR, 'Coord_XY') FOR j=3 TO LEN(aColumnNames) AADD(aR, aColumnNames[j]) NEXT aColumnNames := {} FOR j=1 TO LEN(aR) AADD(aColumnNames, aR[j]) NEXT DC_ASave(aColumnNames, "_ColumnNames.arx") // Запись массива наименований шкал (колонок) в виде файла DC_ASave(aColumnNames, "_Inp_nameAll.arx") // Запись массива наименований шкал (колонок) в виде файла ***** Записать новые файлы: Inp_name.txt и Inp_nameALL.txt для БД Inp_data.dbf CrLf = CHR(13)+CHR(10) // Конец строки (записи) String = '' FOR j=1 TO LEN(aColumnNames) String = String + aColumnNames[j] + CrLf NEXT StrFile(String, "Inp_nameAll.txt") // Запись текстового файла "Inp_nameAll.txt" String = '' FOR j=2 TO LEN(aColumnNames) String = String + aColumnNames[j] + CrLf NEXT StrFile(String, "Inp_name.txt") // Запись текстового файла "Inp_name.txt" // Записать файлы: _ColumnNames.arx и _482.txt ***** Скопировать файлы с именами колонок уже не файла Inp_map1.xls, а файла Inp_data.dbf из папки Inp_data в папку с системой CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций Name_SS = Disk_dir+"\AID_DATA\Inp_data\_ColumnNames.arx" Name_DD = Disk_dir+"\_ColumnNames.arx" *MsgBox(Name_SS+' => '+Name_DD) COPY FILE (Name_SS) TO (Name_DD) *********** Сформировать файл параметров режима 2.3.2.2() // Сохранить файл с информацией о заданых параметрах программного интерфейса в текущей директории системы // и в папке приложения, чтобы можно было потом узнать при каких параметрах оно создано DO CASE CASE mFile = 'Inp_map1.' Regim = 1 // Формализации ПО или ген.расп.выб. CASE mFile = 'Rsp_map1.' Regim = 2 // Формализации ПО или ген.расп.выб. ENDCASE Flag_zer = 1 // Считать нули и пробелы отсутствием данных? [1]-да, [2]-нет N_Chast = 1 // На сколько частей N разбивать обучающую или распознаваемую выборку (в зависимости от Regim) M_ClSc1 = 2 // Номер начального столбца диапазона классификационных шкал M_ClSc2 = 2 // Номер конечного столбца диапазона классификационных шкал M_OpSc1 = 3 // Номер начального столбца диапазона описательных шкал M_OpSc2 = N_ColMap-1 // Номер конечного столбца диапазона описательных шкал M_ObAnk = 3 // Создавать анкеты исходной выборки по строкам Inp_data-[1], по классам-[2], и 1-е, и 2-е [3] M_Interval = 1 // 1-равные интервалы, 2-адаптивные интервалы (с примерно равным количеством наблюдений, по Котельникову) N_SKGrCl = 10 N_SKGrPr = 10 K_N_ClSc = 1 K_N_OpSc = 1 K_N_GrClSc = 10 K_N_GrOpSc = 10 M_Scenario = .F. mGorizMin = 5 mGorizMax = 5 mGlubMin = 5 mGlubMax = 5 K_GradNClSc = 10 K_GradNOpSc = 10 M_ChastObi = .F. M_ChastRso = .F. N_ChastObi = 1 N_ChastRso = 1 M_XlsDbf = 3 mTxtCSField = 1 // Способ интерпретации значений текстовых полей - классификационных шкал файла исходных данных mTxtOSField = 1 // Способ интерпретации значений текстовых полей - описательных шкал файла исходных данных mTxtCSSep = " " // Разделитель элементов классификационных шкал, если mTxtCSField=3 mTxtOSSep = " " // Разделитель элементов описательных шкал, если mTxtOSField=3 * mScenario = 1 // mScenario=1 Не применять сценарный метод АСК-анализа и спец.интерпретацию TXT-полей (старый вариант) mScenario = 1 // Не применять сценарный метод АСК-анализа mSpecInterprCls = .F. // Не применять спец.интерпретацию текстовых полей классов mSpecInterprAtr = .F. // Не применять спец.интерпретацию текстовых полей признаков mNameGrNumSc= 1 // Какие наименования ГРАДАЦИЙ числовых шкал использовать mClsAvr = .F. // .F. - делать модель из Inp_data, .T. - делать модель из Inp_data_avr mSortUnqCls = 1 // Выделять уникальные значения классов и сортировать, 1-да, 2-нет mLemmatCls = 2 // Проводить лемматизацию классов, 1-да, 2-нет mSortUnqGos = 1 // Выделять уникальные значения признаков и сортировать, 1-да, 2-нет mLemmatGos = 2 // Проводить лемматизацию признаков, 1-да, 2-нет // Сохранить файл с информацией о заданых параметрах программного интерфейса в текущей директории системы PRIVATE aSoftInt[40] aSoftInt[ 1] = Regim aSoftInt[ 2] = Flag_zer aSoftInt[ 3] = M_ClSc1 aSoftInt[ 4] = M_ClSc2 aSoftInt[ 5] = M_OpSc1 aSoftInt[ 6] = M_OpSc2 aSoftInt[ 7] = N_SKGrCl aSoftInt[ 8] = N_SKGrPr aSoftInt[ 9] = K_N_ClSc aSoftInt[10] = K_N_OpSc aSoftInt[11] = K_N_GrClSc aSoftInt[12] = K_N_GrOpSc aSoftInt[13] = M_ObAnk aSoftInt[14] = N_Chast aSoftInt[15] = M_Interval aSoftInt[16] = M_Scenario aSoftInt[17] = K_GradNClSc // Количество градаций в числовой классификационной шкале aSoftInt[18] = K_GradNOpSc // Количество градаций в числовой описательной шкале aSoftInt[19] = mGorizMin aSoftInt[20] = mGorizMax aSoftInt[21] = mGlubMin aSoftInt[22] = mGlubMax aSoftInt[23] = M_ChastObi aSoftInt[24] = M_ChastRso aSoftInt[25] = N_ChastObi aSoftInt[26] = N_ChastRso aSoftInt[27] = M_XlsDbf aSoftInt[28] = mTxtCSField aSoftInt[29] = mTxtOSField aSoftInt[30] = mTxtCSSep aSoftInt[31] = mTxtOSSep * aSoftInt[32] = mScenario // mScenario=1 Не применять сценарный метод АСК-анализа и спец.интерпретацию TXT-полей (старый вариант) aSoftInt[32] = mScenario // mScenario=1 Не применять сценарный метод АСК-анализа aSoftInt[33] = mSpecInterprCls // .T. - Применить спец.интерпретацию текстовых полей классов, .F. - не применять aSoftInt[34] = mSpecInterprAtr // .T. - Применить спец.интерпретацию текстовых полей признаков, .F. - не применять aSoftInt[35] = mNameGrNumSc // Какие наименования ГРАДАЦИЙ числовых шкал использовать aSoftInt[36] = mClsAvr // .F. = модель без усреднения по классам aSoftInt[37] = mSortUnqCls // Выделять уникальные значения классов и сортировать, 1-да, 2-нет aSoftInt[38] = IF(mSpecInterprCls,mLemmatCls,2) // Проводить лемматизацию классов, 1-да, 2-нет aSoftInt[39] = mSortUnqGos // Выделять уникальные значения признаков и сортировать, 1-да, 2-нет aSoftInt[40] = IF(mSpecInterprAtr,mLemmatGos,2) // Проводить лемматизацию признаков, 1-да, 2-нет DC_ASave(aSoftInt , Disk_dir +"\_2_3_2_2.arx") * DC_ASave(aSoftInt , M_NewAppl+"\_2_3_2_2.arx") * MsgBox("Переход к 482: Преобразование: Inp_data.dbf или Inp_rasp.dbf => Points_XYZ.dbf") F482(mFile, mNumColumn, 6) // Преобразование: Inp_data.dbf или Inp_rasp.dbf => Points_XYZ.dbf // Наименования шкал взяты из Inp_map1, а в нем на 1 колонку больше, чем в Inp_data // учесть это в F482 при выборке данных и выводе наименований форм с учетом значения mRegim aMess := {} DO CASE CASE mFile = 'Inp_map1.' AADD(aMess, L('Преобразование 1d Excel-таблицы: "Inp_map1.xls" в файл исходных данных: "Inp_data.dbf" завершено успешно!')) IF nModel = 2 AADD(aMess, L('Для создания модели будут выполнены режимы 2.3.2.2 и 3.5 с параметрами по умолчанию')) ENDIF AADD(aMess, L(' ')) LB_Warning(aMess, L('4.8. Геокогнитивная подсистема "Эйдос"' )) IF nModel = 2 F2_3_2_2("Картографическое приложение","") F3_5('CPU') ENDIF CASE mFile = 'Rsp_map1.' AADD(aMess, L('Преобразование 1d Excel-таблицы: "Rsp_map1.xls" в файл распознаваемой выборки: "Inp_rasp.dbf" завершено успешно!')) IF nRasp = 2 AADD(aMess, L('Для применения модели будут выполнены режимы 2.3.2.2 и 4.1.2 с параметрами по умолчанию')) ENDIF AADD(aMess, L(' ')) LB_Warning(aMess, L('4.8. Геокогнитивная подсистема "Эйдос"' )) IF nRasp = 2 F2_3_2_2("","") F4_1_2(0,.T.,"4_1_2",'CPU') ENDIF ENDCASE ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL *----------------------- ***************************************************************** ******** Формирование внешних и внутренних контуров ************* ***************************************************************** FUNCTION Contouring(hDC1,aPixel) LOCAL GetList[0], GetOptions, oSay, oDialog, oProgress, oScrn LOCAL i, j, nXSize := Len(aPixel), nYSize := Len(aPixel[1]) LOCAL hMemoryDC := CreateMemoryDC( hDC1, nXSize, nYSize ) // Для ускорения работы GetPixel() примерно в 50 раз LOCAL Xc, Yc, Nc LOCAL oBitmap PUBLIC Contour := 1 // Только внешние контуры PUBLIC ContCol := 2 // Ставить точку итогового контура если PUBLIC N_intervR := 20 // Число яркостных интервалов красного цвета PUBLIC N_intervG := 20 // Число яркостных интервалов зеленого цвета PUBLIC N_intervB := 20 // Число яркостных интервалов синего цвета PUBLIC FillColor := 4 // Что делать с цветами после оконтуривания PUBLIC ddColorR := .T. // Расширять динамический диапазон красного цвета PUBLIC ddColorG := .T. // Расширять динамический диапазон зеленого цвета PUBLIC ddColorB := .T. // Расширять динамический диапазон синего цвета // Относительный вес частных критериев выделения точек контуров в % (сумма должна быть = 100) PUBLIC Priv_crit_a := 20 // Учет степени отличия от окружения PUBLIC Priv_crit_b := 20 // Учет расстояния от центра тяжести PUBLIC Priv_crit_c := 60 // Учет расстояния от предыдущей точки контура f = 52 // Отступ вывода в правой части окна @ 0, 0 DCGROUP oGroup1 CAPTION L('Какие контуры формировать?') SIZE 78.0, 2.5 @ 1, 2 DCRADIO Contour VALUE 1 PROMPT L('Только внешние' ) PARENT oGroup1 @ 1,f/2 DCRADIO Contour VALUE 2 PROMPT L('И внешние, и внутренние' ) PARENT oGroup1 @ 3, 0 DCGROUP oGroup2 CAPTION L('Задайте число яркостных интервалов:' ) SIZE 78.0, 2.5 @ 1, 1 DCSAY L('Red: ') GET N_intervR PICTURE "##########" PARENT oGroup2 @ 1,f/2 DCSAY L('Green:') GET N_intervG PICTURE "##########" PARENT oGroup2 @ 1, f DCSAY L('Blue: ') GET N_intervB PICTURE "##########" PARENT oGroup2 @ 6, 0 DCGROUP oGroup3 CAPTION L('Ставить точку итогового контура если:') SIZE 78.0, 3.5 @ 1, 2 DCRADIO ContCol VALUE 1 PROMPT L('- есть точки и Red, и Green, и Blue контуров') PARENT oGroup3 @ 2, 2 DCRADIO ContCol VALUE 2 PROMPT L('- есть точка или Red, или Green, или Blue контура' ) PARENT oGroup3 @10, 0 DCGROUP oGroup4 CAPTION L('Цвета после оконтуривания:') SIZE 78.0, 5.5 @ 1, 2 DCRADIO FillColor VALUE 1 PROMPT L('Расширить динамический диапазон цветов:' ) PARENT oGroup4 @ 2, 2 DCRADIO FillColor VALUE 2 PROMPT L('Показывать только контуры' ) PARENT oGroup4 @ 3, 2 DCRADIO FillColor VALUE 3 PROMPT L('Показывать исходное изображение и контуры в RGB' ) PARENT oGroup4 @ 4, 2 DCRADIO FillColor VALUE 4 PROMPT L('Показывать исходное изображение и контуры в RGB и в лучах: Red, Green, Blue') PARENT oGroup4 d = 0.85 s = d @ s,40 DCGROUP oGroup5 CAPTION L('Для каких цветов?') SIZE 26, 4.0 PARENT oGroup4 HIDE {||.NOT.FillColor=1} @ s, 2 DCCHECKBOX ddColorR PROMPT 'Red' PARENT oGroup5 EDITPROTECT {||.NOT.FillColor=1} HIDE {||.NOT.FillColor=1};s=s+d @ s, 2 DCCHECKBOX ddColorG PROMPT 'Green' PARENT oGroup5 EDITPROTECT {||.NOT.FillColor=1} HIDE {||.NOT.FillColor=1};s=s+d @ s, 2 DCCHECKBOX ddColorB PROMPT 'Blue' PARENT oGroup5 EDITPROTECT {||.NOT.FillColor=1} HIDE {||.NOT.FillColor=1};s=s+d StandVol = .F. StandPov = .F. N_Cont = 1 ViewExcel = .T. N_GradUg = 30 N_PointCont = 10 @16, 0 DCGROUP oGroup6 CAPTION L('Задайте параметры ввода изображений:') SIZE 78.0, 7.5 @ 1, 2 DCCHECKBOX StandVol PROMPT L('Стандартизировать размеры изображений? ' ) PARENT oGroup6 // 1 @ 2, 2 DCCHECKBOX StandPov PROMPT L('Стандартизировать поворот изображений? ' ) PARENT oGroup6 // 2 @ 3, 2 DCCHECKBOX ViewExcel PROMPT L('Отображать заполнение данными MS Excel? ' ) PARENT oGroup6 // 3 @ 4.2, 4.5 DCSAY L('Задайте число контуров в изображениях: ' ) PARENT oGroup6 // 4 @ 4, f DCGET N_Cont PICTURE "#####" PARENT oGroup6 @ 5.2, 4.5 DCSAY L('Задайте количество градаций угла: 2 <= N_Grad <= 360:' ) PARENT oGroup6 // 5 @ 5, f DCGET N_GradUg PICTURE "#####" PARENT oGroup6 @ 6.2, 4.5 DCSAY L('Задайте число точек на радиус-векторе для поиска контура:') PARENT oGroup6 // 6 @ 6, f DCGET N_PointCont PICTURE "#####" PARENT oGroup6 @ 1, f DCPUSHBUTTON CAPTION L('Пояснения по режиму') SIZE LEN(L('Пояснение по режиму')), 2.8 ACTION {||Help48()} PARENT oGroup6 Regim = 1 @24, 0 DCGROUP oGroup7 CAPTION L('Создавать модель или применять?') SIZE 78.0, 3.5 @ 1, 2 DCRADIO Regim VALUE 1 PROMPT L('Формализации предм.области, генерация обуч.выборки, синтез и верификация модели') PARENT oGroup7 @ 2, 2 DCRADIO Regim VALUE 2 PROMPT L('Генерация распознавамой выборки и идентификация (классификация) изображений' ) PARENT oGroup7 Pausa = 1 @28, 0 DCGROUP oGroup8 CAPTION L('Делать ли паузу после вывода изображений?') SIZE 78.0, 2.5 @ 1, 2 DCRADIO Pausa VALUE 1 PROMPT L('Нет') PARENT oGroup8 @ 1,f/2 DCRADIO Pausa VALUE 2 PROMPT L('Да' ) PARENT oGroup8 @31, 0 DCGROUP oGroup7 CAPTION L('Относительный вес частных критериев выделения точек конутров в %:') SIZE 78.0, 4.5 @ 1.2, 4.5 DCSAY L('Учет степени отличия от окружения:' ) PARENT oGroup7 @ 2.2, 4.5 DCSAY L('Учет расстояния от центра тяжести:' ) PARENT oGroup7 @ 3.2, 4.5 DCSAY L('Учет расстояния от предыдущей точки контура:' ) PARENT oGroup7 @ 1, f DCGET Priv_crit_a PICTURE "#####" PARENT oGroup7 @ 2, f DCGET Priv_crit_b PICTURE "#####" PARENT oGroup7 @ 3, f DCGET Priv_crit_c PICTURE "#####" PARENT oGroup7 DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; OPTIONS GetOptions ; ADDBUTTONS; MODAL ; TITLE L('4.8. Геокогнитивная подсистема "Эйдос". Оконтуривание') ******************************************************************** IF lExit ** Button Ok ELSE RETURN NIL ENDIF ******************************************************************** IF N_intervR < 2 .OR. N_intervG < 2 .OR. N_intervB < 2 LB_Warning(L('Число яркостных интервалов должно быть больше 1'),L('4.8. Геокогнитивная подсистема "Эйдос"')) RETURN NIL ENDIF ** Проверки на корректность заданного числа градаций угла IF N_GradUg < 2 aMess := {} AADD(aMess, L('Задано недопустимо малое число градаций угла: ')+ALLTRIM(STR(N_GradUg))+',') AADD(aMess, L('Поэтому оно принято минимальным допустимым: = 2.')) LB_Warning(aMess, L('4.8. Геокогнитивная подсистема "Эйдос"')) N_GradUg = 2 ENDIF IF N_GradUg > 360 aMess := {} AADD(aMess, L('Задано недопустимо большое число градаций угла: ')+ALLTRIM(STR(N_GradUg))+',') AADD(aMess, L('Поэтому оно принято максимальным допустимым: = 360.')) LB_Warning(aMess, L('4.8. Геокогнитивная подсистема "Эйдос"')) N_GradUg = 360 ENDIF IF Priv_crit_a + Priv_crit_b + Priv_crit_c <> 100 aMess := {} AADD(aMess, L('Сумма заданных значений частных критериев выбора точки контура не равна 100%')) AADD(aMess, L(' ')) AADD(aMess, L('Поэтому заданы следующие значения:')) AADD(aMess, L(' ')) AADD(aMess, L('Учет степени отличия от окружения = 20')) AADD(aMess, L('Учет расстояния от центра тяжести = 20')) AADD(aMess, L('Учет расстояния от предыдущей точки контура = 60')) LB_Warning(aMess, L('4.8. Геокогнитивная подсистема "Эйдос"')) Priv_crit_a := 20 // Учет степени отличия от окружения Priv_crit_b := 20 // Учет расстояния от центра тяжести Priv_crit_c := 60 // Учет расстояния от предыдущей точки контура ENDIF ************************************************************************** *** ИСПОЛНЕНИЕ ************************************************************************** ClearImageTr() *** Определение путей на файлы изображений символов *** Сформировать массив наименований папок и в каждой из них массив полных имен графических файлов cWorkPath = M_ApplsPath+"\Inp_data\" aAll := DIRECTORY( cWorkPath + "*.*", 'D' ) // Почему-то в массив попадает информация не только по директориям IF LEN(aAll) = 0 Mess = L(" В папке: ")+cWorkPath+L(" нет файлов!") LB_Warning(Mess, L("2.3.2.5: Ввод изображений с учетом цвета пикселей")) RETURN nil ENDIF * DC_DebugQout( aAll ) aDir := {} FOR j = 1 TO LEN(aAll) IF aAll[j, 5] = "D" IF aAll[j, 5] <> '.' IF aAll[j, 5] <> '..' AADD(aDir, aAll[j, 1]) ENDIF ENDIF ENDIF NEXT * DC_DebugQout( aDIR ) aFileName := {} // Массив полных имен файлов изображений aFileNmSh := {} // Массив коротких имен файлов изображений IF LEN(aDIR) = 0 Mess = L(" В папке: ")+cWorkPath+L(" нет поддиректорий!") LB_Warning(Mess, L("2.3.2.5: Ввод изображений с учетом цвета пикселей")) RETURN nil ENDIF FOR j = 1 TO LEN(aDIR) aFNbmp = DIRECTORY( cWorkPath + aDIR[j] + "\*.bmp" ) IF LEN(aFNbmp) > 0 FOR f = 1 TO LEN(aFNbmp) AADD(aFileName, cWorkPath + aDIR[j] + "\" + aFNbmp[f,1] ) AADD(aFileNmSh, aFNbmp[f,1] ) NEXT ENDIF aFNjpg = DIRECTORY( cWorkPath + aDIR[j] + "\*.jpg" ) IF LEN(aFNjpg) > 0 FOR f = 1 TO LEN(aFNjpg) AADD(aFileName, cWorkPath + aDIR[j] + "\" + aFNjpg[f,1] ) AADD(aFileNmSh, aFNjpg[f,1] ) NEXT ENDIF NEXT * DC_DebugQout( aFileName ) * DC_DebugQout( aFileNmSh ) IF LEN(aFileName) = 0 Mess = L(" В поддиректориях папки: "+cWorkPath+" нет bmp и jpg графических файлов!") LB_Warning(Mess, L("2.3.2.5: Ввод изображений с учетом цвета пикселей")) RETURN nil ENDIF *** Если БД "Image.dbf" нет, то создать ее IF .NOT. FILE("Image.dbf") GenDBFImage(.F.) ENDIF * Записать массив полных имен файлов изображений, а потом считать и использовать его DC_ASave(aFileName, "_FileName.arx") * DC_DebugQout( aFileNmSh ) * aFileName := DC_ARestore("_FileName.arx") * DC_DebugQout( aFileNmSh ) DC_ASave(aFileNmSh, "_FileNmSh.arx") * aFileNmSh := DC_ARestore("_FileNmSh.arx") * DC_DebugQout( aFileNmSh ) * MsgBox('STOP') ***************************************************************************************************** ** БЕЛЫЙ ЦВЕТ ПИКСЕЛЕЙ ИГНОРИРОВАТЬ, СЧИТАТЬ НЕ ЗНАЧИМЫМ (ФОНОМ), Т.Е. ЗНАЧИМЫЕ ТОЧКИ НЕ БЕЛОГО ЦВЕТА ***************************************************************************************************** ** Имя графического файла для рисования - источника исходных данных DO CASE CASE FILE('Delone.bmp') mFileName = 'Delone.bmp' CASE FILE('Delone.jpg') mFileName = 'Delone.jpg' // Нежелательно, т.к. изображение размыто OTHERWISE LB_Warning(L('В текущей папке системы: ')+Disk_dir+L(' должен быть файл: "Delone.bmp" или "Delone.jpg"'),L('4.8. Геокогнитивная подсистема "Эйдос"' )) RETURN nil ENDCASE GenDBFImage(.F.) // 1. Пересоздать (стереть) БД для изображений: "Image.Dbf" CreateImages() // 2. Оцифровать изображения и записать их в БД "Image.Dbf" nWidthMax = VAL(FileStr('_WidthMax.txt')) nHeightMax = VAL(FileStr('_HeightMax.txt')) ***** Определение максимального размера изображения oScrn := DC_WaitOn( L('Определение максимального размера изображения' ),,,,,,,,,,,.F.) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Image VIA 'FOXCDX' EXCLUSIVE NEW nXSize = -999999999 nYSize = -999999999 aFileNmSh := {} DO WHILE !IMAGE->(Eof()) aPixel := Bin2Var(IMAGE->array) // Загрузка массива из БД Image AADD(aFileNmSh, FIELDGET(2)) // Для формирования имен классов. Вместо записи и считывания массива использовать БД nXSize = MAX(nXSize, Len(aPixel)) nYSize = MAX(nYSize, Len(aPixel[1])) IMAGE->(dbSkip()) ENDDO DC_Impl(oScrn) StrFile(STR(nXSize,9)+' '+STR(nYSize,9), '_XYSize.txt') // Запись текстового файла с параметрами nXSize, nYSize *nXSize = VAL(SUBSTR(FileStr('_XYSize.txt'), 1,9)) // Загрузка параметра nXSize из текстового файла *nYSize = VAL(SUBSTR(FileStr('_XYSize.txt'),11,9)) // Загрузка параметра nYSize из текстового файла IF nXSize > 450 LB_Warning(L('Желательно, чтобы размеры изображений по X были не больше 450 pix !!!'),L('4.8. Геокогнитивная подсистема "Эйдос"' )) ENDIF IF nYSize > 800 LB_Warning(L('Желательно, чтобы размеры изображений по Y были не больше 800 pix !!!'),L('4.8. Геокогнитивная подсистема "Эйдос"' )) ENDIF ***** Задать атрибуты линии aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT *aAttr [ GRA_AL_COLOR ] := fColor // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) aInp_name := {} ******* Сформировать массивы и БД частотных распределений яркостей цветов точек изображения PRIVATE aRed[256], aGreen[256], aBlue[256] AFILL(aRed,0) AFILL(aGreen,0) AFILL(aBlue,0) aStructure := { { "pColor" , "C", 5, 0 } } // Наименование цвета FOR c=0 TO 255 AADD(aStructure, { "C"+ALLTRIM(STR(c,3)), "N", 15, 0 }) NEXT DbCreate( 'FreqColor', aStructure ) *** БД степеней отличия точек радиус-векторов от ближайшего окружения *** Рассортировать все точки радиус-вектора по степени их отличия от окружения *** Оставить столько точек, сколько задано контуров *** Рассортировать в порядке убывания расстояния от точки до центра тяжести и определить номера контуров aStructure := { { "pImage", "C", 80, 0 },; // Полное наименование файла изображения (не используется) { "pRVang", "N", 3, 0 },; // Угол поворота радиуса-вектора в полярной системе координат в градусах { "pRVlen", "N", 19, 7 },; // Расстояние от центра тяжести до данной точки { "pX" , "N", 19, 7 },; // Координаты X,Y, точки радиус-вектора { "pY" , "N", 19, 7 },; // Координаты X,Y, точки радиус-вектора { "pNCont", "N", 15, 0 },; // Номер контура, на котором находится точка { "pRed" , "N", 19, 7 },; // Степень отличия точки от ближайшего окружения в красном луче { "pGreen", "N", 19, 7 },; // Степень отличия точки от ближайшего окружения в зеленом луче { "pBlue" , "N", 19, 7 },; // Степень отличия точки от ближайшего окружения в синем луче { "pRGB" , "N", 19, 7 },; // Сумарная степень отличия точки от ближайшего окружения во всех лучах { "pRGBst", "N", 19, 7 },; // Стандартизированная сумарная степень отличия точки от ближайшего окружения во всех лучах { "pRVlst", "N", 19, 7 },; // Стандартизированное расстояние от центра тяжести до данной точки { "pIntKr", "N", 19, 7 } } // Интегральный критерий значимости точки: сумма отличий от фона по трем цветам + расстояние от центра тяжести DbCreate( 'PointRV', aStructure ) *** БД точек контуров для всех радиус-векторов и всх изображений aStructure := { { "pImage", "C", 80, 0 },; // Полное наименование файла изображения { "pRVang", "N", 3, 0 },; // Угол поворота радиуса-вектора в полярной системе координат в градусах { "pRVlen", "N", 19, 7 },; // Расстояние от центра тяжести до данной точки { "pX" , "N", 19, 7 },; // Координаты X,Y, точки радиус-вектора { "pY" , "N", 19, 7 },; // Координаты X,Y, точки радиус-вектора { "pNCont", "N", 15, 0 },; // Номер контура, на котором находится точка { "pRed" , "N", 19, 7 },; // Степень отличия точки от ближайшего окружения в красном луче { "pGreen", "N", 19, 7 },; // Степень отличия точки от ближайшего окружения в зеленом луче { "pBlue" , "N", 19, 7 },; // Степень отличия точки от ближайшего окружения в синем луче { "pRGB" , "N", 19, 7 },; // Сумарная степень отличия точки от ближайшего окружения во всех лучах { "pRGBst", "N", 19, 7 },; // Стандартизированная сумарная степень отличия точки от ближайшего окружения во всех лучах { "pRVlst", "N", 19, 7 },; // Стандартизированное расстояние от центра тяжести до данной точки { "pIntKr", "N", 19, 7 } } // Интегральный критерий значимости точки: сумма отличий от фона по трем цветам + расстояние от центра тяжести DbCreate( 'PointRVs', aStructure ) ********** БД для внешнего контура всех изображений aStructure := { { "pImage", "C", 80, 0 },; // Полное наименование файла изображения { "pRVang", "N", 3, 0 },; // Угол поворота радиуса-вектора в полярной системе координат в градусах { "pRVlen", "N", 19, 7 },; // Расстояние от центра тяжести до данной точки { "pX" , "N", 19, 7 },; // Координаты X,Y, точки радиус-вектора { "pY" , "N", 19, 7 },; // Координаты X,Y, точки радиус-вектора { "pNCont", "N", 15, 0 },; // Номер контура, на котором находится точка { "pRed" , "N", 19, 7 },; // Степень отличия точки от ближайшего окружения в красном луче { "pGreen", "N", 19, 7 },; // Степень отличия точки от ближайшего окружения в зеленом луче { "pBlue" , "N", 19, 7 },; // Степень отличия точки от ближайшего окружения в синем луче { "pRGB" , "N", 19, 7 },; // Сумарная степень отличия точки от ближайшего окружения во всех лучах { "pRGBst", "N", 19, 7 },; // Стандартизированная сумарная степень отличия точки от ближайшего окружения во всех лучах { "pRVlst", "N", 19, 7 },; // Стандартизированное расстояние от центра тяжести до данной точки { "pIntKr", "N", 19, 7 } } // Интегральный критерий значимости точки: сумма отличий от фона по трем цветам + расстояние от центра тяжести DbCreate( 'OutCont', aStructure ) ****************************** DIRCHANGE("AID_DATA") // Перейти в папку со всеми БД: AID_DATA IF FILEDATE("Out_data",16) = CTOD("//") DIRMAKE("Out_data") ELSE ZapDir ("Out_data", .T.) DIRMAKE("Out_data") ENDIF DIRCHANGE(Disk_dir) // Перейти в папку с системой Эйдос ****************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE OutCont EXCLUSIVE NEW INDEX ON pImage TO OutCont ****************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE OutCont INDEX OutCont EXCLUSIVE NEW USE PointRV EXCLUSIVE NEW USE PointRVs EXCLUSIVE NEW USE FreqColor EXCLUSIVE NEW USE Image VIA 'FOXCDX' EXCLUSIVE NEW;N_Image = RECCOUNT() SELECT Image DBGOTOP() DO WHILE !IMAGE->(Eof()) mFileName = ALLTRIM(IMAGE->image_name) ********* Координаты точек контуров aContXRGB := {} // RGB aContYRGB := {} aContXR := {} // R aContYR := {} aContXG := {} // G aContYG := {} aContXB := {} // B aContYB := {} oScrn := DC_WaitOn( L('Поиск центра тяжести изображения: "')+mFileName+'"'+' N'+ALLTRIM(STR(RECNO()))+'/'+ALLTRIM(STR(RECCOUNT())),,,,,,,,,,,.F.) aPixel := Bin2Var(IMAGE->array) // Загрузка массива из БД Image nXSizeAr = Len(aPixel) nYSizeAr = Len(aPixel[1]) *** Определить минимальные (не равные нулю) и максимальные яркости лучей MinRed = +999999 MaxRed = -999999 MinGreen = +999999 MaxGreen = -999999 MinBlue = +999999 MaxBlue = -999999 FOR y := 1 TO nYSizeAr FOR x := 1 TO nXSizeAr nColor = AutomationTranslateColor(aPixel[x,y], .t.) aRGB = GraGetRGBIntensity(nColor) // Взаимнообратные операции преобразования формы кодирования цвета в массиве RGB и одним числом MinRed = MIN(MinRed , aRGB[1]) MaxRed = MAX(MaxRed , aRGB[1]) MinGreen = MIN(MinGreen, aRGB[2]) MaxGreen = MAX(MaxGreen, aRGB[2]) MinBlue = MIN(MinBlue , aRGB[3]) MaxBlue = MAX(MaxBlue , aRGB[3]) aRed [1+aRGB[1]] = aRed [1+aRGB[1]] + 1 aGreen[1+aRGB[2]] = aGreen[1+aRGB[2]] + 1 aBlue [1+aRGB[3]] = aBlue [1+aRGB[3]] + 1 NEXT NEXT ****** Записать массивы частотных распределений яркостей цветов точек изображения в БД FreqColor SELECT FreqColor APPEND BLANK;FIELDPUT(1,'Red' );FOR c=0 TO 255;FIELDPUT(2+c,aRed [1+c]);NEXT APPEND BLANK;FIELDPUT(1,'Green');FOR c=0 TO 255;FIELDPUT(2+c,aGreen[1+c]);NEXT APPEND BLANK;FIELDPUT(1,'Blue' );FOR c=0 TO 255;FIELDPUT(2+c,aBlue [1+c]);NEXT APPEND BLANK;FIELDPUT(1,'Сумма');FOR c=0 TO 255;FIELDPUT(2+c,aRed [1+c]+aGreen[1+c]+aBlue[1+c]);NEXT SELECT Image AADD(aInp_name, ALLTRIM(IMAGE->image_name)) mNumImage = RECNO() ClearImageTr() // Сброс изображения ****** Поиск координат центра тяжести контурного изображения *************************** Xc = 0 // Координаты центра тяжести контурного изображения и количество точек контура Yc = 0 Nc = 0 FOR y := 2 TO nYSizeAr-1 FOR x := 2 TO nXSizeAr-1 * Координаты пикселей * *---------------------* * |X-1,Y-1|X,Y-1|X+1,Y-1| * *---------------------* * |X-1,Y |X,Y |X+1,Y | * *---------------------* * |X-1,Y+1|X,Y+1|X+1,Y+1| * *---------------------* * Нумерация пикселей как кнопок на цифровой клавиатуре * *---------------------* * | 7 | 8 | 9 | * *---------------------* * | 4 | 5 | 6 | * *---------------------* * | 1 | 2 | 3 | * *---------------------* mCol = aPixel[x-1, y+1];nColor = AutomationTranslateColor(mCol, .t.);aRGB1 = GraGetRGBIntensity(nColor) // Цвет 1-го пикселя mCol = aPixel[x , y+1];nColor = AutomationTranslateColor(mCol, .t.);aRGB2 = GraGetRGBIntensity(nColor) // Цвет 2-го пикселя mCol = aPixel[x+1, y+1];nColor = AutomationTranslateColor(mCol, .t.);aRGB3 = GraGetRGBIntensity(nColor) // Цвет 3-го пикселя mCol = aPixel[x-1, y ];nColor = AutomationTranslateColor(mCol, .t.);aRGB4 = GraGetRGBIntensity(nColor) // Цвет 4-го пикселя mCol = aPixel[x , y ];nColor = AutomationTranslateColor(mCol, .t.);aRGB5 = GraGetRGBIntensity(nColor) // Цвет 5-го пикселя mCol = aPixel[x+1, y ];nColor = AutomationTranslateColor(mCol, .t.);aRGB6 = GraGetRGBIntensity(nColor) // Цвет 6-го пикселя mCol = aPixel[x-1, y-1];nColor = AutomationTranslateColor(mCol, .t.);aRGB7 = GraGetRGBIntensity(nColor) // Цвет 7-го пикселя mCol = aPixel[x , y-1];nColor = AutomationTranslateColor(mCol, .t.);aRGB8 = GraGetRGBIntensity(nColor) // Цвет 8-го пикселя mCol = aPixel[x+1, y-1];nColor = AutomationTranslateColor(mCol, .t.);aRGB9 = GraGetRGBIntensity(nColor) // Цвет 9-го пикселя ******** Расчет средней яркости окружающих пикселей по трем цветам mColAvrR = (aRGB1[1]+aRGB2[1]+aRGB3[1]+aRGB4[1]+aRGB6[1]+aRGB7[1]+aRGB8[1]+aRGB9[1])/8 mColAvrG = (aRGB1[2]+aRGB2[2]+aRGB3[2]+aRGB4[2]+aRGB6[2]+aRGB7[2]+aRGB8[2]+aRGB9[2])/8 mColAvrB = (aRGB1[3]+aRGB2[3]+aRGB3[3]+aRGB4[3]+aRGB6[3]+aRGB7[3]+aRGB8[3]+aRGB9[3])/8 ****** Яркости цветов R,G,B центрального пикселя (5-го) mCol5R = aRGB5[1] mCol5G = aRGB5[2] mCol5B = aRGB5[3] ****** Есть точка контура? * mFlagR = IF(ABS(mCol5R - mColAvrR) > (MaxRed -MinRed )/N_intervR, .T., .F.) * mFlagG = IF(ABS(mCol5G - mColAvrG) > (MaxGreen-MinGreen)/N_intervG, .T., .F.) * mFlagB = IF(ABS(mCol5B - mColAvrB) > (MaxBlue -MinBlue )/N_intervB, .T., .F.) mFlagR = IF(ABS(mCol5R - mColAvrR) > 255/N_intervR, .T., .F.) mFlagG = IF(ABS(mCol5G - mColAvrG) > 255/N_intervG, .T., .F.) mFlagB = IF(ABS(mCol5B - mColAvrB) > 255/N_intervB, .T., .F.) ** Ставить точку итогового контура если: mFlag = .F. DO CASE CASE ContCol = 1 // - есть точки и Red, и Green, и Blue контуров IF mFlagR .AND. mFlagG .AND. mFlagB mFlag = .T. AADD(aContXR, x) // ######## AADD(aContYR, y) // ######## AADD(aContXG, x) // ######## AADD(aContYG, y) // ######## AADD(aContXB, x) // ######## AADD(aContYB, y) // ######## ENDIF CASE ContCol = 2 // - есть точка или Red, или Green, или Blue контура IF mFlagR mFlag = .T. AADD(aContXR, x) AADD(aContYR, y) ENDIF IF mFlagG mFlag = .T. AADD(aContXG, x) AADD(aContYG, y) ENDIF IF mFlagB mFlag = .T. AADD(aContXB, x) AADD(aContYB, y) ENDIF ENDCASE ******** Рисование точки контура, если в точке X,Y цвет отличается от окружения больше чем на заданный (расчетный) порог IF mFlag Xc = Xc + X Yc = Yc + Y Nc = Nc + 1 AADD(aContXRGB, x) AADD(aContYRGB, y) ENDIF NEXT NEXT DC_Impl(oScrn) ********** Занести в БД "Image.dbf" координаты центра тяжести изображения * ********** Создать БД Image.dbf и ее индексные массивы * aStructure := { { "Image_name", "C", 250, 0 },; // Полное имя файла * { "Short_name", "C", 15, 0 },; // Короткое имя файла * { "Xcentr" , "N", 19, 7 },; // Координата X центра тяжести * { "Ycentr" , "N", 19, 7 },; // Координата Y центра тяжести * { "Array" , "M", 10, 0 } } // Memo-поле с 2d-массивом цветов изображения по пикселям** * DbCreate( "Image.dbf", aStructure, "FOXCDX" ) Xc = Xc / Nc // Координаты центра тяжести изображения, посчитанные по предварительным контурам Yc = Yc / Nc SELECT Image REPLACE Xcentr WITH Xc REPLACE Ycentr WITH Yc IF Xc + Yc > 0 **************************************************************************** **** Нарисовать изображение с центром тяжести **** и точками исходных контуров, которые использовались для его определения **************************************************************************** ClearImageTr() ***** Расчет позиций для четырех равных по X полей изображений шириной nXSizeAr ***** и пяти равных промежутков между ними d и слева и справа от изображений до края окна X_Max = 1800 // Размеры окна изображения Y_Max = 850 d = (X_Max-4*nXSizeAr)/5 // Расстояние между полями изображений и слева и справа до края окна dY = (Y_Max-1*nYSizeAr)/2 - 30 // Расстояние по Y до края поля изображений dX1 = 1*d+0*nXSizeAr // Расстояние по X до края поля 1-го изображения dX2 = 2*d+1*nXSizeAr // Расстояние по X до края поля 2-го изображения dX3 = 3*d+2*nXSizeAr // Расстояние по X до края поля 3-го изображения dX4 = 4*d+3*nXSizeAr // Расстояние по X до края поля 4-го изображения ******************************* ****** Надпись изображения oFont := XbpFont():new():create('18.Arial Bold') GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты mTitle = 'Файл: "'+mFileName+'"' aTxtPar = DC_GraQueryTextbox(mTitle, oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox("Длина текста в пикселях="+ALLTRIM(STR(aTxtPar[1]))+". Высота текста в пикселях="+ALLTRIM(STR(aTxtPar[2]))) GraStringAt( oPS, { X_Max/2-aTxtPar[2]/2, Y_Max-aTxtPar[2]-15 }, mTitle) mTitle = 'оригинальное RGB-изображение и изображения в лучах Red, Green, Blue' aTxtPar = DC_GraQueryTextbox(mTitle, oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox("Длина текста в пикселях="+ALLTRIM(STR(aTxtPar[1]))+". Высота текста в пикселях="+ALLTRIM(STR(aTxtPar[2]))) GraStringAt( oPS, { X_Max/2-aTxtPar[2]/2, Y_Max-aTxtPar[2]-45 }, mTitle) ****************************** aAttr := Array( GRA_AM_COUNT ) // Создать массив атрибутов * aAttr[ GRA_AM_COLOR ] := fColor // Задать цвет маркера aAttr[ GRA_AM_SYMBOL ] := GRA_MARKSYM_DOT // Задать стиль маркера GraSetAttrMarker( oPS, aAttr ) // Установить атрибуты D = 5 FOR y := 1 TO nYSizeAr FOR x := 1 TO nXSizeAr nColor = AutomationTranslateColor(aPixel[x,y], .t.) aRGB = GraGetRGBIntensity(nColor) // Взаимнообратные операции преобразования формы кодирования цвета в массиве RGB и одним числом ** Цвета после оконтуривания DO CASE CASE FillColor=1 // Расширить динамический диапазон цветов CASE FillColor=2 // Показывать только контуры CASE FillColor=3 // Оставить исходные цвета fColor := GraMakeRGBColor({ aRGB[1], aRGB[2], aRGB[3] }) aAttr[ GRA_AM_COLOR ] := fColor // Задать цвет маркера GraSetAttrMarker( oPS, aAttr ) // Установить атрибуты GraMarker ( oPS,{ x+dX1, nYSizeAr-Y+dY } ) CASE FillColor=4 // Показывать RGB-цвета и в лучах: Red, Green, Blue fColor := GraMakeRGBColor({ aRGB[1], aRGB[2], aRGB[3] }) aAttr[ GRA_AM_COLOR ] := fColor // Задать цвет маркера GraSetAttrMarker( oPS, aAttr ) // Установить атрибуты GraMarker ( oPS,{ x+dX1, nYSizeAr-Y+dY } ) fColor := GraMakeRGBColor({ aRGB[1], 0, 0 }) aAttr[ GRA_AM_COLOR ] := fColor // Задать цвет маркера GraSetAttrMarker( oPS, aAttr ) // Установить атрибуты GraMarker ( oPS,{ x+dX2, nYSizeAr-Y+dY } ) fColor := GraMakeRGBColor({ 0, aRGB[2], 0 }) aAttr[ GRA_AM_COLOR ] := fColor // Задать цвет маркера GraSetAttrMarker( oPS, aAttr ) // Установить атрибуты GraMarker ( oPS,{ x+dX3, nYSizeAr-Y+dY } ) fColor := GraMakeRGBColor({ 0, 0, aRGB[3] }) aAttr[ GRA_AM_COLOR ] := fColor // Задать цвет маркера GraSetAttrMarker( oPS, aAttr ) // Установить атрибуты GraMarker ( oPS,{ x+dX4, nYSizeAr-Y+dY } ) ENDCASE NEXT NEXT ******* Запись изображения Pos = RAT("\",mFileName) IF Pos > 0 cFileName = ConvToAnsiCP(SUBSTR(mFileName, Pos+1, LEN(mFileName)-Pos)) // Получилось ELSE cFileName = ConvToAnsiCP(ALLTRIM(mFileName)) // Получилось ENDIF IF FILE (cFileName) ERASE(cFileName) ENDIF cFileName = SUBSTR(cFileName,1,LEN(cFileName)-4)+'-RGB_orig.bmp' * WTF oStatic PAUSE // Отладка DC_Scrn2ImageFile( oStatic1, cFileName ) ******* Копирование изображения в папку для выходных изображений Name_SS = Disk_dir +"/"+cFileName Name_DD = M_ApplsPath+"\Out_data\"+cFileName COPY FILE (Name_SS) TO (Name_DD) ERASE(cFileName) IF Pausa=2;MILLISEC(5000);ENDIF ****** Надпись изображения oFont := XbpFont():new():create('18.Arial Bold') GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты mTitle = 'RGB-изображение файла: "'+mFileName+'"' aTxtPar = DC_GraQueryTextbox(mTitle, oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox("Длина текста в пикселях="+ALLTRIM(STR(aTxtPar[1]))+". Высота текста в пикселях="+ALLTRIM(STR(aTxtPar[2]))) *********** Стереть область заголовка GraSetColor( oPS, GRA_CLR_WHITE, GRA_CLR_WHITE ) GraBox( oPS, { 0, Y_Max-aTxtPar[2]-70 }, { 1820, Y_Max }, GRA_FILL ) GraSetColor( oPS, GRA_CLR_BLACK, GRA_CLR_BLACK ) GraStringAt( oPS, { X_Max/2-aTxtPar[2]/2, Y_Max-aTxtPar[2]-15 }, mTitle) mTitle = 'и изображения в лучах Red, Green, Blue с первичными контурами и центром тяжести' aTxtPar = DC_GraQueryTextbox(mTitle, oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox("Длина текста в пикселях="+ALLTRIM(STR(aTxtPar[1]))+". Высота текста в пикселях="+ALLTRIM(STR(aTxtPar[2]))) GraStringAt( oPS, { X_Max/2-aTxtPar[2]/2, Y_Max-aTxtPar[2]-45 }, mTitle) ** Цвета после оконтуривания с исходными контурами, которые использовались для определения координат центра тяжести DO CASE CASE FillColor=1 // Расширить динамический диапазон цветов CASE FillColor=2 // Показывать только контуры ******** Рисование точек контура ********** fColor := GraMakeRGBColor({ 0, 0, 0 }) // Черный aAttr := Array( GRA_AM_COUNT ) // Создать массив атрибутов aAttr[ GRA_AM_COLOR ] := fColor // Задать цвет маркера aAttr[ GRA_AM_SYMBOL ] := GRA_MARKSYM_DOT // Задать стиль маркера GraSetAttrMarker( oPS, aAttr ) // Установить атрибуты FOR j=1 TO LEN(aContXRGB) GraMarker ( oPS,{ aContXRGB[j]+dX1, nYSizeAr-aContYRGB[j]+dY } ) NEXT CASE FillColor=3 // Оставить исходные цвета fColor := GraMakeRGBColor({ 255, 229, 53 }) // Желтый aAttr := Array( GRA_AL_COUNT ) // атрибуты линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := fColor aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraArc( oPS, { Xc+dX1, nYSizeAr-Yc+dY }, 2 ) // Рисует круг стилем линии GraArc( oPS, { Xc+dX1, nYSizeAr-Yc+dY }, 3 ) // Рисует круг стилем линии GraArc( oPS, { Xc+dX1, nYSizeAr-Yc+dY }, 4 ) // Рисует круг стилем линии ******** Рисование точек контура ********** fColor := GraMakeRGBColor({ 255, 229, 53 }) // Желтый aAttr := Array( GRA_AM_COUNT ) // Создать массив атрибутов aAttr[ GRA_AM_COLOR ] := fColor // Задать цвет маркера aAttr[ GRA_AM_SYMBOL ] := GRA_MARKSYM_DOT // Задать стиль маркера GraSetAttrMarker( oPS, aAttr ) // Установить атрибуты FOR j=1 TO LEN(aContXRGB) GraMarker ( oPS,{ aContXRGB[j]+dX1, nYSizeAr-aContYRGB[j]+dY } ) NEXT CASE FillColor=4 // Показывать RGB-цвета и в лучах: Red, Green, Blue fColor := GraMakeRGBColor({ 255, 229, 53 }) // Желтый aAttr := Array( GRA_AL_COUNT ) // атрибуты линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := fColor aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraArc( oPS, { Xc+dX1, nYSizeAr-Yc+dY }, 2 ) // Рисует круг стилем линии GraArc( oPS, { Xc+dX1, nYSizeAr-Yc+dY }, 3 ) // Рисует круг стилем линии GraArc( oPS, { Xc+dX1, nYSizeAr-Yc+dY }, 4 ) // Рисует круг стилем линии ******** Рисование точек контура ********** aAttr := Array( GRA_AM_COUNT ) // Создать массив атрибутов aAttr[ GRA_AM_COLOR ] := fColor // Задать цвет маркера aAttr[ GRA_AM_SYMBOL ] := GRA_MARKSYM_DOT // Задать стиль маркера GraSetAttrMarker( oPS, aAttr ) // Установить атрибуты FOR j=1 TO LEN(aContXRGB) GraMarker ( oPS,{ aContXRGB[j]+dX1, nYSizeAr-aContYRGB[j]+dY } ) NEXT fColor := GraMakeRGBColor({ 0, 255, 255 }) // Дополнительный к Красному aAttr := Array( GRA_AL_COUNT ) // атрибуты линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := fColor aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraArc( oPS, { Xc+dX2, nYSizeAr-Yc+dY }, 2 ) // Рисует круг стилем линии GraArc( oPS, { Xc+dX2, nYSizeAr-Yc+dY }, 3 ) // Рисует круг стилем линии GraArc( oPS, { Xc+dX2, nYSizeAr-Yc+dY }, 4 ) // Рисует круг стилем линии ******** Рисование точек контура ********** aAttr := Array( GRA_AM_COUNT ) // Создать массив атрибутов aAttr[ GRA_AM_COLOR ] := fColor // Задать цвет маркера aAttr[ GRA_AM_SYMBOL ] := GRA_MARKSYM_DOT // Задать стиль маркера GraSetAttrMarker( oPS, aAttr ) // Установить атрибуты FOR j=1 TO LEN(aContXR) GraMarker ( oPS,{ aContXR[j]+dX2, nYSizeAr-aContYR[j]+dY } ) NEXT fColor := GraMakeRGBColor({ 255, 0, 255 }) // Дополнительный к Зеленому aAttr := Array( GRA_AL_COUNT ) // атрибуты линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := fColor aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraArc( oPS, { Xc+dX3, nYSizeAr-Yc+dY }, 2 ) // Рисует круг стилем линии GraArc( oPS, { Xc+dX3, nYSizeAr-Yc+dY }, 3 ) // Рисует круг стилем линии GraArc( oPS, { Xc+dX3, nYSizeAr-Yc+dY }, 4 ) // Рисует круг стилем линии ******** Рисование точек контура ********** aAttr := Array( GRA_AM_COUNT ) // Создать массив атрибутов aAttr[ GRA_AM_COLOR ] := fColor // Задать цвет маркера aAttr[ GRA_AM_SYMBOL ] := GRA_MARKSYM_DOT // Задать стиль маркера GraSetAttrMarker( oPS, aAttr ) // Установить атрибуты FOR j=1 TO LEN(aContXG) GraMarker ( oPS,{ aContXG[j]+dX3, nYSizeAr-aContYG[j]+dY } ) NEXT fColor := GraMakeRGBColor({ 255, 255, 0 }) // Дополнительный к Синему aAttr := Array( GRA_AL_COUNT ) // атрибуты линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := fColor aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraArc( oPS, { Xc+dX4, nYSizeAr-Yc+dY }, 2 ) // Рисует круг стилем линии GraArc( oPS, { Xc+dX4, nYSizeAr-Yc+dY }, 3 ) // Рисует круг стилем линии GraArc( oPS, { Xc+dX4, nYSizeAr-Yc+dY }, 4 ) // Рисует круг стилем линии ******** Рисование точек контура ********** aAttr := Array( GRA_AM_COUNT ) // Создать массив атрибутов aAttr[ GRA_AM_COLOR ] := fColor // Задать цвет маркера aAttr[ GRA_AM_SYMBOL ] := GRA_MARKSYM_DOT // Задать стиль маркера GraSetAttrMarker( oPS, aAttr ) // Установить атрибуты FOR j=1 TO LEN(aContXB) GraMarker ( oPS,{ aContXB[j]+dX4, nYSizeAr-aContYB[j]+dY } ) NEXT ENDCASE ******* Запись изображения Pos = RAT("\",mFileName) IF Pos > 0 cFileName = ConvToAnsiCP(SUBSTR(mFileName, Pos+1, LEN(mFileName)-Pos)) // Получилось ELSE cFileName = ConvToAnsiCP(ALLTRIM(mFileName)) // Получилось ENDIF IF FILE (cFileName) ERASE(cFileName) ENDIF cFileName = SUBSTR(cFileName,1,LEN(cFileName)-4)+'-RGB_cegr.bmp' * WTF oStatic PAUSE // Отладка DC_Scrn2ImageFile( oStatic1, cFileName ) ******* Копирование изображения в папку для выходных изображений Name_SS = Disk_dir +"/"+cFileName Name_DD = M_ApplsPath+"\Out_data\"+cFileName COPY FILE (Name_SS) TO (Name_DD) ERASE(cFileName) IF Pausa=2;MILLISEC(5000);ENDIF ********************************************************************************* ***** Теперь построить контур(ы) с использованием точек только на радиус-векторах ********************************************************************************* ***** Найти min и max длину радиус-вектора от центра тяжести изображения до всех точек массива aPixel oScrn := DC_WaitOn( L('Поиск контуров изображения: "')+mFileName+'"'+' N'+ALLTRIM(STR(RECNO()))+'/'+ALLTRIM(STR(RECCOUNT())),,,,,,,,,,,.F. ) RVmin = +999999 RVmax = -999999 * PRIVATE aRVlen[nXSizeAr,nYSizeAr] // Массив длин радиус-векторов от центра тяжести (Xc,Yc) до точек с координатами (X,Y) * PRIVATE aRVang[nXSizeAr,nYSizeAr] // Массив углов радиус-векторов от центра тяжести (Xc,Yc) до точек с координатами (X,Y) cPixel = aPixel FOR y := 1 TO nYSizeAr FOR x := 1 TO nXSizeAr RVmin = MIN(RVmin, SQRT((Xc-x)^2+(Yc-y)^2)) RVmax = MAX(RVmax, SQRT((Xc-x)^2+(Yc-y)^2)) * aRVlen[x,y] = SQRT((Xc-x)^2+(Yc-y)^2) * aRVang[x,y] = ARCTANG((Yc-y)/(Xc-x)) * GradRad NEXT NEXT *** Рассортировать все точки радиус-вектора по степени их отличия от окружения *** Оставить столько точек, сколько задано контуров *** Рассортировать в порядке убывания расстояния от точки до центра тяжести и определить номера контуров ################################# FOR ug = 0 TO 360 STEP 360/N_GradUg // Цикл по радиус-векторам ****** Для каждой точки радиус-вектора определить степень ее отличия от ближайшего окружения SELECT PointRV;ZAP FOR rv = RVmin TO RVmax // Цикл по точкам радиус-вектора, т.е. по его длине x := ROUND(Xc + rv * COS( ug * GradRad ), 0) y := ROUND(Yc + rv * SIN( ug * GradRad ), 0) IF 2 <= x .AND. x <= nXSizeAr-1 IF 2 <= y .AND. y <= nYSizeAr-1 * Координаты пикселей * *---------------------* * |X-1,Y-1|X,Y-1|X+1,Y-1| * *---------------------* * |X-1,Y |X,Y |X+1,Y | * *---------------------* * |X-1,Y+1|X,Y+1|X+1,Y+1| * *---------------------* * Нумерация пикселей как кнопок на цифровой клавиатуре * *---------------------* * | 7 | 8 | 9 | * *---------------------* * | 4 | 5 | 6 | * *---------------------* * | 1 | 2 | 3 | * *---------------------* mCol = aPixel[x-1, y+1];nColor = AutomationTranslateColor(mCol, .t.);aRGB1 = GraGetRGBIntensity(nColor) // Цвет 1-го пикселя mCol = aPixel[x , y+1];nColor = AutomationTranslateColor(mCol, .t.);aRGB2 = GraGetRGBIntensity(nColor) // Цвет 2-го пикселя mCol = aPixel[x+1, y+1];nColor = AutomationTranslateColor(mCol, .t.);aRGB3 = GraGetRGBIntensity(nColor) // Цвет 3-го пикселя mCol = aPixel[x-1, y ];nColor = AutomationTranslateColor(mCol, .t.);aRGB4 = GraGetRGBIntensity(nColor) // Цвет 4-го пикселя mCol = aPixel[x , y ];nColor = AutomationTranslateColor(mCol, .t.);aRGB5 = GraGetRGBIntensity(nColor) // Цвет 5-го пикселя mCol = aPixel[x+1, y ];nColor = AutomationTranslateColor(mCol, .t.);aRGB6 = GraGetRGBIntensity(nColor) // Цвет 6-го пикселя mCol = aPixel[x-1, y-1];nColor = AutomationTranslateColor(mCol, .t.);aRGB7 = GraGetRGBIntensity(nColor) // Цвет 7-го пикселя mCol = aPixel[x , y-1];nColor = AutomationTranslateColor(mCol, .t.);aRGB8 = GraGetRGBIntensity(nColor) // Цвет 8-го пикселя mCol = aPixel[x+1, y-1];nColor = AutomationTranslateColor(mCol, .t.);aRGB9 = GraGetRGBIntensity(nColor) // Цвет 9-го пикселя ******** Расчет средней яркости окружающих пикселей по трем цветам mColAvrR = (aRGB1[1]+aRGB2[1]+aRGB3[1]+aRGB4[1]+aRGB6[1]+aRGB7[1]+aRGB8[1]+aRGB9[1])/8 mColAvrG = (aRGB1[2]+aRGB2[2]+aRGB3[2]+aRGB4[2]+aRGB6[2]+aRGB7[2]+aRGB8[2]+aRGB9[2])/8 mColAvrB = (aRGB1[3]+aRGB2[3]+aRGB3[3]+aRGB4[3]+aRGB6[3]+aRGB7[3]+aRGB8[3]+aRGB9[3])/8 ****** Яркости цветов R,G,B центрального пикселя (5-го) mCol5R = aRGB5[1] mCol5G = aRGB5[2] mCol5B = aRGB5[3] * MsgBox(STR(i)+STR(j)+STR(mCol5R)+STR(mCol5G)+STR(mCol5B)) ****** Данные о точке * mFlagR = IF(ABS(mCol5R - mColAvrR) > (MaxRed -MinRed )/N_intervR, .T., .F.) * mFlagG = IF(ABS(mCol5G - mColAvrG) > (MaxGreen-MinGreen)/N_intervG, .T., .F.) * mFlagB = IF(ABS(mCol5B - mColAvrB) > (MaxBlue -MinBlue )/N_intervB, .T., .F.) mFlagR = IF(ABS(mCol5R - mColAvrR) > 255/N_intervR, .T., .F.) mFlagG = IF(ABS(mCol5G - mColAvrG) > 255/N_intervG, .T., .F.) mFlagB = IF(ABS(mCol5B - mColAvrB) > 255/N_intervB, .T., .F.) ****** Запомнить данные об этом пикселе в БД PointRV dR = ABS(mCol5R - mColAvrR) dG = ABS(mCol5G - mColAvrG) dB = ABS(mCol5B - mColAvrB) *aStructure := { { "pImage", "C", 254, 0 },; // Полное наименование файла изображения (не используется) * { "pRVang", "N", 3, 0 },; // Угол поворота радиуса-вектора в полярной системе координат в градусах * { "pRVlen", "N", 19, 7 },; // Расстояние от центра тяжести до данной точки * { "pX" , "N", 19, 7 },; // Координаты X,Y, точки радиус-вектора * { "pY" , "N", 19, 7 },; // Координаты X,Y, точки радиус-вектора * { "pNCont", "N", 15, 0 },; // Номер контура, на котором находится точка * { "pRed" , "N", 19, 7 },; // Степень отличия точки от ближайшего окружения в красном луче * { "pGreen", "N", 19, 7 },; // Степень отличия точки от ближайшего окружения в зеленом луче * { "pBlue" , "N", 19, 7 },; // Степень отличия точки от ближайшего окружения в синем луче * { "pRGB" , "N", 19, 7 },; // Сумарная степень отличия точки от ближайшего окружения во всех лучах * { "pRGBst", "N", 19, 7 },; // Стандартизированная сумарная степень отличия точки от ближайшего окружения во всех лучах * { "pRVlst", "N", 19, 7 },; // Стандартизированное расстояние от центра тяжести до данной точки * { "pIntKr", "N", 19, 7 } } // Интегральный критерий значимости точки: сумма отличий от фона по трем цветам + расстояние от центра тяжести *DbCreate( 'PointRV', aStructure ) IF dR+dG+dB > 0 APPEND BLANK REPLACE pRVang WITH ug REPLACE pRVlen WITH rv REPLACE pX WITH x REPLACE pY WITH y REPLACE pRed WITH dR REPLACE pGreen WITH dG REPLACE pBlue WITH dB REPLACE pRGB WITH dR+dG+dB fColor := GraMakeRGBColor({ 0, 0, 0 }) // Черный ELSE fColor := GraMakeRGBColor({ 230,231,232 }) // Серый ENDIF aAttr := Array( GRA_AM_COUNT ) // Создать массив атрибутов aAttr[ GRA_AM_COLOR ] := fColor // Задать цвет маркера aAttr[ GRA_AM_SYMBOL ] := GRA_MARKSYM_DOT // Задать стиль маркера GraSetAttrMarker( oPS, aAttr ) // Установить атрибуты GraMarker ( oPS,{ x+dX1, nYSizeAr-Y+dY } ) * MsgBox(STR(x)+STR(y)+STR(dr)+STR(dg)+STR(db)) ENDIF ENDIF NEXT SELECT PointRV ****** Стандартизировать pRGB и pRVlen pRGBmin = +9999999 pRGBmax = -9999999 pRVlenMin = +9999999 pRVlenMax = -9999999 DBGOTOP() DO WHILE .NOT. EOF() pRGBmin = MIN(pRGBmin, pRGB) pRGBmax = MAX(pRGBmax, pRGB) pRVlenMin = MIN(pRVlenMin, pRVlen) pRVlenMax = MAX(pRVlenMax, pRVlen) DBSKIP(1) ENDDO *aStructure := { { "pImage", "C", 254, 0 },; // Полное наименование файла изображения * { "pRVang", "N", 3, 0 },; // Угол поворота радиуса-вектора в полярной системе координат в градусах * { "pRVlen", "N", 19, 7 },; // Расстояние от центра тяжести до данной точки * { "pX" , "N", 19, 7 },; // Координаты X,Y, точки радиус-вектора * { "pY" , "N", 19, 7 },; // Координаты X,Y, точки радиус-вектора * { "pNCont", "N", 15, 0 },; // Номер контура, на котором находится точка * { "pRed" , "N", 19, 7 },; // Степень отличия точки от ближайшего окружения в красном луче * { "pGreen", "N", 19, 7 },; // Степень отличия точки от ближайшего окружения в зеленом луче * { "pBlue" , "N", 19, 7 },; // Степень отличия точки от ближайшего окружения в синем луче * { "pRGB" , "N", 19, 7 },; // Сумарная степень отличия точки от ближайшего окружения во всех лучах * { "pRGBst", "N", 19, 7 },; // Стандартизированная сумарная степень отличия точки от ближайшего окружения во всех лучах * { "pRVlst", "N", 19, 7 },; // Стандартизированное расстояние от центра тяжести до данной точки * { "pIntKr", "N", 19, 7 } } // Интегральный критерий значимости точки: сумма отличий от фона по трем цветам + расстояние от центра тяжести *DbCreate( 'PointRVs', aStructure ) ******************************************************************************************* ***** НО ТАК, ЧТОБЫ ОНИ БЫЛИ БЛИЖАЙШИЕ К ПРЕДЫДУЩИМ ####################################### ***** Это должно позволить уменьшить изрезанность контура ***** ДЛЯ ЭТОГО СДЕЛАТЬ ИНТЕГРАЛЬНЫЙ КРИТЕРИЙ, УЧИТЫВАЮЩИЙ: ***** - СТЕПЕНЬ ОТЛИЧИЯ ОТ ФОНА; (УЖЕ ЕСТЬ) ***** - РАССТОЯНИЕ ОТ ЦЕНТРА ТЯЖЕСТИ; (УЖЕ ЕСТЬ) ***** - РАССТОЯНИЕ ОТ ПРЕДЫДУЩЕЙ ТОЧКИ (СДЕЛАТЬ) ############################# ******************************************************************************************* // Относительный вес частных критериев в % ############################# * a = 25 // Учет степени отличия от окружения * b = 40 // Учет расстояния от центра тяжести * c = 35 // Учет расстояния от предыдущей точки контура SELECT PointRV DBGOTOP() mX = pX mY = pY DO WHILE .NOT. EOF() mRGBst = (pRGB -pRGBmin )/(pRGBmax -pRGBmin ) mRVlst = (pRVlen-pRVlenMin)/(pRVlenMax-pRVlenMin) REPLACE pRGBst WITH mRGBst REPLACE pRVlst WITH mRVlst REPLACE pIntKr WITH Priv_crit_a*mRGBst + Priv_crit_b*mRVlst - Priv_crit_c*SQRT((mX-pX)^2+(mY-pY)^2) DBSKIP(1) mX = pX mY = pY ENDDO *########################################################################################## * ************************************************************* * ***** Оставить самые дальние точки из самых значимых * ***** сначала сортируя точки по степени отличия от окружения, * ***** а потом по расстоянию от центра тяжести * ************************************************************* * * ***** Рассортировать все точки радиус-вектора по степени их отличия от ближайшего окружения * * SELECT PointRV * ** INDEX ON STR(999.9999999-pRGB ,19,7) TO PointRV1 //################## * INDEX ON STR(999.9999999-pIntKr,19,7) TO PointRV1 //################## * mNumCont = 0 * * DBGOTOP() ** DO WHILE .NOT. EOF() .AND. mNumCont < IF(N_Cont<10,10,N_Cont) // Всегда брать не менее 10 наиболее ценных точек, даже если задано меньше контуров * DO WHILE .NOT. EOF() .AND. mNumCont < 10 // Всегда брать не менее 10 наиболее ценных точек, даже если задано меньше контуров * REPLACE pNCont WITH ++mNumCont * DBSKIP(1) * ENDDO * * ****** Оставить столько точек, сколько задано контуров * ** DELETE FOR pNCont < IF(N_Cont<10,10,N_Cont) * DELETE FOR pNCont = 0 * PACK * * MsgBox('STOP-1') * * *** Рассортировать в порядке убывания расстояния от точки до центра тяжести и определить номера контуров ##################### * * INDEX ON STR(999.9999999-pRVlen,19,7) TO PointRV2 //#################### ** INDEX ON STR(999.9999999-pIntKr,19,7) TO PointRV2 //#################### * * mNumCont = 0 * * DBGOTOP() * DO WHILE .NOT. EOF() .AND. mNumCont < N_Cont * REPLACE pNCont WITH ++mNumCont * DBSKIP(1) * ENDDO * * MsgBox('STOP-2') *########################################################################################## * **************************************************** * ***** Оставить самые дальние точки из самых значимых * ***** сортируя точки по интегральному критерию, * ***** учитывающему и степень отличия от окружения, * ***** и расстояние от центра тяжести * **************************************************** INDEX ON STR(999.9999999-pIntKr,19,7) TO PointRV1 //################## ***** Рассортировать все точки радиус-вектора по убыванию интегрального критерия SELECT PointRV INDEX ON STR(999.9999999-pIntKr,19,7) TO PointRV1 //################## mNumCont = 0 DBGOTOP() * DO WHILE .NOT. EOF() .AND. mNumCont < IF(N_Cont<10,10,N_Cont) // Всегда брать не менее 10 наиболее ценных точек, даже если задано меньше контуров DO WHILE .NOT. EOF() .AND. mNumCont < 10 // Всегда брать не менее 10 наиболее ценных точек, даже если задано меньше контуров REPLACE pNCont WITH ++mNumCont DBSKIP(1) ENDDO ****** Оставить столько точек, сколько задано контуров * DELETE FOR pNCont < IF(N_Cont<10,10,N_Cont) DELETE FOR pNCont = 0 PACK * MsgBox('STOP-1') mNumCont = 0 DBGOTOP() DO WHILE .NOT. EOF() .AND. mNumCont < N_Cont REPLACE pNCont WITH ++mNumCont DBSKIP(1) ENDDO * MsgBox('STOP-2') *########################################################################################## ****** Занести информацию о найденных точках контуров изображения текущего радиус-вектора в БД PointRVs.dbf ****** Может быть надо сначала сбросить эту БД? SELECT PointRV DBGOTOP() DO WHILE .NOT. EOF() aR := {} FOR j=1 TO FCOUNT() AADD(aR, FIELDGET(j)) NEXT SELECT PointRVs APPEND BLANK FOR j=1 TO LEN(aR) FIELDPUT(j, aR[j]) NEXT REPLACE pImage WITH mFileName SELECT PointRV DBSKIP(1) ENDDO NEXT ****** Перерисовать центр тяжести на RGB-изображении fColor := GraMakeRGBColor({ 255, 229, 53 }) // Желтый aAttr := Array( GRA_AL_COUNT ) // атрибуты линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := fColor aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraArc( oPS, { Xc+dX1, nYSizeAr-Yc+dY }, 2 ) // Рисует круг стилем линии GraArc( oPS, { Xc+dX1, nYSizeAr-Yc+dY }, 3 ) // Рисует круг стилем линии GraArc( oPS, { Xc+dX1, nYSizeAr-Yc+dY }, 4 ) // Рисует круг стилем линии DC_Impl(oScrn) * MsgBox('STOP-3') IF Pausa=2;MILLISEC(5000);ENDIF ENDIF // Если изображение с найденным центром тяжести SELECT Image DBSKIP(1) ENDDO ************************************************************************************************************** ****** Сформировать внешний контур: выбрать из всех контуров наиболее удаленный и его считать внешним контуром ############### ************************************************************************************************************** ****** Определение максимальной длины полного наименования изображения SELECT PointRVs DBGOTOP() mLenImage = -9999999 DO WHILE .NOT. EOF() mLenImage = MAX(mLenImage, LEN(ALLTRIM(PIMAGE))) DBSKIP(1) ENDDO ****** Рассортировать в порядке убывания расстояния от точки до центра тяжести ################### ****** для каждого файла и угла оставить только первое значение SELECT PointRVs INDEX ON SUBSTR(PIMAGE,1,mLenImage)+STR(pRVang,4) TO PointRVs1 UNIQUE //################### DBGOTOP() DO WHILE .NOT. EOF() cFileName = SUBSTR(pImage, RAT("\",pImage)+1, LEN(pImage)-RAT("\",pImage)) // Получилось aR := {} FOR j=1 TO FCOUNT() AADD(aR, FIELDGET(j)) NEXT SELECT OutCont APPEND BLANK FOR j=1 TO LEN(aR) FIELDPUT(j, aR[j]) NEXT REPLACE pImage WITH cFileName SELECT PointRVs DBSKIP(1) ENDDO SELECT OutCont INDEX ON SUBSTR(PIMAGE,1,mLenImage)+STR(pRVang,4) TO OutCont //################### DBGOTOP() DO WHILE .NOT. EOF() aR := {} FOR j=1 TO FCOUNT() AADD(aR, FIELDGET(j)) NEXT SELECT PointRVs APPEND BLANK FOR j=1 TO LEN(aR) FIELDPUT(j, aR[j]) NEXT SELECT OutCont DBSKIP(1) ENDDO *#################################################### ***************************************************** ******* Отображение внешнего контура всех изображений ***************************************************** ******* Изображать оригинал в центре левой половины окна, ****** а внешний контур в центре правой половины на сетке из заданных радиус-векторов (как с символами) ClearImageTr() SELECT OutCont INDEX ON SUBSTR(PIMAGE,1,mLenImage) TO OutCont DBGOTOP() mIMAGE = SUBSTR(PIMAGE,1,mLenImage) mX = pX mY = pY ************ X_Max = 1800 Y_Max = 850 SELECT Image DBGOTOP() DO WHILE .NOT. EOF() ********* Загрузка данных о рисунке из БД 'Image.dbf' mFileName = ALLTRIM(IMAGE->Short_name) aPixel := Bin2Var(IMAGE->array) // Загрузка массива из БД Image nXSizeAr = Len(aPixel) // Размер изображения по X nYSizeAr = Len(aPixel[1]) // Размер изображения по Y Xc = Xcentr // Координаты центра тяжести изображения Yc = Ycentr IF Xc + Yc > 0 ***** Расчет позиций для двух равных по X полей изображений шириной nXSizeAr ***** и трех равных промежутков между ними d и слева и справа от изображений до края окна d = (X_Max-2*nXSizeAr)/3 // Расстояние между правым и левым изображениями и слева и справа до края окна dY = (Y_Max-1*nYSizeAr)/2 - 30 // Расстояние по Y до края поля изображения 1-го и 2-го контуров dX1 = d // Расстояние по X до края поля изображения 1-го контура dX2 = 2*d+1*nXSizeAr // Расстояние по X до края поля изображения 2-го контура ***** Отобразить назание экранной формы ****** Надпись изображения oFont := XbpFont():new():create('22.Arial Bold') GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты mTitle = 'Внешний контур изображения: "'+mFileName+'"' aTxtPar = DC_GraQueryTextbox(mTitle, oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox("Длина текста в пикселях="+ALLTRIM(STR(aTxtPar[1]))+". Высота текста в пикселях="+ALLTRIM(STR(aTxtPar[2]))) GraStringAt( oPS, { X_Max/2-aTxtPar[2]/2, Y_Max-aTxtPar[2]-10 }, mTitle) ***** Отображение оригинала ******************* aAttr := Array( GRA_AM_COUNT ) // Создать массив атрибутов * aAttr[ GRA_AM_COLOR ] := fColor // Задать цвет маркера aAttr[ GRA_AM_SYMBOL ] := GRA_MARKSYM_DOT // Задать стиль маркера GraSetAttrMarker( oPS, aAttr ) // Установить атрибуты FOR y := 1 TO nYSizeAr FOR x := 1 TO nXSizeAr nColor = AutomationTranslateColor(aPixel[x,y], .t.) aRGB = GraGetRGBIntensity(nColor) // Взаимнообратные операции преобразования формы кодирования цвета в массиве RGB и одним числом fColor := GraMakeRGBColor({ aRGB[1], aRGB[2], aRGB[3] }) aAttr[ GRA_AM_COLOR ] := fColor // Задать цвет маркера GraSetAttrMarker( oPS, aAttr ) // Установить атрибуты GraMarker ( oPS,{ x+dX1, nYSizeAr-Y+dY } ) NEXT NEXT ***** Отображение внешнего контура ************ ***** Рисование координатной сетки oFont := XbpFont():new():create('8.Arial') GraSetFont(oPS , oFont) // Установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := aColor[146] aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_SOLID // Тип линии aAttr [ GRA_AL_COLOR ] := aColor[146] // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты RVmin = +999999 RVmax = -999999 FOR y := 1 TO nYSizeAr FOR x := 1 TO nXSizeAr RVmin = MIN(RVmin, SQRT((Xc-x)^2+(Yc-y)^2)) RVmax = MAX(RVmax, SQRT((Xc-x)^2+(Yc-y)^2)) NEXT NEXT FOR ug = 0 TO 360 STEP 360/N_GradUg // Цикл по радиус-векторам FOR rv = RVmin TO RVmax // Цикл по точкам радиус-вектора, т.е. по его длине x := ROUND(Xc + rv * COS( ug * GradRad ), 0) y := ROUND(Yc + rv * SIN( ug * GradRad ), 0) fColor := GraMakeRGBColor({ 230,231,232 }) // Серый aAttr := Array( GRA_AM_COUNT ) // Создать массив атрибутов aAttr[ GRA_AM_COLOR ] := fColor // Задать цвет маркера aAttr[ GRA_AM_SYMBOL ] := GRA_MARKSYM_DOT // Задать стиль маркера GraSetAttrMarker( oPS, aAttr ) // Установить атрибуты * GraMarker ( oPS,{ X+dX1+Xc-nXSizeAr/2, nYSizeAr-Y+dY } ) GraMarker ( oPS,{ X+dX2+Xc-nXSizeAr/2, nYSizeAr-Y+dY } ) NEXT x := ROUND(Xc + (RVmax+10) * COS( ug * GradRad ), 0) y := ROUND(Yc + (RVmax+10) * SIN( ug * GradRad ), 0) * GraStringAt( oPS, { X+dX1+Xc-nXSizeAr/2, nYSizeAr-Y+dY }, ALLTRIM(STR(ug,3))) // Надписи углов на радиус-векторах координатной сетки GraStringAt( oPS, { X+dX2+Xc-nXSizeAr/2, nYSizeAr-Y+dY }, ALLTRIM(STR(ug,3))) NEXT aAttr := ARRAY( GRA_AM_COUNT ) // Массив для атрибутов маркеров aAttr[ GRA_AM_SYMBOL ] := GRA_MARKSYM_DOT aAttr[ GRA_AM_COLOR ] := fColor // Задать цвет маркера GraSetAttrMarker( oPS, aAttr ) FOR rv=0 TO RVmax STEP RVmax/5 FOR ug=0 TO 360 STEP 0.5 X := Xc + rv * COS( ug * GradRad ) Y := Yc + rv * SIN( ug * GradRad ) GraMarker( oPS, { X+dX2+Xc-nXSizeAr/2, nYSizeAr-Y+dY } ) // Нарисовать точку координатной окружности NEXT GraStringAt( oPS, { X+dX2+Xc-nXSizeAr/2, nYSizeAr-Y+dY }, ALLTRIM(STR(rv,3))) NEXT SELECT OutCont SET ORDER TO 1 T=DBSEEK(mFileName) IF T mX = pX mY = pY DO WHILE .NOT. EOF() .AND. PIMAGE = mFileName ***** Нарисовать линии контуров ******************* aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 2 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты GraLine( oPS, { mX+dX1, nYSizeAr-mY+dY }, { pX+dX1, nYSizeAr-pY+dY } ) // Нарисовать отрезок контура на оригинале GraLine( oPS, { mX+dX2, nYSizeAr-mY+dY }, { pX+dX2, nYSizeAr-pY+dY } ) // Нарисовать отрезок контура на контуре fColor := GraMakeRGBColor({ 255, 0, 0 }) // Красный aAttr := Array( GRA_AL_COUNT ) // атрибуты линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := fColor aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraArc( oPS, { pX+dX1, nYSizeAr-pY+dY }, 2 ) // Рисует круг стилем линии на оригинале GraArc( oPS, { pX+dX2, nYSizeAr-pY+dY }, 2 ) // Рисует круг стилем линии на контуре mX = pX mY = pY DBSKIP(1) ENDDO ****** Перерисовать центр тяжести на RGB-изображении fColor := GraMakeRGBColor({ 255, 0, 0 }) // Красный aAttr := Array( GRA_AL_COUNT ) // атрибуты линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := fColor aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) GraArc( oPS, { Xc+dX1, nYSizeAr-Yc+dY }, 2 ) // Рисует круг стилем линии GraArc( oPS, { Xc+dX1, nYSizeAr-Yc+dY }, 3 ) // Рисует круг стилем линии GraArc( oPS, { Xc+dX1, nYSizeAr-Yc+dY }, 4 ) // Рисует круг стилем линии GraArc( oPS, { Xc+dX2, nYSizeAr-Yc+dY }, 2 ) // Рисует круг стилем линии GraArc( oPS, { Xc+dX2, nYSizeAr-Yc+dY }, 3 ) // Рисует круг стилем линии GraArc( oPS, { Xc+dX2, nYSizeAr-Yc+dY }, 4 ) // Рисует круг стилем линии ******* Запись изображения Pos = RAT("\",mFileName) IF Pos > 0 cFileName = ConvToAnsiCP(SUBSTR(mFileName, Pos+1, LEN(mFileName)-Pos)) // Получилось cFileName = SUBSTR(cFileName,1,LEN(cFileName))+'-Cont1.bmp' ELSE cFileName = ConvToAnsiCP(ALLTRIM(mFileName)) // Получилось cFileName = SUBSTR(cFileName,1,LEN(cFileName)-4)+'-Cont1.bmp' ENDIF IF FILE (cFileName) ERASE(cFileName) ENDIF * WTF oStatic PAUSE // Отладка DC_Scrn2ImageFile( oStatic1, cFileName ) ******* Копирование изображения в папку для выходных изображений Name_SS = Disk_dir +"/"+cFileName Name_DD = M_ApplsPath+"\Out_data\"+cFileName COPY FILE (Name_SS) TO (Name_DD) ERASE(cFileName) IF Pausa=2;MILLISEC(5000);ENDIF ClearImageTr() ENDIF ENDIF // Изображение с найденным центром тяжести SELECT Image DBSKIP(1) ENDDO ****** Записать текстовый файл ErrorImage.txt ****** с именами файлов, для которых не удалось найти центры тяжести CrLf = CHR(13)+CHR(10) // Конец строки (записи) mErrorImage = 'Файлы изображений, для которых не удалось найти центры тяжести' + CrLf + CrLf SELECT Image DBGOTOP() nErrorImage = 0 DO WHILE .NOT. EOF() IF Xcentr + Ycentr = 0 mErrorImage = mErrorImage + ALLTRIM(STR(++nErrorImage)) + ' ' + ALLTRIM(Image_name) + CrLf ENDIF DBSKIP(1) ENDDO IF nErrorImage = 0 StrFile('Ошибок нет. Все файлы успешно обработаны', "ErrorImage.txt") // Запись текстового файла "ErrorImage.txt" ELSE StrFile(mErrorImage, "ErrorImage.txt") // Запись текстового файла "ErrorImage.txt" ENDIF ClearImageTr() ****************************************************************************************** ************** Сформировать БД Inp_data.dbf на основе OutCont.dbf ************************ ****************************************************************************************** ***** Определить максимальную длину наименования объекта обучающей выборки, ***** максимальную длину наименования класса и количество углов (описательных шкал) ***** для формирования БД Inp_data.dbf ***** Не записывать в БД Inp_data.dbf данные по изображениям, по которым не удалось выявить контуры CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE OutCont EXCLUSIVE NEW;N_rec = RECCOUNT() USE Image VIA 'FOXCDX' EXCLUSIVE NEW;N_Image = RECCOUNT() aRVang := {} SELECT OutCont DBGOTOP() DO WHILE .NOT. EOF() IF ASCAN(aRVang, pRVang) = 0 AADD (aRVang, pRVang) ENDIF DBSKIP(1) ENDDO ASORT(aRVang) mLenImage = -9999999 mLenClass = -9999999 SELECT Image DBGOTOP() DO WHILE .NOT. EOF() IF Xcentr + Ycentr > 0 mLenImage = MAX(mLenImage, LEN(ALLTRIM(Image_name))) ********** Сформировать имя класса: ********** 1. Убрать расширение ********** 2. Узнать, есть ли в имени файла черточка "-" ********** 3. Если есть, то имя класса - это часть имени файла до черточки ********** 4. Если нет, то имя класса - это все имя файла без расширения ********** 1. Убрать расширение mShortName = ALLTRIM(Short_name) mShortName = SUBSTR(mShortName,1,LEN(mShortName)-4) Pos = AT('-',mShortName) // 2. Узнать, есть ли в имени файла черточка "-" IF Pos > 0 mShortName = SUBSTR(mShortName,1,Pos-1) // 3. Если есть, то имя класса - это часть имени файла до черточки ENDIF // 4. Если нет, то имя класса - это все имя файла mLenClass = MAX(mLenClass, LEN(ALLTRIM(mShortName))) ENDIF // Изображение с найденным центром тяжести DBSKIP(1) ENDDO aStructure := { { "Object", "C", mLenImage, 0},; { "Class" , "C", mLenClass, 0} } FOR j=1 TO LEN(aRVang) * AADD(aStructure, { 'A'+ALLTRIM(STR(aRVang[j])), "N", 19, 7 }) AADD(aStructure, { STRTRAN(STR(aRVang[j],3),' ','0'), "N", 19, 7 }) NEXT DO CASE CASE Regim = 1 // Формализации предм.области, генерация обуч.выборки, синтез и верификация модели DbCreate( 'Inp_data.dbf', aStructure ) * MsgBox('STOP-1') CASE Regim = 2 // Генерация распознавамой выборки и идентификация (классификация) изображений DbCreate( 'Inp_rasp.dbf', aStructure ) ENDCASE ************************************************************************ ***** Формирование БД Inp_data.dbf ************************************* ************************************************************************ CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE OutCont EXCLUSIVE NEW INDEX ON pImage TO OutCont CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE OutCont INDEX OutCont EXCLUSIVE NEW USE Inp_data EXCLUSIVE NEW USE Image VIA 'FOXCDX' EXCLUSIVE NEW;N_Image = RECCOUNT() SELECT Image DBGOTOP() DO WHILE !IMAGE->(Eof()) IF Xcentr + Ycentr > 0 ********* Загрузка данных о рисунке из БД 'Image.dbf' mImageName = ALLTRIM(IMAGE->Image_name) mShortName = ALLTRIM(IMAGE->Short_name) ********** Сформировать имя класса: ********** 1. Убрать расширение, если оно есть ********** 2. Узнать, есть ли в имени файла черточка "-" ********** 3. Если есть, то имя класса - это часть имени файла до черточки ********** 4. Если нет, то имя класса - это все имя файла ********** 1. Убрать расширение (без расширения поиск не работает) <<<===#################################### mShortName = ALLTRIM(Short_name) Pos = AT('-',mShortName) // 2. Узнать, есть ли в имени файла черточка "-" IF Pos = 0 // 3. Если черточки нет, то имя класса - это часть имени до точки Pos = AT('.',mShortName) ENDIF mClsName = SUBSTR(mShortName,1,Pos-1) // 3. Если есть, то имя класса - это часть имени файла до черточки DO CASE CASE Regim = 1 // Формализации предм.области, генерация обуч.выборки, синтез и верификация модели SELECT Inp_data CASE Regim = 2 // Генерация распознавамой выборки и идентификация (классификация) изображений SELECT Inp_rasp ENDCASE APPEND BLANK REPLACE Object WITH mImageName REPLACE Class WITH mClsName SELECT OutCont SET ORDER TO 1 T=DBSEEK(mShortName) IF T DO WHILE .NOT. EOF() .AND. PIMAGE = mShortName mRVang = pRVang mRVlen = pRVlen SELECT Inp_data * Pos = FIELDPOS('A'+ALLTRIM(STR(mRVang))) Pos = FIELDPOS(STRTRAN(STR(mRVang,3),' ','0')) IF Pos > 0 FIELDPUT(Pos, mRVlen) ENDIF SELECT OutCont DBSKIP(1) ENDDO ENDIF ENDIF // Изображение с найденным центром тяжести SELECT Image DBSKIP(1) ENDDO *** <<<===###################### *CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций *MsgBox('STOP-1') *QUIT ******** Удалить в БД Inp_data.dbf строки по изображениям, по которым не удалось выявить контуры mFlagDel = .F. SELECT Inp_data DBGOTOP() DO WHILE .NOT. EOF() s = 0 FOR j=3 TO FCOUNT() s = s + FIELDGET(j) NEXT IF s = 0 FIELDPUT(1, 'DELETE') mFlagDel = .T. ENDIF DBSKIP(1) ENDDO IF mFlagDel DELETE FOR FIELDGET(1) = 'DELETE' PACK ENDIF ***** Создать файл параметров для интерфейса 2.3.2.2. ***** Записать новые файлы: Inp_name.txt и Inp_nameALL.txt для БД Inp_data.dbf CrLf = CHR(13)+CHR(10) // Конец строки (записи) String = "Object" + CrLf +; "Class" + CrLf FOR j=1 TO LEN(aRVang) * String = String + 'A'+ALLTRIM(STR(aRVang[j])) + CrLf String = String + STRTRAN(STR(aRVang[j],3),' ','0')+'°' + CrLf NEXT StrFile(String, "Inp_nameAll.txt") // Запись текстового файла "Inp_nameAll.txt" String = "Class" + CrLf FOR j=1 TO LEN(aRVang) * String = String + 'A'+ALLTRIM(STR(aRVang[j])) + CrLf String = String + STRTRAN(STR(aRVang[j],3),' ','0')+'°' + CrLf NEXT StrFile(String, "Inp_name.txt") // Запись текстового файла "Inp_name.txt" *********** сформировать файл параметров режима 2.3.2.2() // Сохранить файл с информацией о заданых параметрах программного интерфейса в текущей директории системы // и в папке приложения, чтобы можно было потом узнать при каких параметрах оно создано * Regim = 1 // Формализации ПО или ген.расп.выб. (значение присвоено в диалоге) Flag_zer = 1 // Считать нули и пробелы отсутствием данных? [1]-да, [2]-нет N_Chast = 1 // На сколько частей N разбивать обучающую или распознаваемую выборку (в зависимости от Regim) M_ClSc1 = 2 // Номер начального столбца диапазона классификационных шкал M_ClSc2 = 2 // Номер конечного столбца диапазона классификационных шкал M_OpSc1 = 3 // Номер начального столбца диапазона описательных шкал M_OpSc2 = LEN(aRVang)+2 // Номер конечного столбца диапазона описательных шкал M_ObAnk = 3 // Создавать анкеты исходной выборки по строкам Inp_data-[1], по классам-[2], и 1-е, и 2-е [3] M_Interval = 1 // 1-равные интервалы, 2-адаптивные интервалы (с примерно равным количеством наблюдений, по Котельникову) N_SKGrCl = 10 N_SKGrPr = 10 K_N_ClSc = 1 K_N_OpSc = 1 K_N_GrClSc = 10 K_N_GrOpSc = 10 M_Scenario = .F. mGorizMin = 5 mGorizMax = 5 mGlubMin = 5 mGlubMax = 5 K_GradNClSc = 10 K_GradNOpSc = 10 M_ChastObi = .F. M_ChastRso = .F. N_ChastObi = 1 N_ChastRso = 1 M_XlsDbf = 3 mTxtCSField = 1 // Способ интерпретации значений текстовых полей - классификационных шкал файла исходных данных mTxtOSField = 1 // Способ интерпретации значений текстовых полей - описательных шкал файла исходных данных mTxtCSSep = " " // Разделитель элементов классификационных шкал, если mTxtCSField=3 mTxtOSSep = " " // Разделитель элементов описательных шкал, если mTxtOSField=3 * mScenario = 1 // mScenario=1 Не применять сценарный метод АСК-анализа и спец.интерпретацию TXT-полей (старый вариант) mScenario = 1 // Не применять сценарный метод АСК-анализа mSpecInterprCls = .F. // Не применять спец.интерпретацию текстовых полей классов mSpecInterprAtr = .F. // Не применять спец.интерпретацию текстовых полей признаков mNameGrNumSc= 1 // Какие наименования ГРАДАЦИЙ числовых шкал использовать mClsAvr = .F. // .F. - делать модель из Inp_data, .T. - делать модель из Inp_data_avr mSortUnqCls = 1 // Выделять уникальные значения классов и сортировать, 1-да, 2-нет mLemmatCls = 2 // Проводить лемматизацию классов, 1-да, 2-нет mSortUnqGos = 1 // Выделять уникальные значения признаков и сортировать, 1-да, 2-нет mLemmatGos = 2 // Проводить лемматизацию признаков, 1-да, 2-нет // Сохранить файл с информацией о заданых параметрах программного интерфейса в текущей директории системы PRIVATE aSoftInt[40] aSoftInt[ 1] = Regim aSoftInt[ 2] = Flag_zer aSoftInt[ 3] = M_ClSc1 aSoftInt[ 4] = M_ClSc2 aSoftInt[ 5] = M_OpSc1 aSoftInt[ 6] = M_OpSc2 aSoftInt[ 7] = N_SKGrCl aSoftInt[ 8] = N_SKGrPr aSoftInt[ 9] = K_N_ClSc aSoftInt[10] = K_N_OpSc aSoftInt[11] = K_N_GrClSc aSoftInt[12] = K_N_GrOpSc aSoftInt[13] = M_ObAnk aSoftInt[14] = N_Chast aSoftInt[15] = M_Interval // 1-равные интервалы, 2-адаптивные интервалы (с примерно равным количеством наблюдений, по Котельникову) aSoftInt[16] = M_Scenario aSoftInt[17] = K_GradNClSc // Количество градаций в числовой классификационной шкале aSoftInt[18] = K_GradNOpSc // Количество градаций в числовой описательной шкале aSoftInt[19] = mGorizMin aSoftInt[20] = mGorizMax aSoftInt[21] = mGlubMin aSoftInt[22] = mGlubMax aSoftInt[23] = M_ChastObi aSoftInt[24] = M_ChastRso aSoftInt[25] = N_ChastObi aSoftInt[26] = N_ChastRso aSoftInt[27] = M_XlsDbf aSoftInt[28] = mTxtCSField aSoftInt[29] = mTxtOSField aSoftInt[30] = mTxtCSSep aSoftInt[31] = mTxtOSSep * aSoftInt[32] = mScenario // mScenario=1 Не применять сценарный метод АСК-анализа и спец.интерпретацию TXT-полей (старый вариант) aSoftInt[32] = mScenario // mScenario=1 Не применять сценарный метод АСК-анализа aSoftInt[33] = mSpecInterprCls // .T. - Применить спец.интерпретацию текстовых полей классов, .F. - не применять aSoftInt[34] = mSpecInterprAtr // .T. - Применить спец.интерпретацию текстовых полей признаков, .F. - не применять aSoftInt[35] = mNameGrNumSc // Какие наименования ГРАДАЦИЙ числовых шкал использовать aSoftInt[36] = mClsAvr // .F. = модель без усреднения по классам aSoftInt[37] = mSortUnqCls // Выделять уникальные значения классов и сортировать, 1-да, 2-нет aSoftInt[38] = IF(mSpecInterprCls,mLemmatCls,2) // Проводить лемматизацию классов, 1-да, 2-нет aSoftInt[39] = mSortUnqGos // Выделять уникальные значения признаков и сортировать, 1-да, 2-нет aSoftInt[40] = IF(mSpecInterprAtr,mLemmatGos,2) // Проводить лемматизацию признаков, 1-да, 2-нет DC_ASave(aSoftInt , Disk_dir +"\_2_3_2_2.arx") * DC_ASave(aSoftInt , M_NewAppl+"\_2_3_2_2.arx") ******* Копирование Inp_data.dbf и Inp_name.txt в папку Inp_data CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DO CASE CASE Regim = 1 // Формализации предм.области, генерация обуч.выборки, синтез и верификация модели Name_SS = 'Inp_data.dbf' Name_DD = M_ApplsPath+"\Inp_data\Inp_data.dbf" COPY FILE (Name_SS) TO (Name_DD) ERASE('Inp_data.dbf') CASE Regim = 2 // Генерация распознавамой выборки и идентификация (классификация) изображений Name_SS = 'Inp_rasp.dbf' Name_DD = M_ApplsPath+"\Inp_data\Inp_rasp.dbf" COPY FILE (Name_SS) TO (Name_DD) ERASE('Inp_rasp.dbf') ENDCASE Name_SS = 'Inp_nameAll.txt' Name_DD = M_ApplsPath+"\Inp_data\Inp_nameAll.txt" COPY FILE (Name_SS) TO (Name_DD) ERASE('Inp_nameAll.txt') Name_SS = 'Inp_name.txt' Name_DD = M_ApplsPath+"\Inp_data\Inp_name.txt" COPY FILE (Name_SS) TO (Name_DD) ERASE('Inp_name.txt') aMess := {} DO CASE CASE Regim = 1 // Формализации предм.области, генерация обуч.выборки, синтез и верификация модели AADD(aMess, L('Преобразование изображений в файл исходных данных: "Inp_data.dbf" завершено успешно!')) IF nErrorImage > 0 AADD(aMess, L(' ')) AADD(aMess, L('В процессе работы были обнаружены некорректные изображения. Информация о них в файле: ')+Disk_dir+'\ErrorImage.txt') ENDIF IF mFlagDel AADD(aMess, L(' ')) AADD(aMess, L('Не по всем изображениям удалось сформировать контуры. Строк по ним нет в БД: ')+Disk_dir+'\Inp_data.dbf') ENDIF AADD(aMess, L(' ')) AADD(aMess, L('Для создания модели надо выполнить режимы 2.3.2.2 и 3.5 с параметрами по умолчанию')) LB_Warning(aMess, L('4.8. Геокогнитивная подсистема "Эйдос"' )) F2_3_2_2("","") F3_5('CPU') CASE Regim = 2 // Генерация распознавамой выборки и идентификация (классификация) изображений AADD(aMess, L('Преобразование изображений в файл распознаваемой выборки: "Inp_rasp.dbf" завершено успешно!')) IF nErrorImage > 0 AADD(aMess, L(' ')) AADD(aMess, L('В процессе работы были обнаружены некорректные изображения. Информация о них в файле: ')+Disk_dir+'\ErrorImage.txt') ENDIF IF mFlagDel AADD(aMess, L(' ')) AADD(aMess, L('Не по всем изображениям удалось сформировать контуры. Строк по ним нет в БД: ')+Disk_dir+'\Inp_data.dbf') ENDIF AADD(aMess, L(' ')) AADD(aMess, L('Для применения модели надо выполнить режимы 2.3.2.2 и 4.1.2 с параметрами по умолчанию')) LB_Warning(aMess, L('4.8. Геокогнитивная подсистема "Эйдос"' )) F2_3_2_2("","") F4_1_2(0,.T.,"4_1_2",'CPU') ENDCASE ****************************************************************************************** ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL *------------------------------------ ************************************************** ******** Цветовое зонирование изображения ******** ************************************************** ******** Заменить оригинальные цвета всех пикселей ******** интервальными значениями цветов ************************************************** FUNCTION ColorZone(hDC1,aPixel) LOCAL GetList[0], GetOptions, oSay, oDialog, oProgress, oScrn LOCAL i, j, nXSize := Len(aPixel), nYSize := Len(aPixel[1]) LOCAL hMemoryDC := CreateMemoryDC( hDC1, nXSize, nYSize ) // Для ускорения работы GetPixel() примерно в 50 раз LOCAL Xc, Yc, Nc LOCAL oBitmap ******* Узнать разрешение экрана и не показывать изображений большой размерности **************** nWidth := AppDeskTop():currentSize()[1] // current screen size width in pixels nHeight := AppDeskTop():currentSize()[2] // current screen size height in pixels * nWidth = 1366 // <<<===########################## * nHeight = 768 * F4_8('L('4.7. АСК-анализ изображений по пикселям, спектрам и контурам')') // Если F4_8() запускается не из главного меню, а из F4_7(), то может работать на любом экране * IF mTitle = L('4.8. Геокогнитивная подсистема') // 4.8. Геокогнитивная подсистема работает только на экранах с разрешением 1920 x 1080 и более IF nWidth < 1800 aMess := {} AADD(aMess, L("Для правильного отображения графической формы")) AADD(aMess, L("необходимо разрешение экрана 1800 pix по горизонтали,")) AADD(aMess, L("а фактически установлено: ")+ALLTRIM(STR(nWidth))+" pix") LB_Warning(aMess ) Running(.F.) ReTURN NIL ENDIF IF nHeight < 850 aMess := {} AADD(aMess, L("Для правильного отображения графической формы")) AADD(aMess, L("необходимо разрешение экрана 850 pix по вертикали,")) AADD(aMess, L("а фактически установлено: ")+ALLTRIM(STR(nHeight))+" pix") LB_Warning(aMess ) Running(.F.) ReTURN NIL ENDIF * ENDIF ************************************************************************************************* ****************************************************************** *** Изображения для цветового зонирования брать из папкки Inp_data ****************************************************************** PUBLIC AllColor := 1 // 1 - Одинаковое для всех цветов, 2 - Для каждого цвета свое PUBLIC N_interv := 8 // Число яркостных интервалов всех цветов PUBLIC N_intervR := 8 // Число яркостных интервалов красного цвета PUBLIC N_intervG := 8 // Число яркостных интервалов зеленого цвета PUBLIC N_intervB := 8 // Число яркостных интервалов синего цвета @ 0, 0 DCGROUP oGroup1 CAPTION L('Задайте число цветовых зон:' ) SIZE 67.0, 7.0 @1.5, 2 DCRADIO AllColor VALUE 1 PROMPT L('Одинаковое для всех цветов:') PARENT oGroup1 @2.5, 2 DCRADIO AllColor VALUE 2 PROMPT L('Для каждого цвета RGB свое:') PARENT oGroup1 @0.8,40 DCGROUP oGroup2 CAPTION L('Число цветовых зон:') SIZE 25, 2.5 PARENT oGroup1 HIDE {||.NOT.AllColor=1} @1 , 1 DCSAY L('RGB: ') GET N_interv PICTURE "##########" PARENT oGroup2 EDITPROTECT {||.NOT.AllColor=1} HIDE {||.NOT.AllColor=1} @1.8,40 DCGROUP oGroup2 CAPTION L('Число цветовых зон:') SIZE 25, 4.5 PARENT oGroup1 HIDE {||.NOT.AllColor=2} @1 , 1 DCSAY L('Red: ') GET N_intervR PICTURE "##########" PARENT oGroup2 EDITPROTECT {||.NOT.AllColor=2} HIDE {||.NOT.AllColor=2} @2 , 1 DCSAY L('Green: ') GET N_intervG PICTURE "##########" PARENT oGroup2 EDITPROTECT {||.NOT.AllColor=2} HIDE {||.NOT.AllColor=2} @3 , 1 DCSAY L('Blue: ') GET N_intervB PICTURE "##########" PARENT oGroup2 EDITPROTECT {||.NOT.AllColor=2} HIDE {||.NOT.AllColor=2} Pausa = 1 mMess = L('Делать ли паузу после вывода изображений?') @7.5, 0 DCGROUP oGroup3 CAPTION mMess SIZE 67.0, 3.5 @1 , 2 DCRADIO Pausa VALUE 1 PROMPT L('Нет') PARENT oGroup3 @2 , 2 DCRADIO Pausa VALUE 2 PROMPT L('Да' ) PARENT oGroup3 @1 ,40 DCPUSHBUTTON CAPTION L('Пояснения по режиму') SIZE 25, 1.8 ACTION {||Help48()} PARENT oGroup3 DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; OPTIONS GetOptions ; ADDBUTTONS; MODAL ; TITLE L('4.8. Геокогнитивная подсистема "Эйдос". Цветовые зоны') ******************************************************************** IF lExit ** Button Ok ELSE RETURN NIL ENDIF ******************************************************************** IF AllColor = 1 // 1 - Одинаковое для всех цветов, 2 - Для каждого цвета свое N_intervR = N_interv // Число яркостных интервалов красного цвета N_intervG = N_interv // Число яркостных интервалов зеленого цвета N_intervB = N_interv // Число яркостных интервалов синего цвета ENDIF IF N_intervR < 2 .OR. N_intervG < 2 .OR. N_intervB < 2 LB_Warning(L('Число цветовых зон должно быть больше 1'),L('4.8. Геокогнитивная подсистема "Эйдос"')) RETURN NIL ENDIF ************************************************************************** *** ИСПОЛНЕНИЕ ************************************************************************** ClearImageTr() *** Определение путей на файлы изображений символов *** Сформировать массив наименований папок и в каждой из них массив полных имен графических файлов cWorkPath = M_ApplsPath+"\Inp_data\" aAll := DIRECTORY( cWorkPath + "*.*", 'D' ) // Почему-то в массив попадает информация не только по директориям IF LEN(aAll) = 0 Mess = L(" В папке: "+cWorkPath+" нет файлов!") LB_Warning(Mess, L("2.3.2.5: Ввод изображений с учетом цвета пикселей")) RETURN nil ENDIF * DC_DebugQout( aAll ) aDir := {} FOR j = 1 TO LEN(aAll) IF aAll[j, 5] = "D" IF aAll[j, 5] <> '.' IF aAll[j, 5] <> '..' AADD(aDir, aAll[j, 1]) ENDIF ENDIF ENDIF NEXT * DC_DebugQout( aDIR ) aFileName := {} // Массив полных имен файлов изображений aFileNmSh := {} // Массив коротких имен файлов изображений IF LEN(aDIR) = 0 Mess = L(" В папке: "+cWorkPath+" нет поддиректорий!") LB_Warning(Mess, L("2.3.2.5: Ввод изображений с учетом цвета пикселей")) RETURN nil ENDIF FOR j = 1 TO LEN(aDIR) aFNbmp = DIRECTORY( cWorkPath + aDIR[j] + "\*.bmp" ) IF LEN(aFNbmp) > 0 FOR f = 1 TO LEN(aFNbmp) AADD(aFileName, cWorkPath + aDIR[j] + "\" + aFNbmp[f,1] ) AADD(aFileNmSh, aFNbmp[f,1] ) NEXT ENDIF aFNjpg = DIRECTORY( cWorkPath + aDIR[j] + "\*.jpg" ) IF LEN(aFNjpg) > 0 FOR f = 1 TO LEN(aFNjpg) AADD(aFileName, cWorkPath + aDIR[j] + "\" + aFNjpg[f,1] ) AADD(aFileNmSh, aFNjpg[f,1] ) NEXT ENDIF NEXT * DC_DebugQout( aFileName ) * DC_DebugQout( aFileNmSh ) IF LEN(aFileName) = 0 Mess = L(" В поддиректориях папки: "+cWorkPath+" нет bmp и jpg графических файлов!") LB_Warning(Mess, L("2.3.2.5: Ввод изображений с учетом цвета пикселей")) RETURN nil ENDIF *** Если БД "Image.dbf" нет, то создать ее IF .NOT. FILE("Image.dbf") GenDBFImage(.F.) ENDIF * Записать массив полных имен файлов изображений, а потом считать и использовать его DC_ASave(aFileName, "_FileName.arx") * DC_DebugQout( aFileNmSh ) * aFileName := DC_ARestore("_FileName.arx") * DC_DebugQout( aFileNmSh ) DC_ASave(aFileNmSh, "_FileNmSh.arx") * aFileNmSh := DC_ARestore("_FileNmSh.arx") * DC_DebugQout( aFileNmSh ) * MsgBox('STOP') ***************************************************************************************************** ** БЕЛЫЙ ЦВЕТ ПИКСЕЛЕЙ ИГНОРИРОВАТЬ, СЧИТАТЬ НЕ ЗНАЧИМЫМ (ФОНОМ), Т.Е. ЗНАЧИМЫЕ ТОЧКИ НЕ БЕЛОГО ЦВЕТА ***************************************************************************************************** ** Имя графического файла для рисования - источника исходных данных DO CASE CASE FILE('Delone.bmp') mFileName = 'Delone.bmp' CASE FILE('Delone.jpg') mFileName = 'Delone.jpg' // Нежелательно, т.к. изображение размыто OTHERWISE LB_Warning(L('В текущей папке системы: ')+Disk_dir+L(' должен быть файл: "Delone.bmp" или "Delone.jpg"'),L('4.8. Геокогнитивная подсистема "Эйдос"' )) RETURN nil ENDCASE ******************************************************************************** GenDBFImage(.F.) // 1. Пересоздать (стереть) БД для изображений: "Image.Dbf" ******************************************************************************** CreateImages() // 2. Оцифровать изображения и записать их в БД "Image.Dbf" ******************************************************************************** nWidthMax = VAL(FileStr('_WidthMax.txt')) nHeightMax = VAL(FileStr('_HeightMax.txt')) ***** Определение максимального размера изображения oScrn := DC_WaitOn( L('Определение максимального размера изображения' ),,,,,,,,,,,.F.) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Image VIA 'FOXCDX' EXCLUSIVE NEW nFNLen = -999999999 nXSize = -999999999 nYSize = -999999999 aFileNmSh := {} DO WHILE !IMAGE->(Eof()) aPixel := Bin2Var(IMAGE->array) // Загрузка массива из БД Image AADD(aFileNmSh, FIELDGET(2)) // Для формирования имен классов. Вместо записи и считывания массива использовать БД nXSize = MAX(nXSize, Len(aPixel)) nYSize = MAX(nYSize, Len(aPixel[1])) nFNLen = MAX(nFNLen, LEN(ALLTRIM(IMAGE->image_name))) IMAGE->(dbSkip()) ENDDO DC_Impl(oScrn) StrFile(STR(nXSize,9)+' '+STR(nYSize,9), '_XYSize.txt') // Запись текстового файла с параметрами nXSize, nYSize *nXSize = VAL(SUBSTR(FileStr('_XYSize.txt'), 1,9)) // Загрузка параметра nXSize из текстового файла *nYSize = VAL(SUBSTR(FileStr('_XYSize.txt'),11,9)) // Загрузка параметра nYSize из текстового файла IF nXSize > 400 LB_Warning(L('Желательно, чтобы размеры изображений по X были не больше 400 pix !!!'),L('4.8. Геокогнитивная подсистема "Эйдос"' )) ENDIF IF nYSize > 350 LB_Warning(L('Желательно, чтобы размеры изображений по Y были не больше 350 pix !!!'),L('4.8. Геокогнитивная подсистема "Эйдос"' )) ENDIF ****************************** DIRCHANGE("AID_DATA") // Перейти в папку со всеми БД: AID_DATA IF FILEDATE("Out_data",16) = CTOD("//") DIRMAKE("Out_data") ELSE ZapDir ("Out_data", .T.) DIRMAKE("Out_data") ENDIF DIRCHANGE(Disk_dir) // Перейти в папку с системой Эйдос ********** Создать БД ColorZone.dbf ************* aStructure := { { "Image_name", "C", nFNLen, 0 },; // Полное имя файла { "pX" , "N", 15, 7 },; { "pY" , "N", 15, 7 },; { "pRedMin" , "N", 15, 7 },; { "pRed" , "N", 3, 0 },; { "pRedMax" , "N", 15, 7 },; { "pGreenMin" , "N", 15, 7 },; { "pGreen" , "N", 3, 0 },; { "pGreenMax" , "N", 15, 7 },; { "pBlueMin" , "N", 15, 7 },; { "pBlue" , "N", 3, 0 },; { "pBlueMax" , "N", 15, 7 } } DbCreate( "ColorZone.dbf", aStructure ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE ColorZone EXCLUSIVE NEW USE Image VIA 'FOXCDX' EXCLUSIVE NEW N_Image = RECCOUNT() X_Max = 1800 Y_Max = 850 SELECT Image DBGOTOP() DO WHILE .NOT. EOF() ClearImageTr() mFileName = ALLTRIM(IMAGE->image_name) * oScrn := DC_WaitOn( L('Цветовое зонирование файла: "'+mFileName+'"'+' N'+ALLTRIM(STR(RECNO()))+'/'+ALLTRIM(STR(RECCOUNT())),,,,,,,,,,,.F.) aPixel := Bin2Var(IMAGE->array) // Загрузка массива из БД Image nXSizeAr = Len(aPixel) nYSizeAr = Len(aPixel[1]) *********************************************************************************** **** Нарисовать оригинальные RGB-изображение и изображения в лучах Red, Green, Blue *********************************************************************************** ClearImageTr() ***** Расчет позиций для четырех равных по X полей изображений шириной nXSizeAr ***** расчет позиций для двух равных по Y полей изображений шириной nYSizeAr ***** и пяти равных промежутков между ними d и слева и справа от изображений до края окна X_Max = 1800 // Размеры окна изображения Y_Max = 850 dx = (X_Max-4*nXSizeAr)/5 // Расстояние между полями изображений и слева и справа до края окна dy = (Y_Max-2*nYSizeAr)/3 // Расстояние между полями изображений и слева и справа до края окна dX1 = 1*dx+0*nXSizeAr // Расстояние по X до края поля 1-го изображения dX2 = 2*dx+1*nXSizeAr // Расстояние по X до края поля 2-го изображения dX3 = 3*dx+2*nXSizeAr // Расстояние по X до края поля 3-го изображения dX4 = 4*dx+3*nXSizeAr // Расстояние по X до края поля 4-го изображения dY1 = Y_Max-1*dy-0*nYSizeAr - 30 // Расстояние по Y до края поля 1-го изображения dY2 = Y_Max-2*dy-1*nYSizeAr - 30 // Расстояние по Y до края поля 2-го изображения ******************************* ****** Надпись изображения ********************* oFont := XbpFont():new():create('18.Arial Bold') GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты mTitle = 'Файл изображения: "'+mFileName+'"'+' N'+ALLTRIM(STR(RECNO()))+'/'+ALLTRIM(STR(RECCOUNT())) aTxtPar = DC_GraQueryTextbox(mTitle, oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox("Длина текста в пикселях="+ALLTRIM(STR(aTxtPar[1]))+". Высота текста в пикселях="+ALLTRIM(STR(aTxtPar[2]))) GraStringAt( oPS, { X_Max/2, Y_Max-aTxtPar[2]-15 }, mTitle) mTitle = 'Оригинальные RGB-изображение и изображения в лучах Red, Green, Blue' aTxtPar = DC_GraQueryTextbox(mTitle, oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox("Длина текста в пикселях="+ALLTRIM(STR(aTxtPar[1]))+". Высота текста в пикселях="+ALLTRIM(STR(aTxtPar[2]))) GraStringAt( oPS, { X_Max/2, dY1+dy/4 }, mTitle) mTitle = 'Зонированные RGB-изображение и изображения в лучах Red, Green, Blue. Количество цветовых зон: Red='+ALLTRIM(STR(N_intervR))+', Green='+ALLTRIM(STR(N_intervG))+', Blue='+ALLTRIM(STR(N_intervB)) aTxtPar = DC_GraQueryTextbox(mTitle, oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox("Длина текста в пикселях="+ALLTRIM(STR(aTxtPar[1]))+". Высота текста в пикселях="+ALLTRIM(STR(aTxtPar[2]))) GraStringAt( oPS, { X_Max/2, dY2+dy/4 }, mTitle) ************************************************ aAttr := Array( GRA_AM_COUNT ) // Создать массив атрибутов aAttr[ GRA_AM_SYMBOL ] := GRA_MARKSYM_DOT // Задать стиль маркера GraSetAttrMarker( oPS, aAttr ) // Установить атрибуты FOR y := 1 TO nYSizeAr FOR x := 1 TO nXSizeAr nColor = AutomationTranslateColor(aPixel[x,y], .t.) aRGB = GraGetRGBIntensity(nColor) ***** Все цвета aAttr[ GRA_AM_COLOR ] := GraMakeRGBColor({ aRGB[1], aRGB[2], aRGB[3] }) // Задать цвет маркера GraSetAttrMarker( oPS, aAttr ) // Установить атрибуты GraMarker ( oPS, { dX1+x, dY1-y } ) ***** Red ***** aAttr[ GRA_AM_COLOR ] := GraMakeRGBColor({ aRGB[1],0,0 }) // Задать цвет маркера GraSetAttrMarker( oPS, aAttr ) // Установить атрибуты GraMarker ( oPS, { dX2+x, dY1-y } ) ***** Green *** aAttr[ GRA_AM_COLOR ] := GraMakeRGBColor({ 0,aRGB[2],0 }) // Задать цвет маркера GraSetAttrMarker( oPS, aAttr ) // Установить атрибуты GraMarker ( oPS, { dX3+x, dY1-y } ) ***** Blue **** aAttr[ GRA_AL_COLOR ] := GraMakeRGBColor({ 0,0,aRGB[3] }) // Задать цвет маркера GraSetAttrMarker( oPS, aAttr ) // Установить атрибуты GraMarker ( oPS, { dX4+x, dY1-y } ) NEXT NEXT *********************************************************************************** **** Нарисовать зонированные RGB-изображение и изображения в лучах Red, Green, Blue *********************************************************************************** *** Определить минимальные (не равные нулю) и максимальные яркости лучей MinRed = +999999 MaxRed = -999999 MinGreen = +999999 MaxGreen = -999999 MinBlue = +999999 MaxBlue = -999999 FOR y := 1 TO nYSizeAr FOR x := 1 TO nXSizeAr nColor = AutomationTranslateColor(aPixel[x,y], .t.) aRGB = GraGetRGBIntensity(nColor) // Взаимнообратные операции преобразования формы кодирования цвета в массиве RGB и одним числом MinRed = MIN(MinRed , aRGB[1]) MaxRed = MAX(MaxRed , aRGB[1]) MinGreen = MIN(MinGreen, aRGB[2]) MaxGreen = MAX(MaxGreen, aRGB[2]) MinBlue = MIN(MinBlue , aRGB[3]) MaxBlue = MAX(MaxBlue , aRGB[3]) NEXT NEXT * MsgBox(STR(MinRed) +STR(MaxRed)) * MsgBox(STR(MinGreen)+STR(MaxGreen)) * MsgBox(STR(MinBlue) +STR(MaxBlue)) * MinRed = 0 * MaxRed = 255 * MinGreen = 0 * MaxGreen = 255 * MinBlue = 0 * MaxBlue = 255 ******* Расчет массивов начальных и конечных значений цветовых зон (интервалов) для разных цветов aMinRed := {} // Массив минимальных значений цветовых интервалов красного цвета aMaxRed := {} // Массив максимальных значений цветовых интервалов красного цвета aMinGreen := {} // Массив минимальных значений цветовых интервалов зеленого цвета aMaxGreen := {} // Массив максимальных значений цветовых интервалов зеленого цвета aMinBlue := {} // Массив минимальных значений цветовых интервалов синего цвета aMaxBlue := {} // Массив максимальных значений цветовых интервалов синего цвета dR = ( MaxRed - MinRed ) / N_intervR // Размер цветового интервала красного цвета dG = ( MaxGreen - MinGreen ) / N_intervG // Размер цветового интервала зеленого цвета dB = ( MaxBlue - MinBlue ) / N_intervB // Размер цветового интервала синего цвета FOR j=1 TO N_intervR AADD(aMinRed , MinRed + (j-1)*dR ) AADD(aMaxRed , MinRed + j *dR ) NEXT FOR j=1 TO N_intervG AADD(aMinGreen, MinGreen + (j-1)*dG ) AADD(aMaxGreen, MinGreen + j *dG ) NEXT FOR j=1 TO N_intervB AADD(aMinBlue , MinBlue + (j-1)*dB ) AADD(aMaxBlue , MinBlue + j *dB ) NEXT * DC_ArrayView( aMinRed ) * DC_ArrayView( aMaxRed ) * DC_ArrayView( aMinGreen ) * DC_ArrayView( aMaxGreen ) * DC_ArrayView( aMinBlue ) * DC_ArrayView( aMaxBlue ) *** Замена оригинальных цветов пикселей средними значениями цветов цветовых зон, в которые они попадают FOR y := 1 TO nYSizeAr FOR x := 1 TO nXSizeAr ******************************************************************************************************* * Взаимнообратные операции преобразования формы кодирования цвета в массиве RGB и одним числом * nColor = AutomationTranslateColor(aPixel1[x,y], .t.) * IF GraIsRGBColor(nColor) // Это цвет? * aRGB = GraGetRGBIntensity(nColor) * nColorPix = GraMakeRGBColor(aRGB) * MsgBox(STR(nColor)+STR(nColorPix)) // nColor === nColorPix * aPixel2[x,y] = AutomationTranslateColor(nColorPix,.f.) // aPixel2[x,y] === aPixel1[x,y] ? * ENDIF ******************************************************************************************************* nColor = AutomationTranslateColor(aPixel[x,y], .t.) aRGB = GraGetRGBIntensity(nColor) // Взаимнообратные операции преобразования формы кодирования цвета в массиве RGB и одним числом mColorPixR = aRGB[1] mColorPixG = aRGB[2] mColorPixB = aRGB[3] mFlagR = .F. FOR j=1 TO N_intervR IF aMinRed[j] <= aRGB[1] .AND. aRGB[1] <= aMaxRed[j] mColorPixR = ROUND(aMinRed[j] + ( aMaxRed[j] - aMinRed[j] ) / 2,0) // Среднее значение цвета j-й цветовой зоны красного цвета mMinRed = aMinRed[j] mMaxRed = aMaxRed[j] mFlagR = .T. EXIT ENDIF NEXT mFlagG = .F. FOR j=1 TO N_intervG IF aMinGreen[j] <= aRGB[2] .AND. aRGB[2] <= aMaxGreen[j] mColorPixG = ROUND(aMinGreen[j] + ( aMaxGreen[j] - aMinGreen[j] ) / 2,0) // Среднее значение цвета j-й цветовой зоны зеленого цвета mMinGreen = aMinGreen[j] mMaxGreen = aMaxGreen[j] mFlagG = .T. EXIT ENDIF NEXT mFlagB = .F. FOR j=1 TO N_intervB IF aMinBlue[j] <= aRGB[3] .AND. aRGB[3] <= aMaxBlue[j] mColorPixB = ROUND(aMinBlue[j] + ( aMaxBlue[j] - aMinBlue[j] ) / 2,0) // Среднее значение цвета j-й цветовой зоны синего цвета mMinBlue = aMinBlue[j] mMaxBlue = aMaxBlue[j] mFlagB = .T. EXIT ENDIF NEXT * MsgBox('Исходные цвета: '+STR(aRGB[1],3) +STR(aRGB[2],3) +STR(aRGB[3],3)) * MsgBox('Зонированные цвета: '+STR(mColorPixR,3)+STR(mColorPixG,3)+STR(mColorPixB,3)) * mColorPixR = aRGB[1] * mColorPixG = aRGB[2] * mColorPixB = aRGB[3] **** Записать данные об изображении IF mFlagR .AND. mFlagG .AND. mFlagB ***** Все цвета aAttr[ GRA_AM_COLOR ] := GraMakeRGBColor({ mColorPixR, mColorPixG, mColorPixB }) // Задать цвет маркера GraSetAttrMarker( oPS, aAttr ) // Установить атрибуты GraMarker ( oPS, { dX1+x, dY2-y } ) ***** Red ***** aAttr[ GRA_AM_COLOR ] := GraMakeRGBColor({ mColorPixR,0,0 }) // Задать цвет маркера GraSetAttrMarker( oPS, aAttr ) // Установить атрибуты GraMarker ( oPS, { dX2+x, dY2-y } ) ***** Green *** aAttr[ GRA_AM_COLOR ] := GraMakeRGBColor({ 0,mColorPixG,0 }) // Задать цвет маркера GraSetAttrMarker( oPS, aAttr ) // Установить атрибуты GraMarker ( oPS, { dX3+x, dY2-y } ) ***** Blue **** aAttr[ GRA_AM_COLOR ] := GraMakeRGBColor({ 0,0,mColorPixB }) // Задать цвет маркера GraSetAttrMarker( oPS, aAttr ) // Установить атрибуты GraMarker ( oPS, { dX4+x, dY2-y } ) * ********** Создать БД ColorZone.dbf ************** * aStructure := { { "Image_name", "C", nFNLen, 0 },; // Полное имя файла * { "pX" , "N", 15, 7 },; * { "pY" , "N", 15, 7 },; * { "pRedMin" , "N", 15, 7 },; * { "pRed" , "N", 3, 0 },; * { "pRedMax" , "N", 15, 7 },; * { "pGreenMin" , "N", 15, 7 },; * { "pGreen" , "N", 3, 0 },; * { "pGreenMax" , "N", 15, 7 },; * { "pBlueMin" , "N", 15, 7 },; * { "pBlue" , "N", 3, 0 },; * { "pBlueMax" , "N", 15, 7 } } * DbCreate( "ColorZone.dbf", aStructure ) SELECT ColorZone APPEND BLANK REPLACE Image_name WITH mFileName REPLACE pX WITH x REPLACE pY WITH y REPLACE pRedMin WITH mMinRed REPLACE pRed WITH mColorPixR REPLACE pRedMax WITH mMaxRed REPLACE pGreenMin WITH mMinGreen REPLACE pGreen WITH mColorPixG REPLACE pGreenMax WITH mMaxGreen REPLACE pBlueMin WITH mMinBlue REPLACE pBlue WITH mColorPixB REPLACE pBlueMax WITH mMaxBlue ENDIF NEXT NEXT * DC_Impl(oScrn) ******* Запись изображения Pos = RAT("\",mFileName) IF Pos > 0 cFileName = ConvToAnsiCP(SUBSTR(mFileName, Pos+1, LEN(mFileName)-Pos)) // Получилось ELSE cFileName = ConvToAnsiCP(ALLTRIM(mFileName)) // Получилось ENDIF IF FILE (cFileName) ERASE(cFileName) ENDIF cFileName = SUBSTR(cFileName,1,LEN(cFileName)-4)+'-RGB_ColZone.bmp' * WTF oStatic PAUSE // Отладка DC_Scrn2ImageFile( oStatic1, cFileName ) ******* Копирование изображения в папку для выходных изображений Name_SS = Disk_dir +"/"+cFileName Name_DD = M_ApplsPath+"\Out_data\"+cFileName COPY FILE (Name_SS) TO (Name_DD) ERASE(cFileName) IF Pausa=2;MILLISEC(5000);ENDIF SELECT Image DBSKIP(1) ENDDO RETURN NIL *------------------------------------ ******************************************************************************** ******** Формируется отчет о распределении объектов обучающей выборки по классам ******************************************************************************** FUNCTION F2_3_3_4() Running(.T.) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF ApplChange("2.3.3.4()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF IF .NOT. FILE('ObI_Kcl.dbf') aMess := {} AADD(aMess, L('В папке приложения: ')+M_PathAppl+L(' нет файла: "ObI_Kcl.dbf"')) AADD(aMess, L('Необходимо сформировать обучающую выборку в режиме 2.2()')) LB_Warning(aMess, L('2.3.3.4. Распределение объектов обуч. выборки по классам' )) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF aStructure := { { "Kod_cls" , "N", 15, 0 }, ; { "Kod_obj" , "N", 15, 0 } } DbCreate( 'Cls_Obj', aStructure ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Obi_Zag EXCLUSIVE NEW USE ObI_Kcl EXCLUSIVE NEW USE Cls_Obj EXCLUSIVE NEW ************* Определить максимальную длину кода класса *** mMaxLenKodObj = -99999 SELECT Obi_Zag DBGOTOP() DO WHILE .NOT. EOF() mMaxLenKodObj = MAX(mMaxLenKodObj, LEN(ALLTRIM(STR(Kod_obj,15)))) DBSKIP(1) ENDDO SELECT ObI_Kcl nMax = RECCOUNT() Mess = L('2.3.3.4. Распределение объектов обучающей выборки по классам') @ 4,5 DCPROGRESS oProgress SIZE 70,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 DCREAD GUI TITLE Mess PARENT @oDialog FIT EXIT oDialog:show() nTime = 0 DC_GetProgress(oProgress,0,nMax) ***** Сформировать базу ******* DBGOTOP() DO WHILE .NOT. EOF() mKodObj = Kod_Obj aKodCls := {} FOR j=2 TO FCOUNT() mKodCls = FIELDGET(j) IF mKodCls > 0 AADD(aKodCls, mKodCls) ENDIF NEXT SELECT Cls_Obj FOR j=1 TO LEN(aKodCls) APPEND BLANK REPLACE Kod_cls WITH aKodCls[j] REPLACE Kod_obj WITH mKodObj NEXT DC_GetProgress(oProgress, ++nTime, nMax) SELECT ObI_Kcl DBSKIP(1) ENDDO *MsgBox('STOP') DC_GetProgress(oProgress,nMax,nMax) oDialog:Destroy() ***** Сформировать отчет ******* oScrn := DC_WaitOn( L('Печать отчета о распр.объектов обуч.выборки по классам: ')+M_PathAppl+'Cls_Obj.txt',,,,,,,,,,,.F. ) set device to printer set printer on set printer to ("Cls_Obj.txt") set console off CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Cls_Obj EXCLUSIVE NEW INDEX ON STR(Kod_cls,15)+STR(Kod_obj,15) TO Cls_Obj Ln = 65 ?"ОТЧЕТ О РАСПРЕДЕЛЕНИИ ОБЪЕКТОВ ОБУЧАЮЩЕЙ ВЫБОРКИ ПО КЛАССАМ" CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW USE Cls_Obj INDEX Cls_Obj EXCLUSIVE NEW ********** Определение числа объектов на класс aKodCls := {} aNameCls := {} aNObjCls := {} // Число объектов обуч.выборки на класс SELECT Classes DBGOTOP() DO WHILE .NOT. EOF() AADD(aKodCls , Kod_cls ) AADD(aNameCls, DelZeroNameGr(Name_cls)) AADD(aNObjCls, 0 ) DBSKIP(1) ENDDO SELECT Cls_Obj mVsegoObj = 0 FOR j=1 TO LEN(aKodCls) SET FILTER TO aKodCls[j]=Kod_cls COUNT TO aNObjCls[j] mVsegoObj = mVsegoObj + aNObjCls[j] NEXT ********************************************** SELECT Cls_Obj SET FILTER TO SET ORDER TO 1 DBGOTOP() mKodCls = Kod_cls aKodObj := {} ?REPLICATE("=",Ln) ?"Класс: "+ALLTRIM(STR(mKodCls))+", "+DelZeroNameGr(aNameCls[mKodCls]) ?"Число объектов обучающей выборки в классе="+ALLTRIM(STR(aNObjCls[mKodCls])) ?REPLICATE("~",Ln) DO WHILE .NOT. EOF() IF mKodCls = Kod_cls AADD(aKodObj, Kod_obj) ELSE ******* Печать ****** ASORT(aKodObj) mStr = '' FOR j=1 TO LEN(aKodObj) IF LEN( mStr + STR(aKodObj[j],mMaxLenKodObj)) <= Ln mStr = mStr + STR(aKodObj[j],mMaxLenKodObj)+ ' ' ELSE ?mStr mStr = STR(aKodObj[j],mMaxLenKodObj)+' ' ENDIF NEXT ?mStr ?REPLICATE("=",Ln) mKodCls = Kod_cls aKodObj := {} AADD(aKodObj, Kod_obj) ?"Класс: "+ALLTRIM(STR(mKodCls))+", "+DelZeroNameGr(aNameCls[mKodCls]) ?"Число объектов обучающей выборки в классе="+ALLTRIM(STR(aNObjCls[mKodCls])) ?REPLICATE("~",Ln) ENDIF SELECT Cls_Obj SET ORDER TO 1 DBSKIP(1) ENDDO ******* Печать ****** ASORT(aKodObj) mStr = '' FOR j=1 TO LEN(aKodObj) IF LEN( mStr + STR(aKodObj[j],mMaxLenKodObj)) <= Ln mStr = mStr + STR(aKodObj[j],mMaxLenKodObj)+ ' ' ELSE ?mStr mStr = STR(aKodObj[j],mMaxLenKodObj)+' ' ENDIF NEXT ?mStr ?REPLICATE("=",Ln) ?"Всего логических объектов обучающей выборки во всех классах: "+ALLTRIM(STR(mVsegoObj)) ?REPLICATE("=",Ln) DC_Impl(oScrn) Set device to screen Set printer off Set printer to Set console on CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций aMess := {} AADD(aMess, L('Печать отчета о распределении объектов обучающей выборки по классам:')) AADD(aMess, M_PathAppl+'Cls_Obj.txt') AADD(aMess, L('успешно завершена!')) LB_Warning(aMess, L('2.3.3.4. Распределение объектов обуч. выборки по классам' )) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ************************************************************************************************************ ******** 2.3.3.5. Объединение объектов обуч.выборки с одинаковыми классами ******** Формирование новой обучающей выборки, в которой объединены признаки объектов с одинаковыми классами ************************************************************************************************************ FUNCTION F2_3_3_5() Running(.T.) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF ApplChange("2.3.3.5()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF IF .NOT. FILE('ObI_Kcl.dbf') aMess := {} AADD(aMess, L('В папке приложения: ')+M_PathAppl+L(' нет файла: "ObI_Kcl.dbf"')) AADD(aMess, L('Необходимо сформировать обучающую выборку в режиме 2.2()')) LB_Warning(aMess, L('2.3.3.5. Объединение объектов обуч.выборки с одинаковыми классами' )) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ****** Определение максимальной длины наименования объекта обучающей выборки и создание БД Cls_obj с информацией USE Obi_Zag EXCLUSIVE NEW SELECT Obi_Zag DBGOTOP() mMaxLenNameObj = -9999 DO WHILE .NOT. EOF() mMaxLenNameObj = MAX(mMaxLenNameObj, LEN(ALLTRIM(Name_obj))) DBSKIP(1) ENDDO aStructure := { { "Kod_obj" , "N", 15, 0 }, ; { "Sort_key" , "C", 60, 0 }, ; { "Name_obj" , "C", mMaxLenNameObj, 0 } } DbCreate( 'Cls_obj', aStructure ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций COPY FILE ("Obi_Zag.dbf") TO ("ObiZagTmp.dbf") COPY FILE ("Obi_Kcl.dbf") TO ("ObiKclTmp.dbf") COPY FILE ("Obi_Kcl.dbf") TO ("ObiKclTmps.dbf") COPY FILE ("Obi_Kpr.dbf") TO ("ObiKprTmp.dbf") CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE ObI_Kcl EXCLUSIVE NEW SELECT ObI_Kcl INDEX ON STR(Cls1,15)+STR(Cls2,15)+STR(Cls3,15)+STR(Cls4,15)+STR(Kod_obj) TO ObI_Kcl CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Obi_Kpr EXCLUSIVE NEW SELECT Obi_Kpr INDEX ON STR(Kod_obj,15) TO Obi_Kpr CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Attributes EXCLUSIVE NEW;N_Gos = RECCOUNT() USE Obi_Zag EXCLUSIVE NEW;N_Obj1= RECCOUNT() USE Obi_Kcl INDEX Obi_Kcl EXCLUSIVE NEW;N_RecObiKcl = RECCOUNT() USE Obi_Kpr INDEX Obi_Kpr EXCLUSIVE NEW USE Cls_Obj EXCLUSIVE NEW;ZAP USE ObiZagTmp EXCLUSIVE NEW;ZAP USE ObiKclTmp EXCLUSIVE NEW;ZAP USE ObiKclTmps EXCLUSIVE NEW;ZAP USE ObiKprTmp EXCLUSIVE NEW;ZAP nMax = N_RecObiKcl Mess = L('2.3.3.5. Объединение объектов обуч.выборки с одинаковыми классами') @ 4,5 DCPROGRESS oProgress SIZE 75,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 DCREAD GUI TITLE Mess PARENT @oDialog FIT EXIT oDialog:show() nTime = 0 DC_GetProgress(oProgress,0,nMax) ****** Копирование из Obi_Kcl записей в ObiKclTmp с одинаковым уникальным набором классов по одному объекту на каждый уникальный набор SELECT Obi_Kcl SET ORDER TO 1 DBGOTOP() aKodObj := {} // Массив кодов объектов обучающей выборки с одинаковым уникальным набором классов. Надо чтобы код формировался с 1-го. mKodCls = STR(Cls1,15)+STR(Cls2,15)+STR(Cls3,15)+STR(Cls4,15) DO WHILE .NOT. EOF() IF mKodCls = STR(Cls1,15)+STR(Cls2,15)+STR(Cls3,15)+STR(Cls4,15) mKodObj = Kod_obj SELECT Obi_Kcl SET ORDER TO 1 IF ASCAN(aKodObj, mKodObj) = 0 AADD (aKodObj, mKodObj) aR := {} // В Obi_Kcl может быть несколько строк с кодами классов FOR j=1 TO FCOUNT() mV = FIELDGET(j) IF mV > 0 AADD(aR, mV) ENDIF NEXT ENDIF SELECT Obi_Zag DBGOTO(mKodObj) mNameObj = ALLTRIM(Name_obj) SELECT Cls_obj APPEND BLANK REPLACE Kod_obj WITH mKodObj REPLACE Sort_key WITH mKodCls REPLACE Name_obj WITH mNameObj ELSE * DC_DebugQout( aKodObj ) // Отладка Имя Размер Дата Время ****** Добавить запись о объекте обучающей выборки с одинаковым уникальным набором классов SELECT ObiKclTmp // В Obi_Kcl может быть несколько строк с кодами классов APPEND BLANK FOR j=1 TO LEN(aR) IF aR[j] > 0 FIELDPUT(j, aR[j]) ENDIF NEXT FIELDPUT(1,aKodObj[1]) ******* Сформировать общий для этих объектов обучающей выборки объединенный набор признаков // Формирование объединенного массива кодов признаков всех объектов обучающей выборки с таким уникальным набором классов IF LEN(aKodObj) > 0 SELECT Obi_Kpr SET ORDER TO 1 Ar_Kpr := {} // Объединенный массив кодов признаков всех объектов обучающей выборки с уникальным набором классов: mKodCls FOR j=1 TO LEN(aKodObj) T=DBSEEK(STR(aKodObj[j],15)) IF T FOR jj=2 TO 8 M_Kpr = FIELDGET(jj) IF VALTYPE(M_Kpr) = "N" IF 0 < M_Kpr .AND. M_Kpr <= N_Gos AADD(Ar_Kpr, M_Kpr) ENDIF ENDIF NEXT ENDIF NEXT ****** Запись массива кодов признаков в БД ObiKprTmp * ASORT(Ar_Kpr) SELECT ObiKprTmp APPEND BLANK FIELDPUT(1,aKodObj[1]) IF LEN(Ar_Kpr) > 0 k=2 FOR jj=1 TO LEN(Ar_Kpr) IF k <= 8 FIELDPUT(k++,Ar_Kpr[jj]) ELSE k=2 APPEND BLANK FIELDPUT(1,aKodObj[1]) FIELDPUT(k++,Ar_Kpr[jj]) ENDIF NEXT ENDIF // Формирование записи БД заголовков объектов обучающей выборки SELECT Obi_Zag DBGOTO(aKodObj[1]) mNameObj = ALLTRIM(Name_obj) SELECT ObiZagTmp APPEND BLANK REPLACE Kod_obj WITH aKodObj[1] REPLACE Name_obj WITH mNameObj ENDIF SELECT Obi_Kcl SET ORDER TO 1 mKodCls = STR(Cls1,15)+STR(Cls2,15)+STR(Cls3,15)+STR(Cls4,15) aKodObj := {} // Массив кодов объектов обучающей выборки с одинаковым уникальным набором классов ENDIF DC_GetProgress(oProgress, ++nTime, nMax) SELECT Obi_Kcl SET ORDER TO 1 DBSKIP() ENDDO *DC_DebugQout( aKodObj ) // Отладка Имя Размер Дата Время ****** Добавить запись о объекте обучающей выборки с одинаковым уникальным набором классов SELECT ObiKclTmp // В Obi_Kcl может быть несколько строк с кодами классов APPEND BLANK FOR j=1 TO LEN(aR) IF aR[j] > 0 FIELDPUT(j, aR[j]) ENDIF NEXT FIELDPUT(1,aKodObj[1]) ******* Сформировать общий для этих объектов обучающей выборки объединенный набор признаков // Формирование объединенного массива кодов признаков всех объектов обучающей выборки с таким уникальным набором классов IF LEN(aKodObj) > 0 SELECT Obi_Kpr SET ORDER TO 1 Ar_Kpr := {} // Объединенный массив кодов признаков всех объектов обучающей выборки с уникальным набором классов: mKodCls FOR j=1 TO LEN(aKodObj) T=DBSEEK(STR(aKodObj[j],15)) IF T FOR jj=2 TO 8 M_Kpr = FIELDGET(jj) IF VALTYPE(M_Kpr) = "N" IF 0 < M_Kpr .AND. M_Kpr <= N_Gos AADD(Ar_Kpr, M_Kpr) ENDIF ENDIF NEXT ENDIF NEXT ****** Запись массива кодов признаков в БД ObiKprTmp ASORT(Ar_Kpr) SELECT ObiKprTmp APPEND BLANK FIELDPUT(1,aKodObj[1]) IF LEN(Ar_Kpr) > 0 k=2 FOR jj=1 TO LEN(Ar_Kpr) IF k <= 8 FIELDPUT(k++,Ar_Kpr[jj]) ELSE k=2 APPEND BLANK FIELDPUT(1,aKodObj[1]) FIELDPUT(k++,Ar_Kpr[jj]) ENDIF NEXT ENDIF // Формирование записи БД заголовков объектов обучающей выборки SELECT Obi_Zag DBGOTO(aKodObj[1]) mNameObj = ALLTRIM(Name_obj) SELECT ObiZagTmp APPEND BLANK REPLACE Kod_obj WITH aKodObj[1] REPLACE Name_obj WITH mNameObj ENDIF ****** Физическая сортировка ObiKclTmp по коду объекта обучающей выборки <<<===###################### SELECT ObiKclTmp INDEX ON STR(Cls1,15)+STR(Cls2,15)+STR(Cls3,15)+STR(Cls4,15)+STR(Kod_obj,15) TO ObiKclTmp DBGOTOP() DO WHILE .NOT. EOF() aR := {} FOR j=1 TO FCOUNT() mV = FIELDGET(j) IF mV > 0 AADD(aR, mV) ENDIF NEXT SELECT ObiKclTmps APPEND BLANK FOR j=1 TO LEN(aR) IF aR[j] > 0 FIELDPUT(j, aR[j]) ENDIF NEXT SELECT ObiKclTmp DBSKIP() ENDDO CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций COPY FILE ("ObiKclTmps.dbf") TO ("ObiKclTmp.dbf") ****** Перекодировать все базы данных обучающей выборки ******** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE ObiZagTmp EXCLUSIVE NEW USE ObiKclTmp EXCLUSIVE NEW USE ObiKprTmp EXCLUSIVE NEW SELECT ObiZagTmp DBGOTOP() aKodObj := {} mRecno = 0 DO WHILE .NOT. EOF() AADD(aKodObj, Kod_obj) REPLACE Kod_obj WITH ++mRecno DBSKIP() ENDDO *DC_DebugQout( aKodObj ) // Отладка Имя Размер Дата Время SELECT ObiKclTmp DBGOTOP() DO WHILE .NOT. EOF() mPos = ASCAN(aKodObj, Kod_obj) IF mPos > 0 REPLACE Kod_obj WITH mPos ENDIF DBSKIP() ENDDO SELECT ObiKprTmp DBGOTOP() DO WHILE .NOT. EOF() mPos = ASCAN(aKodObj, Kod_obj) IF mPos > 0 REPLACE Kod_obj WITH mPos ENDIF DBSKIP() ENDDO CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций COPY FILE ("ObiZagTmp.dbf") TO ("Obi_Zag.dbf") COPY FILE ("ObiKclTmp.dbf") TO ("Obi_Kcl.dbf") COPY FILE ("ObiKprTmp.dbf") TO ("Obi_Kpr.dbf") *MsgBox('STOP') DC_GetProgress(oProgress,nMax,nMax) oDialog:Destroy() aMess := {} AADD(aMess, L('Формирование новой обучающей выборки, в которой объединены признаки объектов с одинаковыми')) AADD(aMess, L('наборами классов и все объекты обуч.выборки имеют уникальный набор классов, успешно завершена!')) LB_Warning(aMess, L('2.3.3.5. Объединение объектов обуч.выборки с одинаковыми классами' )) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ****************************************************************************************** ******** 5.12. Печать структур всех баз данных. ******** Распечатка структур (даталогических моделей) всех баз данных текущего приложения. ******** Преобразование всех баз данных в Excel-файлы: dbf ===>>> xls ****************************************************************************************** FUNCTION F5_12() Running(.T.) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF ApplChange("5.12()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ********* Поиск DBF-файлов в папке теущего приложения aFileName := {} // Массив коротких имен файлов баз данных aDbfName = DIRECTORY( "*.dbf" ) IF LEN(aDbfName) > 0 FOR f = 1 TO LEN(aDbfName) AADD(aFileName, aDbfName[f,1] ) NEXT ENDIF * DC_DebugQout( aFileName ) nMax = LEN(aFileName) Mess = L('Преобразование всех баз данных (*.dbf) в Excel-файлы') @ 4,5 DCPROGRESS oProgr SIZE 70,1.1 MAXCOUNT nMax COLOR aColor[153] PERCENT EVERY 100 DCREAD GUI TITLE Mess PARENT @oDial FIT EXIT oDial:show() nTime = 0 DC_GetProgress(oProgr,0,nMax) FOR j=1 TO LEN(aFileName) mName = SUBSTR(aFileName[j], 1, AT('.', aFileName[j])-1) Name_SS = mName+'.dbf' Name_DD = mName+'.xls' * LB_Warning(L("Источник: "+Name_SS+", приемник: "+Name_DD)) COPY FILE (Name_SS) TO (Name_DD) DC_GetProgress(oProgr, ++nTime, nMax) NEXT * MsgBox('STOP') DC_GetProgress(oProgr,nMax,nMax) oDial:Destroy() *** ПЕЧАТЬ СТРУКТУР В ФАЙЛ ****************************************************************** set device to printer set printer on set printer to ("Structure_All_DataBases.txt") set console off ?"СТРУКТУРЫ (ДАТАЛОГИЧЕСКИЕ МОДЕЛИ) ВСЕХ БАЗ ДАННЫХ ТЕКУЩЕГО ПРИЛОЖЕНИЯ:" ?'' ?REPLICATE('=',130) mStr = '' FOR N = 1 TO LEN(aFileName) IF LEN(mStr+aFileName[N]+', ') <= 130 mStr = mStr+aFileName[N]+', ' ELSE ?mStr mStr = aFileName[N]+', ' ENDIF NEXT ?mStr ?REPLICATE('=',130) ?'Всего: '+ALLTRIM(STR(LEN(aFileName)))+' баз данных' ?REPLICATE('=',130) ?'' FOR i = 1 TO LEN(aFileName) Db_name = aFileName[i] CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * StrFile(Db_name, '_Db_name.txt') USE (Db_name) EXCLUSIVE NEW // <<<===######################################################### Struct = DBSTRUCT(Db_name) ?'* ' ?"* Структура базы данных N°"+'='+ALLTRIM(STR(i))+': '+aFileName[i] ?"* ============================================================================" ?"* | N | Имя поля | Тип | Ширина | Дес. | Примечание |" ?"* ============================================================================" ** 12345 12345678901 12345 12345678 123456 123456789012345 FOR j=1 TO FCOUNT() ?"* |"+PADC(j,5)+"| "+PADR(Struct[j,1],11)+"|"+PADC(Struct[j,2],5)+"|"+PADC(Struct[j,3],8)+"|"+PADC(Struct[j,4],6)+"|" NEXT ?"* ============================================================================" ?"* В С Е Г О длина записи:"+PADC(STR(RECSIZE(),5),8)+" байтов. |" ?"* ============================================================================" NEXT ?'* (C) Универсальная когнитивная аналитическая система "ЭЙДОС-X++"' Set device to screen Set printer off Set printer to Set console on ************************************************************************************ aMess := {} AADD(aMess, L('Печать отчета о структурах всех баз данных текущего приложения успешно завершена.')) AADD(aMess, L('Путь на отчет: ')+M_PathAppl+'Structure_All_DataBases.txt') AADD(aMess, L('Преобразование всех баз данных (dbf-файлов) в Excel-файлы успешно завершено!')) LB_Warning(aMess, L('5.12. Печать структур всех баз данных приложения' )) DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы *LC_RunShell("_5_12py.exe",927978416) // Программа, написанная на # Питоне # и откомпилированная *LC_RunShellAidosPy(717400306, "_5_12py") // Мой вариант на Питоне в системе __AIDOS-PY.exe LC_RunShell("__AIDOS-PY.exe", 717400306, "_5_12py") // Мой вариант на Питоне в системе __AIDOS-PY.exe ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL *************************************************************************************************************************** ******** Прописывает для числовых шкал в БД Classes и Attributes минимальное, максимальное и среднее значение всех градаций ******** Вставить после синтеза моделей в 3.5, присвоения модели статуса текущей в 5.6 и в функции F483. *************************************************************************************************************************** FUNCTION MinMaxAvr() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() // Можно вставить прогресс USE Attributes EXCLUSIVE NEW;N_Atr = RECCOUNT() ****************************** *nMax = N_Cls+N_Atr *Mess = L('Расчет Min, Max, AVR в БД Classes и Attributes') *@ 4,5 DCPROGRESS oProgr SIZE 80,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 *DCREAD GUI TITLE Mess PARENT @oDial FIT EXIT *oDial:show() nTime = 0 *DC_GetProgress(oProgr,0,nMax) ***************************** SELECT Classes DBGOTOP() DO WHILE .NOT. EOF() mName = Name_cls p4 = AT('{', mName) p6 = AT('}', mName) p5 = p4 + AT(',', SUBSTR(mName, p4, p6-1)) * MsgBox(STR(RECNO())+' '+SUBSTR(mName, p4+1, p5-p4-1)+' '+SUBSTR(mName, p5+1, p6-p5-1)) IF p4*p5*p6 > 0 mMinGR = VAL(SUBSTR(mName, p4+1, p5-p4-1)) mMaxGR = VAL(SUBSTR(mName, p5+1, p6-p5-1)) mAvrGR = mMinGR+(mMaxGR-mMinGR)/2 REPLACE Min_GrInt WITH mMinGR // Минимальная граница интервала REPLACE Max_GrInt WITH mMaxGR // Максимальная граница интервала REPLACE Avr_GrInt WITH mMinGR+(mMaxGR-mMinGR)/2 // Среднее значение интервала ENDIF * DC_GetProgress(oProgr, ++nTime, nMax) DBSKIP(1) ENDDO SELECT Attributes DBGOTOP() DO WHILE .NOT. EOF() mName = Name_atr p4 = AT('{', mName) p6 = AT('}', mName) p5 = p4 + AT(',', SUBSTR(mName, p4, p6-1)) * MsgBox(STR(RECNO())+' '+SUBSTR(mName, p4+1, p5-p4-1)+' '+SUBSTR(mName, p5+1, p6-p5-1)) IF p4*p5*p6 > 0 mMinGR = VAL(SUBSTR(mName, p4+1, p5-p4-1)) mMaxGR = VAL(SUBSTR(mName, p5+1, p6-p5-1)) mAvrGR = mMinGR+(mMaxGR-mMinGR)/2 REPLACE Min_GrInt WITH mMinGR // Минимальная граница интервала REPLACE Max_GrInt WITH mMaxGR // Максимальная граница интервала REPLACE Avr_GrInt WITH mMinGR+(mMaxGR-mMinGR)/2 // Среднее значение интервала ENDIF * DC_GetProgress(oProgr, ++nTime, nMax) DBSKIP(1) ENDDO *DC_GetProgress(oProgr,nMax,nMax) *oDial:Destroy() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций RETURN NIL ********************************************************************************************************** ******** 2.3.2.2. Универсальный программный интерфейс импорта данных в систему "ЭЙДОС-Xpro" *************** ******** DTOS, API-2.3.2.2 ввод табличных числовых и текстовых данных в систему Эйдос с ADS ********************************************************************************************************** #include "inkey.ch" #include "dcdir.ch" #include "appevent.ch" #include "xbp.ch" #include "dll.ch" #include "dccursor.ch" #Include "thread.ch" #include "class.ch" #include "dmlb.ch" #include "fileio.ch" #include "dctree.ch" *#include "SystemMetrics.ch" *#include "axcdxcmx.ch" // Графика ActiveX #include "collat.ch" #include "common.ch" #include "dbedit.ch" #include "Dbfdbe.ch" #include "dcapp.ch" #include "dcbitmap.ch" #include "dccargo.ch" #include "dcdialog.ch" #include "dcdir.ch" #include "dcfiles.ch" #include "dcgra.ch" #include "dcgraph.ch" // графика #include "BdColors.Ch" // графика #include "dccolors.ch" // графика #include "dcprint.ch" // графика #include "Dcicon.ch" #include "dcmsg.ch" #include "dcpick.ch" #include "deldbe.ch" #include "directry.ch" #include "dmlb.ch" #include "express.ch" #include "fileio.ch" #include "font.ch" #include "gra.ch" #include "inkey.ch" #include "memvar.ch" #include "natmsg.ch" #include "prompt.ch" #include '_dcdbfil.ch' #include "set.ch" #include "std.ch" #include "xbp.ch" #include '_dcappe.ch' #include 'dcscope.ch' #include '_dcstru.ch' #include 'dcfields.ch' #include 'dccolor.ch' *#include "Fileio.ch" // Max_DB *#include "rmchart.ch" // Графика ActiveX #include "dcads.ch" #pragma Library( "ASINet10.lib" ) // 2.0 // Для альтернативного и неальтернативного выбора в просмотре таблиц *#define BMP_CHECKED "check1.bmp" *#define BMP_UNCHECKED "check2.bmp" *#define BMP_RACHECKED "radio1.bmp" *#define BMP_RAUNCHECKED "radio2.bmp" *#include "test.ch" #define BMP_CHECKED 10002 #define BMP_UNCHECKED 10003 #define BMP_RACHECKED 10004 #define BMP_RAUNCHECKED 10005 #pragma library( "ascom10.lib" ) #pragma library( "dclip1.lib" ) #pragma library( "dclip2.lib" ) #pragma library( "dclipx.lib" ) #pragma library( "xbtbase1.lib" ) #pragma library( "xbtbase2.lib" ) #pragma library( "xppui2.lib" ) #pragma library( "XPPRT0.LIB" ) #Pragma Library("Taskbar.lib") #xtranslate NTrim() => LTrim(Str()) #define USE_HTTPCLIENT // comment out to try Method2 //#include "Imgview.ch" /* * We use user defined events */ #define xbeDS_DirChanged xbeP_User + 100 #define xbeFS_FileMarked xbeP_User + 101 #define xbeFS_FileSelected xbeP_User + 102 #define DCAREAMSG_1 'Invalid Expression in Index Key:' /* * This directive calculates a centered position */ #xtrans CenterPos( , ) => ; { Int( (\[1] - \[1]) / 2 ) ; , Int( (\[2] - \[2]) / 2 ) } #define DC_RDDMSG_1 'Invalid RDD selection - '+cSuperRdd #define DC_RDDMSG_2 'DBE Name Description' #define DC_RDDMSG_3 'Select a Database Driver' *#define ADSDBE_MEMOFILE_EXT (DBE_USER+1) // RO *#define ADSDBE_INDEX_EXT (DBE_USER+2) // RW *#define ADSDBE_TBL_MODE (DBE_USER+3) // RW *#define ADSDBE_LOCK_MODE (DBE_USER+4) // RW *#define ADSDBE_RIGHTS_MODE (DBE_USER+5) // RW *#define ADSDBE_MEMOBLOCKSIZE (DBE_USER+6) // RW *#define ADSDBE_PASSWORD (DBE_USER+7) // RW // Return types of ADSDBE_TBL_MODE *#define ADSDBE_NTX 1 *#define ADSDBE_CDX 2 *#define ADSDBE_ADT 3 // Для опредедения разрешения монитора от Джимми #define DESKTOPVERTRES 117 #define DESKTOPHORZRES 118 // Excel Orientation #DEFINE xlLandscape 2 #DEFINE xlPortrait 1 #DEFINE xlWorkbookNormal -4143 #DEFINE xlCellTypeLastCell 11 #DEFINE SRCCOPY 0xCC0020 // Для быстрой графики Роджера #define KEYEVENTF_KEYUP 0x02 #define VK_MENU 0x12 #define VK_SNAPSHOT 0x2C #DEFINE VK_LBUTTON 0x01 #DEFINE VK_RBUTTON 0x02 * Для CSV=>DBF конвертера *#include "ot4xb.ch" // => ot4xb.dll => www.xbwin.com #ifndef CRLF #define CRLF chr(13)+chr(10) #endif * Klasse zum sequentiellen Einlesen groбer Dateien *#IF .t. // zum Einbinden in eigenes Projekt, .f. setzen ! STATIC snHdll *********************************************************************** *********************************************************************** FUNCTION F2_3_2_2(mApplName, mFunctName) LOCAL GetList[0], oStatus, lContinue := .T., oProgressm, oDialogm LOCAL lOk:=.T., aSay[30], Mess97, Mess98, Mess99, oDialog // Массив сообщений отображаемых стадий исполнения (до 30 на экране) Running(.T.) SET EXACT ON // Присравнении .T. если совпадают все символы, включая совпадение длины **************************************************************************** ******** Луценко Е.В., 08/17/11 10:20pm ***** ******** УНИВЕРСАЛЬНЫЙ ПРОГРАММНЫЙ ИНТЕРФЕЙС ФОРМАЛИЗАЦИИ ПРЕДМЕТНОЙ ***** ******** ОБЛАСТИ И ИМПОРТА ДАННЫХ В СИСТЕМУ "ЭЙДОС" ***** ******** 1. Стандартный вид интерфейса "Эйдос" ***** ******** 2. Пояснение об именах и структуре исходых файлов ***** ******** 3. Диалог задания диапазонов столбцов с классами и признаками ***** ******** 4. Диалог задания количества градаций в числовых шкалах ***** ******** (после подсчета количества числовых столбцов классов и признаков) ******** 5. Наименования полей брать из текстового файла Inp_name.txt ***** ******** в п.2 дать пояснения как его сделать из Excel-файла Inp_data.dbf ******** (перенести шапку в Word, преобразовать таблицу в текст с разделителем ******** - знаком абзаца, записать его как Inp.txt текст MS-DOS) ******** Все это можно делать с использованием интерфейса А.Н.Лебедева ***** ******** и заменить этим режимом этот интерфейс, ***** ******** а также позже можно объединить Наташин интерфейс с траспонированным ******** А.Н.Лебедева и тоже включить его в систему (чтобы он работал ***** ******** с числовыми и тестовыми данными) ***** **************************************************************************** IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF ******************************************************************************************************************************* // Диалог задания параметров работы программного интерфейса ** Выбор режима работы ************************************************** ** Если файл _2_3_2_2.arx существует, то ** - дать пользователю возможность выбора режима работы: ** 1. Формирование шкал, градаций и обучающей выборки ** 2. Формирование распознаваемой выборки ** - присвоить всем переменным, задаваемым в диалоге, начальные значения ** из этого файла и с этими значениями начинать диалог ** Если файла _2_3_2_2.arx не существует, то значит режим запускается впервые ** и нет смысла давать пользователю возможность выбора режима работы, ** а надо автоматически выбирать режим формализации предметной области, ** и диалог задания значений параметров начинать "с нуля" или значений по умолчанию IF FILE(Disk_dir+"\_2_3_2_2.arx") aSoftInt = DC_ARestore(Disk_dir+"\_2_3_2_2.arx") Regim = aSoftInt[ 1] Flag_zer = aSoftInt[ 2] M_ClSc1 = aSoftInt[ 3] M_ClSc2 = aSoftInt[ 4] M_OpSc1 = aSoftInt[ 5] M_OpSc2 = aSoftInt[ 6] N_SKGrCl = aSoftInt[ 7] N_SKGrPr = aSoftInt[ 8] K_N_ClSc = aSoftInt[ 9] K_N_OpSc = aSoftInt[10] K_N_GrClSc = aSoftInt[11] K_N_GrOpSc = aSoftInt[12] M_ObAnk = aSoftInt[13] N_Chast = aSoftInt[14] M_Interval = aSoftInt[15] M_Scenario = aSoftInt[16] K_GradNClSc = aSoftInt[17] // Количество градаций в числовой классификационной шкале K_GradNOpSc = aSoftInt[18] // Количество градаций в числовой описательной шкале mGorizMin = aSoftInt[19] mGorizMax = aSoftInt[20] mGlubMin = aSoftInt[21] mGlubMax = aSoftInt[22] M_ChastObi = aSoftInt[23] M_ChastRso = aSoftInt[24] N_ChastObi = aSoftInt[25] N_ChastRso = aSoftInt[26] M_XlsDbf = aSoftInt[27] mTxtCSField = aSoftInt[28] // Способ интерпретации значений текстовых полей - классификационных шкал файла исходных данных mTxtOSField = aSoftInt[29] // Способ интерпретации значений текстовых полей - описательных шкал файла исходных данных mTxtCSSep = aSoftInt[30] mTxtOSSep = aSoftInt[31] * mScenario = aSoftInt[32] // mScenario=1 Не применять сценарный метод АСК-анализа и спец.интерпретацию TXT-полей (старый вариант) mScenario = aSoftInt[32] // mScenario=1 Не применять сценарный метод АСК-анализа, mScenario=2 - применять mSpecInterprCls = aSoftInt[33] // .T. - Применить спец.интерпретацию текстовых полей классов, .F. - не применять mSpecInterprAtr = aSoftInt[34] // .T. - Применить спец.интерпретацию текстовых полей признаков, .F. - не применять mNameGrNumSc= aSoftInt[35] // Какие наименования ГРАДАЦИЙ числовых шкал использовать mClsAvr = aSoftInt[36] // .F. - делать модель из Inp_data, .T. - делать модель из Inp_data_avr mSortUnqCls = IF(mSpecInterprCls=.F., 1, aSoftInt[37]) // Выделять уникальные значения классов и сортировать, 1-да, 2-нет mLemmatCls = IF(mSpecInterprCls,aSoftInt[38],2) // Проводить лемматизацию классов, 1-да, 2-нет mSortUnqGos = IF(mSpecInterprAtr=.F., 1, aSoftInt[39]) // Выделять уникальные значения признаков и сортировать, 1-да, 2-нет mLemmatGos = IF(mSpecInterprAtr,aSoftInt[40],2) // Проводить лемматизацию признаков, 1-да, 2-нет ELSE Regim = 1 // Формализации ПО или ген.расп.выб. Flag_zer = 1 // Считать нули и пробелы отсутствием данных? [1]-да, [2]-нет M_ClSc1 = 2 // Номер начального столбца диапазона классификационных шкал M_ClSc2 = 3 // Номер конечного столбца диапазона классификационных шкал M_OpSc1 = M_ClSc2+1 // Номер начального столбца диапазона описательных шкал M_OpSc2 = M_OpSc1 // Номер конечного столбца диапазона описательных шкал N_SKGrCl = 40 N_SKGrPr = 40 K_N_ClSc = M_ClSc2-M_ClSc1+1 // Кол-во числовых классификационных шкал K_N_OpSc = M_OpSc2-M_OpSc1+1 // Кол-во числовых описательных шкал K_N_GrClSc = 3 // Кол-во градаций в числ.кл.шкалах K_N_GrOpSc = 3 // Кол-во градаций в числ.оп.шкалах M_ObAnk = 3 // Создавать анкеты исходной выборки по строкам Inp_data-[1], по классам-[2], и 1-е, и 2-е [3] N_Chast = 1 // На сколько частей N разбивать обучающую или распознавемую выборку (в зависимости от Regim) M_Interval = 1 // 1-равные интервалы, 2-адаптивные интервалы (с примерно равным количеством наблюдений, по Котельникову) M_Scenario = .F. K_GradNClSc = 3 K_GradNOpSc = 3 mGorizMin = 5 mGorizMax = 5 mGlubMin = 5 mGlubMax = 5 M_ChastObi = .F. M_ChastRso = .F. N_ChastObi = 1 N_ChastRso = 1 M_XlsDbf = 2 mTxtCSField = 1 mTxtOSField = 1 mTxtCSSep = " " // Разделитель элементов классификационных шкал, если mTxtCSField=3 mTxtOSSep = " " // Разделитель элементов описательных шкал, если mTxtOSField=3 * mScenario = 1 // mScenario=1 Не применять сценарный метод АСК-анализа и спец.интерпретацию TXT-полей (старый вариант) mScenario = 1 // Не применять сценарный метод АСК-анализа mSpecInterprCls = .F. // Не применять спец.интерпретацию текстовых полей классов mSpecInterprAtr = .F. // Не применять спец.интерпретацию текстовых полей признаков mNameGrNumSc= 1 // Какие наименования ГРАДАЦИЙ числовых шкал использовать mClsAvr =.T. // .F. - делать модель из Inp_data, .T. - делать модель из Inp_data_avr mSortUnqCls = 1 // Выделять уникальные значения классов и сортировать, 1-да, 2-нет mLemmatCls = 2 // Проводить лемматизацию классов, 1-да, 2-нет mSortUnqGos = 1 // Выделять уникальные значения признаков и сортировать, 1-да, 2-нет mLemmatGos = 2 // Проводить лемматизацию признаков, 1-да, 2-нет ENDIF // Сохранить файл с информацией о заданых параметрах программного интерфейса в текущей директории системы И В ПАПКЕ INP_DATA PRIVATE aSoftInt[40] aSoftInt[ 1] = Regim aSoftInt[ 2] = Flag_zer aSoftInt[ 3] = M_ClSc1 aSoftInt[ 4] = M_ClSc2 aSoftInt[ 5] = M_OpSc1 aSoftInt[ 6] = M_OpSc2 aSoftInt[ 7] = N_SKGrCl aSoftInt[ 8] = N_SKGrPr aSoftInt[ 9] = K_N_ClSc aSoftInt[10] = K_N_OpSc aSoftInt[11] = K_N_GrClSc aSoftInt[12] = K_N_GrOpSc aSoftInt[13] = M_ObAnk aSoftInt[14] = N_Chast aSoftInt[15] = M_Interval // 1-равные интервалы, 2-адаптивные интервалы (с примерно равным количеством наблюдений, по Котельникову) aSoftInt[16] = M_Scenario aSoftInt[17] = K_GradNClSc // Количество градаций в числовой классификационной шкале aSoftInt[18] = K_GradNOpSc // Количество градаций в числовой описательной шкале aSoftInt[19] = mGorizMin aSoftInt[20] = mGorizMax aSoftInt[21] = mGlubMin aSoftInt[22] = mGlubMax aSoftInt[23] = M_ChastObi aSoftInt[24] = M_ChastRso aSoftInt[25] = N_ChastObi aSoftInt[26] = N_ChastRso aSoftInt[27] = M_XlsDbf aSoftInt[28] = mTxtCSField aSoftInt[29] = mTxtOSField aSoftInt[30] = mTxtCSSep aSoftInt[31] = mTxtOSSep * aSoftInt[32] = mScenario // mScenario=1 Не применять сценарный метод АСК-анализа и спец.интерпретацию TXT-полей (старый вариант) aSoftInt[32] = mScenario // mScenario=1 Не применять сценарный метод АСК-анализа aSoftInt[33] = mSpecInterprCls // Применить спец.интерпретацию текстовых полей классов aSoftInt[34] = mSpecInterprAtr // Применить спец.интерпретацию текстовых полей признаков aSoftInt[35] = mNameGrNumSc // Какие наименования ГРАДАЦИЙ числовых шкал использовать aSoftInt[36] = mClsAvr // .F. = модель без усреднения по классам aSoftInt[37] = IF(mSpecInterprCls=.F., 1, mSortUnqCls) // Выделять уникальные значения классов и сортировать, 1-да, 2-нет aSoftInt[38] = IF(mSpecInterprCls,mLemmatCls, 2) // Проводить лемматизацию классов, 1-да, 2-нет aSoftInt[39] = IF(mSpecInterprAtr=.F., 1, mSortUnqGos) // Выделять уникальные значения признаков и сортировать, 1-да, 2-нет aSoftInt[40] = IF(mSpecInterprAtr,mLemmatGos, 2) // Проводить лемматизацию признаков, 1-да, 2-нет DC_ASave(aSoftInt , Disk_dir +"\_2_3_2_2.arx") ***** ОТОБРАЖЕНИЕ ИНФОРМАЦИИ О ФУНКЦИЯХ ПРОГРАММНОГО ИНТЕРФЕЙСА ************ Mess1 = L('Автоматическая формализация предметной области: генерация классификационных и описательных шкал') Mess2 = L('и градаций, а также обучающей и распознаваемой выборки на основе базы исходных данных: "Inp_data"') @ 0,0 DCSAY Mess1 FONT '10.Helvetica Bold' SAYSIZE 0 @ 1,0 DCSAY Mess2 FONT '10.Helvetica Bold' SAYSIZE 0 mStrinFrame = 2.5 // Позиция первой строки нулевой группы, следующая группа ниже на 2+N строки, если в группе N строк mWidthFrame = 51 // Ширина группы, следующая группа справа правее этой ширины на 3 символа mPosGet = 40 // Отступ полей ввода числовых значений внутри групп @ mStrinFrame, 0 DCGROUP oGroup1 CAPTION L('Задайте тип файла исходных данных: "Inp_data":') SIZE mWidthFrame,5.5 @ 0.9, 2 DCRADIO M_XlsDbf VALUE 1 PROMPT L('XLS - MS Excel-2003' ) PARENT oGroup1 @ 1.9, 2 DCRADIO M_XlsDbf VALUE 2 PROMPT L('XLSX- MS Excel-2007(2010)' ) PARENT oGroup1 @ 2.9, 2 DCRADIO M_XlsDbf VALUE 3 PROMPT L('DBF - DBASE IV (DBF/NTX)' ) PARENT oGroup1 @ 3.9, 2 DCRADIO M_XlsDbf VALUE 4 PROMPT L('CSV - CSV => DBF конвертер' ) PARENT oGroup1 Mess = L('Стандарт XLS-файла') @ 1.0, 30.5 DCPUSHBUTTON CAPTION Mess SIZE LEN(Mess)-0, 1.7 ACTION {||Help2322xls()} PARENT oGroup1 Mess = L('Стандарт DBF-файла') @ 3.0, 30.5 DCPUSHBUTTON CAPTION Mess SIZE LEN(Mess)-0, 1.0 ACTION {||Help2322dbf()} PARENT oGroup1 Mess = L('Стандарт CSV-файла') @ 4.0, 30.5 DCPUSHBUTTON CAPTION Mess SIZE LEN(Mess)-0, 1.0 ACTION {||Help2322csv()} PARENT oGroup1 * mClsAvr = .T. // .F. - делать модель из Inp_data, .T. - делать модель из Inp_data_avr @ mStrinFrame, mWidthFrame+3 DCGROUP oGroup2 CAPTION L('Задайте параметры:') SIZE mWidthFrame,5.5 @ 0.8, 2 DCRADIO Flag_zer VALUE 1 PROMPT L('Нули и пробелы считать ОТСУТСТВИЕМ данных' ) PARENT oGroup2 @ 1.6, 2 DCRADIO Flag_zer VALUE 2 PROMPT L('Нули и пробелы считать ЗНАЧЕНИЯМИ данных' ) PARENT oGroup2 @ 2.4, 2 DCCHECKBOX mClsAvr PROMPT L('Создавать БД средних по классам "Inp_davr.dbf"?') PARENT oGroup2 Mess = L('Требования к файлу исходных данных') @ 3.5, 2 DCPUSHBUTTON CAPTION Mess SIZE LEN(Mess)+6.5, 1.5 ACTION {||Help2322xls()} FONT('9.Helvetica Bold') PARENT oGroup2 mStrinFrame = mStrinFrame+6 @ mStrinFrame, 0 DCGROUP oGroup3 CAPTION L('Задайте диапазон столбцов классификационных шкал:') SIZE mWidthFrame,3.5 @ 1, 2 DCSAY L("Начальный столбец классификационных шкал:") PARENT oGroup3;@1,mPosGet+2 DCGET M_ClSc1 PARENT oGroup3 PICTURE "#####" @ 2, 2 DCSAY L("Конечный столбец классификационных шкал:") PARENT oGroup3;@2,mPosGet+2 DCGET M_ClSc2 PARENT oGroup3 PICTURE "#####" @ mStrinFrame, mWidthFrame+3 DCGROUP oGroup4 CAPTION L('Задайте диапазон столбцов описательных шкал:') SIZE mWidthFrame,3.5 @ 1, 2 DCSAY L("Начальный столбец описательных шкал:") PARENT oGroup4;@1,mPosGet DCGET M_OpSc1 PARENT oGroup4 PICTURE "#####" @ 2, 2 DCSAY L("Конечный столбец описательных шкал:") PARENT oGroup4;@2,mPosGet DCGET M_OpSc2 PARENT oGroup4 PICTURE "#####" mStrinFrame = mStrinFrame+4 @ mStrinFrame, 0 DCGROUP oGroup5 CAPTION L('Задайте режим:') SIZE mWidthFrame,3.5 @ 1, 2 DCRADIO Regim VALUE 1 PROMPT L('Формализации предметной области (на основе "Inp_data")') PARENT oGroup5 @ 2, 2 DCRADIO Regim VALUE 2 PROMPT L('Генерации распознаваемой выборки (на основе "Inp_rasp")') PARENT oGroup5 @ mStrinFrame, mWidthFrame+3 DCGROUP oGroup6 CAPTION L('Задайте способ выбора размера интервалов:') SIZE mWidthFrame,3.5 @ 1, 2 DCRADIO M_Interval VALUE 1 PROMPT L('Равные интервалы с разным числом наблюдений') PARENT oGroup6 @ 2, 2 DCRADIO M_Interval VALUE 2 PROMPT L('Разные интервалы с равным числом наблюдений') PARENT oGroup6 // В этом случае не применять спец.интерпретацию текстовых полей <<<===####### // и стирать изображение всех параметров, заданных при текстовой интерпретации * mSpecInterprCls = .F. * mSpecInterprAtr = .F. mStrinFrame = mStrinFrame+4 ******************************** @mStrinFrame, 0 DCGROUP oGroup7 CAPTION L('Задание параметров формирования сценариев или способа интерпретации текстовых полей "Inp_data":') SIZE mWidthFrame*2+3, 14.5 @ 1, 2 DCRADIO mScenario VALUE 1 PROMPT L('Не применять сценарный метод АСК-анализа' ) PARENT oGroup7 SIZE 0 @ 1, mWidthFrame+3+2 DCRADIO mScenario VALUE 2 PROMPT L('Применить сценарный метод АСК-анализа' ) PARENT oGroup7 SIZE 0 * Старый вариант закоментирован * @ 3, 2 DCRADIO mScenario VALUE 3 PROMPT L('Применить специальную интерпретацию текстовых полей "Inp_data"') PARENT oGroup7 SIZE 0 @ 2, 2 DCCHECKBOX mSpecInterprCls PROMPT L('Применить спец.интерпретацию текстовых полей классов' ) PARENT oGroup7 SIZE 0 HIDE {|| .NOT.mScenario=1 .OR. M_Interval=2} @ 2, mWidthFrame+3+2 DCCHECKBOX mSpecInterprAtr PROMPT L('Применить спец.интерпретацию текстовых полей признаков') PARENT oGroup7 SIZE 0 HIDE {|| .NOT.mScenario=1 .OR. M_Interval=2} ******************************** @ 5.5,2 DCGROUP oGroup22 CAPTION L('Интерпретация TXT-полей классов:' ) SIZE mWidthFrame-2,3.5 PARENT oGroup7 HIDE {|| .NOT.mScenario=1 .AND. .NOT. mSpecInterprCls=.F. } @ 1,2 DCSAY L('Значения полей текстовых классификационных шкал файла') PARENT oGroup22 EDITPROTECT {|| .NOT.mScenario=1 .AND. .NOT. mSpecInterprCls=.F.} HIDE {|| .NOT.mScenario=1 .AND. .NOT. mSpecInterprCls=.F.} @ 2,2 DCSAY L('исходных данных "Inp_data" рассматриваются как целое' ) PARENT oGroup22 EDITPROTECT {|| .NOT.mScenario=1 .AND. .NOT. mSpecInterprCls=.F.} HIDE {|| .NOT.mScenario=1 .AND. .NOT. mSpecInterprCls=.F.} @ 5.5,mWidthFrame+3 DCGROUP oGroup14 CAPTION L('Интерпретация TXT-полей признаков:') SIZE mWidthFrame-2,3.5 PARENT oGroup7 HIDE {|| .NOT.mScenario=1 .AND. .NOT. mSpecInterprAtr=.F. } @ 1,2 DCSAY L('Значения полей текстовых описательных шкал файла' ) PARENT oGroup14 EDITPROTECT {|| .NOT.mScenario=1 .AND. .NOT. mSpecInterprAtr=.F.} HIDE {|| .NOT.mScenario=1 .AND. .NOT. mSpecInterprAtr=.F.} @ 2,2 DCSAY L('исходных данных "Inp_data" рассматриваются как целое' ) PARENT oGroup14 EDITPROTECT {|| .NOT.mScenario=1 .AND. .NOT. mSpecInterprAtr=.F.} HIDE {|| .NOT.mScenario=1 .AND. .NOT. mSpecInterprAtr=.F.} ******************************** h = 1.6 // Смещение вверх FOR j=1 TO 10 @3+j,2 DCSAY REPLICATE(' ',mWidthFrame*2) PARENT oGroup7 HIDE {|| .NOT. mScenario=2 } NEXT @ 4.1-h,2+31 DCSAY L('Параметры формирования сценариев:') PARENT oGroup7 HIDE {|| .NOT.mScenario=2} FONT "10.HelvBold" SIZE 0 @ 5.4-h,2 DCGROUP oGroup8 CAPTION L('Прошлый период:') SIZE mWidthFrame-2,3.5 PARENT oGroup7 HIDE {|| .NOT.mScenario=2 } @ 1,2 DCSAY L("Глубина предыстории минимальная :" ) PARENT oGroup8 EDITPROTECT {|| .NOT.mScenario=2 } HIDE {|| .NOT.mScenario=2 } @ 2,2 DCSAY L("Глубина предыстории максимальная:" ) PARENT oGroup8 EDITPROTECT {|| .NOT.mScenario=2 } HIDE {|| .NOT.mScenario=2 } @ 1,mPosGet DCGET mGlubMin PARENT oGroup8 PICTURE "#####" EDITPROTECT {|| .NOT.mScenario=2 } HIDE {|| .NOT.mScenario=2 } @ 2,mPosGet DCGET mGlubMax PARENT oGroup8 PICTURE "#####" EDITPROTECT {|| .NOT.mScenario=2 } HIDE {|| .NOT.mScenario=2 } @ 5.4-h,mWidthFrame+3 DCGROUP oGroup10 CAPTION L('Будущий период:' ) SIZE mWidthFrame-2,3.5 PARENT oGroup7 HIDE {|| .NOT.mScenario=2 } @ 1,2 DCSAY L("Горизонт прогнозирования минимальный :") PARENT oGroup10 EDITPROTECT {|| .NOT.mScenario=2 } HIDE {|| .NOT.mScenario=2 } @ 2,2 DCSAY L("Горизонт прогнозирования максимальный:") PARENT oGroup10 EDITPROTECT {|| .NOT.mScenario=2 } HIDE {|| .NOT.mScenario=2 } @ 1,mPosGet DCGET mGorizMin PARENT oGroup10 PICTURE "#####" EDITPROTECT {|| .NOT.mScenario=2 } HIDE {|| .NOT.mScenario=2 } @ 2,mPosGet DCGET mGorizMAx PARENT oGroup10 PICTURE "#####" EDITPROTECT {|| .NOT.mScenario=2 } HIDE {|| .NOT.mScenario=2 } *** Новые параметры сценарного АСК-анализа <<<===############## CrClsFinValFutScen = .T. // .T. - только для финальных значений будущих сценариев, .F. - для всех точек mCreateAttPointPast = 1 s = 1;d = 0.8 @ 9.4-h,2 DCGROUP oGroup21 CAPTION L('Рассматривать отдельно точки прошлых сценариев? ' ) SIZE mWidthFrame-2,4.5 PARENT oGroup7 HIDE {|| .NOT.mScenario=2 } @ s, 2 DCRADIO mCreateAttPointPast VALUE 1 PROMPT L('Не рассматривать ' ) SIZE 0 PARENT oGroup21 EDITPROTECT {|| .NOT.mScenario=2 } HIDE {|| .NOT.mScenario=2 };s=s+d @ s, 2 DCRADIO mCreateAttPointPast VALUE 2 PROMPT L('Рассматривать, но только финальные точки' ) SIZE 0 PARENT oGroup21 EDITPROTECT {|| .NOT.mScenario=2 } HIDE {|| .NOT.mScenario=2 };s=s+d @ s, 2 DCRADIO mCreateAttPointPast VALUE 3 PROMPT L('Рассматривать все точки ' ) SIZE 0 PARENT oGroup21 EDITPROTECT {|| .NOT.mScenario=2 } HIDE {|| .NOT.mScenario=2 };s=s+d mCreateClsPointFuture = 1 s = 1;d = 0.8 @ 9.4-h,mWidthFrame+3 DCGROUP oGroup22 CAPTION L('Рассматривать отдельно точки будущих сценариев? ' ) SIZE mWidthFrame-2,4.5 PARENT oGroup7 HIDE {|| .NOT.mScenario=2 } @ s, 2 DCRADIO mCreateClsPointFuture VALUE 1 PROMPT L('Не рассматривать ' ) SIZE 0 PARENT oGroup22 EDITPROTECT {|| .NOT.mScenario=2 } HIDE {|| .NOT.mScenario=2 };s=s+d @ s, 2 DCRADIO mCreateClsPointFuture VALUE 2 PROMPT L('Рассматривать, но только финальные точки' ) SIZE 0 PARENT oGroup22 EDITPROTECT {|| .NOT.mScenario=2 } HIDE {|| .NOT.mScenario=2 };s=s+d @ s, 2 DCRADIO mCreateClsPointFuture VALUE 3 PROMPT L('Рассматривать все точки ' ) SIZE 0 PARENT oGroup22 EDITPROTECT {|| .NOT.mScenario=2 } HIDE {|| .NOT.mScenario=2 };s=s+d * s = 1;d = 0.8 * @ 9.4-h,2 DCGROUP oGroup21 CAPTION L('Пояснение по сценарному методу АСК-анализа:') SIZE 2*mWidthFrame-1,6.2 PARENT oGroup7 HIDE {|| .NOT.mScenario=2 } * @ s,2 DCSAY L('Когда сценарный метод АСК-анализа не применяется, то записи файла исходных данных "Inp_data" рассматриваются сами по себе ') PARENT oGroup21 EDITPROTECT {|| .NOT.mScenario=2 } HIDE {|| .NOT.mScenario=2 };s=s+d * @ s,2 DCSAY L('независмо друг от друга. Если же он применяется, то как классы рассматриваются сценарии изменения значений полей классифи-') PARENT oGroup21 EDITPROTECT {|| .NOT.mScenario=2 } HIDE {|| .NOT.mScenario=2 };s=s+d * @ s,2 DCSAY L('кационных шкал на заданное количество записей вперед от текущей записи (горизонт прогнозирования), а за значения факторов ') PARENT oGroup21 EDITPROTECT {|| .NOT.mScenario=2 } HIDE {|| .NOT.mScenario=2 };s=s+d * @ s,2 DCSAY L('принимаются сценарии изменения значений полей описательных шкал на заданное их количество назад (глубина предыстории). ') PARENT oGroup21 EDITPROTECT {|| .NOT.mScenario=2 } HIDE {|| .NOT.mScenario=2 };s=s+d mStr = L('Подробное теоретическое описание сценарного АСК-анализа с детальным численным примером') * @12.6,12 DCPUSHBUTTON CAPTION mStr SIZE LEN(mStr)-5, 1.4 ACTION {||DC_SpawnURL( 'https://www.researchgate.net/publication/343365649', .T., .T. )} PARENT oGroup7 EDITPROTECT {|| .NOT.mScenario=2 } HIDE {|| .NOT.mScenario=2 };s=s+d @12.6,12 DCPUSHBUTTON CAPTION mStr SIZE LEN(mStr)-5, 1.4 ACTION {||Help2322ScenASKA()} PARENT oGroup7 EDITPROTECT {|| .NOT.mScenario=2 } HIDE {|| .NOT.mScenario=2 };s=s+d ******************************** @ 4.1,2+20 DCSAY L('Параметры интерпретации значений текстовых полей "Inp_data":') PARENT oGroup7 HIDE {|| .NOT.mScenario=1 } FONT "10.HelvBold" SIZE 0 mNWordsCS = 0 @ 5.5,2 DCGROUP oGroup11 CAPTION L('В качестве классов рассматриваются:') SIZE mWidthFrame-2,8.5 PARENT oGroup7 HIDE {|| .NOT.mSpecInterprCls=.T. .OR. .NOT.mScenario=1 .OR. M_Interval=2} @ 1,2 DCRADIO mTxtCSField VALUE 1 PROMPT L('Значения полей целиком' ) PARENT oGroup11 @ 2,2 DCRADIO mTxtCSField VALUE 3 PROMPT L('Элементы значений полей - слова > символов:') PARENT oGroup11 @ 3,2 DCRADIO mTxtCSField VALUE 2 PROMPT L('Элементы значений полей - символы' ) PARENT oGroup11 @ 2,mPosGet DCGET mNWordsCS PARENT oGroup11 EDITPROTECT {|| .NOT.mTxtCSField=3 } HIDE {|| .NOT.mTxtCSField=3 } PICTURE "#####" * mSortUnqCls = 2 @ 4.4,2 DCGROUP oGroup15 CAPTION L(' ') SIZE mWidthFrame-6,3.5 PARENT oGroup11 HIDE {|| .NOT.mTxtCSField=1 } @ 1,2 DCRADIO mSortUnqCls VALUE 1 PROMPT L('Выделять уникальные значения и сортировать ') PARENT oGroup15 EDITPROTECT {|| .NOT.mTxtCSField=1 } HIDE {|| .NOT.mTxtCSField=1 } @ 2,2 DCRADIO mSortUnqCls VALUE 2 PROMPT L('Не выделять уникальных значений и не сортировать') PARENT oGroup15 EDITPROTECT {|| .NOT.mTxtCSField=1 } HIDE {|| .NOT.mTxtCSField=1 } * mLemmatCls = 1 @ 4.4,2 DCGROUP oGroup16 CAPTION L(' ') SIZE mWidthFrame-6,3.5 PARENT oGroup11 HIDE {|| .NOT.mTxtCSField=3 } @ 1,2 DCRADIO mLemmatCls VALUE 1 PROMPT L('Проводить лемматизацию' )+SPACE(38) PARENT oGroup16 EDITPROTECT {|| .NOT.mTxtCSField=3 } HIDE {|| .NOT.mTxtCSField=3 } @ 2,2 DCRADIO mLemmatCls VALUE 2 PROMPT L('Не проводить лемматизацию')+SPACE(38) PARENT oGroup16 EDITPROTECT {|| .NOT.mTxtCSField=3 } HIDE {|| .NOT.mTxtCSField=3 } @ 4.4,2 DCGROUP oGroup17 CAPTION L(' ') SIZE mWidthFrame-6,3.5 PARENT oGroup11 HIDE {|| .NOT.mTxtCSField=2 } @ 1,2 DCSAY SPACE(42) PARENT oGroup17 EDITPROTECT {|| .NOT.mTxtCSField=2 } HIDE {|| .NOT.mTxtCSField=2 } @ 2,2 DCSAY SPACE(42) PARENT oGroup17 EDITPROTECT {|| .NOT.mTxtCSField=2 } HIDE {|| .NOT.mTxtCSField=2 } ******************************** mNWordsOS = 0 @ 5.5,mWidthFrame+3 DCGROUP oGroup12 CAPTION L('В качестве признаков рассматриваются:') SIZE mWidthFrame-2,8.5 PARENT oGroup7 HIDE {|| .NOT.mSpecInterprAtr=.T. .OR. .NOT.mScenario=1 .OR. M_Interval=2} @ 1,2 DCRADIO mTxtOSField VALUE 1 PROMPT L('Значения полей целиком' ) PARENT oGroup12 @ 2,2 DCRADIO mTxtOSField VALUE 3 PROMPT L('Элементы значений полей - слова > символов:') PARENT oGroup12 @ 3,2 DCRADIO mTxtOSField VALUE 2 PROMPT L('Элементы значений полей - символы' ) PARENT oGroup12 @ 2,mPosGet DCGET mNWordsOS PARENT oGroup12 EDITPROTECT {|| .NOT.mTxtOSField=3 } HIDE {|| .NOT.mTxtOSField=3 } PICTURE "#####" * mSortUnqGos = 2 @ 4.4,2 DCGROUP oGroup18 CAPTION L(' ') SIZE mWidthFrame-6,3.5 PARENT oGroup12 HIDE {|| .NOT.mTxtOSField=1 } @ 1,2 DCRADIO mSortUnqGos VALUE 1 PROMPT L('Выделять уникальные значения и сортировать' ) PARENT oGroup18 EDITPROTECT {|| .NOT.mTxtOSField=1 } HIDE {|| .NOT.mTxtOSField=1 } @ 2,2 DCRADIO mSortUnqGos VALUE 2 PROMPT L('Не выделять уникальных значений и не сортировать') PARENT oGroup18 EDITPROTECT {|| .NOT.mTxtOSField=1 } HIDE {|| .NOT.mTxtOSField=1 } * mLemmatGos = 1 @ 4.4,2 DCGROUP oGroup19 CAPTION L(' ') SIZE mWidthFrame-6,3.5 PARENT oGroup12 HIDE {|| .NOT.mTxtOSField=3 } @ 1,2 DCRADIO mLemmatGos VALUE 1 PROMPT L('Проводить лемматизацию' )+SPACE(38) PARENT oGroup19 EDITPROTECT {|| .NOT.mTxtOSField=3 } HIDE {|| .NOT.mTxtOSField=3 } @ 2,2 DCRADIO mLemmatGos VALUE 2 PROMPT L('Не проводить лемматизацию')+SPACE(38) PARENT oGroup19 EDITPROTECT {|| .NOT.mTxtOSField=3 } HIDE {|| .NOT.mTxtOSField=3 } @ 4.4,2 DCGROUP oGroup20 CAPTION L(' ') SIZE mWidthFrame-6,3.5 PARENT oGroup12 HIDE {|| .NOT.mTxtOSField=2 } @ 1,2 DCSAY SPACE(42) PARENT oGroup20 EDITPROTECT {|| .NOT.mTxtOSField=2 } HIDE {|| .NOT.mTxtOSField=2 } @ 2,2 DCSAY SPACE(42) PARENT oGroup20 EDITPROTECT {|| .NOT.mTxtOSField=2 } HIDE {|| .NOT.mTxtOSField=2 } ******************************** mStrinFrame = mStrinFrame+15.0 ******************************** D = 50;h = 0.25 @mStrinFrame, 0 DCGROUP oGroup13 CAPTION L('Какие наименования ГРАДАЦИЙ числовых шкал использовать:' ) SIZE mWidthFrame*2+3, 4.5 @ 1 , 2 DCRADIO mNameGrNumSc VALUE 1 PROMPT L('Только интервальные числовые значения' ) PARENT oGroup13 SIZE 0 @ 1+h, D DCSAY L('(например: "1/3-{59873.0000000, 178545.6666667}")' ) PARENT oGroup13 SIZE 0 @ 2 , 2 DCRADIO mNameGrNumSc VALUE 2 PROMPT L('Только наименования интервальных числовых значений' ) PARENT oGroup13 SIZE 0 @ 2+h, D DCSAY L('(например: "Минимальное")' ) PARENT oGroup13 SIZE 0 @ 3 , 2 DCRADIO mNameGrNumSc VALUE 3 PROMPT L('И интервальные числовые значения, и их наименования') PARENT oGroup13 SIZE 0 @ 3+h, D DCSAY L('(например: "Минимальное: 1/3-{59873.0000000, 178545.6666667}")' ) PARENT oGroup13 SIZE 0 * DCGETOPTIONS CASCADE // Позиционирование нового окна по вертикали DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; OPTIONS GetOptions ; ADDBUTTONS; MODAL ; TITLE L('2.3.2.2. Универсальный программный интерфейс импорта данных в систему "ЭЙДОС-X++"') *************************************************** IF lExit ** Button Ok ELSE ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF *************************************************** ************************************************************************************************************************************ IF M_XlsDbf=4 // CSV в разработке. Проблема с кодировкой. Данные не вводятся * DIRCHANGE(Disk_dir+'\AID_DATA\Inp_data\') // Перейти в папку: ..\AID_DATA\Inp_data\ * mFileCsv = Disk_dir+'\AID_DATA\Inp_data\Inp_data.csv' * mFileXls = Disk_dir+'\AID_DATA\Inp_data\Inp_data.xlsx' * CsvXls(mFileCsv, mFileXls) * DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы mFlag = CsvDbfConv() IF mFlag M_XlsDbf=3 ELSE ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ENDIF *DC_ASave(aSoftInt , Disk_dir +"\_2_3_2_2.arx") ********** Приведение в соответствие параметров режимов, введенных вручную и не вводимых при заданных вручную значениях *Сделать проверки: ***************** *Если заданы адаптивные интервалы *- и сценарный метод АСК-анализа *- и специальная интерпретация текстовых полей *то исправить значения 2.3.2.2 и выдать сообщение * ЕСЛИ НЕ Применить спец.интерпретацию текстовых полей классов, то сортировать и делать уникальные текстовые знания * ЕСЛИ Применить спец.интерпретацию текстовых полей признаков, то сортировать и делать уникальные текстовые знания M_Scenario = IF(mScenario=2, .T., .F.) // Если применяется сценарный метод АСК-анализа mFlag = .F. IF M_Scenario // Задан сценарный метод АСК-анализа aMess := {} AADD(aMess, L('Задан сценарный метод АСК-анализа')) IF mSpecInterprCls AADD(aMess, L(', а также специальная интерпретация текстовых полей классов')) mFlag = .T. ENDIF IF mSpecInterprAtr AADD(aMess, ' '+L('и специальная интерпретация текстовых полей признаков.')) mFlag = .T. ENDIF IF mFlag AADD(aMess, L('Поэтому сценарный метод АСК-анализа отключен')) IF mSpecInterprCls .OR. mSpecInterprAtr AADD(aMess, L('Поэтому спец. интерпретация тестовых полей отключена')) ENDIF AADD(aMess, L('и значения текстовых полей рассматриваются как целое.')) AADD(aMess, L('')) AADD(aMess, L('Если эти параметры не соответствуют текущей задаче, советуем')) AADD(aMess, L('повторно зайти в режим 2.3.2.2 и задать все параметры заново')) ERASE(Disk_dir +'\_2_3_2_2.arx') LB_Warning(aMess) mSpecInterprCls = .F. // Спец.интерпр.тестовых полей не применяется со сценарным методом АСК-анализа mSpecInterprAtr = .F. mTxtCSField = 1 // Значения TXT-полей классов рассматриваются как целое mTxtOSField = 1 // Значения TXT-полей признаков рассматриваются как целое mScenario = 1 // Отключить сценарный метод АСК-анализа M_Scenario = .F. ENDIF ENDIF IF mSpecInterprCls = .F. // .T. - Применить спец.интерпретацию текстовых полей классов, .F. - не применять mTxtCSField = 1 // Значения TXT-полей классов рассматриваются как целое mSortUnqCls = 1 // Выделять уникальные значения классов и сортировать, 1-да, 2-нет mLemmatCls = 2 // Проводить лемматизацию классов, 1-да, 2-нет ENDIF IF mSpecInterprAtr = .F. // .T. - Применить спец.интерпретацию текстовых полей признаков, .F. - не применять mTxtOSField = 1 // Значения TXT-полей признаков рассматриваются как целое mSortUnqGos = 1 // Выделять уникальные значения признаков и сортировать, 1-да, 2-нет mLemmatGos = 2 // Проводить лемматизацию призанков, 1-да, 2-нет ENDIF // Заглушки разрабатываемых режимов ############################################################ IF M_XlsDbf=4 LB_Warning(L('Опция: "Тип файла исходных данных: CSV => DBF конвертер, находится в разработке')) Running(.F.) RETURN NIL ENDIF IF mGlubMin * mGlubMax * mGorizMin * mGorizMax = 0 LB_Warning(L('Минимальные и максимальные глубина предыстории и горизонт прогнозирования должны быть больше нуля!')) Running(.F.) RETURN NIL ENDIF IF mGlubMin > mGlubMax LB_Warning(L('Минимальная глубина предыстории не может быть больше максимальной!')) Running(.F.) RETURN NIL ENDIF IF mGorizMin > mGorizMax LB_Warning(L('Минимальный горизонт прогнозирования не может быть больше максимального!')) Running(.F.) RETURN NIL ENDIF *MsgBox(STR(Regim)) DO CASE CASE Regim = 1 // Формирование шкал, градаций и обучающей выборки PUBLIC cExcelFile := 'Inp_data' PUBLIC cDbaseFile := cExcelFile // Создать новое пустое приложение * aSave_adds := DC_DataSave() // Сохранение вычислительной среды (открытые и текущие БД и индексы) DIRCHANGE(Disk_dir) ***** Создать новое пустое приложение или открыть ранее созданное в режиме 1.3 (это для лаб.работ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Appls EXCLUSIVE NEW N_Appl = RECCOUNT() // Кол-во приложений aSave_adds := DC_DataSave() // Сохранение вычислительной среды (открытые и текущие БД и индексы) FlagAppl = .T. // Если .T. - новое приложение, если .F. - то уже имеющееся (не используется) IF LEN(ALLTRIM(mApplName)) > 0 .AND. N_Appl > 0 // Это для лаб.работ, т.к. для них приложение с нужным именем создается при установке лаб.работы SELECT Appls DBGOTOP() DO WHILE .NOT. EOF() IF LEN(ALLTRIM(BY_DEFAULT )) > 0 FlagAppl = .F. mApplName = ALLTRIM(Name_Appl) M_NewAppl = ALLTRIM(PATH_APPL) ENDIF DBSKIP(1) ENDDO ELSE mApplName = IF(LEN(ALLTRIM(mApplName)) > 0, ALLTRIM(mApplName), L('Приложение, созданное путем ввода даных из БД Inp_data. Это название надо скорректировать в режиме 1.3!' )) M_NewAppl = ADD_ZAPPL(mApplName) * MsgBox(M_NewAppl) // Создать основные БД нового приложения ********************************************** DIRCHANGE(M_NewAppl) // Перейти в папку с БД новой модели и создать БД формализации предметной области: GenDbfClSc(.F.) // Классификационные шкалы GenDbfGrClSc(.F.) // Градации классификационных шкал GenDbfClass(.F.) // Классификационные шкалы и градации GenDbfOpSc(.F.) // Описательные шкалы GenDbfGrOpSc(.F.) // Градации описательных шкал GenDbfAttr(.F.) // Описательные шкалы и градации GenDbfObiZag() // Заголовки объектов обучающей выборки GenDbfObiKcl() // Коды классов объектов обучающей выборки GenDbfObiKpr() // Коды признаков объектов обучающей выборки GenDbfRsoZag() // Заголовки объектов распознаваемой выборки GenDbfRsoKcl() // Коды классов объектов распознаваемой выборки GenDbfRsoKpr() // Коды признаков объектов распознаваемой выборки *************************************************************************************** ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций **################################################################################################################################ ** ИЗ КАКОЙ ФУНКЦИИ ЗАПУЩЕН РЕЖИМ 2.3.2.2()? IF LEN(ALLTRIM(mFunctName)) > 0 // Если файл с номером ранее запущенного режима существует, то выдать сообщение о необходимости предварительного закрытия создавшей его функции IF AT("1.3()", mFunctName) > 0 // Если запуск из режима 1.3, то разрешать открывать окно 2.3.2.2() IF ApplChange("") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF ELSE IF ApplChange("2.3.2.2()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF ENDIF ENDIF **################################################################################################################################ M_NewAppl = ALLTRIM(M_NewAppl) ** XLS - имя файла базы исходных данных: Inp_data.xls **************************** IF M_XlsDbf=1 // Определить, есть ли файлы в папке: AID_DATA\Inp_data DIRCHANGE(Disk_dir+"\AID_DATA\Inp_data\") IF .NOT. FILE("Inp_data.xls") Mess = L('В папке: '+M_ApplsPath+'\Inp_data\ должен быть файл: "Inp_data.xls"') LB_Warning(Mess) Help2322xls() // Пояснение о назначении режима ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF Flag_InpRasp = .T. IF .NOT. FILE("Inp_rasp.xls") Flag_InpRasp = .F. ENDIF DIRCHANGE(Disk_dir) // Скопировать в новое приложение файл: Inp_data.xls Name_SS = Disk_dir+"\AID_DATA\Inp_data\Inp_data.xls" Name_DD = M_NewAppl +"Inp_data.xls" COPY FILE (Name_SS) TO (Name_DD) *** ПРЕОБРАЗОВАНИЕ EXCEL-ФАЙЛА Inp_data.xls в БД: Inp_data.dbf *** и файл наименований классификационных и описательных шкал: Inp_name.txt cExcelFile = cExcelFile + '.xls' mFlag = LC_Excel2WorkArea( cExcelFile, M_NewAppl ) IF mFlag Name_SS = M_NewAppl +"Inp_data.dbf" Name_DD = Disk_dir+"\AID_DATA\Inp_data\Inp_data.dbf" COPY FILE (Name_SS) TO (Name_DD) ENDIF * MsgBox('STOP') IF .NOT. mFlag LB_Warning(L('Исправьте файл исходных данных !'), L('2.3.2.2. Универсальный программный интерфейс импорта данных в систему "ЭЙДОС-X++"' )) Help2322xls() // Пояснение о назначении режима ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF *********************************************************************************************** // Если считать нули и пробелы отсуствием данных, то удалить из БД исходных данных Inp_data.dbf // все неописанные объекты обучающей выборки *********************************************************************************************** IF Flag_zer = 1 oScrn := DC_WaitOn( L('Удаление неописанных объектов из БД Inp_data.dbf' )) aObjDel := {} AADD(aObjDel, L('Номера записей и наименования удаленных объектов обучающей выборки'),,,,,,,,,,,.F.) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Inp_data EXCLUSIVE NEW SELECT Inp_data aFields = DC_ARestore(Disk_dir+'/_FieldName.arx') // Загрузка массива наименований всех полей файла Inp_data из папки с системой для использования при включенном ADS DBGOTOP() mFlagPack = .F. DO WHILE .NOT. EOF() mFlagZ = .T. // Все числовые поля записи равны нулю и все текстовые пробелу FOR j=M_OpSc1 TO M_OpSc2 mVal = FIELDGET(j) IF .NOT. EMPTY(mVal) mFlagZ = .F. EXIT ENDIF * DO CASE * CASE VALTYPE(mVal) = 'N' * IF mVal <> 0 * mFlagZ = .F. * EXIT * ENDIF * CASE VALTYPE(mVal) = 'C' * IF LEN(ALLTRIM(mVal)) > 0 * mFlagZ = .F. * EXIT * ENDIF * ENDCASE NEXT IF mFlagZ // Если в описании объекта были числовые поля и они все были равны нулю DELETE // Если в описании объекта были текстовые поля и они все были равны пробелу mFlagPack = .T. mVal = FIELDGET(1) DO CASE CASE VALTYPE(mVal) = 'N' AADD(aObjDel, ALLTRIM(STR(RECNO()))+' '+ALLTRIM(STR(mVal))) CASE VALTYPE(mVal) = 'C' AADD(aObjDel, ALLTRIM(STR(RECNO()))+' '+ALLTRIM(mVal)) ENDCASE ENDIF DBSKIP(1) ENDDO IF mFlagPack PACK ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * MsgBox('STOP') DC_ASave(aObjDel, "_ObjDel.arx") // Сохранение массива номеров и наименований удаленных объектов обучающей выборки DC_Impl(oScrn) ENDIF ENDIF ** XLSX - имя файла базы исходных данных: Inp_data.XLSX ************************** IF M_XlsDbf=2 // Определить, есть ли файлы в папке: AID_DATA\Inp_data DIRCHANGE(Disk_dir+"\AID_DATA\Inp_data\") IF .NOT. FILE("Inp_data.xlsx") Mess = L('В папке: '+M_ApplsPath+'\Inp_data\ должен быть файл: "Inp_data.xlsx"') LB_Warning(Mess) Help2322xls() // Пояснение о назначении режима ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF Flag_InpRasp = .T. IF .NOT. FILE("Inp_rasp.xlsx") Flag_InpRasp = .F. ENDIF DIRCHANGE(Disk_dir) // Скопировать в новое приложение файл: Inp_data.xlsx Name_SS = Disk_dir+"\AID_DATA\Inp_data\Inp_data.xlsx" Name_DD = M_NewAppl +"Inp_data.xlsx" COPY FILE (Name_SS) TO (Name_DD) *** ПРЕОБРАЗОВАНИЕ EXCEL-ФАЙЛА Inp_data.xlsx в БД: Inp_data.dbf *** и файл наименований классификационных и описательных шкал: Inp_name.txt cExcelFile = cExcelFile + '.xlsx' mFlag = LC_Excel2WorkArea( cExcelFile, M_NewAppl ) IF mFlag Name_SS = M_NewAppl +"Inp_data.dbf" Name_DD = Disk_dir+"\AID_DATA\Inp_data\Inp_data.dbf" COPY FILE (Name_SS) TO (Name_DD) ENDIF IF .NOT. mFlag LB_Warning(L('Исправьте файл исходных данных !'), L('2.3.2.2. Универсальный программный интерфейс импорта данных в систему "ЭЙДОС-X++"' )) Help2322xls() // Пояснение о назначении режима ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF *********************************************************************************************** // Если считать нули и пробелы отсуствием данных, то удалить из БД исходных данных Inp_data.dbf // все неописанные объекты обучающей выборки *********************************************************************************************** IF Flag_zer = 1 oScrn := DC_WaitOn( L('Удаление неописанных объектов из БД Inp_data.dbf' ),,,,,,,,,,,.F.) aObjDel := {} AADD(aObjDel, 'Номера записей и наименования удаленных объектов обучающей выборки') CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Inp_data EXCLUSIVE NEW SELECT Inp_data DBGOTOP() mFlagPack = .F. DO WHILE .NOT. EOF() mFlagZ = .T. // Все числовые поля записи равны нулю и все текстовые пробелу FOR j=M_OpSc1 TO M_OpSc2 mVal = FIELDGET(j) IF .NOT. EMPTY(mVal) mFlagZ = .F. EXIT ENDIF * DO CASE * CASE VALTYPE(mVal) = 'N' * IF mVal <> 0 * mFlagZ = .F. * EXIT * ENDIF * CASE VALTYPE(mVal) = 'C' * IF LEN(ALLTRIM(mVal)) > 0 * mFlagZ = .F. * EXIT * ENDIF * ENDCASE NEXT IF mFlagZ // Если в описании объекта были числовые поля и они все были равны нулю DELETE // Если в описании объекта были текстовые поля и они все были равны пробелу mFlagPack = .T. mVal = FIELDGET(1) DO CASE CASE VALTYPE(mVal) = 'N' AADD(aObjDel, ALLTRIM(STR(RECNO()))+' '+ALLTRIM(STR(mVal))) CASE VALTYPE(mVal) = 'C' AADD(aObjDel, ALLTRIM(STR(RECNO()))+' '+ALLTRIM(mVal)) ENDCASE ENDIF DBSKIP(1) ENDDO IF mFlagPack PACK ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * MsgBox('STOP') DC_ASave(aObjDel, "_ObjDel.arx") // Сохранение массива номеров и наименований удаленных объектов обучающей выборки DC_Impl(oScrn) ENDIF ENDIF ** DBF - имя файла базы исходных данных: Inp_data.DBF **************************** IF M_XlsDbf=3 // Определить, есть ли файлы в папке: AID_DATA/Inp_data DIRCHANGE(Disk_dir+"/AID_DATA/Inp_data/") IF .NOT. FILE("Inp_data.dbf") Mess = L('В папке: '+M_ApplsPath+'\Inp_data\ должен быть файл: "Inp_data.dbf"') LB_Warning(Mess) Help2322dbf() // Пояснение о назначении режима ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF IF .NOT. FILE("Inp_name.txt") Mess = L('В папке: '+M_ApplsPath+'Inp_data\ должен быть файл: "Inp_name.txt"') LB_Warning(Mess) Help2322dbf() // Пояснение о назначении режима ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ENDIF ** CSV => DBF конвертер - имя файла базы исходных данных: Inp_data.CSV *********** ** Тип файла исходных данных: CSV - Comma-Separated Values" ********************** IF M_XlsDbf=4 // CSV в разработке. Проблема с кодировкой. Данные не вводятся CsvDbfConv() ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF IF M_XlsDbf=4 // Определить, есть ли файлы в папке: AID_DATA/Inp_data DIRCHANGE(Disk_dir+"/AID_DATA/Inp_data/") IF .NOT. FILE("Inp_data.csv") Mess = L('В папке: '+M_ApplsPath+'\Inp_data\ должен быть файл: "Inp_data.csv"') LB_Warning(Mess) Help2322dbf() // Пояснение о назначении режима ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF IF .NOT. FILE("Inp_name.txt") Mess = L('В папке: '+M_ApplsPath+'Inp_data\ должен быть файл: "Inp_name.txt"') LB_Warning(Mess) Help2322dbf() // Пояснение о назначении режима ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ENDIF * IF M_XlsDbf=3 .OR. M_XlsDbf=4 **** ############################################################################################################################# **** Если ввод исходных данных был из Inp_data.dbf сделать эти файлы из Inp_name.txt в папке приложения и в ..\Aid_data\Inp_data\: **** ############################################################################################################################# ********* Загрузить файл Inp_name.txt и сформировать массив: aColumnNames DIRCHANGE(M_ApplsPath+"Inp_data\") CrLf = CHR(13)+CHR(10) // Конец строки (абзаца) (CrLf) M_InpName = ALLTRIM(FILESTR('Inp_name.txt')) // Загрузка Inp_name.txt M_InpName = "Object" + CrLf + STRTRAN(M_InpName,CHR(26),"") + CrLf // Вместо поля Object M_InpNameALL = M_InpName * LB_Warning(M_InpName) aInp_name := {} aColumnNames := {} FOR ff=1 TO NUMTOKEN(M_InpName,CrLf) * MsgBox(STR(ff)+SUBSTR(UPPER(ALLTRIM(TOKEN(M_InpName,CrLf,ff))),1,255)) AADD(aInp_name , SUBSTR(UPPER(ALLTRIM(TOKEN(M_InpName,CrLf,ff))),1,255)) // Ограничение длины наименования шкалы 255 символов AADD(aColumnNames, SUBSTR(UPPER(ALLTRIM(TOKEN(M_InpName,CrLf,ff))),1,255)) // Ограничение длины наименования шкалы 255 символов NEXT **** Наименования колонок со 1-й по последнюю CrLf = CHR(13)+CHR(10) // Конец строки (абзаца) (CrLf) mCol_name = "" FOR j=1 TO LEN(aColumnNames) // 1-ю колонку включаем в Inp_nameAll.txt, для других целей mNameJ = ALLTRIM(aColumnNames[j]) mNameJ = UPPER(SUBSTR(mNameJ,1,1)) + SUBSTR(mNameJ,2) // Сделать первые символы заголовков колонок большими, а остальные оставить как есть mCol_name = mCol_name + mNameJ + CrLf NEXT StrFile( M_InpNameALL, M_NewAppl +"/Inp_nameAll.txt") // Добавить путь на папку Inp_data DC_ASave(aColumnNames, M_NewAppl +"/_ColumnNames.arx") // Запись массива наименований шкал (колонок) в виде файла DC_ASave(aInp_name , M_NewAppl +"/_Inp_name.arx") // Запись массива наименований шкал (колонок) в виде файла StrFile( M_InpNameALL, M_ApplsPath+"/Inp_data/Inp_nameAll.txt") // Добавить путь на папку Inp_data DC_ASave(aColumnNames, M_ApplsPath+"/Inp_data/_ColumnNames.arx") // Запись массива наименований шкал (колонок) в виде файла DC_ASave(aInp_name , M_ApplsPath+"/Inp_data/_Inp_name.arx") // Запись массива наименований шкал (колонок) в виде файла * aInp_name = DC_ARestore(M_NewAppl +"/_Inp_name.arx") // Загрузка массива наименований шкал (колонок) из файла * ENDIF IF M_XlsDbf=4 // CSV в разработке. Проблема с кодировкой. Данные не вводятся Razrab() ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ** CSV - имя файла базы исходных данных: Inp_data.CSV **************************** ** Тип файла исходных данных: CSV - Comma-Separated Values" ********************** IF M_XlsDbf=4 *********************************************************************************************** // Преобразование Inp_data.csv в Inp_data.dbf *********************************************************************************************** *** Создать структуру файла: Inp_data.dbf основываясь на Inp_name.txt *** Создать Inp_data.dbf с избыточными размерами полей (255) aStructure := {} FOR j=1 TO LEN(aInp_name) AADD(aStructure, { "N"+ALLTRIM(STR(j)), "C", 255, 0 } ) NEXT * LB_Warning(aInp_name) // Отладка * DC_DebugQout( aStructure ) // Отладка DbCreate( 'InpDataTMP', aStructure ) *** Преобразовать в Inp_data.dbf 1000 записей из Inp_data.csv oScrn := DC_WaitOn( L('Определение минимальных достаточных размеров полей БД "Inp_data.dbf"' ),,,,,,,,,,,.F.) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE InpDataTMP EXCLUSIVE NEW SELECT InpDataTMP * APPEND FROM Inp_data.csv DELIMITED WITH ";" * APPEND FROM Inp_data.csv RECORD 1000 DELIMITED WITH ";" * APPEND FROM Inp_data.csv WHILE RECNO() <= 1000 DELIMITED WITH ";" APPEND FROM Inp_data.csv DELIMITED *** Определить минимальные достаточные для размещения данных размеры полей SELECT InpDataTMP PRIVATE aLenField[LEN(aInp_name)] AFILL(aLenField, 1) DBGOTOP();DELETE;PACK;DBGOTOP() // Удалить строку заголовков колонок *** Может быть минимальные достаточные размеры полей определить по-другому FOR j=1 TO LEN(aInp_name) ***** 1-й вариант (предпочтительный) * INDEX ON STR(LEN(ALLTRIM(FIELDNAME(j))),3) TO Inp_data * DBGOBOTTOM() * aLenField[j] = MAX(aLenField[j], LEN(ALLTRIM(FIELDGET(j)))) ***** 2-й вариант (работающий) mRec = 0 DBGOTOP() DO WHILE .NOT. EOF() .AND. ++mRec < 1000 aLenField[j] = MAX(aLenField[j], LEN(ALLTRIM(FIELDGET(j)))) DBSKIP(1) ENDDO NEXT DC_Impl(oScrn) *** Создать БД Inp_data.dbf c минимальными достаточными для размещения данных размерами полей oScrn := DC_WaitOn( L('Конвертирование "Inp_data.csv" ===> "Inp_data.dbf"' ),,,,,,,,,,,.F.) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций aStructure := {} FOR j=1 TO LEN(aInp_name) AADD(aStructure, { "N"+ALLTRIM(STR(j)), "C", aLenField[j], 0 } ) NEXT DbCreate( 'Inp_data', aStructure ) *** Преобразовать весь файл Inp_data.csv в Inp_data.dbf CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Inp_data EXCLUSIVE NEW SELECT Inp_data APPEND FROM Inp_data.csv DELIMITED DBGOTOP();DELETE;PACK;DBGOTOP() // Удалить строку заголовков колонок DC_Impl(oScrn) *** Потом все делать как с Inp_data.dbf ENDIF *********************************************************************************************** // Если считать нули и пробелы отсуствием данных, то удалить из БД исходных данных Inp_data.dbf // все неописанные объекты обучающей выборки *********************************************************************************************** IF Flag_zer = 1 oScrn := DC_WaitOn( L('Удаление неописанных объектов из БД Inp_data.dbf' )) aObjDel := {} AADD(aObjDel, L('Номера записей и наименования удаленных объектов обучающей выборки'),,,,,,,,,,,.F.) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Inp_data EXCLUSIVE NEW SELECT Inp_data DBGOTOP() mFlagPack = .F. DO WHILE .NOT. EOF() mFlagZ = .T. // Все числовые поля записи равны нулю и все текстовые пробелу FOR j=M_OpSc1 TO M_OpSc2 mVal = FIELDGET(j) IF .NOT. EMPTY(mVal) mFlagZ = .F. EXIT ENDIF * DO CASE * CASE VALTYPE(mVal) = 'N' * IF mVal <> 0 * mFlagZ = .F. * EXIT * ENDIF * CASE VALTYPE(mVal) = 'C' * IF LEN(ALLTRIM(mVal)) > 0 * mFlagZ = .F. * EXIT * ENDIF * ENDCASE NEXT IF mFlagZ // Если в описании объекта были числовые поля и они все были равны нулю DELETE // Если в описании объекта были текстовые поля и они все были равны пробелу mFlagPack = .T. mVal = FIELDGET(1) DO CASE CASE VALTYPE(mVal) = 'N' AADD(aObjDel, ALLTRIM(STR(RECNO()))+' '+ALLTRIM(STR(mVal))) CASE VALTYPE(mVal) = 'C' AADD(aObjDel, ALLTRIM(STR(RECNO()))+' '+ALLTRIM(mVal)) ENDCASE ENDIF DBSKIP(1) ENDDO IF mFlagPack PACK ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * MsgBox('STOP') DC_ASave(aObjDel, "_ObjDel.arx") // Сохранение массива номеров и наименований удаленных объектов обучающей выборки DC_Impl(oScrn) ENDIF * **** Нумерация строк в файле Inp_data.dbf * oScrn := DC_WaitOn( L('Нумерация объектов обучающей выборки в БД Inp_data.dbf',,,,,,,,,,,.F. ) * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * USE Inp_data EXCLUSIVE NEW * SELECT Inp_data * DBGOTOP() * DO WHILE .NOT. EOF() * FIELDPUT(1, RECNO()) * DBSKIP(1) * ENDDO * DC_Impl(oScrn) * MsgBox('STOP') Flag_InpRasp = .T. IF .NOT. FILE("Inp_rasp.dbf") Flag_InpRasp = .F. ENDIF // Скопировать в новое приложение файлы Inp_data.dbf и Inp_name.txt DIRCHANGE(Disk_dir) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций Name_SS = Disk_dir+"\AID_DATA\Inp_data\Inp_data.dbf" Name_DD = ALLTRIM(M_NewAppl) +"Inp_data.dbf" * MsgBox(Name_SS+' => '+Name_DD) COPY FILE (Name_SS) TO (Name_DD) // ######################################################################## Name_SS = Disk_dir+"\AID_DATA\Inp_data\Inp_name.txt" Name_DD = ALLTRIM(M_NewAppl) +"Inp_name.txt" COPY FILE (Name_SS) TO (Name_DD) // Если в папке Inp_data есть БД Inp_rasp.dbf, то скопировать ее в папку приложения, иначе - записать с ее именем БД Inp_data.dbf (?) IF Flag_InpRasp Name_SS = Disk_dir+"\AID_DATA\Inp_data\Inp_rasp.dbf" ELSE Name_SS = Disk_dir+"\AID_DATA\Inp_data\Inp_data.dbf" ENDIF Name_DD = ALLTRIM(M_NewAppl) +"Inp_rasp.dbf" * MsgBox(Name_SS+' => '+Name_DD) // <<<===################################################################## Когда на xls-dbf конвертер на Питоне, то не работает COPY FILE (Name_SS) TO (Name_DD) CASE Regim = 2 // Формирование распознаваемой выборки PUBLIC cExcelFile := 'Inp_rasp' PUBLIC cDbaseFile := cExcelFile IF ApplChange("") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF IF .NOT.FILE(Disk_dir+"\_2_3_2_2.arx") LB_Warning(L('Необходимо сначала выполнить генерацию шкал и обучающей выборки!'), L('2.3.2.2. Универсальный программный интерфейс импорта данных в систему "ЭЙДОС-X++"' )) Running(.F.) RETURN NIL ENDIF DO CASE CASE M_XlsDbf=1 // XLS cExcelFile = cExcelFile + '.xls' CASE M_XlsDbf=2 // XLSX cExcelFile = cExcelFile + '.xlsx' CASE M_XlsDbf=3 // DBF cExcelFile = cExcelFile + '.dbf' ENDCASE // Определить, есть ли в папке: AID_DATA/Inp_data/ файл Inp_rasp.xls (xlsx) // если есть, то скопировать его в папку приложения, иначе - выдать сообщение CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir+"\AID_DATA\Inp_data\") //########################################################### * MsgBox(Disk_dir+"\AID_DATA\Inp_data\"+cExcelFile) IF FILE(cExcelFile) // Скопировать в новое приложение файлы Inp_data.dbf и Inp_name.txt DIRCHANGE(Disk_dir) Name_SS = Disk_dir+"\AID_DATA\Inp_data\"+cExcelFile Name_DD = M_PathAppl+cExcelFile // Путь на текущее приложение * MsgBox(Name_SS+' => '+Name_DD) COPY FILE (Name_SS) TO (Name_DD) ELSE Mess = L('В папке:')+' '+M_ApplsPath+L('\Inp_data\ должен быть файл: "')+cExcelFile+'"' LB_Warning(Mess, L('2.3.2.2. Универсальный программный интерфейс импорта данных в систему "ЭЙДОС-X++"' )) Help2322xls() // Пояснение о назначении режима Running(.F.) RETURN NIL ENDIF IF M_XlsDbf = 1 .OR. M_XlsDbf = 2 mFlag = LC_Excel2WorkArea( cExcelFile, M_PathAppl ) // Преобразование файла Inp_rasp.xls (xlsx) в Inp_rasp.dbf * MsgBox(cExcelFile) IF mFlag Name_SS = M_PathAppl +"Inp_rasp.dbf" Name_DD = Disk_dir+"\AID_DATA\Inp_data\Inp_rasp.dbf" COPY FILE (Name_SS) TO (Name_DD) ENDIF IF .NOT. mFlag LB_Warning(L('Исправьте файл исходных данных !'), L('2.3.2.2. Универсальный программный интерфейс импорта данных в систему "ЭЙДОС-X++"' )) Help2322xls() // Пояснение о назначении режима Running(.F.) RETURN NIL ENDIF ENDIF ENDCASE ******* Передача данных в лемматизацию PRIVATE aSoftInt[40] aSoftInt[ 1] = Regim aSoftInt[ 2] = Flag_zer aSoftInt[ 3] = M_ClSc1 aSoftInt[ 4] = M_ClSc2 aSoftInt[ 5] = M_OpSc1 aSoftInt[ 6] = M_OpSc2 aSoftInt[ 7] = N_SKGrCl aSoftInt[ 8] = N_SKGrPr aSoftInt[ 9] = K_N_ClSc aSoftInt[10] = K_N_OpSc aSoftInt[11] = K_N_GrClSc aSoftInt[12] = K_N_GrOpSc aSoftInt[13] = M_ObAnk aSoftInt[14] = N_Chast aSoftInt[15] = M_Interval aSoftInt[16] = M_Scenario aSoftInt[17] = K_GradNClSc // Количество градаций в числовой классификационной шкале aSoftInt[18] = K_GradNOpSc // Количество градаций в числовой описательной шкале aSoftInt[19] = mGorizMin aSoftInt[20] = mGorizMax aSoftInt[21] = mGlubMin aSoftInt[22] = mGlubMax aSoftInt[23] = M_ChastObi aSoftInt[24] = M_ChastRso aSoftInt[25] = N_ChastObi aSoftInt[26] = N_ChastRso aSoftInt[27] = M_XlsDbf aSoftInt[28] = mTxtCSField aSoftInt[29] = mTxtOSField aSoftInt[30] = mTxtCSSep aSoftInt[31] = mTxtOSSep *aSoftInt[32] = mScenario // mScenario=1 Не применять сценарный метод АСК-анализа и спец.интерпретацию TXT-полей (старый вариант) aSoftInt[32] = mScenario // mScenario=1 Не применять сценарный метод АСК-анализа aSoftInt[33] = mSpecInterprCls // Применить спец.интерпретацию текстовых полей классов aSoftInt[34] = mSpecInterprAtr // Применить спец.интерпретацию текстовых полей признаков aSoftInt[35] = mNameGrNumSc // Какие наименования ГРАДАЦИЙ числовых шкал использовать aSoftInt[36] = mClsAvr // .F. = модель без усреднения по классам aSoftInt[37] = mSortUnqCls // Выделять уникальные значения классов и сортировать, 1-да, 2-нет aSoftInt[38] = IF(mSpecInterprCls,mLemmatCls,2) // Проводить лемматизацию классов, 1-да, 2-нет aSoftInt[39] = mSortUnqGos // Выделять уникальные значения признаков и сортировать, 1-да, 2-нет aSoftInt[40] = IF(mSpecInterprAtr,mLemmatGos,2) // Проводить лемматизацию признаков, 1-да, 2-нет DC_ASave(aSoftInt , Disk_dir +"\_2_3_2_2.arx") *************************************************************************************************** **** Проверить все колонки Inp_data.dbf (а Inp_rasp.dbf проверять не надо) на вариабельность значений, **** Сделать массив номеров колонок со значениями: .T., если есть варибельность, и .F., если ее нет **** При форм.предм.области записать этот массив в виде файла arx, а при распознавании скачать и использовать <===#########################################, **** Если такие колонки есть, то сделать об этом сообщение (типа того, что есть в конце), **** При всех обработках колонок в Inp_data.dbf и Inp_rasp.dbf пропускать эти колонки DO CASE CASE Regim=1 DIRCHANGE(Disk_dir +"\AID_DATA\Inp_data\") CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Inp_data EXCLUSIVE NEW SELECT Inp_data PRIVATE aErrorNum[FCOUNT()] AFILL(aErrorNum,.F.) // Массив для обхода колонок, в которых нет варабельности FOR ff=2 TO FCOUNT() DBGOTOP() mFv = FIELDGET(ff) DO WHILE .NOT. EOF() IF mFv <> FIELDGET(ff) // Если значение поля в первой записи отличается от какого-нибудь другого aErrorNum[ff] = .T. EXIT ENDIF DBSKIP(1) ENDDO NEXT *** Отладка ************** *DC_DebugQout( aInp_name ) *LB_Warning(aInp_name) *LB_Warning(aErrorNum) aErrorVar := {} // Номера и имена колонок, в которых нет варабельности (для сообщения) IF LEN(aInp_name) > 0 FOR ff=2 TO LEN(aErrorNum) IF .NOT. aErrorNum[ff] IF ff-1 <= LEN(aInp_name) AADD(aErrorVar, '['+ALLTRIM(STR(ff))+'] - "'+ALLTRIM(aInp_name[ff])+'"') ENDIF ENDIF NEXT ENDIF DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы * aErrorNum = DC_ARestore(Disk_dir +"\_ErrorNum.arx") DC_ASave(aErrorNum , Disk_dir +"\_ErrorNum.arx") DIRCHANGE(Disk_dir +"\AID_DATA\Inp_data\") CASE Regim=2 DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы aErrorNum = DC_ARestore(Disk_dir +"\_ErrorNum.arx") * DC_ASave(aErrorNum , Disk_dir +"\_ErrorNum.arx") DIRCHANGE(Disk_dir +"\AID_DATA\Inp_data\") CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Inp_rasp EXCLUSIVE NEW SELECT Inp_rasp ENDCASE *************************************************************************************************** **** Скопировать Inp_data.dbf или Inp_rasp.dbf из папки приложения в AID_DATA/INP_DATA **** или проверять их наличие в папке приложения *MsgBox(STR(mLemmatCls)+STR(mLemmatGos)) IF mLemmatCls=1 .OR. mLemmatGos=1 Lemma2322(.T., Regim) // Лемматизация ####################################################### ENDIF *MsgBox(STR(Regim)) ********* Для отображения наименований шкал без вариабельности градаций после окончания режима 2.3.2.2. IF ApplChange("") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения (не убирать! Это НУЖНО!) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF *** Эти файлы записываются программой преобразования из Excel в DBF * DC_ASave(aInp_name, "_ColumnNames.arx") // Запись массива наименований шкал (колонок) в виде файла * DC_ASave(aInp_name, "_Inp_name.arx") // Запись массива наименований шкал (колонок) в виде файла aInp_name = DC_ARestore("_Inp_name.arx") // Загрузка массива наименований шкал (колонок) из файла // Создание БД для отображения результатов шкалирования и базы событий ************************ * "СУММАРНОЕ КОЛИЧЕСТВО ШКАЛ И ГРАДАЦИЙ СИМ(кл/пр):[####### x #######]" * "╔═══════════╦═════════════════════════╦═════════════════════════╗" * "║ ║ Классификационные ║ Описательные ║" * "║ ╟────────┬────────┬───────╫────────┬────────┬───────╢" * "║ ║ Шкалы │Градации│ Гр/шк ║ Шкалы │Градации│ Гр/шк ║" * "╠═══════════╬════════╪════════╪═══════╬════════╪════════╪═══════╣" * "║ Числовые ║####### │####### │###### ║####### │####### │###### ║" * "╟───────────╫────────┼────────┼───────╫────────┼────────┼───────╢" * "║ Текстовые ║####### │####### │###### ║####### │####### │###### ║" * "╠═══════════╬════════╪════════╪═══════╬════════╪════════╪═══════╣" * "║ ВСЕГО: ║####### │####### │###### ║####### │####### │###### ║" * "╚═══════════╩════════╧════════╧═══════╩════════╧════════╧═══════╝" * 12345678901234567890123456789012345678901234567890123456789012345 * 10 21 30 39 47 56 65 ***** Создание БД ScaleAll ********************** cFileName := "ScaleAll.dbf" aStructure := { { "Data_Type" , "C", 9, 0 }, ; { "Cl_Scale" , "N", 15, 0 }, ; { "GrCl_Scal" , "N", 15, 0 }, ; { "Gr_ClSc" , "N", 15, 2 }, ; { "Op_Scale" , "N", 15, 0 }, ; { "GrOp_Scal" , "N", 15, 0 }, ; { "Gr_OpSc" , "N", 15, 2 } } DbCreate( cFileName, aStructure ) *********************************************************************************************** *MsgBox(STR(Regim)) IF Regim = 1 // Генерация шкал, градаций и обучающей выборки ************************ * MsgBox('STOP') ***** Создание БД EventsKO ********************* CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Inp_data EXCLUSIVE NEW;N_Obj = RECCOUNT() // С ADS иногда возникает ошибка при попытке индексирования в строке 1839 <<<===################### aFieldName := {} aFieldSize := {} DbeSetDefault("DBFNTX") // ADS OFF FOR j=1 TO FCOUNT() mFS = FIELDSIZE(j) AADD(aFieldName, ALLTRIM(FIELDNAME(j))) AADD(aFieldSize, ALLTRIM(STR(IF(mFS<=25,mFS,25)))) NEXT DO CASE CASE mADStxt = 'OFF' DbeSetDefault("DBFNTX") // ADS OFF CASE mADStxt = 'ON' DbeSetDefault("ADSDBE") // ADS ON ENDCASE IF N_Obj = 0 aMess := {} AADD(aMess, L('Файл: "INP_DATA (.XLS, .DBF, .CSV)" в папке: '+Disk_dir+"\AID_DATA\Inp_data\"+' должен быть не пустой,')) AADD(aMess, L('т.е. содержать данные об объектах обучающей выборки')) LB_Warning(aMess) Help2322dbf() // Пояснение о назначении режима Running(.F.) RETURN NIL ENDIF SELECT Inp_data mLF = IF(mScenario=1, FIELDSIZE(1), 255) // Из-за сценариев надо делать МАКСИМАЛЬНУЮ длину поля наименования <<<===########### aStructure := { { "Name_obj" , "C",mLF, 0} } FOR j=2 TO FCOUNT() Fv = FIELDGET(j) // Наименование объекта обучающей выборки mFieldName = FIELDNAME(j) AADD(aStructure, { mFieldName , "N", 8, 0 }) NEXT AADD(aStructure, { "MemoCls", "M", 10, 0 }) AADD(aStructure, { "MemoAtr", "M", 10, 0 }) DbCreate( "EventsKO.dbf", aStructure ) // База событий для обучающей выборки aStructure := { { "Name_obj" , "C",mLF, 0} } FOR j=2 TO FCOUNT() Fv = FIELDGET(j) // Наименование объекта обучающей выборки mFieldName = FIELDNAME(j) AADD(aStructure, { mFieldName , "N", 8, 0 }) NEXT AADD(aStructure, { "MemoCls", "C", 255, 0 }) AADD(aStructure, { "MemoAtr", "C", 255, 0 }) DbCreate( "EventsKOs.dbf", aStructure ) // База событий для обучающей выборки ДЛЯ ОТЛАДКИ <<<===################### USE EventsKOs EXCLUSIVE NEW PUBLIC mRecSizeEvKOs := RECSIZE() ENDIF IF Regim = 2 ***** Создание БД EventsKR ********************* CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Inp_rasp EXCLUSIVE NEW;N_Obj = RECCOUNT() IF N_Obj = 0 aMess := {} AADD(aMess, L('Файл: "INP_RASP (.XLS, .DBF, .CSV)" в папке: '+Disk_dir+"\AID_DATA\Inp_rasp\"+' должен быть не пустой,')) AADD(aMess, L('т.е. содержать данные об объектах распознаваемой выборки')) LB_Warning(aMess) Help2322dbf() // Пояснение о назначении режима Running(.F.) RETURN NIL ENDIF SELECT Inp_rasp mLF = IF(mScenario=1, FIELDSIZE(1), 255) // Из-за сценариев надо делать максимальную длину поля наименования <<<===########### aStructure := { { "Name_obj" , "C",mLF, 0} } FOR j=2 TO FCOUNT() Fv = FIELDGET(j) // Наименование объекта распознаваемой выборки mFieldName = FIELDNAME(j) AADD(aStructure, { mFieldName , "N", 8, 0 }) NEXT AADD(aStructure, { "MemoCls", "M", 10, 0 }) AADD(aStructure, { "MemoAtr", "M", 10, 0 }) DbCreate( "EventsKR.dbf", aStructure ) // База событий для распознаваемой выборки aStructure := { { "Name_obj" , "C",mLF, 0} } FOR j=2 TO FCOUNT() Fv = FIELDGET(j) // Наименование объекта распознаваемой выборки mFieldName = FIELDNAME(j) AADD(aStructure, { mFieldName , "N", 8, 0 }) NEXT AADD(aStructure, { "MemoCls", "C", 255, 0 }) AADD(aStructure, { "MemoAtr", "C", 255, 0 }) DbCreate( "EventsKRs.dbf", aStructure ) // База событий для распознаваемой выборки ДЛЯ ОТЛАДКИ <<<+++################### USE EventsKRs EXCLUSIVE NEW PUBLIC mRecSizeEvKRs := RECSIZE() ENDIF *********************************************************************************************** ***** Сделать расчет количества числовых классификационных и описательных шкал ***** суммарное количество уникальных текстовых наименований в текстовых шкалах ***** и подсчитать максимальное кол-во интервалов, которое можно задавать в диалоге *********************************************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE ScaleAll EXCLUSIVE NEW IF Regim = 1 // Генерация шкал, градаций и обучающей выборки ************************ USE Inp_data EXCLUSIVE NEW // Здесь возникает ошибка открытия БД <===################# * USE Inp_data SHARED NEW // Здесь возникает ошибка открытия БД <===################# SELECT Inp_data ENDIF IF Regim = 2 // Генерация шкал, градаций и обучающей выборки ************************ USE Inp_rasp EXCLUSIVE NEW // Здесь возникает ошибка открытия БД <===################# SELECT Inp_rasp ENDIF N_Col = FCOUNT() IF M_ClSc1 = 1 LB_Warning(L('Начальный столбец классификационных шкал должен быть больше 1'),L('2.3.2.2. Универсальный программный интерфейс импорта данных в систему "ЭЙДОС-X++"')) Running(.F.) RETURN NIL ENDIF IF M_ClSc1 > N_Col LB_Warning(L('Начальный столбец класс.шкал не должен быть больше числа столбцов файла исходных данных: ')+ALLTRIM(STR(N_Col)),L('2.3.2.2. Универсальный программный интерфейс импорта данных в систему "ЭЙДОС-X++"')) Running(.F.) RETURN NIL ENDIF IF M_ClSc2 > N_Col LB_Warning(L('Конечный столбец класс.шкал не должен быть больше числа столбцов файла исходных данных: ')+ALLTRIM(STR(N_Col)),L('2.3.2.2. Универсальный программный интерфейс импорта данных в систему "ЭЙДОС-X++"')) Running(.F.) RETURN NIL ENDIF IF M_OpSc1 = 1 LB_Warning(L('Начальный столбец описательных шкал должен быть больше 1'),L('2.3.2.2. Универсальный программный интерфейс импорта данных в систему "ЭЙДОС-X++"')) Running(.F.) RETURN NIL ENDIF IF M_OpSc1 > N_Col LB_Warning(L('Начальный столбец опис.шкал не должен быть больше числа столбцов файла исходных данных: ')+ALLTRIM(STR(N_Col)),L('2.3.2.2. Универсальный программный интерфейс импорта данных в систему "ЭЙДОС-X++"')) Running(.F.) RETURN NIL ENDIF IF M_OpSc2 > N_Col LB_Warning(L('Конечный столбец опис.шкал не должен быть больше числа столбцов файла исходных данных: ')+ALLTRIM(STR(N_Col)),L('2.3.2.2. Универсальный программный интерфейс импорта данных в систему "ЭЙДОС-X++"')) Running(.F.) RETURN NIL ENDIF K_N_ClSc = 0 // Кол-во числовых классификационных шкал K_N_OpSc = 0 // Кол-во числовых описательных шкал K_C_ClSc = 0 // Кол-во текстовых классификационных шкал K_C_OpSc = 0 // Кол-во текстовых описательных шкал K_C_GrClSc = 0 // Кол-во градаций текстовых классификационных шкал K_C_GrOpSc = 0 // Кол-во градаций текстовых описательных шкал ***** Отображение стадии исполнения в кратком варианте ***************************************** nMax = FCOUNT()-1 nTime = 0 @ 4,5 DCPROGRESS oProgressm SIZE 70,1.1 MAXCOUNT nMax COLOR GRA_CLR_BLUE PERCENT EVERY 100 DCREAD GUI TITLE L('2.3.2.2. Подождите, идет поиск шкал и градаций !!!') PARENT @oDialogm FIT EXIT oDialogm:show() DC_GetProgress(oProgressm,0,nMax) ************************************************************************************************ ******* РАСЧЕТ КОЛИЧЕСТВА КЛАССИФИКАЦИОННЫХ И ОПИСАТЕЛЬНЫХ ШКАЛ *********** * K_N_ClSc // Кол-во числовых классификационных шкал * K_N_OpSc // Кол-во числовых описательных шкал * K_C_ClSc // Кол-во текстовых классификационных шкал * K_C_OpSc // Кол-во текстовых описательных шкал * K_N_GrClSc // Кол-во градаций числовых классификационных шкал * K_N_GrOpSc // Кол-во градаций числовых описательных шкал * K_C_GrClSc // Кол-во градаций текстовых классификационных шкал * K_C_GrOpSc // Кол-во градаций текстовых описательных шкал * DbeSetDefault("DBFNTX") // ADS OFF * DbeSetDefault("ADSDBE") // ADS ON FOR ff=2 TO FCOUNT() // Начало цикла по полям Inp_data.dbf Fv = FIELDGET(ff) DO CASE CASE FIELDTYPE(ff)="N" // Числовые столбцы DO CASE CASE M_ClSc1 <= ff .AND. ff <= M_ClSc2 // КЛАССИФИКАЦИОННЫЕ ШКАЛЫ: ++K_N_ClSc CASE M_OpSc1 <= ff .AND. ff <= M_OpSc2 // ОПИСАТЕЛЬНЫЕ ШКАЛЫ: ++K_N_OpSc ENDCASE *Function startfunction(cText) *Local bBlock := "{|| "+cText +"')}" *Local uResult *bBlock := &(bBlock) *uResult := eval(bBlock) *return uResult CASE FIELDTYPE(ff)="C" // Символьные столбцы * MsgBox('STOP') DO CASE CASE M_ClSc1 <= ff .AND. ff <= M_ClSc2 // КЛАССИФИКАЦИОННЫЕ ШКАЛЫ: ++K_C_ClSc DO CASE CASE mADStxt = 'OFF' DbeSetDefault("DBFNTX") // ADS OFF INDEX ON SUBSTR(FIELDGET(ff),1,256) TO Inp_tmp UNIQUE // Не работает в ADS <<<===################################ CASE mADStxt = 'ON' DbeSetDefault("ADSDBE") // ADS ON * INDEX ON PadRight(FIELDGET(ff),256,".") TO Inp_tmp UNIQUE // Работает в ADS, но не всегда. В ADS длина ключа индекса должна быть ФИКСИРОВАННОЙ * INDEX ON PadRight(FIELDGET(ff),256) TO Inp_tmp UNIQUE // Работает в ADS, но не всегда. В ADS длина ключа индекса должна быть ФИКСИРОВАННОЙ * INDEX ON PadRight(ALLTRIM(FIELDGET(ff)),FIELDSIZE(ff),".") TO Inp_tmp UNIQUE // Работает в ADS, но не всегда. В ADS длина ключа индекса должна быть ФИКСИРОВАННОЙ * mFieldName = aFieldName[ff] * mFieldSize = aFieldSize[ff] * INDEX ON PadRight(&mFieldName,mFieldSize,".") TO Inp_tmp UNIQUE // Не работает в ADS <<<===################################ * DbCreateIndex("Inp_tmp", PadRight(aFieldName[ff],aFieldSize[ff],"."), .T. ) * DbCreateIndex("Inp_tmp", aFieldName[ff], .T. ) * DbCreateIndex("Inp_tmp", mFieldName, {|| mFieldName }, .T. ) * StartFunction('INDEX ON '+aFieldName[ff]+' TO Inp_tmp UNIQUE') * MsgBox('INDEX ON PadRight('+aFieldName[ff]+','+aFieldSize[ff]+',".") TO Inp_tmp UNIQUE') * StartFunctTXT('INDEX ON PadR('+aFieldName[ff]+','+aFieldSize[ff]+',".") TO Inp_tmp UNIQUE') * MsgBox('DbCreateIndex("Inp_tmp", PadR('+aFieldName[ff]+','+aFieldSize[ff]+',"."), .T.)') * StartFunctTXT('DbCreateIndex("Inp_tmp", PadR('+aFieldName[ff]+','+aFieldSize[ff]+',"."), .T.)') ENDCASE COUNT TO Cr K_C_GrClSc = K_C_GrClSc + Cr CASE M_OpSc1 <= ff .AND. ff <= M_OpSc2 // ОПИСАТЕЛЬНЫЕ ШКАЛЫ: ++K_C_OpSc DO CASE CASE mADStxt = 'OFF' DbeSetDefault("DBFNTX") // ADS OFF INDEX ON SUBSTR(FIELDGET(ff),1,256) TO Inp_tmp UNIQUE // Не работает в ADS <<<===################################ CASE mADStxt = 'ON' DbeSetDefault("ADSDBE") // ADS ON * INDEX ON PadRight(FIELDGET(ff),256,".") TO Inp_tmp UNIQUE // Работает в ADS, но не всегда. В ADS длина ключа индекса должна быть ФИКСИРОВАННОЙ * INDEX ON PadRight(FIELDGET(ff),256) TO Inp_tmp UNIQUE // Работает в ADS, но не всегда. В ADS длина ключа индекса должна быть ФИКСИРОВАННОЙ * INDEX ON PadRight(ALLTRIM(FIELDGET(ff)),FIELDSIZE(ff),".") TO Inp_tmp UNIQUE // Работает в ADS, но не всегда. В ADS длина ключа индекса должна быть ФИКСИРОВАННОЙ * mFieldName = aFieldName[ff] * mFieldSize = aFieldSize[ff] * INDEX ON PadRight(&mFieldName,mFieldSize,".") TO Inp_tmp UNIQUE // Не работает в ADS <<<===################################ * DbCreateIndex("Inp_tmp", PadRight(aFieldName[ff],aFieldSize[ff],"."), .T. ) * DbCreateIndex("Inp_tmp", aFieldName[ff], .T. ) * DbCreateIndex("Inp_tmp", mFieldName, {|| mFieldName }, .T. ) * StartFunction('INDEX ON '+aFieldName[ff]+' TO Inp_tmp UNIQUE') * MsgBox('INDEX ON PadRight('+aFieldName[ff]+','+aFieldSize[ff]+',".") TO Inp_tmp UNIQUE') * StartFunctTXT('INDEX ON PadR('+aFieldName[ff]+','+aFieldSize[ff]+',".") TO Inp_tmp UNIQUE') * MsgBox('DbCreateIndex("Inp_tmp", PadR('+aFieldName[ff]+','+aFieldSize[ff]+',"."), .T.)') * StartFunctTXT('DbCreateIndex("Inp_tmp", PadR('+aFieldName[ff]+','+aFieldSize[ff]+',"."), .T.)') ENDCASE COUNT TO Cr K_C_GrOpSc = K_C_GrOpSc + Cr ENDCASE ENDCASE DC_GetProgress(oProgressm, ++nTime, nMax) * MILLISEC(100) NEXT * DbeSetDefault("DBFNTX") // ADS OFF * DbeSetDefault("ADSDBE") // ADS ON DC_GetProgress(oProgressm,nMax,nMax) oDialogm:Destroy() ***** РАСЧЕТ И ВЫВОД ИНФОРМАЦИИ О МАКС.КОЛ-ВЕ ГРАДАЦИЙ КЛАССИФИКАЦИОННЫХ ШКАЛ IF .NOT. FILE(Disk_dir+"\_2_3_2_2.arx") N_SKGrCl = K_C_GrClSc + K_N_ClSc * 10 // суммарное кол-во градаций = кол-во гр.текстовых шкал + по 10 градаций на каждую числ.шкалу N_SKGrPr = K_C_GrOpSc + K_N_OpSc * 10 // суммарное кол-во градаций = кол-во гр.текстовых шкал + по 10 градаций на каждую числ.шкалу ENDIF *** ################################################################################# // Сюда вставить подготовку отображения БД ScleAll.dbf * "СУММАРНОЕ КОЛИЧЕСТВО ШКАЛ И ГРАДАЦИЙ СИМ(кл/пр): [####### x #######]" * "╔═══════════╦═════════════════════════╦═════════════════════════╗" * "║ ║ Классификационные ║ Описательные ║" * "║ ╟────────┬────────┬───────╫────────┬────────┬───────╢" * "║ ║ Шкалы │Градации│ Гр/шк ║ Шкалы │Градации│ Гр/шк ║" * "╠═══════════╬════════╪════════╪═══════╬════════╪════════╪═══════╣" * "║ Числовые ║####### │####### │###### ║####### │####### │###### ║" * "╟───────────╫────────┼────────┼───────╫────────┼────────┼───────╢" * "║ Текстовые ║####### │####### │###### ║####### │####### │###### ║" * "╠═══════════╬════════╪════════╪═══════╬════════╪════════╪═══════╣" * "║ ВСЕГО: ║####### │####### │###### ║####### │####### │###### ║" * "╚═══════════╩════════╧════════╧═══════╩════════╧════════╧═══════╝" * 12345678901234567890123456789012345678901234567890123456789012345 * 10 21 30 39 47 56 65 SELECT ScaleALL;ZAP ScaleALL->(DBAPPEND());ScaleALL->Data_Type := L("Числовые" ) ScaleALL->(DBAPPEND());ScaleALL->Data_Type := L("Текстовые") ScaleALL->(DBAPPEND());ScaleALL->Data_Type := L("ВСЕГО:" ) // Управление перерасчетом ********************************************************************* PRIVATE lProcessing := .T., oStatusW, oBrowse n=0 DO WHILE .T. WindowWidth = 104.5 FlagErrorCls = .F. FlagErrorAtr = .F. IF Regim = 1 // Генерация шкал, градаций и обучающей выборки ************************ @10, 0 DCGROUP oGroup8 CAPTION L('Задайте количество числовых диапазонов (интервалов, градаций) в шкале:') SIZE WindowWidth,2.5 IF K_N_ClSc > 0 // Кол-во числовых классификационных шкал @ 1,4.5 DCSAY L("В классификационных шкалах:") PARENT oGroup8 @ 1,DCGUI_COL+1 DCGET K_GradNClSc PARENT oGroup8 PICTURE "#########" ENDIF IF K_N_OpSc > 0 // Кол-во числовых описательной шкал @ 1,55.4 DCSAY L("В описательных шкалах:") PARENT oGroup8 @ 1,DCGUI_COL+1 DCGET K_GradNOpSc PARENT oGroup8 PICTURE "#########" ENDIF K_N_GrClSc = K_N_ClSc * K_GradNClSc // Суммарное кол-во град.числовых класс.шкал K_N_GrOpSc = K_N_OpSc * K_GradNOpSc // Суммарное кол-во град.числовых опис. шкал N_SKGrCl = K_N_GrClSc + K_C_GrClSc // Суммарное кол-во град.класс.шкал N_SKGrPr = K_N_GrOpSc + K_C_GrOpSc // Суммарное кол-во град.опис. шкал ENDIF * K_N_ClSc // Кол-во числовых классификационных шкал * K_N_OpSc // Кол-во числовых описательных шкал * K_C_ClSc // Кол-во текстовых классификационных шкал * K_C_OpSc // Кол-во текстовых описательных шкал * K_N_GrClSc // Кол-во градаций числовых классификационных шкал * K_N_GrOpSc // Кол-во градаций числовых описательных шкал * K_C_GrClSc // Кол-во градаций текстовых классификационных шкал * K_C_GrOpSc // Кол-во градаций текстовых описательных шкал N_SKGrCl = IF(N_SKGrCl <= 2035, N_SKGrCl, 2035) N_SKGrPr = IF(N_SKGrPr <= 14000, N_SKGrPr, 14000) // В ADS нет ограничения * K_N_GrClSc = N_SKGrCl - K_C_GrClSc * K_N_GrOpSc = N_SKGrPr - K_C_GrOpSc ********** Если нет шкал, то нет и градаций: K_N_GrClSc = IF(K_N_ClSc=0,0,K_N_GrClSc) K_N_GrOpSc = IF(K_N_OpSc=0,0,K_N_GrOpSc) K_C_GrClSc = IF(K_C_ClSc=0,0,K_C_GrClSc) K_C_GrOpSc = IF(K_C_OpSc=0,0,K_C_GrOpSc) * СУММАРНОЕ КОЛИЧЕСТВО ШКАЛ И ГРАДАЦИЙ СИМ(кл/пр): [####### x #######]" * ╔═══════════╦═════════════════════════╦═════════════════════════╗" * ║ ║ Классификационные ║ Описательные ║" * ║ ╟────────┬────────┬───────╫────────┬────────┬───────╢" * ║ ║ Шкалы │Градации│ Гр/шк ║ Шкалы │Градации│ Гр/шк ║" * ╠═══════════╬════════╪════════╪═══════╬════════╪════════╪═══════╣" * 1 ║ Числовые ║ 2 │ 3 │ 4 ║ 5 │ 6 │ 7 ║" * ╟───────────╫────────┼────────┼───────╫────────┼────────┼───────╢" * 2 ║ Текстовые ║ 2 │ 3 │ 4 ║ 5 │ 6 │ 7 ║" * ╠═══════════╬════════╪════════╪═══════╬════════╪════════╪═══════╣" * 3 ║ ВСЕГО: ║ 2 │ 3 │ 4 ║ 5 │ 6 │ 7 ║" * ╚═══════════╩════════╧════════╧═══════╩════════╧════════╧═══════╝" // Классификационные шкалы DBGOTO(1);FIELDPUT( 2, K_N_ClSc ) // Кол-во числовых классификационных шкал DBGOTO(2);FIELDPUT( 2, K_C_ClSc ) // Кол-во текстовых классификационных шкал DBGOTO(3);FIELDPUT( 2, K_N_ClSc+K_C_ClSc ) // Суммарное кол-во классификационных шкал DBGOTO(1);FIELDPUT( 3, K_N_GrClSc ) // Суммарное кол-во градаций числовых клас.шкал DBGOTO(2);FIELDPUT( 3, K_C_GrClSc ) // Суммарное кол-во градаций текстовых клас.шкал DBGOTO(3);FIELDPUT( 3, K_N_GrClSc+K_C_GrClSc ) // Суммарное кол-во градаций числ.и текст.клас.шкал DBGOTO(1);FIELDPUT( 4, K_N_GrClSc/K_N_ClSc ) // Среднее кол-во градаций в числовых классификационных шкалах DBGOTO(2);FIELDPUT( 4, K_C_GrClSc/K_C_ClSc ) // Среднее кол-во градаций в текстовых классификационных шкалах Mv = (K_N_GrClSc+K_C_GrClSc)/(K_N_ClSc+K_C_ClSc) DBGOTO(3);FIELDPUT( 4, Mv ) // Среднее кол-во градаций в числ.и текст.клас.шкалах // Описательные шкалы DBGOTO(1);FIELDPUT( 5, K_N_OpSc ) // Кол-во числовых описательных шкал DBGOTO(2);FIELDPUT( 5, K_C_OpSc ) // Кол-во текстовых описательных шкал DBGOTO(3);FIELDPUT( 5, K_N_OpSc+K_C_OpSc ) // Суммарное кол-во описательных шкал DBGOTO(1);FIELDPUT( 6, K_N_GrOpSc ) // Суммарное кол-во градаций числовых клас.шкал DBGOTO(2);FIELDPUT( 6, K_C_GrOpSc ) // Суммарное кол-во градаций текстовых клас.шкал DBGOTO(3);FIELDPUT( 6, K_N_GrOpSc+K_C_GrOpSc ) // Суммарное кол-во градаций числ.и текст.опис.шкал DBGOTO(1);FIELDPUT( 7, K_N_GrOpSc/K_N_OpSc ) // Среднее кол-во градаций в числовых описательных шкалах DBGOTO(2);FIELDPUT( 7, K_C_GrOpSc/K_C_OpSc ) // Среднее кол-во градаций в текстовых описательных шкалах Mv = (K_N_GrOpSc+K_C_GrOpSc)/(K_N_OpSc+K_C_OpSc) DBGOTO(3);FIELDPUT( 7, Mv ) // Среднее кол-во градаций в числ.и текст.опис.шкалах // ######################################################################### // Здесь выдать конкретные сообщения и рекомендации в случаях, если не целое // среднее кол-во градаций в: // - в числовых классификационных шкалах // - в числовых описательных шкалах // В этих случаях предлагать ближайшее целое и на расчет модели не выходить. // И ЕСЛИ СЛИШКОМ БОЛЬШОЕ КОЛИЧЕСТВО КЛАССОВ (Суммарное кол-во градаций числ.и текст.клас.шкал) <= 2035 IF Regim = 1 // Генерация шкал, градаций и обучающей выборки ************************ Flag_err = .F. IF K_N_ClSc > 0 .AND. K_N_GrClSc <= 0 .OR.; K_C_ClSc > 0 .AND. K_C_GrClSc <= 0 M_Exit = 1 Flag_err = .T. Mess3 = "Задайте больше классификационных шкал !!!" LB_Warning(Mess3) ENDIF IF K_N_OpSc > 0 .AND. K_N_GrOpSc <= 0 .OR.; K_C_OpSc > 0 .AND. K_C_GrOpSc <= 0 M_Exit = 1 Flag_err = .T. Mess3 = "Задайте больше описательных шкал !!!" LB_Warning(Mess3) ENDIF ** K_N_ClSc // Кол-во числовых классификационных шкал ** K_C_ClSc // Кол-во текстовых классификационных шкал IF K_N_ClSc + K_C_ClSc <= 0 M_Exit = 1 Flag_err = .T. Mess3 = "Нет классификационных шкал!!! Для продолжения нажмите какую-нибудь клавишу" LB_Warning(Mess3) ENDIF ** K_N_OpSc // Кол-во числовых описательных шкал ** K_C_OpSc // Кол-во текстовых описательных шкал IF K_N_OpSc + K_C_OpSc <= 0 M_Exit = 1 Flag_err = .T. Mess3 = "Нет описательных шкал!!! Для продолжения нажмите какую-нибудь клавишу" LB_Warning(Mess3) ENDIF ** K_N_GrClSc // Суммарное кол-во градаций числовых классификационных шкал ** K_C_GrClSc // Суммарное кол-во градаций текстовых классификационных шкал IF K_N_GrClSc + K_C_GrClSc <= 0 M_Exit = 1 Flag_err = .T. Mess3 = "Нет градаций классификационных шкал!!! Для продолжения нажмите клавишу" LB_Warning(Mess3) ENDIF ** K_N_GrOpSc // Суммарное кол-во градаций числовых описательных шкал ** K_C_GrOpSc // Суммарное кол-во градаций текстовых описательных шкал IF K_N_GrOpSc + K_C_GrOpSc <= 0 M_Exit = 1 Flag_err = .T. Mess3 = "Нет градаций описательных шкал!!! Для продолжения нажмите какую-нибудь клавишу" LB_Warning(Mess3) ENDIF ENDIF /* ----- Create browse ----- */ * СУММАРНОЕ КОЛИЧЕСТВО ГРАДАЦИЙ СИМ(кл/пр): [####### x #######]" * ╔═══════════╦═════════════════════════╦═════════════════════════╗" * ║ ║ Классификационные ║ Описательные ║" * ║ ╟────────┬────────┬───────╫────────┬────────┬───────╢" * ║ ║ Шкалы │Градации│ Гр/шк ║ Шкалы │Градации│ Гр/шк ║" * ╠═══════════╬════════╪════════╪═══════╬════════╪════════╪═══════╣" * 1 ║ Числовые ║ 2 │ 3 │ 4 ║ 5 │ 6 │ 7 ║" * ╟───────────╫────────┼────────┼───────╫────────┼────────┼───────╢" * 2 ║ Текстовые ║ 2 │ 3 │ 4 ║ 5 │ 6 │ 7 ║" * ╠═══════════╬════════╪════════╪═══════╬════════╪════════╪═══════╣" * 3 ║ ВСЕГО: ║ 2 │ 3 │ 4 ║ 5 │ 6 │ 7 ║" * ╚═══════════╩════════╧════════╧═══════╩════════╧════════╧═══════╝" * aStructure := { { "Data_Type" , "C", 9, 0 }, ; * { "Cl_Scale" , "N", 7, 0 }, ; * { "GrCl_Scal" , "N", 7, 0 }, ; * { "Gr_ClSc" , "N", 7, 2 }, ; * { "Op_Scale" , "N", 7, 0 }, ; * { "GrOp_Scal" , "N", 7, 0 }, ; * { "Gr_OpSc" , "N", 7, 2 } } * K_N_ClSc // Кол-во числовых классификационных шкал * K_N_OpSc // Кол-во числовых описательных шкал IF M_Interval=2 // Равное число событий в интервалах IF K_N_ClSc + K_N_OpSc = 0 // Нет числовых шкал M_Interval=1 *** Адаптивные интервалы (разного размера с примерно равным числом наблюдений) неприменимы, *** т.к. в файле исходных данных "Inp_data" нет числовых классификационных или описательных шкал. aMess := {} AADD(aMess, L('В файле исходных данных "Inp_data" нет числовых классификационных или описательных шкал.') ) AADD(aMess, L('Поэтому адаптивные интервалы (разного размера с примерно равным числом наблюдений) неприменимы,')) AADD(aMess, L('и модели будут создаваться при опции: "Равные величины интервалов с разным числом наблюдений".') ) LB_Warning(aMess) ENDIF ENDIF DO CASE CASE M_Interval=1 M_TypeGr = L('"Равные величины интервалов"') CASE M_Interval=2 M_TypeGr = L('"Равное число событий в интервалах"') ENDCASE **************************************************************************************** ** Адаптивные интервалы (разного размера с примерно равным числом наблюдений) и сценарии **************************************************************************************** IF M_Interval = 2 oScrn := DC_WaitOn( L('Расчет границ адаптивных интервалов на основе БД "Inp_data.dbf"' ),,,,,,,,,,,.F.) * SELECT Inp_data // дает ошибку при вводе распознавемой выборки <===########## IF Regim = 1 // Генерация шкал, градаций и обучающей выборки ************************ * USE Inp_data EXCLUSIVE NEW // Здесь возникает ошибка открытия БД <===################# SELECT Inp_data ENDIF IF Regim = 2 // Генерация шкал, градаций и обучающей выборки ************************ * USE Inp_rasp EXCLUSIVE NEW // Здесь возникает ошибка открытия БД <===################# SELECT Inp_rasp ENDIF SET FILTER TO SET ORDER TO N_Rec = RECCOUNT() // Число записей (строк) N_Col = FCOUNT() // Число колонок (столбцов) *** Фомирование границ интервалов таким образом, *** чтобы в них было (примерно) РАВНОЕ количество наблюдений // Загрузка массива имен колонок из файла IF FILE("Inp_name.txt") aInp_name := {} AADD(aInp_name, 'Object') nHandle := DC_txtOpen( "Inp_name.txt" ) DO WHILE !DC_TxtEOF( nHandle ) // Начало цикла по строкам mLine = DC_TxtLine( nHandle ) // Выделить строку из текстового файла AADD(aInp_name, mLine) DC_TxtSkip( nHandle, 1 ) ENDDO DC_TxtClose( nHandle ) DC_ASave(aInp_name, "_ColumnNames.arx") // Запись массива наименований шкал (колонок) в виде файла ENDIF * ******* Отображение стадии исполнения в кратком варианте ***************************************** * PRIVATE oProgress2, oDialog2 * nMax = ( M_ClSc2 - M_ClSc1 + 1) + ( M_OpSc2 - M_OpSc1 + 1 ) * nTime = 0 * @ 4,5 DCPROGRESS oProgress2 SIZE 70,1.1 MAXCOUNT nMax COLOR GRA_CLR_BLUE PERCENT EVERY 100 * DCREAD GUI TITLE L('2.3.2.2. Расчет градаций шкал с равным числом наблюдений разного размера') PARENT @oDialog2 FIT EXIT * oDialog2:show() * DC_GetProgress(oProgress2,0,nMax) * ************************************************************************************************ CrLf = CHR(13)+CHR(10) // Конец строки (абзаца) (CrLf) mABC = "" mABC = L("ПАРАМЕТРЫ ШКАЛ И ГРАДАЦИЙ С АДАПТИВНЫМИ ГРАНИЦАМИ И ПРИМЕРНО РАВНЫМ КОЛИЧЕСТВОМ НАБЛЮДЕНИЙ ПО ГРАДАЦИЯМ") + CrLf +; L("с коррекцией ошибки округления числа наблюдений по интервалу градации при переходе к следующей градации") + CrLf + CrLf * "с коррекцией ошибки округления числа наблюдений по интервалу градации при переходе к следующей градации" + CrLf + ; * "и добавлением малой случайной компоненты, не меняющей значащих цифр, для исключения тождеств.наблюдений " + CrLf + CrLf IF M_Scenario mABC = mABC + L("Характеристика БАЗОВЫХ шкал и градаций для формирования СЦЕНАРИЕВ изменения значений шкал") + CrLf + CrLf ENDIF // Выборка значений наблюдений по шкале mCol из БД Inp_data.dbf // Сделать выборку для классификационных шкал ********************************************************* IF Regim = 1 // Генерация шкал, градаций и обучающей выборки ************************ // Определить максимальное количество градаций, при котором нет пустых интервалов (отдельно для классов и признаков) * K_N_ClSc // Кол-во числовых классификационных шкал * K_N_OpSc // Кол-во числовых описательных шкал * K_C_ClSc // Кол-во текстовых классификационных шкал * K_C_OpSc // Кол-во текстовых описательных шкал * K_N_GrClSc // Кол-во градаций числовых классификационных шкал (суммарное) * K_N_GrOpSc // Кол-во градаций числовых описательных шкал (суммарное) * K_C_GrClSc // Кол-во градаций текстовых классификационных шкал * K_C_GrOpSc // Кол-во градаций текстовых описательных шкал K_N_GrClSc = IF(K_N_GrClSc < N_Rec, K_N_GrClSc, N_Rec) // Кол-во градаций шкалы не может быть больше числа объектов выборки K_N_GrOpSc = IF(K_N_GrOpSc < N_Rec, K_N_GrOpSc, N_Rec) // Кол-во градаций шкалы не может быть больше числа объектов выборки PRIVATE N_GrSc := MAX(K_GradNClSc, K_GradNOpSc) // Большее из кол-ва градаций числовых класс.и опис.шкал * DC_DebugQout( { K_GradNClSc, K_GradNOpSc, N_GrSc } ) PRIVATE aExcelClSc[K_GradNClSc,5] // Массив для рассчета, такой же как в Excel PRIVATE aMinGranInt[N_GrSc,N_Col] // Минимальные границы градаций числовых класс.и опис.шкал PRIVATE aMaxGranInt[N_GrSc,N_Col] // Максимальные границы градаций числовых класс.и опис.шкал PRIVATE aKGradCClSc[N_Col] // Кол-во градаций в текстовых классификационных шкалах PRIVATE aKGradCOpSc[N_Col] // Кол-во градаций в текстовых описательных шкалах * aExcelClSc[1,1] // Обозначение (наименование) интервала * aExcelClSc[1,2] // Суммарное число наблюдений по текущей шкале * aExcelClSc[1,3] // Число градаций в текущей шкале * aExcelClSc[1,4] // Расчетное число наблюдений на интервал * aExcelClSc[1,5] // Фактическое число наблюдений на интервал M_KodClSc = 0 M_KodGrCS = 0 M_KodOpSc = 0 M_KodGrOS = 0 mMaxInt = -99999999 mMaxDec = -99999999 FOR mCol=M_ClSc1 TO M_ClSc2 // Цикл по классификационным шкалам IF aErrorNum[mCol] // Если есть вариабельность SELECT Inp_data SET FILTER TO SET ORDER TO DBGOTOP() mVal = FIELDGET(mCol) IF VALTYPE(mVal)="C" // Текстовый столбец *********************************************************************** IF Flag_zer=1 // <<<===###################################### если Flag_zer=1, то посчитать число градаций с данными другим способом SET FILTER TO LEN(ALLTRIM(FIELDGET(mCol))) > 0 ELSE SET FILTER TO ENDIF INDEX ON FIELDGET(mCol) TO InpD_tmp UNIQUE COUNT TO aKGradCClSc[mCol] * MsgBox(STR(mCol)+STR(M_ClSc1)+STR(M_ClSc2)) * DC_DebugQout( aInp_name ) * MsgBox(aInp_name[mCol]) * MsgBox(ALLTRIM(STR(aKGradCClSc[mCol],19))) mABC = mABC+L("КЛАССИФИКАЦИОННАЯ ШКАЛА:") + " " + L("код: [")+STR(++M_KodClSc, 4) + '], '+; L('наим.: "')+UPPER(aInp_name[mCol]) + '", ' +; L("тип/число градаций в шкале: ")+ M_TypeGr + "/" + ALLTRIM(STR(aKGradCClSc[mCol],19)) + CrLf mNumGrad = 0 DBGOTOP() DO WHILE .NOT. EOF() mNameGr = ALLTRIM(FIELDGET(mCol)) * MsgBox(' |'+mNameGr+'| '+STR(LEN(ALLTRIM(mNameGr)))) DO CASE CASE Flag_zer=1 .AND. LEN(ALLTRIM(mNameGr)) > 0 // Пробелы считать отсутствием данных <<<===################### mABC = mABC+STR(++M_KodGrCS,15)+' '+L("Наим.градации:")+' '+STR(++mNumGrad,LEN(ALLTRIM(STR(aKGradCClSc[mCol],19))))+'/'+ALLTRIM(STR(aKGradCClSc[mCol],19))+'-'+mNameGr+CrLf CASE Flag_zer=2 mABC = mABC+STR(++M_KodGrCS,15)+' '+L("Наим.градации:")+' '+STR(++mNumGrad,LEN(ALLTRIM(STR(aKGradCClSc[mCol],19))))+'/'+ALLTRIM(STR(aKGradCClSc[mCol],19))+'-'+mNameGr+CrLf ENDCASE DBSKIP(1) ENDDO mABC = mABC + CrLf ENDIF IF VALTYPE(mVal)="N" // Числовой столбец ************************************************************************ SET FILTER TO mMaxInt = -99999999 mMaxDec = -99999999 A_inp := {} // Массив значений наблюдений по текущей шкале FOR i=1 TO N_Rec DBGOTO(i) mVal = FIELDGET(mCol) DO CASE CASE Flag_zer=1 * IF mVal <> 0 // Нули считать отсутствием данных <<<===################### IF .NOT. EMPTY(mVal) // Нули считать отсутствием данных <<<===################### AADD (A_inp, mVal) mVal = ALLTRIM(REMRIGHT(STR(mVal,19,7),"0")) // Убрать пробелы впереди и подряд идущие нули справа mMaxInt = MAX(mMaxInt, AT('.', mVal)-1) // Найти максимальную длину целой части mMaxDec = MAX(mMaxDec, LEN(mVal)-AT('.', mVal)) // Найти максимальную длину дробной части ENDIF CASE Flag_zer=2 AADD (A_inp, mVal) mVal = ALLTRIM(REMRIGHT(STR(mVal,19,7),"0")) // Убрать пробелы впереди и подряд идущие нули справа mMaxInt = MAX(mMaxInt, AT('.', mVal)-1) // Найти максимальную длину целой части mMaxDec = MAX(mMaxDec, LEN(mVal)-AT('.', mVal)) // Найти максимальную длину дробной части ENDCASE NEXT * // Рандомизация ############################################ Нужна ли рандомизация? * // Если mMaxDec < 7 добавить к элементам A_inp малую случайную компоненту, заполняющую НЕЗНАЧАЩИЕ десятичные разряды * IF mMaxDec < 7 * FOR i=1 TO LEN(A_inp) * mN = 7 - mMaxDec // Число значащих десятичных разрядов случайного числа * mN = 7 - mMaxDec // Число значащих десятичных разрядов случайного числа * // Добавление малой случайной величины не должно менять значащих десятичных цифр значения шкалы, в т.ч. и при округлении * // Это значит, что его модуль должен быть меньше 0.5 и складываться с положительными значениями и вычитаться из отрицательных * mRnd1 = RANDOM()%44444 * 10 ^ (mN - 12) * IF(A_inp[i] > 0, 1, -1) // 5 случайных разрядов * mRnd2 = RANDOM()%44444 * 10 ^ (mN - 17) * IF(A_inp[i] > 0, 1, -1) // + 1 случайный разряд (6-й) * mRnd = mRnd1 + mRnd2;mRnd = VAL(STR(mRnd,19,7)) // оставить 7 десятичных знаков ** LB_Warning(STR(mRnd1,19,7)+STR(mRnd2,19,7)+STR(mRnd,19,7)) * A_inp[i] = A_inp[i] + mRnd * DBGOTO(i) * FIELDPUT(mCol, A_inp[i]) * NEXT * ENDIF mMaxDec = 7 mMaxInt = mMaxInt + mMaxDec + 1 ASORT(A_inp) // Сортировка всех значений наблюдений по текущей шкале в порядке возрастания aExcelClSc[1,1] = STR(1,LEN(ALLTRIM(STR(K_GradNClSc,19)))) + '/' + ALLTRIM(STR(K_GradNClSc,19)) // Обозначение интервала aExcelClSc[1,2] = LEN(A_inp) // Суммарное число наблюдений по текущей шкале aExcelClSc[1,3] = K_GradNClSc // Число градаций в текущей шкале aExcelClSc[1,4] = INT(aExcelClSc[1,2]/K_GradNClSc) // Расчетное число наблюдений на интервал aExcelClSc[1,5] = 0 // Фактическое число наблюдений на интервал IF aExcelClSc[1,2] > 0 // Суммарное число наблюдений по текущей шкале aMinGranInt[1, mCol] = A_inp[1] // Нижняя граница 1-й градации // Сделать как в Excel-расчете адаптивных интервалов mNumGrad = 1 FOR j=1 TO aExcelClSc[1,2] // Цикл по значениям текущей шкалы IF aExcelClSc[mNumGrad,5] < aExcelClSc[mNumGrad,4] // Если фактическое число НАБЛЮДЕНИЙ в градации меньше расчетного, то суммировать 1 aExcelClSc[mNumGrad,5] = aExcelClSc[mNumGrad,5] + 1 aMaxGranInt[mNumGrad, mCol] = A_inp[j] // Считать очередное значение текущей шкалы верхней границей текущей градации IF mNumGrad+1 <= K_GradNClSc aMinGranInt[mNumGrad+1, mCol] = A_inp[j] // и нижней границей следующей градации, если она есть ENDIF // (добавить малую случ.компоненту, чтобы не было повторов наблюдений) ELSE // Иначе -перейти на следующую градацию, если она есть // и пересчитать число наблюдений на следующую градацию с учетом уже просчитанных IF mNumGrad+1 <= K_GradNClSc // Перейти на следующую градацию, если она есть mNumGrad++ aExcelClSc[mNumGrad,1] = STR(mNumGrad,LEN(ALLTRIM(STR(mNumGrad,19)))) + '/' + ALLTRIM(STR(K_GradNClSc,19)) // Обозначение интервала aExcelClSc[mNumGrad,2] = aExcelClSc[mNumGrad-1,2] - aExcelClSc[mNumGrad-1,5] // Осталось нераспределенных по интервалам наблюдений aExcelClSc[mNumGrad,3] = aExcelClSc[mNumGrad-1,3] - 1 // Интервалов осталось на 1 меньше aExcelClSc[mNumGrad,4] = INT(aExcelClSc[mNumGrad,2]/aExcelClSc[mNumGrad,3]) // Расчетное число наблюдений на очередной интервал aExcelClSc[mNumGrad,5] = 1 // Фактическое число наблюдений на интервал ENDIF ENDIF NEXT * DC_ArrayView( aExcelClSc ) mInpLen = LEN(A_inp) aMaxGranInt[mNumGrad, mCol] = A_inp[mInpLen] // Верхняя граница последней градации * DC_ArrayView( aMaxGranInt ) * DC_ArrayView( aExcelClSc ) // Выдать в нередактируемом текстовом окне с прокруткой по клику на кнопке в окне диалога определения размерности модели mABC = mABC+L("КЛАССИФИКАЦИОННАЯ ШКАЛА:") + " "+L("код: [")+STR(++M_KodClSc, 4) + '], '+; L('наим.:"')+" "+UPPER(aInp_name[mCol]) + '", ' +; L("набл.на шкалу (всего):")+" "+ALLTRIM(STR(aExcelClSc[1,2],19)) + ", " +; L("тип/число градаций в шкале:")+" "+M_TypeGr + "/" + ALLTRIM(STR(aExcelClSc[1,3],19)) + CrLf // Иногда возникает ошибка ############## aNameGrNumSc = NameGrNumSc(K_GradNClSc) // Массив наименований градаций числовых классификационных шкал FOR mNumGrad=1 TO K_GradNClSc IF VALTYPE(aMinGranInt[mNumGrad, mCol])='N' .AND.; VALTYPE(aMaxGranInt[mNumGrad, mCol])='N' .AND.; VALTYPE(aExcelClSc[mNumGrad,5]) ='N' // Какие наименования ГРАДАЦИЙ числовых шкал использовать DO CASE CASE mNameGrNumSc= 1 // Только интервальные числовые значения mABC = mABC+STR(++M_KodGrCS,15)+" "+L("Наим.градации:")+" " + ; STR(mNumGrad,LEN(ALLTRIM(STR(K_GradNClSc,19)))) + '/' + ALLTRIM(STR(K_GradNClSc,19)) +; "-{"+STR(aMinGranInt[mNumGrad, mCol],mMaxInt,mMaxDec)+; ", "+STR(aMaxGranInt[mNumGrad, mCol],mMaxInt,mMaxDec) + "}" +; L(", размер интервала=")+STR(aMaxGranInt[mNumGrad, mCol]-aMinGranInt[mNumGrad, mCol],mMaxInt,mMaxDec) +; L(", расч./факт.число наблюдений на градацию:")+" "+ALLTRIM(STR(aExcelClSc[mNumGrad,5],19))+'/'+ALLTRIM(STR(aExcelClSc[mNumGrad,5],19)) + CrLf CASE mNameGrNumSc= 2 // Только наименования интервальных числовых значений mABC = mABC + aNameGrNumSc[mNumGrad] + ; L(", размер интервала=")+STR(aMaxGranInt[mNumGrad, mCol]-aMinGranInt[mNumGrad, mCol],mMaxInt,mMaxDec) +; L(", расч./факт.число наблюдений на градацию:")+" "+ALLTRIM(STR(aExcelClSc[mNumGrad,5],19))+'/'+ALLTRIM(STR(aExcelClSc[mNumGrad,5],19)) + CrLf CASE mNameGrNumSc= 3 // И интервальные числовые значения, и их наименования mABC = mABC+STR(++M_KodGrCS,15)+" "+L("Наим.градации:") + "-" + aNameGrNumSc[mNumGrad] + ": " + ; STR(mNumGrad,LEN(ALLTRIM(STR(K_GradNClSc,19)))) + '/' + ALLTRIM(STR(K_GradNClSc,19)) +; "-{"+STR(aMinGranInt[mNumGrad, mCol],mMaxInt,mMaxDec)+; ", "+STR(aMaxGranInt[mNumGrad, mCol],mMaxInt,mMaxDec) + "}" +; L(", размер интервала=")+STR(aMaxGranInt[mNumGrad, mCol]-aMinGranInt[mNumGrad, mCol],mMaxInt,mMaxDec) +; L(", расч./факт.число наблюдений на градацию:")+" "+ALLTRIM(STR(aExcelClSc[mNumGrad,5],19))+'/'+ALLTRIM(STR(aExcelClSc[mNumGrad,5],19)) + CrLf ENDCASE ELSE mABC = L('Необходимо либо уменьшить число градаций в КЛАССИФИКАЦИОННОЙ шкале: ')+ CrLf+; L("код: [")+STR(M_KodClSc, 4) + '], '+L('наим.: "')+UPPER(aInp_name[mCol]) + '", ' +; L("набл.на шкалу (всего): ")+ALLTRIM(STR(aExcelClSc[1,2],19)) + ", " +; L("тип/число градаций в шкале: ")+ M_TypeGr + "/" + ALLTRIM(STR(aExcelClSc[1,3],19)) + CrLf mABC = mABC + L('т.к. из-за недостатка данных в этой шкале появляются интервалы без наблюдений,') + CrLf mABC = mABC + L('либо удалить эту шкалу с малым числом наблюдений из файла исходных данных!!!') + CrLf FlagErrorCls = .T. ENDIF NEXT mABC = mABC + CrLf ENDIF ENDIF ENDIF * DC_GetProgress(oProgress2, ++nTime, nMax) NEXT // Выборка значений наблюдений по шкале mCol из БД Inp_data.dbf // Сделать выборку и для описательных шкал ************************************************************ mABC = mABC + REPLICATE("~",141) + CrLf + CrLf PRIVATE aExcelOpSc[K_GradNOpSc, 5] // Массив для рассчета, такой же как в Excel * aExcelOpSc[1,1] // Обозначение интервала * aExcelOpSc[1,2] // Суммарное число наблюдений по текущей шкале * aExcelOpSc[1,3] // Число градаций в текущей шкале * aExcelOpSc[1,4] // Расчетное число наблюдений на интервал * aExcelOpSc[1,5] // Фактическое число наблюдений на интервал * MsgBox(STR(M_OpSc1)+' '+STR(M_OpSc2)) FOR mCol=M_OpSc1 TO M_OpSc2 // Цикл по описательным шкалам IF aErrorNum[mCol] // Если есть вариабельность SELECT Inp_data SET FILTER TO SET ORDER TO DBGOTOP() mVal = FIELDGET(mCol) IF VALTYPE(mVal)="C" // Текстовый столбец *********************************************************************** IF Flag_zer=1 // <<<===###################################### если Flag_zer=1, то посчитать число градаций с данными другим способом SET FILTER TO LEN(ALLTRIM(FIELDGET(mCol))) > 0 ELSE SET FILTER TO ENDIF INDEX ON FIELDGET(mCol) TO InpD_tmp UNIQUE COUNT TO aKGradCOpSc[mCol] mABC = mABC+L("ОПИСАТЕЛЬНАЯ ШКАЛА:")+" "+ L("код: [")+STR(++M_KodOpSc, 4) + '], '+; L('наим.:"')+" "+UPPER(aInp_name[mCol]) + '", ' +; L("тип шкалы/число градаций в шкале:")+" "+ M_TypeGr + "/" + ALLTRIM(STR(aKGradCOpSc[mCol],19)) + CrLf mNumGrad = 0 DBGOTOP() DO WHILE .NOT. EOF() mNameGr = ALLTRIM(FIELDGET(mCol)) * MsgBox(' |'+mNameGr+'| '+STR(LEN(ALLTRIM(mNameGr)))) DO CASE CASE Flag_zer=1 .AND. LEN(ALLTRIM(mNameGr)) > 0 // Пробелы считать отсутствием данных <<<===################### mABC = mABC+STR(++M_KodGrOS,15)+' '+L("Наим.градации:")+' '+STR(++mNumGrad,LEN(ALLTRIM(STR(aKGradCOpSc[mCol],19))))+'/'+ALLTRIM(STR(aKGradCOpSc[mCol],19))+'-'+mNameGr+CrLf CASE Flag_zer=2 mABC = mABC+STR(++M_KodGrOS,15)+' '+L("Наим.градации:")+' '+STR(++mNumGrad,LEN(ALLTRIM(STR(aKGradCOpSc[mCol],19))))+'/'+ALLTRIM(STR(aKGradCOpSc[mCol],19))+'-'+mNameGr+CrLf ENDCASE DBSKIP(1) ENDDO mABC = mABC + CrLf ENDIF IF VALTYPE(mVal)="N" // Числовой столбец ************************************************************************ mMaxInt = -99999999 mMaxDec = -99999999 A_inp := {} // Массив значений наблюдений по текущей шкале FOR i=1 TO N_Rec DBGOTO(i) mVal = FIELDGET(mCol) DO CASE CASE Flag_zer=1 * IF mVal <> 0 // Нули считать отсутствием данных <<<===################### IF .NOT. EMPTY(mVal) // Нули считать отсутствием данных <<<===################### AADD (A_inp, mVal) mVal = ALLTRIM(REMRIGHT(STR(mVal,19,7),"0")) // Убрать пробелы впереди и подряд идущие нули справа mMaxInt = MAX(mMaxInt, AT('.', mVal)-1) // Найти максимальную длину целой части mMaxDec = MAX(mMaxDec, LEN(mVal)-AT('.', mVal)) // Найти максимальную длину дробной части ENDIF CASE Flag_zer=2 AADD (A_inp, mVal) mVal = ALLTRIM(REMRIGHT(STR(mVal,19,7),"0")) // Убрать пробелы впереди и подряд идущие нули справа mMaxInt = MAX(mMaxInt, AT('.', mVal)-1) // Найти максимальную длину целой части mMaxDec = MAX(mMaxDec, LEN(mVal)-AT('.', mVal)) // Найти максимальную длину дробной части ENDCASE NEXT * // Рандомизация ############################################ Нужна ли рандомизация? * // Если mMaxDec < 7 добавить к элементам A_inp малую случайную колмпоненту, заполняющую незначащие десятичные разряды * IF mMaxDec < 7 * FOR i=1 TO LEN(A_inp) * mN = 7 - mMaxDec // Число значащих десятичных разрядов случайного числа * // Добавление малой случайной величины не должно менять значащих десятичных цифр значения шкалы, в т.ч. и при округлении * // Это значит, что его модуль должен быть меньше 0.5 и складываться с положительными значениями и вычитаться из отрицательных * mRnd1 = RANDOM()%44444 * 10 ^ (mN - 12) * IF(A_inp[i] > 0, 1, -1) // 5 случайных разрядов * mRnd2 = RANDOM()%44444 * 10 ^ (mN - 17) * IF(A_inp[i] > 0, 1, -1) // + 1 случайный разряд (6-й) * mRnd = mRnd1 + mRnd2;mRnd = VAL(STR(mRnd,19,7)) // оставить 7 десятичных знаков ** LB_Warning(STR(mRnd1,19,7)+STR(mRnd2,19,7)+STR(mRnd,19,7)) * A_inp[i] = A_inp[i] + mRnd * DBGOTO(i) * FIELDPUT(mCol, A_inp[i]) * NEXT * ENDIF mMaxDec = 7 mMaxInt = mMaxInt + mMaxDec + 1 ASORT(A_inp) // Сортировка всех значений наблюдений по текущей шкале в порядке возрастания aExcelOpSc[1,1] = STR(1,LEN(ALLTRIM(STR(K_GradNOpSc,19)))) + '/' + ALLTRIM(STR(K_GradNOpSc,19)) // Обозначение интервала aExcelOpSc[1,2] = LEN(A_inp) // Суммарное число наблюдений по текущей шкале aExcelOpSc[1,3] = K_GradNOpSc // Число градаций в текущей шкале aExcelOpSc[1,4] = INT(aExcelOpSc[1,2]/K_GradNOpSc) // Расчетное число наблюдений на интервал aExcelOpSc[1,5] = 0 // Фактическое число наблюдений на интервал IF aExcelOpSc[1,2] > 0 aMinGranInt[1, mCol] = A_inp[1] // Нижняя граница 1-й градации // Сделать как в Excel-расчете адаптивных интервалов mNumGrad = 1 FOR j=1 TO aExcelOpSc[1,2] // Цикл по значениям текущей шкалы IF aExcelOpSc[mNumGrad,5] < aExcelOpSc[mNumGrad,4] // Если фактическое число НАБЛЮДЕНИЙ в градации меньше расчетного, то суммировать 1 aExcelOpSc[mNumGrad,5] = aExcelOpSc[mNumGrad,5] + 1 aMaxGranInt[mNumGrad, mCol] = A_inp[j] // Считать очередное значение текущей шкалы верхней граничей текущей градации IF mNumGrad+1 <= K_GradNOpSc aMinGranInt[mNumGrad+1, mCol] = A_inp[j] // и нижней границей следующей градации, если она есть ENDIF ELSE // Иначе -перейти на следующую градацию, если она есть // и пересчитать число наблюдений на следующую градацию с учетом уже просчитанных IF mNumGrad+1 <= K_GradNOpSc // Перейти на следующую градацию, если она есть mNumGrad++ aExcelOpSc[mNumGrad,1] = STR(mNumGrad,LEN(ALLTRIM(STR(mNumGrad,19)))) + '/' + ALLTRIM(STR(K_GradNOpSc,19)) // Обозначение интервала aExcelOpSc[mNumGrad,2] = aExcelOpSc[mNumGrad-1,2] - aExcelOpSc[mNumGrad-1,5] // Осталось нераспределенных по интервалам наблюдений aExcelOpSc[mNumGrad,3] = aExcelOpSc[mNumGrad-1,3] - 1 // Интервалов осталось на 1 меньше aExcelOpSc[mNumGrad,4] = INT(aExcelOpSc[mNumGrad,2]/aExcelOpSc[mNumGrad,3]) // Расчетное число наблюдений на очередной интервал aExcelOpSc[mNumGrad,5] = 1 // Фактическое число наблюдений на интервал ENDIF ENDIF NEXT ENDIF * DC_ArrayView( aExcelOpSc ) mInpLen = LEN(A_inp) IF mInpLen > 0 aMaxGranInt[mNumGrad, mCol] = A_inp[mInpLen] // Верхняя граница последней градации // Выдать в нередактируемом текстовом окне с прокруткой по клику на кнопке в окне диалога определения размерности модели DO CASE CASE M_Interval=1 M_TypeGr = '"Равные величины интервалов"' CASE M_Interval=2 M_TypeGr = '"Равное число событий в интервалах"' ENDCASE * DC_DebugQout( aInp_name ) * MsgBox(STR(mCol)) * MsgBox(aInp_name[mCol]) mABC = mABC+L("ОПИСАТЕЛЬНАЯ ШКАЛА: ") + L("код: [")+STR(++M_KodOpSc, 4) + '], '+; L('наим.: "')+UPPER(aInp_name[mCol]) + '", ' +; L("набл.на шкалу (всего): ")+ALLTRIM(STR(aExcelOpSc[1,2],19)) + ", " +; L("тип/число градаций в шкале: ")+ M_TypeGr + "/" + ALLTRIM(STR(aExcelOpSc[1,3],19)) + CrLf aNameGrNumSc = NameGrNumSc(K_GradNOpSc) // Массив наименований градаций числовых классификационных шкал FOR mNumGrad=1 TO K_GradNOpSc IF VALTYPE(aMinGranInt[mNumGrad, mCol])='N' .AND.; VALTYPE(aMaxGranInt[mNumGrad, mCol])='N' .AND.; VALTYPE(aExcelOpSc[mNumGrad,5]) ='N' // Какие наименования ГРАДАЦИЙ числовых шкал использовать DO CASE CASE mNameGrNumSc= 1 // Только интервальные числовые значения mABC = mABC+STR(++M_KodGrOS,15)+" "+L("Наим.градации:")+" " + ; STR(mNumGrad,LEN(ALLTRIM(STR(K_GradNOpSc,19)))) + '/' + ALLTRIM(STR(K_GradNOpSc,19)) +; "-{"+STR(aMinGranInt[mNumGrad, mCol],mMaxInt,mMaxDec)+; ", "+STR(aMaxGranInt[mNumGrad, mCol],mMaxInt,mMaxDec) + "}" +; L(", размер интервала=")+STR(aMaxGranInt[mNumGrad, mCol]-aMinGranInt[mNumGrad, mCol],mMaxInt,mMaxDec) +; L(", расч./факт.число наблюдений на градацию:")+" "+ALLTRIM(STR(aExcelOpSc[mNumGrad,5],19))+'/'+ALLTRIM(STR(aExcelOpSc[mNumGrad,5],19)) + CrLf CASE mNameGrNumSc= 2 // Только наименования интервальных числовых значений mABC = mABC + aNameGrNumSc[mNumGrad] + ; L(", размер интервала=")+STR(aMaxGranInt[mNumGrad, mCol]-aMinGranInt[mNumGrad, mCol],mMaxInt,mMaxDec) +; L(", расч./факт.число наблюдений на градацию:")+" "+ALLTRIM(STR(aExcelOpSc[mNumGrad,5],19))+'/'+ALLTRIM(STR(aExcelOpSc[mNumGrad,5],19)) + CrLf CASE mNameGrNumSc= 3 // И интервальные числовые значения, и их наименования mABC = mABC+STR(++M_KodGrOS,15)+" "+L("Наим.градации:")+" " + "-" + aNameGrNumSc[mNumGrad] + ": " + ; STR(mNumGrad,LEN(ALLTRIM(STR(K_GradNOpSc,19)))) + '/' + ALLTRIM(STR(K_GradNOpSc,19)) +; "-{"+STR(aMinGranInt[mNumGrad, mCol],mMaxInt,mMaxDec)+; ", "+STR(aMaxGranInt[mNumGrad, mCol],mMaxInt,mMaxDec) + "}" +; L(", размер интервала=")+STR(aMaxGranInt[mNumGrad, mCol]-aMinGranInt[mNumGrad, mCol],mMaxInt,mMaxDec) +; L(", расч./факт.число наблюдений на градацию:")+" "+ALLTRIM(STR(aExcelOpSc[mNumGrad,5],19))+'/'+ALLTRIM(STR(aExcelOpSc[mNumGrad,5],19)) + CrLf ENDCASE ELSE mABC = L('Необходимо либо уменьшить число градаций в ОПИСАТЕЛЬНОЙ шкале: ') + CrLf+; L("код: [")+STR(M_KodOpSc, 4) + '], '+L('наим.: "')+UPPER(aInp_name[mCol]) + '", ' +; L("набл.на шкалу (всего): ")+ALLTRIM(STR(aExcelOpSc[1,2],19)) + ", " +; L("тип/число градаций в шкале: ")+ M_TypeGr + "/" + ALLTRIM(STR(aExcelOpSc[1,3],19)) + CrLf mABC = mABC + L('т.к. из-за недостатка данных в этой шкале появляются интервалы без наблюдений,') + CrLf mABC = mABC + L('либо удалить эту шкалу с малым числом наблюдений из файла исходных данных!!!') + CrLf FlagErrorAtr = .T. ENDIF NEXT mABC = mABC + CrLf ENDIF ENDIF ENDIF * DC_GetProgress(oProgress2, ++nTime, nMax) NEXT // Запись и загрузка массивов: aExcelClSc, aExcelOpSc, aMinGranInt и aMaxGranInt aGradNSc := {} // Массив числа градаций числовых классификационных и описательных шкал AADD(aGradNSc, K_GradNClSc) AADD(aGradNSc, K_GradNOpSc) DC_ASave(aExcelClSc, "_aXlsClSc.arx") // Запись массива aExcelClSc DC_ASave(aExcelOpSc, "_aXlsOpSc.arx") // Запись массива aExcelOpSc * aExcelClSc = DC_ARestore("_aXlsClSc.arx") // Загрузка массива aExcelClSc * aExcelOpSc = DC_ARestore("_aXlsOpSc.arx") // Загрузка массива aExcelOpSc DC_ASave(aGradNSc, "_GradNSc.arx") // Запись массива aGradNSc * aGradNSc = DC_ARestore("_GradNSc.arx") // Загрузка массива aGradNSc DC_ASave(aMinGranInt, "_MinGranInt.arx") // Запись массива aMinGranInt DC_ASave(aMaxGranInt, "_MaxGranInt.arx") // Запись массива aMaxGranInt * aMinGranInt = DC_ARestore("_MinGranInt.arx") // Загрузка массива aMinGranInt * aMaxGranInt = DC_ARestore("_MaxGranInt.arx") // Загрузка массива aMaxGranInt StrFile(STR(mMaxInt), '_mMaxInt.txt') // Запись текстового файла с параметром mMaxInt StrFile(STR(mMaxDec), '_mMaxDec.txt') // Запись текстового файла с параметром mMaxDec * mMaxInt = VAL(FileStr('_mMaxInt.txt')) // Загрузка параметра mMaxInt из текстового файла * mMaxDec = VAL(FileStr('_mMaxDec.txt')) // Загрузка параметра mMaxDec из текстового файла DC_ASave(aKGradCClSc, "_KGrCClSc.arx") // Запись файла с массивом aKGradCClSc[mCol] (число градаций в текстовых шкалах) DC_ASave(aKGradCOpSc, "_KGrCOpSc.arx") // Запись файла с массивом aKGradCOpSc[mCol] (число градаций в текстовых шкалах) * aKGradCClSc = DC_ARestore("_KGrCClSc.arx") // Загрузка параметра aKGradCClSc[mCol] из текстового файла * aKGradCOpSc = DC_ARestore("_KGrCOpSc.arx") // Загрузка параметра aKGradCOpSc[mCol] из текстового файла // Запись БД наименований шкал и параметров их градаций // с последующим просмотром ее после определения кол-ва градаций класс.и описательных шкал StrFile(mABC, 'Prop_Scales.txt') // Запись текстового файла параметров градаций шкал * DC_GetProgress(oProgress2,nMax,nMax) * oDialog2:Destroy() * DC_Impl(oScrn) ENDIF DC_Impl(oScrn) IF FlagErrorCls aMess := {} AADD(aMess, L('Необходимо либо уменьшить число градаций в КЛАССИФИКАЦИОННЫХ шкалах,')) AADD(aMess, L('т.к. из-за недостатка данных появляются интервалы без наблюдений:')) AADD(aMess, L('удалить шкалы либо вообще без наблюдений, т.е. без варибельноси значений,')) AADD(aMess, L('либо с очень малым числом наблюдений из файла исходных данных: Inp_data !!!')) AADD(aMess, L(' ')) AADD(aMess, L('Более подробная информация о шкалах с наблюдениями в файле: ')) AADD(aMess, M_NewAppl+'Prop_Scales.txt') LB_Warning(aMess) ENDIF IF FlagErrorAtr aMess := {} AADD(aMess, L('Необходимо либо уменьшить число градаций в ОПИСАТЕЛЬНЫХ шкалах,')) AADD(aMess, L('т.к. из-за недостатка данных появляются интервалы без наблюдений:')) AADD(aMess, L('удалить шкалы либо вообще без наблюдений, т.е. без варибельноси значений,')) AADD(aMess, L('либо с очень малым числом наблюдений из файла исходных данных: Inp_data !!!')) AADD(aMess, L(' ')) AADD(aMess, L('Более подробная информация о шкалах с наблюдениями в файле: ')) AADD(aMess, M_NewAppl+'Prop_Scales.txt') LB_Warning(aMess) ENDIF ******************************************************************************************* ** Конец модуля: Адаптивные интервалы (разного размера с примерно равным числом наблюдений) ******************************************************************************************* ENDIF IF Regim = 1 // Генерация шкал, градаций и обучающей выборки *********************** // Кнопки задать здесь ******************************************************************** SELECT ScaleALL DBGOTOP() PushName1 = L('Пересчитать шкалы и градации' ) PushName2 = L('Параметры числ.шкал и градаций') PushName3 = L('Выйти на создание модели' ) @ 13,0 DCPUSHBUTTON CAPTION PushName1 SIZE LEN(PushName1), 1.5 ; ACTION {||lProcessing := .T., DC_ReadGuiEvent( DCGUI_EXIT_OK, GetList ) } // Если есть числовые шкалы, то показать кнопку информации о БАЗОВЫХ градациях для построения сценариев IF M_Interval = 2 .AND. K_N_ClSc + K_N_OpSc > 0 @ 13,LEN(PushName1)+2 DCPUSHBUTTON CAPTION PushName2 SIZE LEN(PushName2), 1.5 ; ACTION {||lProcessing := .T., Prop_Scales() } ENDIF @ 13,LEN(PushName1+PushName2)+22.4 DCPUSHBUTTON CAPTION PushName3 SIZE LEN(PushName3), 1.5 ; ACTION {||lProcessing := .F., DC_ReadGuiEvent( DCGUI_EXIT_OK, GetList ) } * M_Interval = 1 // 1-равные интервалы, 2-адаптивные интервалы (с примерно равным количеством наблюдений, по Котельникову) IF K_N_ClSc + K_N_OpSc > 0 @0,0 DCSAY L("ЗАДАНИЕ В ДИАЛОГЕ РАЗМЕРНОСТИ МОДЕЛИ: (")+IF(M_Interval=1,L("равные"), L("адаптивные"))+' '+L("интервалы)") FONT '10.Helvetica Bold' SAYSIZE 0 ELSE @0,0 DCSAY L("ИНФОРМАЦИЯ О РАЗМЕРНОСТИ МОДЕЛИ") FONT '10.Helvetica Bold' SAYSIZE 0 ENDIF SELECT ScaleALL DBGOBOTTOM() Mess = L("Количество градаций классификационных и описательных шкал в модели, т.е.: [# классов x $ признаков]") * Mess = STRTRAN(Mess, "#", ALLTRIM(STR(K_N_GrClSc + K_C_GrClSc,19))) * Mess = STRTRAN(Mess, "$", ALLTRIM(STR(K_N_GrOpSc + K_C_GrOpSc,19))) Mess = STRTRAN(Mess, "#", ALLTRIM(STR(GRCL_SCAL,19))) Mess = STRTRAN(Mess, "$", ALLTRIM(STR(GROP_SCAL,19))) @1,0 DCSAY Mess // Отобразить тип шкал: класс.или опис. и размерность модели DBGOTOP() @2, 0 DCBROWSE oBrowse ALIAS 'ScaleALL' SIZE WindowWidth, 7.1 ; PRESENTATION DC_BrowPres() ; // Только просмотр БД HEADLINES 4 ; // Кол-во строк в заголовке NOHSCROLL NOVSCROLL // Убрать горизонтальную и вертикальную полосы прокрутки DCBROWSECOL FIELD ScaleALL->Data_Type HEADER L("Тип шкалы" ) PARENT oBrowse WIDTH 7 DCBROWSECOL FIELD ScaleALL->Cl_Scale HEADER L("Количество;классифи-;кационных;шкал" ) PARENT oBrowse WIDTH 9 DCBROWSECOL FIELD ScaleALL->GrCl_Scal HEADER L("Количество;градаций;классифи-;кационных;шкал") PARENT oBrowse WIDTH 9 DCBROWSECOL FIELD ScaleALL->Gr_ClSc HEADER L("Среднее;количество;градаций;на класс.шкалу" ) PARENT oBrowse WIDTH 9 DCBROWSECOL FIELD ScaleALL->Op_Scale HEADER L("Количество;описательных;шкал" ) PARENT oBrowse WIDTH 9 DCBROWSECOL FIELD ScaleALL->GrOp_Scal HEADER L("Количество;градаций;описательных;шкал" ) PARENT oBrowse WIDTH 9 DCBROWSECOL FIELD ScaleALL->Gr_OpSc HEADER L("Среднее;количество;градаций;на опис.шкалу" ) PARENT oBrowse WIDTH 9 DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; OPTIONS GetOptions ; FIT ; MODAL ; TITLE L('2.3.2.2. Задание размерности модели системы "ЭЙДОС-X++"') // Сохранить файл с информацией о заданых параметрах программного интерфейса в текущей директории системы // и в папке приложения, чтобы можно было потом узнать при каких параметрах оно создано PRIVATE aSoftInt[40] aSoftInt[ 1] = Regim aSoftInt[ 2] = Flag_zer aSoftInt[ 3] = M_ClSc1 aSoftInt[ 4] = M_ClSc2 aSoftInt[ 5] = M_OpSc1 aSoftInt[ 6] = M_OpSc2 aSoftInt[ 7] = N_SKGrCl aSoftInt[ 8] = N_SKGrPr aSoftInt[ 9] = K_N_ClSc aSoftInt[10] = K_N_OpSc aSoftInt[11] = K_N_GrClSc aSoftInt[12] = K_N_GrOpSc aSoftInt[13] = M_ObAnk aSoftInt[14] = N_Chast aSoftInt[15] = M_Interval aSoftInt[16] = M_Scenario aSoftInt[17] = K_GradNClSc // Количество градаций в числовой классификационной шкале aSoftInt[18] = K_GradNOpSc // Количество градаций в числовой описательной шкале aSoftInt[19] = mGorizMin aSoftInt[20] = mGorizMax aSoftInt[21] = mGlubMin aSoftInt[22] = mGlubMax aSoftInt[23] = M_ChastObi aSoftInt[24] = M_ChastRso aSoftInt[25] = N_ChastObi aSoftInt[26] = N_ChastRso aSoftInt[27] = M_XlsDbf aSoftInt[28] = mTxtCSField aSoftInt[29] = mTxtOSField aSoftInt[30] = mTxtCSSep aSoftInt[31] = mTxtOSSep * aSoftInt[32] = mScenario // mScenario=1 Не применять сценарный метод АСК-анализа и спец.интерпретацию TXT-полей (старый вариант) aSoftInt[32] = mScenario // mScenario=1 Не применять сценарный метод АСК-анализа aSoftInt[33] = mSpecInterprCls // Применить спец.интерпретацию текстовых полей классов aSoftInt[34] = mSpecInterprAtr // Применить спец.интерпретацию текстовых полей признаков aSoftInt[35] = mNameGrNumSc // Какие наименования ГРАДАЦИЙ числовых шкал использовать aSoftInt[36] = mClsAvr // .F. = модель без усреднения по классам aSoftInt[37] = mSortUnqCls // Выделять уникальные значения классов и сортировать, 1-да, 2-нет aSoftInt[38] = IF(mSpecInterprCls,mLemmatCls,2) // Проводить лемматизацию классов, 1-да, 2-нет aSoftInt[39] = mSortUnqGos // Выделять уникальные значения признаков и сортировать, 1-да, 2-нет aSoftInt[40] = IF(mSpecInterprAtr,mLemmatGos,2) // Проводить лемматизацию признаков, 1-да, 2-нет DC_ASave(aSoftInt , Disk_dir +"\_2_3_2_2.arx") DC_ASave(aSoftInt , M_NewAppl+"\_2_3_2_2.arx") DC_ASave(aSoftInt , Disk_dir+'\AID_DATA\Inp_data\_2_3_2_2.arx') // Информация о типе используемого API для интеллектуальных облачных Эйдос-приложений, чтобы при их загрузке сразу запускать нужный API StrFile('API_type=2.3.2.2.', Disk_dir+'\AID_DATA\Inp_data\API_type.txt') IF lProcessing = .F. EXIT ENDIF oBrowse := nil oGroup6 := nil ELSE // Сохранить файл с информацией о заданых параметрах программного интерфейса в текущей директории системы // и в папке приложения, чтобы потом можно было узнать при каких параметрах оно создано PRIVATE aSoftInt[40] aSoftInt[ 1] = Regim aSoftInt[ 2] = Flag_zer aSoftInt[ 3] = M_ClSc1 aSoftInt[ 4] = M_ClSc2 aSoftInt[ 5] = M_OpSc1 aSoftInt[ 6] = M_OpSc2 aSoftInt[ 7] = N_SKGrCl aSoftInt[ 8] = N_SKGrPr aSoftInt[ 9] = K_N_ClSc aSoftInt[10] = K_N_OpSc aSoftInt[11] = K_N_GrClSc aSoftInt[12] = K_N_GrOpSc aSoftInt[13] = M_ObAnk aSoftInt[14] = N_Chast aSoftInt[15] = M_Interval aSoftInt[16] = M_Scenario aSoftInt[17] = K_GradNClSc // Количество градаций в числовой классификационной шкале aSoftInt[18] = K_GradNOpSc // Количество градаций в числовой описательной шкале aSoftInt[19] = mGorizMin aSoftInt[20] = mGorizMax aSoftInt[21] = mGlubMin aSoftInt[22] = mGlubMax aSoftInt[23] = M_ChastObi aSoftInt[24] = M_ChastRso aSoftInt[25] = N_ChastObi aSoftInt[26] = N_ChastRso aSoftInt[27] = M_XlsDbf aSoftInt[28] = mTxtCSField aSoftInt[29] = mTxtOSField aSoftInt[30] = mTxtCSSep aSoftInt[31] = mTxtOSSep * aSoftInt[32] = mScenario // mScenario=1 Не применять сценарный метод АСК-анализа и спец.интерпретацию TXT-полей (старый вариант) aSoftInt[32] = mScenario // mScenario=1 Не применять сценарный метод АСК-анализа aSoftInt[33] = mSpecInterprCls // Применить спец.интерпретацию текстовых полей классов aSoftInt[34] = mSpecInterprAtr // Применить спец.интерпретацию текстовых полей признаков aSoftInt[35] = mNameGrNumSc // Какие наименования ГРАДАЦИЙ числовых шкал использовать aSoftInt[36] = mClsAvr // .F. = модель без усреднения по классам aSoftInt[37] = mSortUnqCls // Выделять уникальные значения классов и сортировать, 1-да, 2-нет aSoftInt[38] = IF(mSpecInterprCls,mLemmatCls,2) // Проводить лемматизацию классов, 1-да, 2-нет aSoftInt[39] = mSortUnqGos // Выделять уникальные значения признаков и сортировать, 1-да, 2-нет aSoftInt[40] = IF(mSpecInterprAtr,mLemmatGos,2) // Проводить лемматизацию признаков, 1-да, 2-нет DC_ASave(aSoftInt , Disk_dir +"\_2_3_2_2.arx") DC_ASave(aSoftInt , M_PathAppl+"\_2_3_2_2.arx") DC_ASave(aSoftInt , Disk_dir+'\AID_DATA\Inp_data\_2_3_2_2.arx') // Информация о типе используемого API для интеллектуальных облачных Эйдос-приложений, чтобы при их загрузке сразу запускать нужный API StrFile('API_type=2.3.2.2.', Disk_dir+'\AID_DATA\Inp_data\API_type.txt') EXIT oBrowse := nil oGroup6 := nil ENDIF ENDDO ********************************************************************************* ***** Конец модуля итерационного интерактивного подбора параметров преобразования ********************************************************************************* DO CASE CASE FlagErrorCls=.T. .AND. FlagErrorAtr=.T. mABC = 'Необходимо уменьшить число градаций во всех шкалах, т.к. из-за недостатка данных появляются интервалы без наблюдений !!!' LB_Warning(mABC) DIRCHANGE(Disk_dir) Running(.F.) RETURN NIL CASE FlagErrorCls=.T. .AND. FlagErrorAtr=.F. mABC = 'Необходимо уменьшить число градаций в классификационных шкалах, т.к. из-за недостатка данных появляются интервалы без наблюдений !!!' LB_Warning(mABC) DIRCHANGE(Disk_dir) Running(.F.) RETURN NIL CASE FlagErrorCls=.F. .AND. FlagErrorAtr=.T. mABC = 'Необходимо уменьшить число градаций в описательных шкалах, т.к. из-за недостатка данных появляются интервалы без наблюдений !!!' LB_Warning(mABC) DIRCHANGE(Disk_dir) Running(.F.) RETURN NIL ENDCASE ************************************************************************************* IF Regim = 2 CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) Name_SS = M_PathAppl+"Inp_rasp.dbf" // Путь на текущее приложение Name_DD = Disk_dir+"\AID_DATA\Inp_data\Inp_rasp.dbf" * MsgBox(Name_SS+' => '+Name_DD) COPY FILE (Name_SS) TO (Name_DD) ENDIF IF Regim = 1 // Генерация шкал, градаций и обучающей выборки ************** *MsgBox(STR(Regim)) DIRCHANGE(M_NewAppl) // Перейти в папку с новым приложением *DIRCHANGE(M_PathAppl) // Перейти в папку с новым приложением * aStructure := { { "Word", "C", 256, 0 } } * DbCreate( 'Words', aStructure ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Inp_data EXCLUSIVE NEW // Вытащить структуру Inp_data, скорректировать формат числовых полей COPY STRUCTURE TO Inp_sh.dbf // Числовые поля сделать все 15,7, т.к. выдает ошибку на целых числовых полях размера 1 ################ *SELECT Inp_data *aStructure := { { "Word", "C", 256, 0 } } *FOR j=1 TO FCOUNT() * IF FIELDTYPE(j) = "C" * AADD(aStructure, { FIELDNAME(j), "C", FIELDSIZE(j), 0 } ) * ELSE * AADD(aStructure, { FIELDNAME(j), "N", 19, 7 } ) * ENDIF *NEXT *DbCreate( "Inp_sh.dbf", aStructure ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE EventsKO EXCLUSIVE NEW COPY STRUCTURE TO EventsTmp.dbf CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE EventsTmp EXCLUSIVE NEW INDEX ON Name_Obj TO Events_NO CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Class_Sc EXCLUSIVE NEW;ZAP USE Gr_ClSc EXCLUSIVE NEW;ZAP USE Classes EXCLUSIVE NEW;ZAP USE Opis_Sc EXCLUSIVE NEW;ZAP USE Gr_OpSc EXCLUSIVE NEW;ZAP USE Attributes EXCLUSIVE NEW;ZAP *USE Words EXCLUSIVE NEW;ZAP USE Inp_data EXCLUSIVE NEW USE Inp_sh EXCLUSIVE NEW;ZAP APPEND BLANK APPEND BLANK APPEND BLANK SELECT Inp_data SET ORDER TO N_ColInpData = FCOUNT() // Массивы вместо Inp_sh ******************************************** PRIVATE aMinSH[N_ColInpData] // Минимальное значение числовой шкалы PRIVATE aMaxSH[N_ColInpData] // Максимальное значение числовой шкалы PRIVATE aDelta[N_ColInpData] // Размер интервала градации в памяти AFILL(aMinSH,0) AFILL(aMaxSH,0) AFILL(aDelta,0) ********* Загрузить файл Inp_name.txt и сформировать массив: A_FNRus M_InpName = ALLTRIM(FILESTR('Inp_name.txt')) // Загрузка Inp_name.txt CrLf = CHR(13)+CHR(10) // Конец строки (абзаца) (CrLf) M_InpName = " " + CrLf + STRTRAN(M_InpName,CHR(26),"") + CrLf *LB_Warning(M_InpName) A_FNRus := {} aInp_name := {} FOR ff=1 TO NUMTOKEN(M_InpName,CrLf) AADD(A_FNRus , SUBSTR(UPPER(ALLTRIM(TOKEN(M_InpName,CrLf,ff))),1,255)) // Ограничение длины наименования шкалы 255 символов AADD(aInp_name, SUBSTR(UPPER(ALLTRIM(TOKEN(M_InpName,CrLf,ff))),1,255)) // Ограничение длины наименования шкалы 255 символов NEXT SELECT Inp_data IF LEN(A_FNRus) <> FCOUNT() aMess := {} AADD(aMess, L('Строк в "Inp_name.txt" должно быть столько же, сколько ШКАЛ в "Inp_data.dbf!"')) AADD(aMess, L('Фактически же в "Inp_name.txt" (#) строк, а в "Inp_data.dbf" ($) шкал"')) AADD(aMess, L('Возможно, надо убрать переносы строк в наименованиях колонок в Excel-файле')) aMess[2] = STRTRAN(aMess[2],"#", ALLTRIM(STR(LEN(A_FNRus),9))) aMess[2] = STRTRAN(aMess[2],"$", ALLTRIM(STR(FCOUNT()-1,9))) LB_Warning(aMess) Running(.F.) RETURN NIL ENDIF *FOR ff=2 TO FCOUNT() // Начало цикла по полям Inp.dbf * DO CASE * CASE M_ClSc1 <= ff .AND. ff <= M_ClSc2 // КЛАССИФИКАЦИОННЫЕ ШКАЛЫ: * CASE M_OpSc1 <= ff .AND. ff <= M_OpSc2 // ОПИСАТЕЛЬНЫЕ ШКАЛЫ: * ENDCASE *NEXT ** Если есть ошибки в параметрах - расчет не проводить IF Flag_err Mess = L("Заданы некорректные параметры!!! Попробуйте еще раз") LB_Warning(Mess) Running(.F.) RETURN NIL ENDIF ******************************************************************************************** // Начало отсчета времени для прогнозирования длительности исполнения SELECT Inp_data SET FILTER TO SET ORDER TO DO CASE CASE M_Interval = 1 .AND. .NOT. M_Scenario // *************************************************************************************************# // Может быть задана опция: "Специальная интерпретация текстовых полей" Wsego = FCOUNT()-1 +; // 1/3: Формирование классификационных и описательных шкал и градаций на основе БД "Inp_data" RECCOUNT() +; // 2/3: Генерация обучающей выборки и базы событий "EventsKO" на основе БД "Inp_data" 12 // 3/3: Переиндексация всех 12 баз данных нового приложения * aSay[1]:SetCaption(L('1/3: Формирование классификационных и описательных шкал и градаций на основе БД "Inp_data"') * aSay[2]:SetCaption(L('2/3: Генерация обучающей выборки и базы событий "EventsKO" на основе БД "Inp_data"') * aSay[3]:SetCaption(L('3/3: Переиндексация всех 12 баз данных нового приложения') ******************************************************************************************** // Отображение стадии исполнения. Будет написано прямо в окне Progress-bar @ 0,0 DCGROUP oGroup1 CAPTION L('Стадии исполнения процесса') FONT "6.Helv" SIZE 105, 4.5 PARENT oTabPage1 @ 6,0 DCGROUP oGroup2 CAPTION L('Прогноз времени исполнения') FONT "6.Helv" SIZE 105, 5.0 PARENT oTabPage2 s = 1 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 1] FONT "10.Helv" // 1 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 2] FONT "10.Helv" // 2 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 3] FONT "10.Helv" // 3 s++ @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay97 FONT "10.HelvBold" s++ @0.2+s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay98 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @1.5+s ,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay99 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE CASE M_Interval = 1 .AND. M_Scenario // ################################################################################################## Wsego = (FCOUNT()-1) +; // 1/5: Формирование классификационных и описательных шкал и градаций на основе БД "Inp_data" RECCOUNT() +; // 2/5: Создание базы событий "EventsKO" из "Inp_data" с кодами событий вместо значений шкал (M_ClSc2-M_ClSc1+1)*(RECCOUNT()-1) +; // 3/5: Доформирование класс.и опис.шкал и град.на основе БД "EventsKO" (сценарии) (M_OpSc2-M_OpSc1+1)*(RECCOUNT()-1) +; RECCOUNT() +; // 4/5: Генерация обучающей выборки на основе базы событий "EventsKO" 12 // 5/5: Переиндексация всех 12 баз данных нового приложения * aSay[1]:SetCaption(L('1/5: Формирование классификационных и описательных шкал и градаций на основе БД "Inp_data"') * aSay[2]:SetCaption(L('2/5: Создание базы событий "EventsKO" из "Inp_data" с кодами событий вместо значений шкал') * aSay[3]:SetCaption(L('3/5: Доформирование классиф.и описат.шкал и градаций на основе БД "EventsKO" (сценарии)') * aSay[4]:SetCaption(L('4/5: Генерация обучающей выборки на основе базы событий "EventsKO"') * aSay[5]:SetCaption(L('5/5: Переиндексация всех 12 баз данных нового приложения') ******************************************************************************************** // Отображение стадии исполнения. Будет написано прямо в окне Progress-bar @ 0,0 DCGROUP oGroup1 CAPTION L('Стадии исполнения процесса') FONT "6.Helv" SIZE 105, 6.5 PARENT oTabPage1 @ 8,0 DCGROUP oGroup2 CAPTION L('Прогноз времени исполнения') FONT "6.Helv" SIZE 105, 5.0 PARENT oTabPage2 s = 1 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 1] FONT "10.Helv" // 1 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 2] FONT "10.Helv" // 2 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 3] FONT "10.Helv" // 3 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 4] FONT "10.Helv" // 4 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 5] FONT "10.Helv" // 5 s++ @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay97 FONT "10.HelvBold" s++ @0.2+s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay98 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @1.5+s ,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay99 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE CASE M_Interval = 2 .AND. .NOT. M_Scenario // ************************************************************************************************** // Может быть задана опция: "Специальная интерпретация текстовых полей" Wsego = FCOUNT()-1 +; // 1/3: Формирование классификационных и описательных шкал и градаций на основе БД "Inp_data" RECCOUNT() +; // 2/3: Генерация обучающей выборки и базы событий "EventsKO" на основе БД "Inp_data" 12 // 3/3: Переиндексация всех 12 баз данных нового приложения * aSay[1]:SetCaption(L('1/3: Формирование классификационных и описательных шкал и градаций на основе БД "Inp_data"') * aSay[2]:SetCaption(L('2/3: Генерация обучающей выборки и базы событий "EventsKO" на основе внешней БД "Inp_data"') * aSay[3]:SetCaption(L('3/3: Переиндексация всех 12 баз данных нового приложения') ******************************************************************************************** // Отображение стадии исполнения. Будет написано прямо в окне Progress-bar @ 0,0 DCGROUP oGroup1 CAPTION L('Стадии исполнения процесса') FONT "6.Helv" SIZE 105, 4.5 PARENT oTabPage1 @ 6,0 DCGROUP oGroup2 CAPTION L('Прогноз времени исполнения') FONT "6.Helv" SIZE 105, 5.0 PARENT oTabPage2 s = 1 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 1] FONT "10.Helv" // 1 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 2] FONT "10.Helv" // 2 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 3] FONT "10.Helv" // 3 s++ @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay97 FONT "10.HelvBold" s++ @0.2+s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay98 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @1.5+s ,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay99 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE CASE M_Interval = 2 .AND. M_Scenario // ************************************************************************************************** ТАК НЕ БЫВАЕТ // Сценарии сделать: п.п. 1 и 2 как при адапт.инт.без сценариев, а дальше как при равных интервалах N_GrNClSc = INT(K_N_GrClSc / K_N_ClSc) // Количество градаций в числовой классификационной шкале N_GrNOpSc = INT(K_N_GrOpSc / K_N_OpSc) // Количество градаций в числовой классификационной шкале Wsego = (M_ClSc2-M_ClSc1+1) +; // 1/5: Формирование классификационных и описательных шкал и градаций на основе БД "Inp_data" (M_OpSc2-M_OpSc1+1) +; (M_ClSc2-M_ClSc1+1)*RECCOUNT() +; // 2/5: Генерация базы событий "EventsKO" на основе внешней БД "Inp_data" (M_OpSc2-M_OpSc1+1)*RECCOUNT() +; (M_ClSc2-M_ClSc1+1)*(RECCOUNT()-1) +; // 3/5: Доформирование класс.и опис.шкал и град.на основе БД "EventsKO" (сценарии) (M_OpSc2-M_OpSc1+1)*(RECCOUNT()-1) +; RECCOUNT() +; // 4/5: Генерация обучающей выборки на основе базы событий "EventsKO" 12 // 5/5: Переиндексация всех 12 баз данных нового приложения * aSay[1]:SetCaption(L('1/5: Формирование классификационных и описательных шкал и градаций на основе БД "Inp_data") * aSay[2]:SetCaption(L('2/5: Генерация базы событий "EventsKO" на основе внешней БД "Inp_data"') * aSay[3]:SetCaption(L('3/5: Доформирование класс.и опис.шкал и град.на основе БД "EventsKO" (сценарии)') * aSay[4]:SetCaption(L('4/5: Генерация обучающей выборки на основе базы событий "EventsKO"') * aSay[5]:SetCaption(L('5/5: Переиндексация всех 12 баз данных нового приложения') ******************************************************************************************** // Отображение стадии исполнения. Будет написано прямо в окне Progress-bar @ 0,0 DCGROUP oGroup1 CAPTION L('Стадии исполнения процесса') FONT "6.Helv" SIZE 105, 6.5 PARENT oTabPage1 @ 8,0 DCGROUP oGroup2 CAPTION L('Прогноз времени исполнения') FONT "6.Helv" SIZE 105, 5.0 PARENT oTabPage2 s = 1 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 1] FONT "10.Helv" // 1 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 2] FONT "10.Helv" // 2 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 3] FONT "10.Helv" // 3 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 4] FONT "10.Helv" // 4 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 5] FONT "10.Helv" // 4 s++ @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay97 FONT "10.HelvBold" s++ @0.2+s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay98 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @1.5+s ,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay99 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE ENDCASE @s , 1 DCPROGRESS oProgress SIZE 95,1.5 PERCENT ; EVERY 1 ; // Кол-во обновлений изображения (в функции самой регулируеся обновление изображений через 0,1 секунды) MAXCOUNT Wsego ; COLOR GRA_CLR_CYAN // Цвет полосы @s++,97 DCPUSHBUTTON CAPTION L('&Cancel') ; ACTION {||lOk:=.T.} OBJECT oButton ; SIZE 7,1.5 DCREAD GUI ; TITLE L('2.3.2.2. Процесс импорта данных из внешней БД "Inp_data" в систему "ЭЙДОС-X++"'); PARENT @oDialog ; FIT ; EXIT ; MODAL oDialog:show() ******************************************************************************************** Time_progress = 0 // Прошло секунд с начала процесса // Процесс может идти больше суток, поэтому для определения // во всех случаях вычисляется время, прошедшее с начала года T_Mess1 = L("Начало:")+" "+TIME() // Начало Sec_1 = (DOY(DATE())-1)*86400+SECONDS() PUBLIC T1 := (DOY(DATE())-1)*86400+SECONDS() // Время предыдущей индикации процесса исполнения PUBLIC T2 := (DOY(DATE())-1)*86400+SECONDS()+1 // Текущее время (1-й раз оно заметно больше T1 чтобы было отображение) PUBLIC T1tp := T1 PUBLIC T2tp := T2 ******************************************************************************************** *######################################################################################################################################### *######################################################################################################################################### SET EXACT ON // Включить режим точного сравнения символьных строк * SET LEXICAL ON DO CASE CASE M_Interval = 1 .AND. .NOT. M_Scenario // ################################################################################################## * aSay[1]:SetCaption(L('1/3: Формирование классификационных и описательных шкал и градаций на основе БД "Inp_data"') * aSay[2]:SetCaption(L('2/3: Генерация обучающей выборки и базы событий "EventsKO" на основе БД "Inp_data"') * aSay[3]:SetCaption(L('3/3: Переиндексация всех 12 баз данных нового приложения') *************************************************************************************************** ***** Сформировать классификационные и описательные шкалы и градации ****************************** *************************************************************************************************** aSay[1]:SetCaption(L('1/3: Формирование классификационных и описательных шкал и градаций на основе БД "Inp_data"')) M_KodClSc = 0 M_KodGrCS = 0 M_KodOpSc = 0 M_KodGrOS = 0 SELECT Inp_data SET FILTER TO SET ORDER TO N_ColInpData = FCOUNT() N_GrCls = INT(K_N_GrClSc/K_N_ClSc) // Кол-во градаций в класс.шкале N_GrAtr = INT(K_N_GrOpSc/K_N_OpSc) // Кол-во градаций в опис. шкале A_NameCls := {} // Массив наименований классов A_NameAtr := {} // Массив наименований признаков A_SymbCls := {} // Массив символов - классов, когда спец.интрпретация TXT-полей как символов A_SymbAtr := {} // Массив символов - классов, когда спец.интрпретация TXT-полей как символов mMaxLenCls = 15 // Максимальная длина наименования класса mMaxLenAtr = 15 // Максимальная длина наименования признака FOR ff=2 TO N_ColInpData // Начало цикла по полям Inp_data.dbf ******************************************** SELECT Inp_data IF aErrorNum[ff] // Если есть вариабельность Fv = FIELDGET(ff) DO CASE CASE FIELDTYPE(ff)="N" // Числовые столбцы * Fv = VAL(STR(Fv,19,7)) DO CASE CASE M_ClSc1 <= ff .AND. ff <= M_ClSc2 // КЛАССИФИКАЦИОННЫЕ ШКАЛЫ: SELECT Inp_data IF Flag_zer = 1 SET FILTER TO FIELDGET(ff) <> 0 ENDIF INDEX ON STR(99999999.9999999-FIELDGET(ff),19,7) TO Mrk_funi DBGOTOP() ;F_MaxSH = FIELDGET(ff) DBGOBOTTOM();F_MinSH = FIELDGET(ff) **** ЕСЛИ В СТОЛБЦЕ НЕТ РАЗЛИЧИЯ ГРАДАЦИЙ, ТО ИГНОРИРОВАТЬ ЕГО ############ IF F_MaxSH = F_MinSH * AADD(aErrorVar, '['+ALLTRIM(STR(ff))+'] - "'+ALLTRIM(aInp_name[ff])+'"') ELSE aMaxSH[ff] = F_MaxSH aMinSH[ff] = F_MinSH aDelta[ff] = (F_MaxSH-F_MinSH)/N_GrCls // Размер интервала градации в памяти (точное значение) SELECT Inp_sh // В расчетах всегда использовать только точное значение DBGOTO(1);FIELDPUT(ff,aMaxSH[ff]) DBGOTO(2);FIELDPUT(ff,aMinSH[ff]) DBGOTO(3);FIELDPUT(ff,aDelta[ff]) SELECT Class_Sc APPEND BLANK REPLACE Kod_ClSc WITH ++M_KodClSc REPLACE Name_ClSc WITH A_FNRus[ff] aNameGrNumSc = NameGrNumSc(N_GrCls) // Массив наименований градаций числовых шкал FOR gr=1 TO N_GrCls SELECT Gr_ClSc APPEND BLANK * F_MinGR = VAL(STR(aMinSH[ff]+(gr-1)*aDelta[ff],19,7)) * F_MaxGR = VAL(STR(aMinSH[ff]+(gr )*aDelta[ff],19,7)) F_MinGR = aMinSH[ff]+(gr-1)*aDelta[ff] F_MaxGR = aMinSH[ff]+(gr )*aDelta[ff] // Какие наименования ГРАДАЦИЙ числовых шкал использовать DO CASE CASE mNameGrNumSc= 1 // Только интервальные числовые значения M_NameGrCS = ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(N_GrCls,19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" CASE mNameGrNumSc= 2 // Только наименования интервальных числовых значений M_NameGrCS = aNameGrNumSc[gr] CASE mNameGrNumSc= 3 // И интервальные числовые значения, и их наименования M_NameGrCS = aNameGrNumSc[gr]+": "+; ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(N_GrCls,19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" ENDCASE REPLACE Kod_ClSc WITH M_KodClSc REPLACE Kod_GrCS WITH ++M_KodGrCS REPLACE Name_GrCS WITH M_NameGrCS // Сформировать БД Classes M_NameCS = UPPER(ALLTRIM(A_FNRus[ff])) M_Name = ALLTRIM(UPPER(A_FNRus[ff]))+"-"+M_NameGrCS mMaxLenCls = MAX( mMaxLenCls, LEN(ALLTRIM(M_Name))) // Максимальная длина наименования класса AADD(A_NameCls, ALLTRIM(M_Name)) // Массив наименований классов SELECT Classes // Имя БЗ брать из переменной APPEND BLANK REPLACE Kod_cls WITH M_KodGrCS REPLACE Name_cls WITH M_Name REPLACE Kod_ClSc WITH M_KodClSc // Код класс.шкалы REPLACE N_ChrClSc WITH LEN(ALLTRIM(A_FNRus[ff])) // Кол-во символов в наим.класс.шкалы REPLACE Min_GrInt WITH F_MinGR // Минимальная граница интервала REPLACE Max_GrInt WITH F_MaxGR // Максимальная граница интервала REPLACE Avr_GrInt WITH F_MinGR+(F_MaxGR-F_MinGR)/2 // Среднее значение интервала NEXT ENDIF CASE M_OpSc1 <= ff .AND. ff <= M_OpSc2 // ОПИСАТЕЛЬНЫЕ ШКАЛЫ: SELECT Inp_data IF Flag_zer = 1 SET FILTER TO FIELDGET(ff) <> 0 ENDIF INDEX ON STR(99999999.9999999-FIELDGET(ff),19,7) TO Mrk_funi * INDEX ON STR(99999999.9999999-FIELDGET(ff),19,7) TO Mrk_funi DBGOTOP() ;F_MaxSH = FIELDGET(ff) DBGOBOTTOM();F_MinSH = FIELDGET(ff) **** ЕСЛИ В ЧИСЛОВОМ СТОЛБЦЕ НЕТ РАЗЛИЧИЯ ГРАДАЦИЙ, ТО ИГНОРИРОВАТЬ ЕГО ############ IF F_MaxSH = F_MinSH * AADD(aErrorVar, '['+ALLTRIM(STR(ff))+'] - "'+ALLTRIM(aInp_name[ff])+'"') ELSE aMaxSH[ff] = F_MaxSH aMinSH[ff] = F_MinSH aDelta[ff] = (F_MaxSH-F_MinSH)/N_GrAtr // Размер интервала градации в памяти (точное значение) SELECT Inp_sh // В расчетах всегда использовать только точное значение * MsgBox(STR(ff)+', '+STR(aMaxSH[ff])) DBGOTO(1);FIELDPUT(ff,aMaxSH[ff]) // ############################ DBGOTO(2);FIELDPUT(ff,aMinSH[ff]) DBGOTO(3);FIELDPUT(ff,aDelta[ff]) SELECT Opis_Sc APPEND BLANK REPLACE Kod_OpSc WITH ++M_KodOpSc REPLACE Name_OpSc WITH A_FNRus[ff] aNameGrNumSc = NameGrNumSc(N_GrAtr) // Массив наименований градаций числовых шкал FOR gr=1 TO N_GrAtr SELECT Gr_OpSc APPEND BLANK * F_MinGR = VAL(STR(aMinSH[ff]+(gr-1)*aDelta[ff],19,7)) * F_MaxGR = VAL(STR(aMinSH[ff]+(gr )*aDelta[ff],19,7)) F_MinGR = aMinSH[ff]+(gr-1)*aDelta[ff] F_MaxGR = aMinSH[ff]+(gr )*aDelta[ff] // Какие наименования ГРАДАЦИЙ числовых шкал использовать DO CASE CASE mNameGrNumSc= 1 // Только интервальные числовые значения M_NameGrOS = ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(N_GrAtr,19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" CASE mNameGrNumSc= 2 // Только наименования интервальных числовых значений M_NameGrOS = aNameGrNumSc[gr] CASE mNameGrNumSc= 3 // И интервальные числовые значения, и их наименования M_NameGrOS = aNameGrNumSc[gr]+": "+; ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(N_GrAtr,19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" ENDCASE REPLACE Kod_OpSc WITH M_KodOpSc REPLACE Kod_GrOS WITH ++M_KodGrOS REPLACE Name_GrOS WITH M_NameGrOS // Сформировать БД Attributes, аналогичную Classes M_NameOS = UPPER(ALLTRIM(A_FNRus[ff])) M_Name = ALLTRIM(UPPER(A_FNRus[ff]))+"-"+M_NameGrOS mMaxLenAtr = MAX( mMaxLenAtr, LEN(ALLTRIM(M_Name))) // Максимальная длина наименования признака AADD(A_NameAtr, ALLTRIM(M_Name)) // Массив наименований признаков SELECT Attributes // Имя БЗ брать из переменной APPEND BLANK REPLACE Kod_atr WITH M_KodGrOS REPLACE Name_atr WITH M_Name REPLACE Kod_OpSc WITH M_KodOpSc // Код опис.шкалы REPLACE N_ChrOpSC WITH LEN(ALLTRIM(A_FNRus[ff])) // Кол-во символов в наим.опис.шкалы REPLACE Min_GrInt WITH F_MinGR // Минимальная граница интервала REPLACE Max_GrInt WITH F_MaxGR // Максимальная граница интервала REPLACE Avr_GrInt WITH F_MinGR+(F_MaxGR-F_MinGR)/2 // Среднее значение интервала NEXT ENDIF ENDCASE CASE FIELDTYPE(ff) = "C" // Символьные столбцы DO CASE CASE M_ClSc1 <= ff .AND. ff <= M_ClSc2 // КЛАССИФИКАЦИОННЫЕ ШКАЛЫ: // ############################## Здесь вставить формирование класс.шкал и град. с символами и разделителями ################################### * DO CASE * CASE mTxtCSField = 1 // Значения рассматриваются как целое * CASE mTxtCSField = 2 // Значения рассматриваются как состоящие из элементов - символов * CASE mTxtCSField = 3 // Значения рассматриваются как состоящие из элементов, разделенных разделителем * mTxtCSSep // Разделитель * ENDCASE DO CASE CASE mTxtCSField = 1 // Значения рассматриваются как целое SELECT Inp_data SET FILTER TO * DBGOTOP();DBGOBOTTOM();DBGOTOP() IF mSortUnqCls = 1 // Выделять уникальные значения классов и сортировать, 1-да, 2-нет INDEX ON SUBSTR(FIELDGET(ff),1,250) TO Inp_tmp UNIQUE ENDIF SELECT Inp_data ********* ЕСЛИ В ТЕКСТОВОМ СТОЛБЦЕ НЕТ РАЗЛИЧИЯ ГРАДАЦИЙ, ТО ИГНОРИРОВАТЬ ЕГО ############ DBGOTOP() ;mVal1 = FIELDGET(ff) DBGOBOTTOM();mVal2 = FIELDGET(ff) IF mVal1 = mVal2 * AADD(aErrorVar, '['+ALLTRIM(STR(ff))+'] - "'+ALLTRIM(aInp_name[ff])+'"') ELSE SELECT Class_Sc APPEND BLANK REPLACE Kod_ClSc WITH ++M_KodClSc REPLACE Name_ClSc WITH A_FNRus[ff] SELECT Inp_data DBGOTOP() DO WHILE .NOT. EOF() Fv = ALLTRIM(FIELDGET(ff)) DO CASE CASE Flag_zer = 1 * IF LEN(Fv) > 0 IF .NOT. EMPTY(Fv) SELECT Gr_ClSc APPEND BLANK M_NameGrCS = Fv REPLACE Kod_ClSc WITH M_KodClSc REPLACE Kod_GrCS WITH ++M_KodGrCS REPLACE Name_GrCS WITH M_NameGrCS * MsgBox(M_NameGrCS) // Сформировать БД Classes M_NameCS = UPPER(ALLTRIM(A_FNRus[ff])) // Если в названии градации уже включено наим.шкалы, то повторно не включать его IF AT(M_NameCS, UPPER(M_NameGrCS)) = 0 M_Name = M_NameCS+"-"+M_NameGrCS ELSE M_Name = M_NameGrCS ENDIF mMaxLenCls = MAX( mMaxLenCls, LEN(ALLTRIM(M_Name))) // Максимальная длина наименования класса AADD(A_NameCls, ALLTRIM(M_Name)) // Массив наименований классов SELECT Classes // Имя БЗ брать из переменной APPEND BLANK REPLACE Kod_cls WITH M_KodGrCS REPLACE Name_cls WITH M_Name REPLACE Kod_ClSc WITH M_KodClSc // Код класс.шкалы REPLACE N_ChrClSc WITH LEN(ALLTRIM(A_FNRus[ff])) // Кол-во символов в наим.класс.шкалы ENDIF CASE Flag_zer = 2 SELECT Gr_ClSc APPEND BLANK M_NameGrCS = Fv REPLACE Kod_ClSc WITH M_KodClSc REPLACE Kod_GrCS WITH ++M_KodGrCS REPLACE Name_GrCS WITH M_NameGrCS // Сформировать БД Classes M_NameCS = UPPER(ALLTRIM(A_FNRus[ff])) // Если в названии градации уже включено наим.шкалы, то повторно не включать его IF AT(M_NameCS, UPPER(M_NameGrCS)) = 0 M_Name = M_NameCS+"-"+M_NameGrCS ELSE M_Name = M_NameGrCS ENDIF mMaxLenCls = MAX( mMaxLenCls, LEN(ALLTRIM(M_Name))) // Максимальная длина наименования класса AADD(A_NameCls, ALLTRIM(M_Name)) // Массив наименований классов SELECT Classes // Имя БЗ брать из переменной APPEND BLANK REPLACE Kod_cls WITH M_KodGrCS REPLACE Name_cls WITH M_Name REPLACE Kod_ClSc WITH M_KodClSc // Код класс.шкалы REPLACE N_ChrClSc WITH LEN(ALLTRIM(A_FNRus[ff])) // Кол-во символов в наим.класс.шкалы ENDCASE SELECT Inp_data DBSKIP(1) ENDDO ENDIF CASE mTxtCSField = 2 // Значения рассматриваются как состоящие из элементов - символов #################################### SELECT Inp_data DBGOTOP() DO WHILE .NOT. EOF() Fv = ALLTRIM(FIELDGET(ff)) FOR w=1 TO LEN(Fv) M_Symb = ASC(SUBSTR(Fv, w, 1)) IF ASCAN(A_SymbCls, M_Symb) = 0 AADD( A_SymbCls, M_Symb) // Массив наименований градаций класс.шкал (классов) ENDIF NEXT SELECT Inp_data DBSKIP(1) ENDDO // Class_Sc и Gr_ClSc сформировать для этого случая после выхода из цикла по полям ################################### CASE mTxtCSField = 3 // Значения рассматриваются как состоящие из элементов, разделенных разделителем ##################### SELECT Class_Sc APPEND BLANK REPLACE Kod_ClSc WITH ++M_KodClSc REPLACE Name_ClSc WITH A_FNRus[ff] SELECT Inp_data SET ORDER TO;SET FILTER TO DBGOTOP() A_NameGrCS := {} DO WHILE .NOT. EOF() Fv = ALLTRIM(FIELDGET(ff)) * MsgBox(STR(NumToken( Fv ))+" "+Fv) * SELECT Words FOR w=1 TO NumToken( Fv ) mWord = TOKEN( Fv,,w ) IF LEN(ALLTRIM(mWord)) > mNWordsCS // Слова короче mNWordsCS символов не рассматривать IF ASCAN(A_NameGrCS, mWord) = 0 // Убрать повторы AADD( A_NameGrCS, mWord) // Массив наименований градаций класс.шкал (классов) * APPEND BLANK * REPLACE Word WITH mWord ENDIF ENDIF NEXT SELECT Inp_data DBSKIP(1) ENDDO IF LEN(A_NameGrCS) > 0 ASORT(A_NameGrCS) FOR j=1 TO LEN(A_NameGrCS) SELECT Gr_ClSc APPEND BLANK M_NameGrCS = Fv REPLACE Kod_ClSc WITH M_KodClSc REPLACE Kod_GrCS WITH ++M_KodGrCS REPLACE Name_GrCS WITH A_NameGrCS[j] // Сформировать БД Classes M_NameCS = UPPER(ALLTRIM(A_FNRus[ff])) // Если в названии градации уже включено наим.шкалы, то повторно не включать его IF AT(M_NameCS, UPPER(A_NameGrCS[j])) = 0 M_Name = M_NameCS+"-"+A_NameGrCS[j] ELSE M_Name = A_NameGrCS[j] ENDIF mMaxLenCls = MAX( mMaxLenCls, LEN(ALLTRIM(M_Name))) // Максимальная длина наименования класса AADD(A_NameCls, ALLTRIM(M_Name)) // Массив наименований классов SELECT Classes // Имя БЗ брать из переменной APPEND BLANK REPLACE Kod_cls WITH M_KodGrCS REPLACE Name_cls WITH M_Name REPLACE Kod_ClSc WITH M_KodClSc // Код класс.шкалы REPLACE N_ChrClSc WITH LEN(ALLTRIM(A_FNRus[ff])) // Кол-во символов в наим.класс.шкалы NEXT ENDIF ENDCASE CASE M_OpSc1 <= ff .AND. ff <= M_OpSc2 // ОПИСАТЕЛЬНЫЕ ШКАЛЫ: // ############################## Здесь вставить формирование описательных шкал и град. с символами и разделителями ################################### * DO CASE * CASE mTxtOSField = 1 // Значения рассматриваются как целое * CASE mTxtOSField = 2 // Значения рассматриваются как состоящие из элементов - символов * CASE mTxtOSField = 3 // Значения рассматриваются как состоящие из элементов, разделенных разделителем (слов) * mTxtOSSep // Разделитель * ENDCASE DO CASE CASE mTxtOSField = 1 // Значения рассматриваются как целое SELECT Inp_data SET FILTER TO * DBGOTOP();DBGOBOTTOM();DBGOTOP() INDEX ON SUBSTR(FIELDGET(ff),1,250) TO Mrk_funi UNIQUE SELECT Inp_data SET ORDER TO 1 ********* ЕСЛИ В СТОЛБЦЕ НЕТ РАЗЛИЧИЯ ГРАДАЦИЙ, ТО ИГНОРИРОВАТЬ ЕГО ############ DBGOTOP() ;mVal1 = FIELDGET(ff) DBGOBOTTOM();mVal2 = FIELDGET(ff) IF mVal1 = mVal2 * AADD(aErrorVar, '['+ALLTRIM(STR(ff))+'] - "'+ALLTRIM(aInp_name[ff])+'"') ELSE SELECT Opis_Sc APPEND BLANK REPLACE Kod_OpSc WITH ++M_KodOpSc REPLACE Name_OpSc WITH A_FNRus[ff] SELECT Inp_data DBGOTOP() DO WHILE .NOT. EOF() Fv = ALLTRIM(FIELDGET(ff)) DO CASE CASE Flag_zer = 1 * IF LEN(Fv) > 0 IF .NOT. EMPTY(Fv) SELECT Gr_OpSc APPEND BLANK M_NameGrOS = Fv REPLACE Kod_OpSc WITH M_KodOpSc REPLACE Kod_GrOS WITH ++M_KodGrOS REPLACE Name_GrOS WITH M_NameGrOS // Сформировать БД Attributes M_NameOS = UPPER(ALLTRIM(A_FNRus[ff])) // Если в названии градации уже включено наим.шкалы, то повторно не включать его IF AT(M_NameOS, UPPER(M_NameGrOS)) = 0 M_Name = M_NameOS+"-"+M_NameGrOS ELSE M_Name = M_NameGrOS ENDIF mMaxLenAtr = MAX( mMaxLenAtr, LEN(ALLTRIM(M_Name))) // Максимальная длина наименования признака AADD(A_NameAtr, ALLTRIM(M_Name)) // Массив наименований признаков SELECT Attributes // Имя БЗ брать из переменной APPEND BLANK REPLACE Kod_atr WITH M_KodGrOS REPLACE Name_atr WITH M_Name REPLACE Kod_OpSc WITH M_KodOpSc // Код опис.шкалы REPLACE N_ChrOpSC WITH LEN(ALLTRIM(A_FNRus[ff])) // Кол-во символов в наим.опис.шкалы ENDIF CASE Flag_zer = 2 SELECT Gr_OpSc APPEND BLANK M_NameGrOS = Fv REPLACE Kod_OpSc WITH M_KodOpSc REPLACE Kod_GrOS WITH ++M_KodGrOS REPLACE Name_GrOS WITH M_NameGrOS // Сформировать БД Attributes M_NameOS = UPPER(ALLTRIM(A_FNRus[ff])) // Если в названии градации уже включено наим.шкалы, то повторно не включать его IF AT(M_NameOS, UPPER(M_NameGrOS)) = 0 M_Name = M_NameOS+"-"+M_NameGrOS ELSE M_Name = M_NameGrOS ENDIF mMaxLenAtr = MAX( mMaxLenAtr, LEN(ALLTRIM(M_Name))) // Максимальная длина наименования признака AADD(A_NameAtr, ALLTRIM(M_Name)) // Массив наименований признаков SELECT Attributes // Имя БЗ брать из переменной APPEND BLANK REPLACE Kod_atr WITH M_KodGrOS REPLACE Name_atr WITH M_Name REPLACE Kod_OpSc WITH M_KodOpSc // Код опис.шкалы REPLACE N_ChrOpSC WITH LEN(ALLTRIM(A_FNRus[ff])) // Кол-во символов в наим.опис.шкалы ENDCASE SELECT Inp_data DBSKIP(1) ENDDO ENDIF CASE mTxtOSField = 2 // Значения рассматриваются как состоящие из элементов - символов ########################################### SELECT Inp_data DBGOTOP() DO WHILE .NOT. EOF() Fv = ALLTRIM(FIELDGET(ff)) FOR w=1 TO LEN(Fv) M_Symb = ASC(SUBSTR(Fv, w, 1)) IF ASCAN(A_SymbAtr, M_Symb) = 0 AADD( A_SymbAtr, M_Symb) // Массив наименований градаций опис.шкал (классов) ENDIF NEXT SELECT Inp_data DBSKIP(1) ENDDO // Opis_Sc и Gr_OpSc сформировать для этого случая после выхода из цикла по полям ################################### CASE mTxtOSField = 3 // Значения рассматриваются как состоящие из элементов, разделенных разделителем ############################## SELECT Opis_Sc APPEND BLANK REPLACE Kod_OpSc WITH ++M_KodOpSc REPLACE Name_OpSc WITH A_FNRus[ff] SELECT Inp_data SET ORDER TO;SET FILTER TO DBGOTOP() A_NameGrOS := {} DO WHILE .NOT. EOF() Fv = ALLTRIM(FIELDGET(ff)) * Fv = FIELDGET(ff) * MsgBox(STR(NumToken( Fv ))+" "+Fv) * SELECT Words FOR w=1 TO NumToken( Fv ) mWord = TOKEN( Fv,,w ) * IF A_FNRus[ff] = "Учр.здравоохранения" .AND.LEN(ALLTRIM(mWord)) < 5 //<<<===#################### отладка * MsgBox(STR(RECNO())+" "+Fv+' '+mWord) * ENDIF IF LEN(ALLTRIM(mWord)) > mNWordsOS // Слова короче mNWordsOS символов не рассматривать IF ASCAN(A_NameGrOS, mWord) = 0 // Убрать повторы AADD( A_NameGrOS, mWord) // Массив наименований градаций описательных шкал (признаков) * APPEND BLANK * REPLACE Word WITH mWord ENDIF ENDIF NEXT SELECT Inp_data DBSKIP(1) ENDDO IF LEN(A_NameGrOS) > 0 ASORT(A_NameGrOS) FOR j=1 TO LEN(A_NameGrOS) SELECT Gr_OpSc APPEND BLANK M_NameGrOS = Fv REPLACE Kod_OpSc WITH M_KodOpSc REPLACE Kod_GrOS WITH ++M_KodGrOS REPLACE Name_GrOS WITH A_NameGrOS[j] // Сформировать БД Attributes M_NameOS = UPPER(ALLTRIM(A_FNRus[ff])) // Если в названии градации уже включено наим.шкалы, то повторно не включать его IF AT(M_NameOS, UPPER(A_NameGrOS[j])) = 0 M_Name = M_NameOS+"-"+A_NameGrOS[j] ELSE M_Name = A_NameGrOS[j] ENDIF mMaxLenAtr = MAX( mMaxLenAtr, LEN(ALLTRIM(M_Name))) // Максимальная длина наименования признака AADD(A_NameAtr, ALLTRIM(M_Name)) // Массив наименований признаков SELECT Attributes // Имя БЗ брать из переменной APPEND BLANK REPLACE Kod_atr WITH M_KodGrOS REPLACE Name_atr WITH M_Name REPLACE Kod_OpSc WITH M_KodOpSc // Код опис.шкалы REPLACE N_ChrOpSc WITH LEN(ALLTRIM(A_FNRus[ff])) // Кол-во символов в наим.опис.шкалы NEXT ENDIF ENDCASE ENDCASE ENDCASE ENDIF lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) NEXT // Сформировать Class_Sc и Gr_ClSc, Opis_Sc и Gr_OpSc ############################################################### IF mTxtCSField = 2 // Значения рассматриваются как состоящие из элементов - символов ################################ IF LEN(A_SymbCls) > 0 // Сформировать Class_Sc и Gr_ClSc SELECT Class_Sc APPEND BLANK REPLACE Kod_ClSc WITH ++M_KodClSc REPLACE Name_ClSc WITH "Символ" ASORT(A_SymbCls) A_NameGrCS := {} FOR j=1 TO LEN(A_SymbCls) AADD(A_NameGrCS, CHR(A_SymbCls[j])) NEXT FOR j=1 TO LEN(A_NameGrCS) SELECT Gr_ClSc APPEND BLANK M_NameGrCS = Fv REPLACE Kod_ClSc WITH M_KodClSc REPLACE Kod_GrCS WITH ++M_KodGrCS REPLACE Name_GrCS WITH A_NameGrCS[j] // Сформировать БД Classes M_Name = "Символ-"+A_NameGrCS[j] mMaxLenCls = MAX( mMaxLenCls, LEN(ALLTRIM(M_Name))) // Максимальная длина наименования класса AADD(A_NameCls, ALLTRIM(M_Name)) // Массив наименований классов SELECT Classes // Имя БЗ брать из переменной APPEND BLANK REPLACE Kod_cls WITH M_KodGrCS REPLACE Name_cls WITH M_Name REPLACE Kod_ClSc WITH M_KodClSc // Код класс.шкалы REPLACE N_ChrClSc WITH LEN(L("Символ")) // Кол-во символов в наим.класс.шкалы NEXT ENDIF ENDIF IF mTxtOSField = 2 // Значения рассматриваются как состоящие из элементов - символов ################################ IF LEN(A_SymbAtr) > 0 // Сформировать Opis_Sc и Gr_OpSc SELECT Opis_Sc APPEND BLANK REPLACE Kod_OpSc WITH ++M_KodOpSc REPLACE Name_OpSc WITH L("Символ") ASORT(A_SymbAtr) A_NameGrOS := {} FOR j=1 TO LEN(A_SymbAtr) AADD(A_NameGrOS, CHR(A_SymbAtr[j])) NEXT FOR j=1 TO LEN(A_NameGrOS) SELECT Gr_OpSc APPEND BLANK M_NameGrOS = Fv REPLACE Kod_OpSc WITH M_KodOpSc REPLACE Kod_GrOS WITH ++M_KodGrOS REPLACE Name_GrOS WITH A_NameGrOS[j] // Сформировать БД Attributes M_Name = "Символ-"+A_NameGrOS[j] mMaxLenAtr = MAX( mMaxLenAtr, LEN(ALLTRIM(M_Name))) // Максимальная длина наименования класса AADD(A_NameAtr, ALLTRIM(M_Name)) // Массив наименований классов SELECT Attributes // Имя БЗ брать из переменной APPEND BLANK REPLACE Kod_atr WITH M_KodGrOS REPLACE Name_atr WITH M_Name REPLACE Kod_OpSc WITH M_KodOpSc // Код класс.шкалы REPLACE N_ChrOpSc WITH LEN(L("Символ")) // Кол-во символов в наим.класс.шкалы NEXT ENDIF ENDIF // Сохранение информации Inp_sh в форме массивов, т.к. массивы содержат точные значения DC_ASave(aMinSH, M_NewAppl+"\aMinSH.arx") DC_ASave(aMaxSH, M_NewAppl+"\aMaxSH.arx") DC_ASave(aDelta, M_NewAppl+"\aDelta.arx") DC_ASave(A_NameCls, M_NewAppl+"\A_NameCls.arx") DC_ASave(A_NameAtr, M_NewAppl+"\A_NameAtr.arx") StrFile(STR(mMaxLenCls), '_MaxLCls.txt') // Запись текстового файла с параметром mMaxLenCls StrFile(STR(mMaxLenAtr), '_MaxLAtr.txt') // Запись текстового файла с параметром mMaxLenAtr * mMaxLenCls = VAL(FileStr('_MaxLCls.txt')) // Загрузка параметра mMaxLenCls из текстового файла * mMaxLenAtr = VAL(FileStr('_MaxLAtr.txt')) // Загрузка параметра mMaxLenAtr из текстового файла aSay[1]:SetCaption(aSay[1]:caption+L(' - Готово ')) *************************************************************************************************** **** Конец создания класс.и опис.шкал и градаций ************************************************** *************************************************************************************************** *************************************************************************************************** ######################################### **** 2/3: Генерация обучающей выборки и базы событий "EventsKO" на основе БД "Inp_data" *********** ######################################### *************************************************************************************************** ######################################### aSay[2]:SetCaption(L('2/3: Генерация обучающей выборки и базы событий "EventsKO" на основе БД "Inp_data"')) ***** Создать индексные массивы для поиска CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW INDEX ON Name_cls TO Cls_name CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Attributes EXCLUSIVE NEW INDEX ON Name_atr TO Atr_name CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes INDEX Cls_name EXCLUSIVE NEW USE Attributes INDEX Atr_name EXCLUSIVE NEW USE Inp_data EXCLUSIVE NEW USE Inp_sh EXCLUSIVE NEW USE EventsKO EXCLUSIVE NEW;ZAP USE Obi_Zag EXCLUSIVE NEW;ZAP USE Obi_Kcl EXCLUSIVE NEW;ZAP USE Obi_Kpr EXCLUSIVE NEW;ZAP ****** Данные для расчета минимальных размеров полей, достаточных для размещения данных ****** В будущем наверное надо сделать EventsKO.txt SELECT EventsKO aStrEventsKO := { { "Name_obj" , "C",250, 0} } FOR j=2 TO FCOUNT() Fv = FIELDGET(1) // Наименование объекта обучающей выборки DO CASE CASE VALTYPE(Fv) = "N" // Числовые столбцы AADD(aStrEventsKO, { FIELDNAME(j), FIELDTYPE(j), FIELDSIZE(j), FIELDDECI(j) }) CASE VALTYPE(Fv) = "C" // Символьные столбцы AADD(aStrEventsKO, { FIELDNAME(j), FIELDTYPE(j), -99999999999, 0 }) CASE VALTYPE(Fv) = "D" // Столбец типа "Дата" AADD(aStrEventsKO, { FIELDNAME(j), "D", -99999999999, 0 }) ENDCASE NEXT SELECT EventsKO FOR j=1 TO N_Obj APPEND BLANK NEXT M_KodObj = 0 SELECT Inp_data;N_Obj = RECCOUNT() SET ORDER TO DBGOTOP() DO WHILE .NOT. EOF() ****** База заголовков SELECT Inp_data Fv = FIELDGET(1) // Наименование объекта обучающей выборки DO CASE CASE VALTYPE(Fv) = "N" // Числовые столбцы M_NameObj = ALLTRIM(STR(Fv,250)) CASE VALTYPE(Fv) = "C" // Символьные столбцы M_NameObj = ALLTRIM(Fv) CASE VALTYPE(Fv) = "D" // Столбец типа "Дата" M_NameObj = ALLTRIM(DTOC(Fv)) ENDCASE M_KodObj = RECNO() *** Формирование массива кодов классов из БД Inp_data A_KodCls := {} // Массив кодов классов текущего объекта обучающей выборки SELECT EventsKO DBGOTO(M_KodObj) REPLACE Name_obj WITH M_NameObj FOR ff = M_ClSc1 TO M_ClSc2 SELECT Inp_data IF aErrorNum[ff] // Если есть вариабельность Fv = FIELDGET(ff) DO CASE CASE FIELDTYPE(ff)="N" // Числовые столбцы * Fv = VAL(STR(Fv,19,6)) ****** Формирование кодов классов SELECT EventsKO aNameGrNumSc = NameGrNumSc(N_GrCls) // Массив наименований градаций числовых шкал FOR gr = 1 TO N_GrCls * F_MinGR = VAL(STR(aMinSH[ff]+(gr-1)*aDelta[ff],19,7)) * F_MaxGR = VAL(STR(aMinSH[ff]+(gr )*aDelta[ff],19,7)) F_MinGR = aMinSH[ff]+(gr-1)*aDelta[ff] F_MaxGR = aMinSH[ff]+(gr )*aDelta[ff] IF F_MinGR <= Fv .AND. Fv <= F_MaxGR // Какие наименования ГРАДАЦИЙ числовых шкал использовать DO CASE CASE mNameGrNumSc= 1 // Только интервальные числовые значения M_Name = ALLTRIM(UPPER(A_FNRus[ff]))+"-"+; ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(N_GrCls,19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" CASE mNameGrNumSc= 2 // Только наименования интервальных числовых значений M_Name = ALLTRIM(UPPER(A_FNRus[ff]))+"-"+aNameGrNumSc[gr] CASE mNameGrNumSc= 3 // И интервальные числовые значения, и их наименования M_Name = ALLTRIM(UPPER(A_FNRus[ff]))+"-"+aNameGrNumSc[gr]+": "+; ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(N_GrCls,19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" ENDCASE M_KodCls = ASCAN(A_NameCls, M_Name) IF M_KodCls > 0 AADD(A_KodCls, M_KodCls) FIELDPUT(ff, M_KodCls) ENDIF EXIT // Исключить повторное кодирование того же значения в следующем интервале ENDIF NEXT CASE FIELDTYPE(ff) = "C" // Символьные столбцы // ############################## Здесь вставить формирование класс.шкал и град. с символами и разделителями ################################### * DO CASE * CASE mTxtCSField = 1 // Значения рассматриваются как целое * CASE mTxtCSField = 2 // Значения рассматриваются как состоящие из элементов - символов * CASE mTxtCSField = 3 // Значения рассматриваются как состоящие из элементов, разделенных разделителем * mTxtCSSep // Разделитель * ENDCASE DO CASE CASE mTxtCSField = 1 // Значения рассматриваются как целое M_NameGrCS = ALLTRIM(Fv) M_Name = ALLTRIM(UPPER(A_FNRus[ff]))+"-"+M_NameGrCS M_KodCls = ASCAN(A_NameCls, M_Name) SELECT EventsKO // при mTxtCSField = 2 или 3 в EventsKO записывать коды через разделитель IF M_KodCls > 0 AADD(A_KodCls, M_KodCls) * FIELDPUT(ff, ALLTRIM(STR(M_KodCls,19))) FIELDPUT(ff, M_KodCls) ENDIF CASE mTxtCSField = 2 // Значения рассматриваются как состоящие из элементов - символов #################################### Fv = ALLTRIM(FIELDGET(ff)) SELECT EventsKO // при mTxtCSField = 2 или 3 в EventsKO записывать коды через разделитель FOR w=1 TO LEN(Fv) M_Symb = ASC(SUBSTR(Fv, w, 1)) M_KodCls = ASCAN(A_SymbCls, M_Symb) IF M_KodCls > 0 AADD(A_KodCls, M_KodCls) FIELDPUT(ff, M_KodCls) aStrEventsKO[ff,4] = MAX(aStrEventsKO[ff,4], LEN(ALLTRIM(Fv+" "+ALLTRIM(STR(M_KodCls,19))))) // 3 ENDIF NEXT CASE mTxtCSField = 3 // Значения рассматриваются как состоящие из элементов, разделенных разделителем ##################### Fv = ALLTRIM(FIELDGET(ff)) SELECT EventsKO // при mTxtCSField = 2 или 3 в EventsKO записывать коды через разделитель FOR w=1 TO NumToken( Fv ) mWord = TOKEN(Fv,,w) IF LEN(ALLTRIM(mWord)) > 0 // Слова короче 4 символов не рассматривать M_Name = ALLTRIM(UPPER(A_FNRus[ff]))+"-"+mWord M_KodCls = ASCAN(A_NameCls, M_Name) IF M_KodCls > 0 AADD(A_KodCls, M_KodCls) FIELDPUT(ff, M_KodCls) MemoAtr = Fv + " " + ALLTRIM(STR(M_KodCls,15)) aStrEventsKO[ff,4] = MAX(aStrEventsKO[ff,4], LEN(ALLTRIM(Fv+" "+ALLTRIM(STR(M_KodCls,19))))) // 3 ENDIF ENDIF NEXT ENDCASE ENDCASE ENDIF NEXT ******* Формирование массива кодов признаков из БД Inp_data A_KodAtr = {} FOR ff=M_OpSc1 TO M_OpSc2 // Начало цикла по полям БД Inp_data SELECT Inp_data IF aErrorNum[ff] // Если есть вариабельность Fv = FIELDGET(ff) DO CASE CASE FIELDTYPE(ff)="N" // Числовые столбцы * Fv = VAL(STR(Fv,19,6)) SELECT EventsKO aNameGrNumSc = NameGrNumSc(N_GrAtr) // Массив наименований градаций числовых шкал FOR gr = 1 TO N_GrAtr * F_MinGR = VAL(STR(aMinSH[ff]+(gr-1)*aDelta[ff],19,7)) * F_MaxGR = VAL(STR(aMinSH[ff]+(gr )*aDelta[ff],19,7)) F_MinGR = aMinSH[ff]+(gr-1)*aDelta[ff] F_MaxGR = aMinSH[ff]+(gr )*aDelta[ff] IF F_MinGR <= Fv .AND. Fv <= F_MaxGR // Какие наименования ГРАДАЦИЙ числовых шкал использовать DO CASE CASE mNameGrNumSc= 1 // Только интервальные числовые значения M_Name = ALLTRIM(UPPER(A_FNRus[ff]))+"-"+; ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(N_GrAtr,19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" CASE mNameGrNumSc= 2 // Только наименования интервальных числовых значений M_Name = ALLTRIM(UPPER(A_FNRus[ff]))+"-"+aNameGrNumSc[gr] CASE mNameGrNumSc= 3 // И интервальные числовые значения, и их наименования M_Name = ALLTRIM(UPPER(A_FNRus[ff]))+"-"+aNameGrNumSc[gr]+": "+; ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(N_GrAtr,19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" ENDCASE M_KodAtr = ASCAN(A_NameAtr, M_Name) IF M_KodAtr > 0 AADD(A_KodAtr, M_KodAtr) FIELDPUT(ff, M_KodAtr) ENDIF EXIT // Исключить повторное кодирование того же значения в следующем интервале ENDIF NEXT CASE FIELDTYPE(ff) = "C" // Символьные столбцы ######################################################## // ############################## Здесь вставить формирование опис.шкал и град. с символами и разделителями ################################### * DO CASE * CASE mTxtOSField = 1 // Значения рассматриваются как целое * CASE mTxtOSField = 2 // Значения рассматриваются как состоящие из элементов - символов * CASE mTxtOSField = 3 // Значения рассматриваются как состоящие из элементов, разделенных разделителем * mTxtOSSep // Разделитель * ENDCASE DO CASE CASE mTxtOSField = 1 // Значения рассматриваются как целое M_NameGrOS = ALLTRIM(Fv) M_Name = ALLTRIM(UPPER(A_FNRus[ff]))+"-"+M_NameGrOS M_KodAtr = ASCAN(A_NameAtr, M_Name) IF M_KodAtr > 0 AADD(A_KodAtr, M_KodAtr) SELECT EventsKO FIELDPUT(ff, M_KodAtr) ENDIF CASE mTxtOSField = 2 // Значения рассматриваются как состоящие из элементов - символов #################################### Fv = ALLTRIM(FIELDGET(ff)) SELECT EventsKO // при mTxtCSField = 2 или 3 в EventsKO записывать коды через разделитель FOR w=1 TO LEN(Fv) M_Symb = ASC(SUBSTR(Fv, w, 1)) M_KodAtr = ASCAN(A_SymbAtr, M_Symb) IF M_KodAtr > 0 AADD(A_KodAtr, M_KodAtr) FIELDPUT(ff, M_KodAtr) aStrEventsKO[ff,4] = MAX(aStrEventsKO[ff,4], LEN(ALLTRIM(Fv+" "+ALLTRIM(STR(M_KodAtr,19))))) // 3 ENDIF NEXT CASE mTxtOSField = 3 // Значения рассматриваются как состоящие из элементов, разделенных разделителем ##################### Fv = ALLTRIM(FIELDGET(ff)) SELECT EventsKO // при mTxtCSField = 2 или 3 в EventsKO записывать коды через разделитель FOR w=1 TO NumToken( Fv ) mWord = TOKEN(Fv,,w) IF LEN(ALLTRIM(mWord)) > 0 // Слова короче 4 символов не рассматривать M_Name = ALLTRIM(UPPER(A_FNRus[ff]))+"-"+mWord M_KodAtr = ASCAN(A_NameAtr, M_Name) IF M_KodAtr > 0 AADD(A_KodAtr, M_KodAtr) FIELDPUT(ff, M_KodAtr) MemoAtr = Fv + " " + ALLTRIM(STR(M_KodAtr,15)) aStrEventsKO[ff,4] = MAX(aStrEventsKO[ff,4], LEN(ALLTRIM(Fv+" "+ALLTRIM(STR(M_KodAtr,19))))) // 3 ENDIF ENDIF NEXT ENDCASE ENDCASE ENDIF NEXT // Формирование записи БД заголовков объектов обучающей выборки SELECT Obi_Zag APPEND BLANK REPLACE Kod_obj WITH M_KodObj REPLACE Name_obj WITH M_NameObj ****** Запись массива кодов классов в БД Obi_Kcl * ASORT(A_KodCls) SELECT Obi_Kcl // И точно также записать EventsKO.dbf APPEND BLANK FIELDPUT(1,M_KodObj) IF LEN(A_KodCls) > 0 k=2 FOR jj=1 TO LEN(A_KodCls) IF k <= 5 FIELDPUT(k++,A_KodCls[jj]) ELSE k=2 APPEND BLANK FIELDPUT(1,M_KodObj) FIELDPUT(k++,A_KodCls[jj]) ENDIF NEXT ENDIF ****** Запись массива кодов признаков в БД Obi_Kpr * ASORT(A_KodAtr) SELECT Obi_Kpr APPEND BLANK FIELDPUT(1,M_KodObj) IF LEN(A_KodAtr) > 0 k=2 FOR jj=1 TO LEN(A_KodAtr) IF k <= 8 FIELDPUT(k++,A_KodAtr[jj]) ELSE k=2 APPEND BLANK FIELDPUT(1,M_KodObj) FIELDPUT(k++,A_KodAtr[jj]) ENDIF NEXT ENDIF lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) SELECT Inp_data DBSKIP(1) ENDDO * DC_DebugQout( A_NameAtr ) ****** Сделать размеры текстовых полей в БД EventsKO минимальными достаточными для размещения данных * CLOSE EventsKO * DC_DBFILE( DC_SETDCLIP(),"EventsKO.dbf", ,,,'DBFNTX',, aStrEventsKO) // Обновление структуры БД с сохранением информации * USE EventsKO EXCLUSIVE NEW * Сделал мемо-поле для особой интерпретации текстовых полей aSay[2]:SetCaption(aSay[2]:caption+L(' - Готово ')) *************************************************************************************************** **** Конец генерации обучающей выборки и базы событий "EventsKO" на основе БД "Inp_data" ********** *************************************************************************************************** CASE M_Interval = 1 .AND. M_Scenario // ################################################################################################## * aSay[1]:SetCaption(L('1/5: Формирование классификационных и описательных шкал и градаций на основе БД "Inp_data"') * aSay[2]:SetCaption(L('2/5: Создание базы событий "EventsKO" из "Inp_data" с кодами событий вместо значений шкал') * aSay[3]:SetCaption(L('3/5: Доформирование классиф.и описат.шкал и градаций на основе БД "EventsKO" (сценарии)') * aSay[4]:SetCaption(L('4/5: Генерация обучающей выборки на основе базы событий "EventsKO"') * aSay[5]:SetCaption(L('5/5: Переиндексация всех 12 баз данных нового приложения') *************************************************************************************************** ***** Сформировать классификационные и описательные шкалы и градации ****************************** *************************************************************************************************** aSay[1]:SetCaption(L('1/5: Формирование классификационных и описательных шкал и градаций на основе БД "Inp_data"')) M_KodClSc = 0 M_KodGrCS = 0 M_KodOpSc = 0 M_KodGrOS = 0 SELECT Inp_data SET ORDER TO N_ColInpData = FCOUNT() N_GrCls = INT(K_N_GrClSc/K_N_ClSc) // Кол-во градаций в класс.шкале N_GrAtr = INT(K_N_GrOpSc/K_N_OpSc) // Кол-во градаций в опис. шкале A_NameCls := {} // Массив наименований классов A_NameAtr := {} // Массив наименований признаков mMaxLenCls = 15 // Максимальная длина наименования класса mMaxLenAtr = 15 // Максимальная длина наименования признака FOR ff=2 TO N_ColInpData // Начало цикла по полям Inp_data.dbf ******************************************** SELECT Inp_data IF aErrorNum[ff] // Если есть вариабельность Fv = FIELDGET(ff) DO CASE CASE FIELDTYPE(ff)="N" // Числовые столбцы * Fv = VAL(STR(Fv,19,6)) DO CASE CASE M_ClSc1 <= ff .AND. ff <= M_ClSc2 // КЛАССИФИКАЦИОННЫЕ ШКАЛЫ: SELECT Inp_data IF Flag_zer = 1 SET FILTER TO FIELDGET(ff) <> 0 ENDIF INDEX ON STR(99999999.9999999-FIELDGET(ff),19,7) TO Mrk_funi DBGOTOP() ;F_MaxSH = FIELDGET(ff) DBGOBOTTOM();F_MinSH = FIELDGET(ff) **** ЕСЛИ В ЧИСЛОВОМ СТОЛБЦЕ НЕТ РАЗЛИЧИЯ ГРАДАЦИЙ, ТО ИГНОРИРОВАТЬ ЕГО ############ IF F_MaxSH = F_MinSH * AADD(aErrorVar, '['+ALLTRIM(STR(ff))+'] - "'+ALLTRIM(aInp_name[ff])+'"') ELSE aMaxSH[ff] = F_MaxSH aMinSH[ff] = F_MinSH aDelta[ff] = (F_MaxSH-F_MinSH)/N_GrCls // Размер интервала градации в памяти (точное значение) SELECT Inp_sh // В расчетах всегда использовать только точное значение DBGOTO(1);FIELDPUT(ff,aMaxSH[ff]) DBGOTO(2);FIELDPUT(ff,aMinSH[ff]) DBGOTO(3);FIELDPUT(ff,aDelta[ff]) SELECT Class_Sc APPEND BLANK REPLACE Kod_ClSc WITH ++M_KodClSc REPLACE Name_ClSc WITH A_FNRus[ff] aNameGrNumSc = NameGrNumSc(N_GrCls) // Массив наименований градаций числовых шкал FOR gr=1 TO N_GrCls SELECT Gr_ClSc APPEND BLANK * F_MinGR = VAL(STR(aMinSH[ff]+(gr-1)*aDelta[ff],19,7)) * F_MaxGR = VAL(STR(aMinSH[ff]+(gr )*aDelta[ff],19,7)) F_MinGR = aMinSH[ff]+(gr-1)*aDelta[ff] F_MaxGR = aMinSH[ff]+(gr )*aDelta[ff] // Какие наименования ГРАДАЦИЙ числовых шкал использовать DO CASE CASE mNameGrNumSc= 1 // Только интервальные числовые значения M_NameGrCS = ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(N_GrCls,19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" CASE mNameGrNumSc= 2 // Только наименования интервальных числовых значений M_NameGrCS = aNameGrNumSc[gr] CASE mNameGrNumSc= 3 // И интервальные числовые значения, и их наименования M_NameGrCS = aNameGrNumSc[gr]+": "+; ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(N_GrCls,19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" ENDCASE REPLACE Kod_ClSc WITH M_KodClSc REPLACE Kod_GrCS WITH ++M_KodGrCS REPLACE Name_GrCS WITH M_NameGrCS // Сформировать БД Classes M_NameCS = UPPER(ALLTRIM(A_FNRus[ff])) M_Name = ALLTRIM(UPPER(A_FNRus[ff]))+"-"+M_NameGrCS mMaxLenCls = MAX( mMaxLenCls, LEN(ALLTRIM(M_Name))) // Максимальная длина наименования класса AADD(A_NameCls, ALLTRIM(M_Name)) // Массив наименований классов SELECT Classes // Имя БЗ брать из переменной APPEND BLANK REPLACE Kod_cls WITH M_KodGrCS REPLACE Name_cls WITH M_Name REPLACE Kod_ClSc WITH M_KodClSc // Код класс.шкалы REPLACE N_ChrClSc WITH LEN(ALLTRIM(A_FNRus[ff])) // Кол-во символов в наим.класс.шкалы REPLACE Min_GrInt WITH F_MinGR // Минимальная граница интервала REPLACE Max_GrInt WITH F_MaxGR // Максимальная граница интервала REPLACE Avr_GrInt WITH F_MinGR+(F_MaxGR-F_MinGR)/2 // Среднее значение интервала NEXT ENDIF CASE M_OpSc1 <= ff .AND. ff <= M_OpSc2 // ОПИСАТЕЛЬНЫЕ ШКАЛЫ: SELECT Inp_data IF Flag_zer = 1 SET FILTER TO FIELDGET(ff) <> 0 ENDIF INDEX ON STR(99999999.9999999-FIELDGET(ff),19,7) TO Mrk_funi DBGOTOP() ;F_MaxSH = FIELDGET(ff) DBGOBOTTOM();F_MinSH = FIELDGET(ff) **** ЕСЛИ В ЧИСЛОВОМ СТОЛБЦЕ НЕТ РАЗЛИЧИЯ ГРАДАЦИЙ, ТО ИГНОРИРОВАТЬ ЕГО ############ IF F_MaxSH = F_MinSH * AADD(aErrorVar, '['+ALLTRIM(STR(ff))+'] - "'+ALLTRIM(aInp_name[ff])+'"') ELSE aMaxSH[ff] = F_MaxSH aMinSH[ff] = F_MinSH aDelta[ff] = (F_MaxSH-F_MinSH)/N_GrAtr // Размер интервала градации в памяти (точное значение) SELECT Inp_sh // В расчетах всегда использовать только точное значение DBGOTO(1);FIELDPUT(ff,aMaxSH[ff]) DBGOTO(2);FIELDPUT(ff,aMinSH[ff]) DBGOTO(3);FIELDPUT(ff,aDelta[ff]) SELECT Opis_Sc APPEND BLANK REPLACE Kod_OpSc WITH ++M_KodOpSc REPLACE Name_OpSc WITH A_FNRus[ff] aNameGrNumSc = NameGrNumSc(N_GrAtr) // Массив наименований градаций числовых шкал FOR gr=1 TO N_GrAtr SELECT Gr_OpSc APPEND BLANK * F_MinGR = VAL(STR(aMinSH[ff]+(gr-1)*aDelta[ff],19,7)) * F_MaxGR = VAL(STR(aMinSH[ff]+(gr )*aDelta[ff],19,7)) F_MinGR = aMinSH[ff]+(gr-1)*aDelta[ff] F_MaxGR = aMinSH[ff]+(gr )*aDelta[ff] // Какие наименования ГРАДАЦИЙ числовых шкал использовать DO CASE CASE mNameGrNumSc= 1 // Только интервальные числовые значения M_NameGrOS = ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(N_GrAtr,19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" CASE mNameGrNumSc= 2 // Только наименования интервальных числовых значений M_NameGrOS = aNameGrNumSc[gr] CASE mNameGrNumSc= 3 // И интервальные числовые значения, и их наименования M_NameGrOS = aNameGrNumSc[gr]+": "+; ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(N_GrAtr,19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" ENDCASE REPLACE Kod_OpSc WITH M_KodOpSc REPLACE Kod_GrOS WITH ++M_KodGrOS REPLACE Name_GrOS WITH M_NameGrOS // Сформировать БД Attributes, аналогичную Classes M_NameOS = UPPER(ALLTRIM(A_FNRus[ff])) M_Name = ALLTRIM(UPPER(A_FNRus[ff]))+"-"+M_NameGrOS mMaxLenAtr = MAX( mMaxLenAtr, LEN(ALLTRIM(M_Name))) // Максимальная длина наименования признака AADD(A_NameAtr, ALLTRIM(M_Name)) // Массив наименований признаков SELECT Attributes // Имя БЗ брать из переменной APPEND BLANK REPLACE Kod_atr WITH M_KodGrOS REPLACE Name_atr WITH M_Name REPLACE Kod_OpSc WITH M_KodOpSc // Код опис.шкалы REPLACE N_ChrOpSC WITH LEN(ALLTRIM(A_FNRus[ff])) // Кол-во символов в наим.опис.шкалы REPLACE Min_GrInt WITH F_MinGR // Минимальная граница интервала REPLACE Max_GrInt WITH F_MaxGR // Максимальная граница интервала REPLACE Avr_GrInt WITH F_MinGR+(F_MaxGR-F_MinGR)/2 // Среднее значение интервала NEXT ENDIF ENDCASE CASE FIELDTYPE(ff) = "C" // Символьные столбцы DO CASE CASE M_ClSc1 <= ff .AND. ff <= M_ClSc2 // КЛАССИФИКАЦИОННЫЕ ШКАЛЫ: SELECT Inp_data SET FILTER TO * DBGOTOP();DBGOBOTTOM();DBGOTOP() INDEX ON FIELDGET(ff) TO Inp_tmp UNIQUE SELECT Inp_data SET ORDER TO 1 ********* ЕСЛИ В ТЕКСТОВОМ СТОЛБЦЕ НЕТ РАЗЛИЧИЯ ГРАДАЦИЙ, ТО ИГНОРИРОВАТЬ ЕГО ############ DBGOTOP() ;mVal1 = FIELDGET(ff) DBGOBOTTOM();mVal2 = FIELDGET(ff) IF mVal1 = mVal2 * AADD(aErrorVar, '['+ALLTRIM(STR(ff))+'] - "'+ALLTRIM(aInp_name[ff])+'"') ELSE SELECT Class_Sc APPEND BLANK REPLACE Kod_ClSc WITH ++M_KodClSc REPLACE Name_ClSc WITH A_FNRus[ff] SELECT Inp_data DBGOTOP() DO WHILE .NOT. EOF() Fv = ALLTRIM(FIELDGET(ff)) DO CASE CASE Flag_zer = 1 * IF LEN(Fv) > 0 IF .NOT. EMPTY(Fv) SELECT Gr_ClSc APPEND BLANK M_NameGrCS = Fv REPLACE Kod_ClSc WITH M_KodClSc REPLACE Kod_GrCS WITH ++M_KodGrCS REPLACE Name_GrCS WITH M_NameGrCS // Сформировать БД Classes M_NameCS = UPPER(ALLTRIM(A_FNRus[ff])) // Если в названии градации уже включено наим.шкалы, то повторно не включать его IF AT(M_NameCS, UPPER(M_NameGrCS)) = 0 M_Name = M_NameCS+"-"+M_NameGrCS ELSE M_Name = M_NameGrCS ENDIF mMaxLenCls = MAX( mMaxLenCls, LEN(ALLTRIM(M_Name))) // Максимальная длина наименования класса AADD(A_NameCls, ALLTRIM(M_Name)) // Массив наименований классов SELECT Classes // Имя БЗ брать из переменной APPEND BLANK REPLACE Kod_cls WITH M_KodGrCS REPLACE Name_cls WITH M_Name REPLACE Kod_ClSc WITH M_KodClSc // Код класс.шкалы REPLACE N_ChrClSc WITH LEN(ALLTRIM(A_FNRus[ff])) // Кол-во символов в наим.класс.шкалы ENDIF CASE Flag_zer = 2 SELECT Gr_ClSc APPEND BLANK M_NameGrCS = Fv REPLACE Kod_ClSc WITH M_KodClSc REPLACE Kod_GrCS WITH ++M_KodGrCS REPLACE Name_GrCS WITH M_NameGrCS // Сформировать БД Classes M_NameCS = UPPER(ALLTRIM(A_FNRus[ff])) // Если в названии градации уже включено наим.шкалы, то повторно не включать его IF AT(M_NameCS, UPPER(M_NameGrCS)) = 0 M_Name = M_NameCS+"-"+M_NameGrCS ELSE M_Name = M_NameGrCS ENDIF mMaxLenCls = MAX( mMaxLenCls, LEN(ALLTRIM(M_Name))) // Максимальная длина наименования класса AADD(A_NameCls, ALLTRIM(M_Name)) // Массив наименований классов SELECT Classes // Имя БЗ брать из переменной APPEND BLANK REPLACE Kod_cls WITH M_KodGrCS REPLACE Name_cls WITH M_Name REPLACE Kod_ClSc WITH M_KodClSc // Код класс.шкалы REPLACE N_ChrClSc WITH LEN(ALLTRIM(A_FNRus[ff])) // Кол-во символов в наим.класс.шкалы ENDCASE SELECT Inp_data DBSKIP(1) ENDDO ENDIF CASE M_OpSc1 <= ff .AND. ff <= M_OpSc2 // ОПИСАТЕЛЬНЫЕ ШКАЛЫ: SELECT Inp_data SET FILTER TO * DBGOTOP();DBGOBOTTOM();DBGOTOP() INDEX ON FIELDGET(ff) TO Mrk_funi UNIQUE SELECT Inp_data SET ORDER TO 1 ********* ЕСЛИ В ТЕКСТОВОМ СТОЛБЦЕ НЕТ РАЗЛИЧИЯ ГРАДАЦИЙ, ТО ИГНОРИРОВАТЬ ЕГО ############ DBGOTOP() ;mVal1 = FIELDGET(ff) DBGOBOTTOM();mVal2 = FIELDGET(ff) IF mVal1 = mVal2 * AADD(aErrorVar, '['+ALLTRIM(STR(ff))+'] - "'+ALLTRIM(aInp_name[ff])+'"') ELSE SELECT Opis_Sc APPEND BLANK REPLACE Kod_OpSc WITH ++M_KodOpSc REPLACE Name_OpSc WITH A_FNRus[ff] SELECT Inp_data DBGOTOP() DO WHILE .NOT. EOF() Fv = ALLTRIM(FIELDGET(ff)) DO CASE CASE Flag_zer = 1 * IF LEN(Fv) > 0 IF .NOT. EMPTY(Fv) SELECT Gr_OpSc APPEND BLANK M_NameGrOS = Fv REPLACE Kod_OpSc WITH M_KodOpSc REPLACE Kod_GrOS WITH ++M_KodGrOS REPLACE Name_GrOS WITH M_NameGrOS // Сформировать БД Attributes M_NameOS = UPPER(ALLTRIM(A_FNRus[ff])) // Если в названии градации уже включено наим.шкалы, то повторно не включать его IF AT(M_NameOS, UPPER(M_NameGrOS)) = 0 M_Name = M_NameOS+"-"+M_NameGrOS ELSE M_Name = M_NameGrOS ENDIF mMaxLenAtr = MAX( mMaxLenAtr, LEN(ALLTRIM(M_Name))) // Максимальная длина наименования признака AADD(A_NameAtr, ALLTRIM(M_Name)) // Массив наименований признаков SELECT Attributes // Имя БЗ брать из переменной APPEND BLANK REPLACE Kod_atr WITH M_KodGrOS REPLACE Name_atr WITH M_Name REPLACE Kod_OpSc WITH M_KodOpSc // Код опис.шкалы REPLACE N_ChrOpSC WITH LEN(ALLTRIM(A_FNRus[ff])) // Кол-во символов в наим.опис.шкалы ENDIF CASE Flag_zer = 2 SELECT Gr_OpSc APPEND BLANK M_NameGrOS = Fv REPLACE Kod_OpSc WITH M_KodOpSc REPLACE Kod_GrOS WITH ++M_KodGrOS REPLACE Name_GrOS WITH M_NameGrOS // Сформировать БД Attributes M_NameOS = UPPER(ALLTRIM(A_FNRus[ff])) // Если в названии градации уже включено наим.шкалы, то повторно не включать его IF AT(M_NameOS, UPPER(M_NameGrOS)) = 0 M_Name = M_NameOS+"-"+M_NameGrOS ELSE M_Name = M_NameGrOS ENDIF mMaxLenAtr = MAX( mMaxLenAtr, LEN(ALLTRIM(M_Name))) // Максимальная длина наименования признака AADD(A_NameAtr, ALLTRIM(M_Name)) // Массив наименований признаков SELECT Attributes // Имя БЗ брать из переменной APPEND BLANK REPLACE Kod_atr WITH M_KodGrOS REPLACE Name_atr WITH M_Name REPLACE Kod_OpSc WITH M_KodOpSc // Код опис.шкалы REPLACE N_ChrOpSC WITH LEN(ALLTRIM(A_FNRus[ff])) // Кол-во символов в наим.опис.шкалы ENDCASE SELECT Inp_data DBSKIP(1) ENDDO ENDIF ENDCASE ENDCASE ENDIF lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) NEXT // Сохранение информации Inp_sh в форме массивов, т.к. массивы содержат точные значения DC_ASave(aMinSH, M_NewAppl+"\aMinSH.arx") DC_ASave(aMaxSH, M_NewAppl+"\aMaxSH.arx") DC_ASave(aDelta, M_NewAppl+"\aDelta.arx") DC_ASave(A_NameCls, M_NewAppl+"\A_NameCls.arx") DC_ASave(A_NameAtr, M_NewAppl+"\A_NameAtr.arx") aSay[1]:SetCaption(aSay[1]:caption+L(' - Готово ')) *************************************************************************************************** **** Конец создания класс.и опис.шкал и градаций ************************************************** *************************************************************************************************** *************************************************************************************************** ######################################### **** 2/5: Создание базы событий "EventsKO" из "Inp_data" с кодами событий вместо значений шкал **** ######################################### *************************************************************************************************** ######################################### aSay[2]:SetCaption(L('2/5: Создание базы событий "EventsKO" из "Inp_data" с кодами событий вместо значений шкал')) ***** Создать индексные массивы для поиска CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW INDEX ON Name_cls TO Cls_name CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Attributes EXCLUSIVE NEW INDEX ON Name_atr TO Atr_name CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE EventsTmp EXCLUSIVE NEW INDEX ON Name_obj TO EventsTmp *************************************************************************************************** ** Создание классов, соответствующих значениям точек будущих сценариев **************************** *************************************************************************************************** ** 1. Создание БД для сортировки сценариев по значениям точек (это сделать в самом начале, т.к. эту БД надо сразу и открывать) (СДЕЛАНО) ** 2. Заполнение БД для сортировки сценариев по значениям точек ** 3. Создание классификационных шкал значений точек всех шкал будущих сценариев ** 4. Создание градаций (классов) классификационной шкалы значений точек всех шкал будущих сценариев ** 5. Добавление в обучающую выборку классов и (объединение) значений факторов значений будущих сценариев (это сделать в п.4/5) *************************************************************************************************** ** 1. Создание БД для сортировки сценариев по финальным значениям (это сделать в самом начале, т.к. эту БД надо сразу и открывать) (СДЕЛАНО) * CrClsFinValFutScen = .T. // .T. - только для финальных значений будущих сценариев, .F. - для всех точек * mCreateAttPointPast = 1 * oGroup21 CAPTION L('Рассматривать отдельно точки прошлых сценариев? ' * mCreateAttPointPast VALUE 1 PROMPT L('Не рассматривать ' * mCreateAttPointPast VALUE 2 PROMPT L('Рассматривать, но только финальные точки' * mCreateAttPointPast VALUE 3 PROMPT L('Рассматривать все точки ' * mCreateClsPointFuture = 1 * oGroup22 CAPTION L('Рассматривать отдельно точки будущих сценариев? ' * mCreateClsPointFuture VALUE 1 PROMPT L('Не рассматривать ' * mCreateClsPointFuture VALUE 2 PROMPT L('Рассматривать, но только финальные точки' * mCreateClsPointFuture VALUE 3 PROMPT L('Рассматривать все точки ' * MsgBox(STR(mCreateClsPointFuture)) IF mCreateClsPointFuture > 1 .OR. mCreateAttPointPast > 1 CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций IF mCreateClsPointFuture > 1 COPY FILE ('Obi_Kcl.dbf') TO ('Obi_KclTmp.dbf') *** Определить максимальную длину наименования базовых классов mML = -999 USE Classes EXCLUSIVE NEW DBGOTOP() DO WHILE .NOT. EOF() mNameCls = ALLTRIM(Name_cls) IF AT("-FUTURE", mNameCls) = 0 mML = MAX(mML, LEN(mNameCls)) ELSE EXIT ENDIF DBSKIP(1) ENDDO aStructure := { { "KodClSc" , "N", 15, 0 }, ; // Код старой классификационной шкалы, соответствующей текущей точке сценария { "KodScen" , "N", 15, 0 }, ; // Код сценария { "NameScen" , "C", 255, 0 }, ; // Наименование сценария { "PointNumb" , "N", 15, 0 }, ; // Номер точки сценария, соответствующей классу { "KodValScen", "N", 15, 0 }, ; // Код значения сценария (в БД Classes) в текущей точке { "NameValSce", "C", mML, 0 }, ; // Наименование значения сценария (в БД Classes) в текущей точке { "NewKodCls" , "N", 15, 0 }, ; // Новый код класса, соответствующего значению сценария в текущей точке { "NEWNAMECLS", "C", 255, 0 }, ; // Новое наименование класса, соответствующего значению сценария в текущей точке { "NEWNAMEVSP", "C", 255, 0 }, ; // Новое наименование подкласса, соответствующего значению сценария в текущей точке { "NewKodClSc", "N", 15, 0 }, ; // Код новой классификационной шкалы, соответствующей текущей точке сценария { "NewNameCS" , "C", 255, 0 } } // Наименование новой классификационной шкалы, соответствующей текущей точке сценария DbCreate( "ValFutScen.dbf", aStructure ) DbCreate( "ValFutSTmp.dbf", aStructure ) ENDIF IF mCreateAttPointPast > 1 COPY FILE ('Obi_Kpr.dbf') TO ('Obi_KprTmp.dbf') *** Определить максимальную длину наименования базовых значений факторов mML = -999 USE Attributes EXCLUSIVE NEW DBGOTOP() DO WHILE .NOT. EOF() mNameAtr = ALLTRIM(Name_atr) IF AT("-PAST", mNameAtr) = 0 mML = MAX(mML, LEN(mNameAtr)) ELSE EXIT ENDIF DBSKIP(1) ENDDO aStructure := { { "KodOpSc" , "N", 15, 0 }, ; // Код старой описательной шкалы, соответствующей текущей точке сценария { "KodScen" , "N", 15, 0 }, ; // Код сценария { "NameScen" , "C", 255, 0 }, ; // Наименование сценария { "PointNumb" , "N", 15, 0 }, ; // Номер точки сценария, соответствующей значению фактора { "KodValScen", "N", 15, 0 }, ; // Код значения сценария (в БД Attributes) в текущей точке { "NameValSce", "C", mML, 0 }, ; // Наименование значения сценария (в БД Attributes) в текущей точке { "NewKodAtr" , "N", 15, 0 }, ; // Новый код значения фактора, соответствующего значению сценария в текущей точке { "NEWNAMEAtr", "C", 255, 0 }, ; // Новое наименование значение фактора, соответствующего значению сценария в текущей точке { "NEWNAMEVSP", "C", 255, 0 }, ; // Новое наименование подфактора, соответствующего значению сценария в текущей точке { "NewKodOpSc", "N", 15, 0 }, ; // Код новой описательной шкалы, соответствующей текущей точке сценария { "NewNameOS" , "C", 255, 0 } } // Наименование новой описательной шкалы, соответствующей текущей точке сценария DbCreate( "ValPastScen.dbf", aStructure ) DbCreate( "ValPastSTmp.dbf", aStructure ) ENDIF ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Class_Sc EXCLUSIVE NEW USE Gr_ClSc EXCLUSIVE NEW USE Classes INDEX Cls_name EXCLUSIVE NEW USE Opis_Sc EXCLUSIVE NEW USE Gr_OpSc EXCLUSIVE NEW USE Attributes INDEX Atr_name EXCLUSIVE NEW USE Inp_data EXCLUSIVE NEW USE Inp_sh EXCLUSIVE NEW USE EventsKO EXCLUSIVE NEW;ZAP USE EventsKOs EXCLUSIVE NEW;ZAP // Для отладки <<<===############### USE Obi_Zag EXCLUSIVE NEW;ZAP USE Obi_Kcl EXCLUSIVE NEW;ZAP USE Obi_Kpr EXCLUSIVE NEW;ZAP USE EventsTmp INDEX EventsTmp EXCLUSIVE NEW;ZAP IF mCreateClsPointFuture > 1 USE Obi_KclTmp EXCLUSIVE NEW;ZAP USE ValFutScen EXCLUSIVE NEW USE ValFutSTmp EXCLUSIVE NEW ENDIF IF mCreateAttPointPast > 1 USE Obi_KprTmp EXCLUSIVE NEW;ZAP USE ValPastScen EXCLUSIVE NEW USE ValPastSTmp EXCLUSIVE NEW ENDIF mMaxLen = 15 M_KodObj = 0 SELECT Inp_data SET ORDER TO DBGOTOP() DO WHILE .NOT. EOF() ****** База заголовков SELECT Inp_data Fv = FIELDGET(1) // Наименование объекта обучающей выборки DO CASE CASE VALTYPE(Fv) = "N" // Числовые столбцы M_NameObj = ALLTRIM(STR(Fv,17)) CASE VALTYPE(Fv) = "C" // Символьные столбцы M_NameObj = ALLTRIM(Fv) CASE VALTYPE(Fv) = "D" // Столбец типа "Дата" M_NameObj = ALLTRIM(DTOC(Fv)) ENDCASE M_KodObj = RECNO() SELECT EventsKO APPEND BLANK REPLACE Name_obj WITH M_NameObj *** Формирование массива кодов классов из БД Inp_data * A_KodCls := {} // Массив кодов классов текущего объекта обучающей выборки FOR ff = M_ClSc1 TO M_ClSc2 SELECT Inp_data Fv = FIELDGET(ff) DO CASE CASE FIELDTYPE(ff)="N" // Числовые столбцы * Fv = VAL(STR(Fv,19,6)) ****** Формирование кодов классов SELECT EventsKO aNameGrNumSc = NameGrNumSc(N_GrCls) // Массив наименований градаций числовых шкал FOR gr = 1 TO N_GrCls * F_MinGR = VAL(STR(aMinSH[ff]+(gr-1)*aDelta[ff],19,7)) * F_MaxGR = VAL(STR(aMinSH[ff]+(gr )*aDelta[ff],19,7)) F_MinGR = aMinSH[ff]+(gr-1)*aDelta[ff] F_MaxGR = aMinSH[ff]+(gr )*aDelta[ff] IF F_MinGR <= Fv .AND. Fv <= F_MaxGR // Какие наименования ГРАДАЦИЙ числовых шкал использовать DO CASE CASE mNameGrNumSc= 1 // Только интервальные числовые значения M_Name = ALLTRIM(UPPER(A_FNRus[ff]))+"-"+; ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(N_GrCls,19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" CASE mNameGrNumSc= 2 // Только наименования интервальных числовых значений M_Name = ALLTRIM(UPPER(A_FNRus[ff]))+"-"+aNameGrNumSc[gr] CASE mNameGrNumSc= 3 // И интервальные числовые значения, и их наименования M_Name = ALLTRIM(UPPER(A_FNRus[ff]))+"-"+aNameGrNumSc[gr]+": "+; ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(N_GrCls,19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" ENDCASE M_KodCls = ASCAN(A_NameCls, M_Name) IF M_KodCls > 0 * AADD(A_KodCls, M_KodCls) FIELDPUT(ff, M_KodCls) mMaxLen = MAX(mMaxLen, LEN(ALLTRIM(STR(M_KodCls,19)))) ENDIF EXIT // Исключить повторное кодирование того же значения в следующем интервале ENDIF NEXT CASE FIELDTYPE(ff) = "C" // Символьные столбцы M_NameGrCS = ALLTRIM(Fv) M_Name = ALLTRIM(UPPER(A_FNRus[ff]))+"-"+M_NameGrCS M_KodCls = ASCAN(A_NameCls, M_Name) IF M_KodCls > 0 * AADD(A_KodCls, M_KodCls) SELECT EventsKO FIELDPUT(ff, M_KodCls) mMaxLen = MAX(mMaxLen, LEN(ALLTRIM(STR(M_KodCls,19)))) ENDIF ENDCASE NEXT ******* Формирование массива кодов признаков из БД Inp_data * A_KodAtr = {} FOR ff=M_OpSc1 TO M_OpSc2 // Начало цикла по полям БД Inp_data SELECT Inp_data IF aErrorNum[ff] // Если есть вариабельность Fv = FIELDGET(ff) DO CASE CASE FIELDTYPE(ff)="N" // Числовые столбцы * Fv = VAL(STR(Fv,19,6)) SELECT EventsKO aNameGrNumSc = NameGrNumSc(N_GrAtr) // Массив наименований градаций числовых шкал FOR gr = 1 TO N_GrAtr * F_MinGR = VAL(STR(aMinSH[ff]+(gr-1)*aDelta[ff],19,7)) * F_MaxGR = VAL(STR(aMinSH[ff]+(gr )*aDelta[ff],19,7)) F_MinGR = aMinSH[ff]+(gr-1)*aDelta[ff] F_MaxGR = aMinSH[ff]+(gr )*aDelta[ff] IF F_MinGR <= Fv .AND. Fv <= F_MaxGR // Какие наименования ГРАДАЦИЙ числовых шкал использовать DO CASE CASE mNameGrNumSc= 1 // Только интервальные числовые значения M_Name = ALLTRIM(UPPER(A_FNRus[ff]))+"-"+; ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(N_GrAtr,19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" CASE mNameGrNumSc= 2 // Только наименования интервальных числовых значений M_Name = ALLTRIM(UPPER(A_FNRus[ff]))+"-"+aNameGrNumSc[gr] CASE mNameGrNumSc= 3 // И интервальные числовые значения, и их наименования M_Name = ALLTRIM(UPPER(A_FNRus[ff]))+"-"+aNameGrNumSc[gr]+": "+; ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(N_GrAtr,19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" ENDCASE M_KodAtr = ASCAN(A_NameAtr, M_Name) IF M_KodAtr > 0 * AADD(A_KodAtr, M_KodAtr) FIELDPUT(ff, M_KodAtr) mMaxLen = MAX(mMaxLen, LEN(ALLTRIM(STR(M_KodAtr,19)))) ENDIF EXIT // Исключить повторное кодирование того же значения в следующем интервале ENDIF NEXT CASE FIELDTYPE(ff) = "C" // Символьные столбцы M_NameGrOS = ALLTRIM(Fv) M_Name = ALLTRIM(UPPER(A_FNRus[ff]))+"-"+M_NameGrOS M_KodAtr = ASCAN(A_NameAtr, M_Name) IF M_KodAtr > 0 * AADD(A_KodAtr, M_KodAtr) SELECT EventsKO FIELDPUT(ff, M_KodAtr) mMaxLen = MAX(mMaxLen, LEN(ALLTRIM(STR(M_KodAtr,19)))) ENDIF ENDCASE ENDIF NEXT lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) SELECT Inp_data DBSKIP(1) ENDDO aSay[2]:SetCaption(aSay[2]:caption+L(' - Готово ')) *************************************************************************************************** **** Конец генерации обучающей выборки и базы событий "EventsKO" на основе БД "Inp_data" ********** *************************************************************************************************** *************************************************************************************************** ################################################################ **** 3/5: Доформирование классиф.и описат.шкал и градаций на основе БД "EventsKO" (сценарии) ****** ВОТ ЭТО И НАДО ПРОВЕРЯТЬ И ДУБЛИРОВАТЬ <<<===################### *************************************************************************************************** ################################################################ aSay[3]:SetCaption(L('3/5: Доформирование классиф.и описат.шкал и градаций на основе БД "EventsKO" (сценарии)')) SELECT Classes ;mMaxLenKCls = LEN(ALLTRIM(STR(RECCOUNT()))) // максимальное число разрядов в градациях базовых классификацинных шкал для кода класса SELECT Attributes;mMaxLenKAtr = LEN(ALLTRIM(STR(RECCOUNT()))) // максимальное число разрядов в градациях базовых описательных шкал для кода признака FOR ff=2 TO N_ColInpData // Начало цикла по полям Inp_data.dbf ******************************************** SELECT EventsKO IF aErrorNum[ff] // Если есть вариабельность Fv = FIELDGET(ff) DO CASE CASE M_ClSc1 <= ff .AND. ff <= M_ClSc2 // КЛАССИФИКАЦИОННЫЕ ШКАЛЫ: SELECT Class_Sc;DBGOBOTTOM();M_KodClSc = Kod_ClSc SELECT Gr_ClSc ;DBGOBOTTOM();M_KodGrCS = Kod_GrCS SELECT Opis_Sc ;DBGOBOTTOM();M_KodOpSc = Kod_OpSc SELECT Gr_OpSc ;DBGOBOTTOM();M_KodGrOS = Kod_GrOS SELECT EventsKO N_Rec = RECCOUNT() N_Col = FCOUNT() * PAST FUTURE FOR N_Gorizont = mGorizMin TO mGorizMax mScen = A_FNRus[ff] + '-FUTURE'+ALLTRIM(STR(N_Gorizont)) SELECT Class_Sc APPEND BLANK REPLACE Kod_ClSc WITH ++M_KodClSc REPLACE Name_ClSc WITH mScen SELECT EventsTmp;ZAP // Сформировать массив сценариев для текущей шкалы // <<<===######################################### aEventsTmp := {} // Массив для недопущения повторов в EventsTmp // Цикл по текущей дате (записи) от 1-й до предпоследней * MsgBox('Горизонт='+STR(N_Gorizont)) // <<<===###################################### FOR M_Recno=1 TO N_Rec mScen = A_FNRus[ff] + '-FUTURE'+ALLTRIM(STR(N_Gorizont)) + '-' SELECT EventsKO DBGOTO(M_Recno) DBSKIP(1) // Код текущей записи тоже включать в сценарий? mGorizont = 1 DO WHILE .NOT. EOF() .AND. mGorizont <= N_Gorizont // Градации класс.шкалы ************************************ mFV = FIELDGET(ff) IF mFV > 0 mSimb = STRTRAN(STR(mFV,mMaxLenKCls),' ','0') IF LEN(mSimb) > 0 mt = mScen + mSimb + IF(mGorizont 0 mSimb = STRTRAN(STR(mFV,mMaxLenKAtr),' ','0') IF LEN(mSimb) > 0 mt = mScen + mSimb + IF(mGlubina < N_Glubina,',','') ++mGlubina mScen = ALLTRIM(SUBSTR(mt,1,255)) ENDIF ENDIF DBSKIP(1) ENDDO IF mGlubina = N_Glubina + 1 IF ASCAN(aEventsTmp, mt) = 0 // Если такого сценария еще нет в справочнике - занести его AADD (aEventsTmp, mt) SELECT EventsTmp APPEND BLANK REPLACE Name_Obj WITH mt ENDIF ENDIF NEXT // Рассортировать массив сценариев для текущей шкалы и внести его в базы данных SELECT EventsTmp INDEX ON Name_Obj TO Events_NO DBGOTOP() DO WHILE .NOT. EOF() M_NameGrOS = ALLTRIM(Name_Obj) SELECT Gr_OpSc APPEND BLANK REPLACE Kod_OpSc WITH M_KodOpSc REPLACE Kod_GrOS WITH ++M_KodGrOS REPLACE Name_GrOS WITH M_NameGrOS // Сформировать БД Classes M_NameOS = A_FNRus[ff] + '-PAST'+ALLTRIM(STR(N_Glubina)) // Если в названии градации уже включено наим.шкалы, то повторно не включать его IF AT(M_NameOS, UPPER(M_NameGrOS)) = 0 M_Name = M_NameOS+"-"+M_NameGrOS ELSE M_Name = M_NameGrOS ENDIF mMaxLenAtr = MAX( mMaxLenAtr, LEN(ALLTRIM(M_Name))) // Максимальная длина наименования AADD(A_NameAtr, ALLTRIM(M_Name)) // Массив наименований признаков SELECT Attributes APPEND BLANK REPLACE Kod_atr WITH M_KodGrOS REPLACE Name_atr WITH M_Name REPLACE Kod_OpSc WITH M_KodOpSc // Код класс.шкалы REPLACE N_ChrOpSc WITH LEN(M_NameOS) // Кол-во символов в наим.класс.шкалы SELECT EventsTmp DBSKIP(1) ENDDO lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) NEXT // <<<===######################################### ENDCASE ENDIF NEXT DC_ASave(A_NameCls, M_NewAppl+"\A_NameCls.arx") DC_ASave(A_NameAtr, M_NewAppl+"\A_NameAtr.arx") *************************************************************************************************** ** Создание классов, соответствующих значениям точек будущих сценариев **************************** *************************************************************************************************** ** 1. Создание БД для сортировки сценариев по значениям точек (это сделать в самом начале, т.к. эту БД надо сразу и открывать) (СДЕЛАНО) ** 2. Заполнение БД для сортировки сценариев по значениям точек ** 3. Создание классификационных шкал значений точек всех шкал будущих сценариев ** 4. Создание градаций (классов) классификационной шкалы значений точек всех шкал будущих сценариев ** 5. Добавление в обучающую выборку классов и (объединение) значений факторов значений будущих сценариев (это сделать в п.4/5) *************************************************************************************************** * MsgBox(STR(mCreateClsPointFuture)) IF mCreateClsPointFuture > 1 * aStructure := { { "KodClSc" , "N", 15, 0 }, ; // Код старой классификационной шкалы, соответствующей текущей точке сценария * { "KodScen" , "N", 15, 0 }, ; // Код сценария * { "NameScen" , "C", 255, 0 }, ; // Наименование сценария * { "PointNumb" , "N", 15, 0 }, ; // Номер точки сценария, соответствующей классу * { "KodValScen", "N", 15, 0 }, ; // Код значения сценария (в БД Classes) в текущей точке * { "NameValSce", "C", mML, 0 }, ; // Наименование значения сценария (в БД Classes) в текущей точке * { "NewKodCls" , "N", 15, 0 }, ; // Новый код класса, соответствующего значению сценария в текущей точке * { "NEWNAMECLS", "C", 255, 0 }, ; // Новое наименование класса, соответствующего значению сценария в текущей точке * { "NEWNAMEVSP", "C", 255, 0 }, ; // Новое наименование подкласса, соответствующего значению сценария в текущей точке * { "NewKodClSc", "N", 15, 0 }, ; // Код новой классификационной шкалы, соответствующей текущей точке сценария * { "NewNameCS" , "C", 255, 0 } } // Наименование новой классификационной шкалы, соответствующей текущей точке сценария * DbCreate( "ValFutScen.dbf", aStructure ) * DbCreate( "ValFutSTmp.dbf", aStructure ) ** 2. Заполнение БД для сортировки сценариев по финальным значениям ** Можно сделать цикл по точкам значений и учитывать не только финальные, а все значения <<<===################ SELECT Gr_ClSc DBGOBOTTOM() mKodMaxCls = KOD_GRCS DBGOTOP() DO WHILE .NOT. EOF() mKOD_CLSC = KOD_CLSC mKOD_GRCS = KOD_GRCS mNAME_GRCS = ALLTRIM(NAME_GRCS) mPos = AT("-FUTURE", mNAME_GRCS) IF mPos > 0 * OPEN-FUTURE3-1,1,1 mPos = RAT('-', mNAME_GRCS) mNameScen = SUBSTR(mNAME_GRCS, mPos+1, LEN(mNAME_GRCS)-mPos) mNewNameCS = SUBSTR(mNAME_GRCS, 1, mPos-1) mNPoints = NUMTOKEN(mNameScen, ',') // Фактическое кол-во точек в сценарии ******* Цикл по точкам сценария ************** * oGroup22 CAPTION L('Рассматривать отдельно точки будущих сценариев? ' * mCreateClsPointFuture VALUE 1 PROMPT L('Не рассматривать ' * mCreateClsPointFuture VALUE 2 PROMPT L('Рассматривать, но только финальные точки' * mCreateClsPointFuture VALUE 3 PROMPT L('Рассматривать все точки ' mPoint1 = IF(mCreateClsPointFuture=3, 1, mNPoints) FOR mPoint=mPoint1 TO mNPoints mKodValScen = VAL(TOKEN(mNameScen, mPoint)) // Код значения сценария (в БД Classes) в текущей точке mRecno = RECNO() DBGOTO(mKodValScen) mNameValSce = ALLTRIM(NAME_GRCS) // Наименование значения сценария (в БД Classes) в текущей точке DBGOTO(mRecno) SELECT ValFutSTmp APPEND BLANK REPLACE KodClSc WITH mKOD_CLSC REPLACE KodScen WITH mKOD_GRCS REPLACE NameScen WITH mNAME_GRCS REPLACE PointNumb WITH mPoint REPLACE KodValScen WITH mKodValScen REPLACE NameValSce WITH mNameValSce REPLACE NEWNAMECLS WITH mNewNameCS+'-Point'+ALLTRIM(STR(mPoint))+'-'+ALLTRIM(mNameValSce) // Новое наименование класса, соответствующего значению точки сценария REPLACE NEWNAMEVSP WITH mNAME_GRCS+'-Point'+ALLTRIM(STR(mPoint))+'-'+ALLTRIM(mNameValSce) // Новое наименование подкласса, соответствующего значению точки сценария REPLACE NewNameCS WITH mNewNameCS+'-Point'+ALLTRIM(STR(mPoint)) // Наименование новой классификационной шкалы, соответствующей значению точки сценария SELECT Gr_ClSc NEXT ENDIF DBSKIP(1) ENDDO ****** Физическая сортировка БД ValFutScen.dbf по полю: KodValScen SELECT Class_Sc DBGOBOTTOM() mLen = LEN(ALLTRIM(STR(Kod_ClSc))) SELECT ValFutSTmp INDEX ON STRTRAN(STR(KodClSc,mLen),' ','0')+ALLTRIM(NEWNAMECLS) TO ValFutSTmp DBGOTOP() DO WHILE .NOT. EOF() ar := {} FOR j=1 TO FCOUNT() AADD(ar, FIELDGET(j)) NEXT SELECT ValFutScen APPEND BLANK FOR j=1 TO LEN(ar) FIELDPUT(j, ar[j]) NEXT SELECT ValFutSTmp DBSKIP(1) ENDDO ****** Кодирование новых классов NEWKODCLS, соответствующих значениям точек сценариев ****** Кодирование новых классификационных шкал, соответствующих значениям точек сценариев SELECT Class_Sc DBGOBOTTOM() mKodMaxCS = Kod_ClSc SELECT ValFutScen DBGOTOP() mKodValScen = KodValScen REPLACE NEWKODCLS WITH ++mKodMaxCls mNEWNAMECS = NEWNAMECS REPLACE NEWKODCLSC WITH ++mKodMaxCS DBSKIP(1) DO WHILE .NOT. EOF() IF mKodValScen = KodValScen REPLACE NEWKODCLS WITH mKodMaxCls ELSE REPLACE NEWKODCLS WITH ++mKodMaxCls mKodValScen = KodValScen ENDIF IF mNEWNAMECS = NEWNAMECS REPLACE NEWKODCLSC WITH mKodMaxCS ELSE REPLACE NEWKODCLSC WITH ++mKodMaxCS mNEWNAMECS = NEWNAMECS ENDIF DBSKIP(1) ENDDO ** 3. Создание классификационных шкал значений точек всех шкал будущих сценариев SELECT ValFutScen DBGOTOP() aNewKodClSc := {} // Исключение повторов шкал mNEWKODCLSC = NEWKODCLSC mNEWNAMECS = ALLTRIM(NEWNAMECS) AADD (aNewKodClSc, mNEWNAMECS) SELECT Class_Sc APPEND BLANK REPLACE Kod_ClSc WITH mNEWKODCLSC REPLACE Name_ClSc WITH mNEWNAMECS SELECT ValFutScen DBSKIP(1) DO WHILE .NOT. EOF() * IF ASCAN(aNewKodClSc, mNEWKODCLSC) = 0 * AADD (aNewKodClSc, mNEWKODCLSC) IF mNEWKODCLSC <> NEWKODCLSC mNEWKODCLSC = NEWKODCLSC mNEWNAMECS = ALLTRIM(NEWNAMECS) SELECT Class_Sc APPEND BLANK REPLACE Kod_ClSc WITH mNEWKODCLSC REPLACE Name_ClSc WITH mNEWNAMECS SELECT ValFutScen ENDIF * ENDIF DBSKIP(1) ENDDO ** 4. Создание градаций (классов) классификационной шкалы финальных значений всех шкал будущих сценариев (Gr_ClSc, Classes) aKodCls := {} SELECT ValFutScen DBGOTOP() DO WHILE .NOT. EOF() mNEWKODCLS = NEWKODCLS mNEWNAMECLS = ALLTRIM(NEWNAMECLS) mNEWKODCLSC = NEWKODCLSC IF ASCAN(aKodCls, mNEWKODCLS) = 0 // Исключение повторов классов AADD (aKodCls, mNEWKODCLS) SELECT Gr_ClSc APPEND BLANK REPLACE KOD_CLSC WITH mNEWKODCLSC REPLACE KOD_GRCS WITH mNEWKODCLS REPLACE NAME_GRCS WITH mNEWNAMECLS SELECT Classes APPEND BLANK REPLACE KOD_CLSC WITH mNEWKODCLSC REPLACE KOD_CLS WITH mNEWKODCLS REPLACE NAME_CLS WITH mNEWNAMECLS REPLACE N_CHRCLSC WITH LEN(ALLTRIM(mNEWNAMECLS)) SELECT ValFutScen ENDIF DBSKIP(1) ENDDO ** 5. Добавление в обучающую выборку классов и (объединение) значений факторов значений точек будущих сценариев (это сделать в п.4/5) ** Вопрос: какие значения факторов обуславливают данное значение точки сценария? ** Ответ: все значерия факторов, обуславливающих все сценарии с таким значением данной точки. ENDIF *************************************************************************************************** ** Создание значений факторов, соответствующих значениям точек прошлых сценариев ****************** *************************************************************************************************** ** 1. Создание БД для сортировки сценариев по значениям точек (это сделать в самом начале, т.к. эту БД надо сразу и открывать) (СДЕЛАНО) ** 2. Заполнение БД для сортировки сценариев по значениям точек ** 3. Создание описательных шкал значений точек всех шкал прошлых сценариев ** 4. Создание градаций (значений факторов) описательной шкалы значений точек всех шкал прошлых сценариев ** 5. Добавление в обучающую выборку значений факторов и (объединение) значений прошлых сценариев (это сделать в п.4/5) *************************************************************************************************** * MsgBox(STR(mCreateClsPointFuture)) IF mCreateAttPointPast > 1 // <<<===#################################################################### * aStructure := { { "KodOpSc" , "N", 15, 0 }, ; // Код старой описательной шкалы, соответствующей текущей точке сценария * { "KodScen" , "N", 15, 0 }, ; // Код сценария * { "NameScen" , "C", 255, 0 }, ; // Наименование сценария * { "PointNumb" , "N", 15, 0 }, ; // Номер точки сценария, соответствующей значению фактора * { "KodValScen", "N", 15, 0 }, ; // Код значения сценария (в БД Attributes) в текущей точке * { "NameValSce", "C", mML, 0 }, ; // Наименование значения сценария (в БД Attributes) в текущей точке * { "NewKodAtr" , "N", 15, 0 }, ; // Новый код значения фактора, соответствующего значению сценария в текущей точке * { "NEWNAMEAtr", "C", 255, 0 }, ; // Новое наименование значение фактора, соответствующего значению сценария в текущей точке * { "NEWNAMEVSP", "C", 255, 0 }, ; // Новое наименование подфактора, соответствующего значению сценария в текущей точке * { "NewKodOpSc", "N", 15, 0 }, ; // Код новой описательной шкалы, соответствующей текущей точке сценария * { "NewNameOS" , "C", 255, 0 } } // Наименование новой описательной шкалы, соответствующей текущей точке сценария * DbCreate( "ValPastScen.dbf", aStructure ) * DbCreate( "ValPastSTmp.dbf", aStructure ) ** 2. Заполнение БД для сортировки сценариев по значениям точек сценариев ** Можно сделать цикл по точкам значений и учитывать не только финальные, а все значения <<<===################ SELECT Gr_OpSc DBGOBOTTOM() mKodMaxAtr = KOD_GROS DBGOTOP() DO WHILE .NOT. EOF() mKOD_OPSC = KOD_OPSC mKOD_GROS = KOD_GROS mNAME_GROS = ALLTRIM(NAME_GROS) mPos = AT("-PAST", mNAME_GROS) IF mPos > 0 * OPEN-PAST-1,1,1 mPos = RAT('-', mNAME_GROS) mNameScen = SUBSTR(mNAME_GROS, mPos+1, LEN(mNAME_GROS)-mPos) mNewNameOS = SUBSTR(mNAME_GROS, 1, mPos-1) mNPoints = NUMTOKEN(mNameScen, ',') // Фактическое кол-во точек в сценарии ******* Цикл по точкам сценария ************** * DCGROUP oGroup21 CAPTION L('Рассматривать отдельно точки прошлых сценариев? ' * DCRADIO mCreateAttPointPast VALUE 1 PROMPT L('Не рассматривать ' * DCRADIO mCreateAttPointPast VALUE 2 PROMPT L('Рассматривать, но только финальные точки' * DCRADIO mCreateAttPointPast VALUE 3 PROMPT L('Рассматривать все точки ' mPoint1 = IF(mCreateAttPointPast=3, 1, mNPoints) FOR mPoint=mPoint1 TO mNPoints mKodValScen = VAL(TOKEN(mNameScen, mPoint)) // Код значения сценария (в БД Classes) в текущей точке mRecno = RECNO() DBGOTO(mKodValScen) mNameValSce = ALLTRIM(NAME_GROS) // Наименование значения сценария (в БД Classes) в текущей точке DBGOTO(mRecno) SELECT ValPastSTmp APPEND BLANK REPLACE KodOpSc WITH mKOD_OPSC REPLACE KodScen WITH mKOD_GROS REPLACE NameScen WITH mNAME_GROS REPLACE PointNumb WITH mPoint REPLACE KodValScen WITH mKodValScen REPLACE NameValSce WITH mNameValSce REPLACE NEWNAMEATR WITH mNewNameOS+'-Point'+ALLTRIM(STR(mPoint))+'-'+ALLTRIM(mNameValSce) // Новое наименование значения фактора, соответствующего значению точки сценария REPLACE NEWNAMEVSP WITH mNAME_GROS+'-Point'+ALLTRIM(STR(mPoint))+'-'+ALLTRIM(mNameValSce) // Новое наименование значения подфактора, соответствующего значению точки сценария REPLACE NewNameOS WITH mNewNameOS+'-Point'+ALLTRIM(STR(mPoint)) // Наименование новой описательной шкалы, соответствующей значению точки сценария SELECT Gr_OpSc NEXT ENDIF DBSKIP(1) ENDDO ****** Физическая сортировка БД ValPastScen.dbf по полю: KodValScen SELECT Opis_Sc DBGOBOTTOM() mLen = LEN(ALLTRIM(STR(Kod_OpSc))) SELECT ValPastSTmp INDEX ON STRTRAN(STR(KodOpSc,mLen),' ','0')+ALLTRIM(NEWNAMEATR) TO ValPastSTmp DBGOTOP() DO WHILE .NOT. EOF() ar := {} FOR j=1 TO FCOUNT() AADD(ar, FIELDGET(j)) NEXT SELECT ValPastScen APPEND BLANK FOR j=1 TO LEN(ar) FIELDPUT(j, ar[j]) NEXT SELECT ValPastSTmp DBSKIP(1) ENDDO ****** Кодирование новых значений факторов NEWKODATR, соответствующих значениям точек сценариев ****** Кодирование новых описательных шкал, соответствующих значениям точек сценариев SELECT Opis_Sc DBGOBOTTOM() mKodMaxOS = Kod_OpSc SELECT ValPastScen DBGOTOP() mKodValScen = KodValScen REPLACE NEWKODATR WITH ++mKodMaxAtr mNEWNAMEOS = NEWNAMEOS REPLACE NEWKODOPSC WITH ++mKodMaxOS DBSKIP(1) DO WHILE .NOT. EOF() IF mKodValScen = KodValScen REPLACE NEWKODATR WITH mKodMaxAtr ELSE REPLACE NEWKODATR WITH ++mKodMaxAtr mKodValScen = KodValScen ENDIF IF mNEWNAMEOS = NEWNAMEOS REPLACE NEWKODOPSC WITH mKodMaxOS ELSE REPLACE NEWKODOPSC WITH ++mKodMaxOS mNEWNAMEOS = NEWNAMEOS ENDIF DBSKIP(1) ENDDO ** 3. Создание описательных шкал значений точек всех шкал будущих сценариев SELECT ValPastScen DBGOTOP() aNewKodOpSc := {} // Исключение повторов шкал mNEWKODOPSC = NEWKODOPSC mNEWNAMEOS = ALLTRIM(NEWNAMEOS) AADD (aNewKodOpSc, mNEWNAMEOS) SELECT Opis_Sc APPEND BLANK REPLACE Kod_OpSc WITH mNEWKODOPSC REPLACE Name_OpSc WITH mNEWNAMEOS SELECT ValPastScen DBSKIP(1) DO WHILE .NOT. EOF() * IF ASCAN(aNewKodOpSc, mNEWKODOPSC) = 0 * AADD (aNewKodOpSc, mNEWKODOPSC) IF mNEWKODOPSC <> NEWKODOPSC mNEWKODOPSC = NEWKODOPSC mNEWNAMEOS = ALLTRIM(NEWNAMEOS) SELECT Opis_Sc APPEND BLANK REPLACE Kod_OpSc WITH mNEWKODOPSC REPLACE Name_OpSc WITH mNEWNAMEOS SELECT ValPastScen ENDIF * ENDIF DBSKIP(1) ENDDO ** 4. Создание градаций (классов) описательной шкалы значений точек всех шкал будущих сценариев (Gr_OpSc, Attributes) aKodAtr := {} SELECT ValPastScen DBGOTOP() DO WHILE .NOT. EOF() mNEWKODATR = NEWKODATR mNEWNAMEATR = ALLTRIM(NEWNAMEATR) mNEWKODOPSC = NEWKODOPSC IF ASCAN(aKodAtr, mNEWKODATR) = 0 // Исключение повторов классов AADD (aKodAtr, mNEWKODATR) SELECT Gr_OpSc APPEND BLANK REPLACE KOD_OPSC WITH mNEWKODOPSC REPLACE KOD_GROS WITH mNEWKODATR REPLACE NAME_GROS WITH mNEWNAMEATR SELECT Attributes APPEND BLANK REPLACE KOD_OPSC WITH mNEWKODOPSC REPLACE KOD_ATR WITH mNEWKODATR REPLACE NAME_ATR WITH mNEWNAMEATR REPLACE N_CHROPSC WITH LEN(ALLTRIM(mNEWNAMEATR)) SELECT ValPastScen ENDIF DBSKIP(1) ENDDO ** 5. Добавление в обучающую выборку классов и (объединение) значений факторов значений точек прошлых сценариев (это сделать в п.4/5) ** Вопрос: какие значения факторов обуславливают данное значение точки сценария? ** Ответ: все значерия факторов, обуславливающих все сценарии с таким значением данной точки. ENDIF aSay[3]:SetCaption(aSay[3]:caption+L(' - Готово ')) *************************************************************************************************** **** Конец доформирования классиф.и описат.шкал и градаций на основе БД "EventsKO" (сценарии) ***** *************************************************************************************************** *************************************************************************************************** **** 4/5: Генерация обучающей выборки на основе базы событий "EventsKO" *************************** *************************************************************************************************** aSay[4]:SetCaption(L('4/5: Генерация обучающей выборки на основе базы событий "EventsKO"')) SELECT EventsKO DBGOTOP() n = 0 DO WHILE .NOT. EOF() // Формирование записи БД заголовков объектов обучающей выборки M_Recno = RECNO() M_KodObj = M_Recno M_NameObj = Name_obj SELECT Obi_Zag APPEND BLANK REPLACE Kod_obj WITH M_KodObj REPLACE Name_obj WITH M_NameObj *** Формирование массива кодов классов из БД EventsKO SELECT EventsKO A_KodCls := {} // Массив базовых кодов классов текущего объекта обучающей выборки FOR ff = M_ClSc1 TO M_ClSc2 DBGOTO(M_Recno) Fv = FIELDGET(ff) AADD(A_KodCls, Fv) FOR N_Gorizont = mGorizMin TO mGorizMax mScen = A_FNRus[ff] + '-FUTURE'+ALLTRIM(STR(N_Gorizont)) + '-' SELECT EventsKO DBGOTO(M_Recno) DBSKIP(1) // Код текущей записи тоже включать в сценарий? mGorizont = 1 DO WHILE .NOT. EOF() .AND. mGorizont <= N_Gorizont // Градации класс.шкалы ************************************ mFV = FIELDGET(ff) IF mFV > 0 mSimb = STRTRAN(STR(mFV,mMaxLenKCls),' ','0') IF LEN(mSimb) > 0 mt = mScen + mSimb + IF(mGorizont 0 // Если такой сценарий есть в справочнике - занести его код в объект обучающей выборки * IF ASCAN(A_KodCls, M_KodCls) = 0 // Каждый код вносить только 1 раз AADD( A_KodCls, M_KodCls) * ENDIF ENDIF ENDIF NEXT NEXT ******* Формирование массива кодов признаков из базы событий EventsKO SELECT EventsKO A_KodAtr = {} // Массив кодов признаков текущего объекта обучающей выборки FOR ff=M_OpSc1 TO M_OpSc2 // Начало цикла по полям БД DBGOTO(M_Recno) IF aErrorNum[ff] // Если есть вариабельность DBGOTO(M_Recno) Fv = FIELDGET(ff) AADD(A_KodAtr, Fv) FOR N_Glubina = mGlubMin TO mGlubMax mScen = A_FNRus[ff] + '-PAST'+ALLTRIM(STR(N_Glubina)) + '-' SELECT EventsKO mGlubina = 1 DBGOTO(M_Recno-N_Glubina+1) * DBSKIP(1) // Код текущей записи тоже включать в сценарий? DO WHILE .NOT. EOF() .AND. mGlubina <= N_Glubina // Градации класс.шкалы ************************************ mFV = FIELDGET(ff) IF mFV > 0 mSimb = STRTRAN(STR(mFV,mMaxLenKAtr),' ','0') IF LEN(mSimb) > 0 mt = mScen + mSimb + IF(mGlubina < N_Glubina,',','') ++mGlubina mScen = ALLTRIM(SUBSTR(mt,1,255)) ENDIF ENDIF DBSKIP(1) ENDDO IF mGlubina = N_Glubina + 1 M_KodAtr = ASCAN(A_NameAtr, mScen) IF M_KodCls > 0 // Если такой сценарий есть в справочнике - занести его код в объект обучающей выборки * IF ASCAN(A_KodAtr, M_KodAtr) = 0 AADD( A_KodAtr, M_KodAtr) * ENDIF ENDIF ENDIF NEXT ENDIF NEXT * DC_DebugQout( A_KodCls, A_KodAtr ) ****** Запись массива кодов классов в БД Obi_Kcl * ASORT(A_KodCls) SELECT Obi_Kcl APPEND BLANK FIELDPUT(1,M_KodObj) IF LEN(A_KodCls) > 0 k=2 FOR jj=1 TO LEN(A_KodCls) IF k <= 5 FIELDPUT(k++,A_KodCls[jj]) ELSE k=2 APPEND BLANK FIELDPUT(1,M_KodObj) FIELDPUT(k++,A_KodCls[jj]) ENDIF NEXT ENDIF ****** Запись массива кодов признаков в БД Obi_Kpr * ASORT(A_KodAtr) SELECT Obi_Kpr APPEND BLANK FIELDPUT(1,M_KodObj) IF LEN(A_KodAtr) > 0 k=2 FOR jj=1 TO LEN(A_KodAtr) IF k <= 8 FIELDPUT(k++,A_KodAtr[jj]) ELSE k=2 APPEND BLANK FIELDPUT(1,M_KodObj) FIELDPUT(k++,A_KodAtr[jj]) ENDIF NEXT ENDIF ****** Формирование массивов кодов классов и признаков для БД EventsKOs. ДЛЯ ОТЛАДКИ РЕЖИМА: "СЦЕНАРНЫЙ МЕТОД АСК-АНАЛИЗА" ****** Копирование кодов базовых классов и базовых признаков EventsKO => EventsKOs * MsgBox(STR(mRecSizeEvKOs)) SELECT EventsKO DBGOTOP() DO WHILE .NOT. EOF() * MsgBox(STR(mRecSizeEvKOs * (n+1))) IF mRecSizeEvKOs * (n+1) > 2*10^9 // Не создавать файл больше 2 Гб EXIT ELSE aR := {} FOR j=1 TO FCOUNT()-2 AADD(aR, FIELDGET(j)) NEXT n++ SELECT EventsKOs APPEND BLANK // <<<===########################### FOR j=1 TO LEN(aR) FIELDPUT(j, aR[j]) NEXT ENDIF SELECT EventsKO DBSKIP(1) ENDDO SELECT EventsKOs IF M_Recno <= RECCOUNT() DBGOTO(M_Recno) ****** Запись массива кодов классов в БД EventsKOs ********************** mKodCls = '' nKodCls = LEN(A_KodCls) FOR j=1 TO nKodCls IF A_KodCls[j] > 0 mKodCls = mKodCls + '[' + ALLTRIM(STR(A_KodCls[j])) + ']-' + A_NameCls[A_KodCls[j]] + IF(j255,'...','') ****** Запись массива кодов признаков в БД EventsKOs ******************** mKodAtr = '' nKodAtr = LEN(A_KodAtr) FOR j=1 TO nKodAtr IF A_KodAtr[j] > 0 mKodAtr = mKodAtr + '[' + ALLTRIM(STR(A_KodAtr[j])) + ']-' + A_NameAtr[A_KodAtr[j]] + IF(j255,'...','') ENDIF lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) SELECT EventsKO DBGOTO(M_Recno) DBSKIP(1) ENDDO *********************************************************************************** ***** Коды сценариев и значений точек сценариев в БД EventsKO.dbf не добавляются!!! *********************************************************************************** *************************************************************************************************** ** Создание классов, соответствующих значениям точек будущих сценариев **************************** *************************************************************************************************** ** 1. Создание БД для сортировки сценариев по значениям точек (это сделать в самом начале, т.к. эту БД надо сразу и открывать) (СДЕЛАНО) ** 2. Заполнение БД для сортировки сценариев по значениям точек ** 3. Создание классификационных шкал значений точек всех шкал будущих сценариев ** 4. Создание градаций (классов) классификационной шкалы значений точек всех шкал будущих сценариев ** 5. Добавление в обучающую выборку классов и (объединение) значений факторов значений будущих сценариев (это сделать в п.4/5) <<<===################ *************************************************************************************************** ** 5. Добавление в обучающую выборку классов и (объединение) значений факторов значений точек будущих сценариев (это сделать в п.4/5) ** Вопрос: какие значения факторов обуславливают данное значение точки сценария? ** Ответ: все значерия факторов, обуславливающих все сценарии с таким значением данной точки. IF mCreateClsPointFuture > 1 *** Формирование SCV-файла с кодами сценариев, соответствующих точке будущего сценария CrLf = CHR(13)+CHR(10) // Конец строки (записи) set printer to ('ValFutScen.txt') set device to printer set printer on set console off SELECT ValFutScen DBGOTOP() mNEWKODCLS = NEWKODCLS mString = ALLTRIM(STR(mNEWKODCLS))+',' DO WHILE .NOT. EOF() IF mNEWKODCLS = NEWKODCLS // Накопление кодов сценариев, соответствующих значению точки mString = mString + ALLTRIM(STR(KODSCEN))+',' ELSE ??SUBSTR(mString, 1, LEN(mString)-1)+CrLf mNEWKODCLS = NEWKODCLS mString = ALLTRIM(STR(mNEWKODCLS))+',' mString = mString + ALLTRIM(STR(KODSCEN))+',' ENDIF DBSKIP(1) ENDDO ??SUBSTR(mString, 1, LEN(mString)-1) *** Перенаправление вывода на консоль Set device to screen Set printer off Set printer to Set console on ************************************************************************************** ** Добавление в обучающую выборку наблюдений с кодами классов, соответствующих значениям точек будущего сценария и признаками, соответсвующими сценариям **** Если в наблюдении встречается код сценария, то добавлять в коды классов наблюдения код значения точки * Файл: ValFutScen.txt * * 34,7,8,9,10 * 35,11,12,13,14,15,16 * 36,17,18,19 * 37,7,8,11,12 * 38,9,10,13,14,15,17 * 39,16,18,19 * 40,7,9,11,13 * 41,8,10,12,14,17,18 * 42,15,16,19 * 43,20,21,22,23 * 44,24,25,26,27,28,29,30 * 45,31,32,33 * 46,20,21,24,25 * 47,22,23,26,27,28,31 * 48,29,30,32,33 * 49,20,22,24,26 * 50,21,23,25,27,29,31,32 * 51,28,30,33 ******* Цикл по строкам текстового файла ****************************************************** aKodCls := {} nHandle := DC_txtOpen( 'ValFutScen.txt' ) DO WHILE !DC_TxtEOF( nHandle ) // Начало цикла по строкам mLine = ALLTRIM(DC_TxtLine( nHandle )) // Выделить строку из текстового файла mKodCls = VAL(TOKEN(mLine, ",", 1)) AADD(aKodCls,mKodCls) mKodScen = 'aKodScen'+ALLTRIM(STR(mKodCls)) &mKodScen := {} FOR w=2 TO NUMTOKEN(mLine,",") // Разделитель между показателями - запятая AADD(&mKodScen, VAL(TOKEN(mLine, ",", w))) NEXT DC_TxtSkip( nHandle, 1 ) ENDDO DC_TxtClose( nHandle ) SELECT ObI_Kcl DBGOTOP() DO WHILE .NOT. EOF() mRecno = RECNO() mKodObj = KOD_OBJ A_KodCls := {} mFlag = .F. FOR j=1 TO 5 mVal = FIELDGET(1+j) IF VALTYPE(mVal) = 'N' IF mVal > 0 FOR i=1 TO LEN(aKodCls) mKodScen = 'aKodScen'+ALLTRIM(STR(aKodCls[i])) IF ASCAN(&mKodScen, mVal) > 0 AADD(A_KodCls, aKodCls[i]) mFlag = .T. ENDIF NEXT ENDIF ENDIF NEXT IF mFlag ****** Запись массива кодов классов в БД Obi_Kcl M_KodObj = mKodObj APPEND BLANK FIELDPUT(1,M_KodObj) IF LEN(A_KodCls) > 0 k=2 FOR jj=1 TO LEN(A_KodCls) IF k <= 5 FIELDPUT(k++,A_KodCls[jj]) ELSE k=2 APPEND BLANK FIELDPUT(1,M_KodObj) FIELDPUT(k++,A_KodCls[jj]) ENDIF NEXT ENDIF A_KodCls := {} ENDIF DBGOTO(mRecno) DBSKIP(1) ENDDO ***** Физическая сортировка БД ObI_Kcl.dbf обучающей выборки SELECT Obi_Zag DBGOBOTTOM() mLen = LEN(ALLTRIM(STR(Kod_obj))) SELECT Obi_Kcl INDEX ON STRTRAN(STR(Kod_obj,mLen),' ','0') TO Obi_KclTmp DBGOTOP() DO WHILE .NOT. EOF() ar := {} FOR j=1 TO FCOUNT() AADD(ar, FIELDGET(j)) NEXT SELECT Obi_KclTmp APPEND BLANK FOR j=1 TO LEN(ar) FIELDPUT(j, ar[j]) NEXT SELECT Obi_Kcl DBSKIP(1) ENDDO CLOSE Obi_Kcl CLOSE Obi_KclTmp COPY FILE ('Obi_KclTmp.dbf') TO ('Obi_Kcl.dbf') ENDIF *************************************************************************************************** ** Создание классов, соответствующих значениям точек прошлых сценариев **************************** *************************************************************************************************** ** 1. Создание БД для сортировки сценариев по значениям точек (это сделать в самом начале, т.к. эту БД надо сразу и открывать) (СДЕЛАНО) ** 2. Заполнение БД для сортировки сценариев по значениям точек ** 3. Создание классификационных шкал значений точек всех шкал будущих сценариев ** 4. Создание градаций (классов) классификационной шкалы значений точек всех шкал будущих сценариев ** 5. Добавление в обучающую выборку классов и (объединение) значений факторов значений будущих сценариев (это сделать в п.4/5) <<<===################ *************************************************************************************************** ** 5. Добавление в обучающую выборку классов и (объединение) значений факторов значений точек будущих сценариев (это сделать в п.4/5) ** Вопрос: какие значения факторов обуславливают данное значение точки сценария? ** Ответ: все значерия факторов, обуславливающих все сценарии с таким значением данной точки. IF mCreateAttPointPast > 1 *** Формирование SCV-файла с кодами сценариев, соответствующих точке будущего сценария CrLf = CHR(13)+CHR(10) // Конец строки (записи) set printer to ('ValPastScen.txt') set device to printer set printer on set console off SELECT ValPastScen DBGOTOP() mNEWKODATR = NEWKODATR mString = ALLTRIM(STR(mNEWKODATR))+',' DO WHILE .NOT. EOF() IF mNEWKODATR = NEWKODATR // Накопление кодов сценариев, соответствующих значению точки mString = mString + ALLTRIM(STR(KODSCEN))+',' ELSE ??SUBSTR(mString, 1, LEN(mString)-1)+CrLf mNEWKODATR = NEWKODATR mString = ALLTRIM(STR(mNEWKODATR))+',' mString = mString + ALLTRIM(STR(KODSCEN))+',' ENDIF DBSKIP(1) ENDDO ??SUBSTR(mString, 1, LEN(mString)-1) *** Перенаправление вывода на консоль Set device to screen Set printer off Set printer to Set console on ************************************************************************************** ** Добавление в обучающую выборку наблюдений с кодами классов, соответствующих значениям точек прошлого сценария и признаками, соответствующими сценариям **** Если в наблюдении встречается код сценария, то добавлять в коды классов наблюдения код значения точки * Файл: ValPastScen.txt * * 34,7,8,9,10 * 35,11,12,13,14,15,16 * 36,17,18,19 * 37,7,8,11,12 * 38,9,10,13,14,15,17 * 39,16,18,19 * 40,7,9,11,13 * 41,8,10,12,14,17,18 * 42,15,16,19 * 43,20,21,22,23 * 44,24,25,26,27,28,29,30 * 45,31,32,33 * 46,20,21,24,25 * 47,22,23,26,27,28,31 * 48,29,30,32,33 * 49,20,22,24,26 * 50,21,23,25,27,29,31,32 * 51,28,30,33 ******* Цикл по строкам текстового файла ****************************************************** aKodCls := {} nHandle := DC_txtOpen( 'ValPastScen.txt' ) DO WHILE !DC_TxtEOF( nHandle ) // Начало цикла по строкам mLine = ALLTRIM(DC_TxtLine( nHandle )) // Выделить строку из текстового файла mKodAtr = VAL(TOKEN(mLine, ",", 1)) AADD(aKodAtr,mKodAtr) mKodScen = 'aKodScen'+ALLTRIM(STR(mKodAtr)) &mKodScen := {} FOR w=2 TO NUMTOKEN(mLine,",") // Разделитель между показателями - запятая AADD(&mKodScen, VAL(TOKEN(mLine, ",", w))) NEXT DC_TxtSkip( nHandle, 1 ) ENDDO DC_TxtClose( nHandle ) SELECT ObI_Kpr DBGOTOP() DO WHILE .NOT. EOF() mRecno = RECNO() mKodObj = KOD_OBJ A_KodAtr := {} mFlag = .F. FOR j=1 TO 8 mVal = FIELDGET(1+j) IF VALTYPE(mVal) = 'N' IF mVal > 0 FOR i=1 TO LEN(aKodAtr) mKodScen = 'aKodScen'+ALLTRIM(STR(aKodAtr[i])) IF ASCAN(&mKodScen, mVal) > 0 AADD(A_KodAtr, aKodAtr[i]) mFlag = .T. ENDIF NEXT ENDIF ENDIF NEXT IF mFlag ****** Запись массива кодов классов в БД Obi_Kpr M_KodObj = mKodObj APPEND BLANK FIELDPUT(1,M_KodObj) IF LEN(A_KodAtr) > 0 k=2 FOR jj=1 TO LEN(A_KodAtr) IF k <= 8 FIELDPUT(k++,A_KodAtr[jj]) ELSE k=2 APPEND BLANK FIELDPUT(1,M_KodAtr) FIELDPUT(k++,A_KodAtr[jj]) ENDIF NEXT ENDIF A_KodAtr := {} ENDIF DBGOTO(mRecno) DBSKIP(1) ENDDO ***** Физическая сортировка БД ObI_Kpr.dbf обучающей выборки SELECT Obi_Zag DBGOBOTTOM() mLen = LEN(ALLTRIM(STR(Kod_obj))) SELECT Obi_Kpr INDEX ON STRTRAN(STR(Kod_obj,mLen),' ','0') TO Obi_KprTmp DBGOTOP() DO WHILE .NOT. EOF() ar := {} FOR j=1 TO FCOUNT() AADD(ar, FIELDGET(j)) NEXT SELECT Obi_KprTmp APPEND BLANK FOR j=1 TO LEN(ar) FIELDPUT(j, ar[j]) NEXT SELECT Obi_Kpr DBSKIP(1) ENDDO CLOSE Obi_Kpr CLOSE Obi_KprTmp COPY FILE ('Obi_KprTmp.dbf') TO ('Obi_Kpr.dbf') ENDIF aSay[4]:SetCaption(aSay[4]:caption+L(' - Готово ')) *************************************************************************************************** **** Конец генерации обучающей выборки на основе базы событий "EventsKO" ************************** *************************************************************************************************** CASE M_Interval = 2 .AND. .NOT. M_Scenario // ################################################################################################## // ################################################################################################## * aSay[1]:SetCaption(L('1/3: Формирование классификационных и описательных шкал и градаций на основе БД "Inp_data"')) * aSay[2]:SetCaption(L('2/3: Генерация обучающей выборки и базы событий "EventsKO" на основе внешней БД "Inp_data"')) * aSay[3]:SetCaption(L('3/3: Переиндексация всех 12 баз данных нового приложения')) A_NameCls := {} // Массив наименований классов A_NameAtr := {} // Массив наименований признаков A_SymbCls := {} // Массив символов - классов, когда спец.интрпретация TXT-полей как символов A_SymbAtr := {} // Массив символов - классов, когда спец.интрпретация TXT-полей как символов mMaxLenCls = 15 // Максимальная длина наименования класса mMaxLenAtr = 15 // Максимальная длина наименования признака // Запись и загрузка массивов aMinGranInt и aMaxGranInt * DC_ASave(aGradNSc, "_GradNSc.arx") // Запись массива aGradNSc aGradNSc = DC_ARestore("_GradNSc.arx") // Загрузка массива aGradNSc * DC_ASave(aMinGranInt, "_MinGranInt.arx") // Запись массива aMinGranInt * DC_ASave(aMaxGranInt, "_MaxGranInt.arx") // Запись массива aMaxGranInt aMinGranInt = DC_ARestore("_MinGranInt.arx") // Загрузка массива aMinGranInt aMaxGranInt = DC_ARestore("_MaxGranInt.arx") // Загрузка массива aMaxGranInt N_GrCls = aGradNSc[1] // Кол-во градаций в класс.шкале N_GrAtr = aGradNSc[2] // Кол-во градаций в опис. шкале ***** Создать индексные массивы для поиска CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;ZAP INDEX ON Name_cls TO Cls_name CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Attributes EXCLUSIVE NEW;ZAP INDEX ON Name_atr TO Atr_name CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE EventsTmp EXCLUSIVE NEW;ZAP INDEX ON Name_obj TO EventsTmp CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Class_Sc EXCLUSIVE NEW;ZAP USE Gr_ClSc EXCLUSIVE NEW;ZAP USE Classes INDEX Cls_name EXCLUSIVE NEW USE Opis_Sc EXCLUSIVE NEW;ZAP USE Gr_OpSc EXCLUSIVE NEW;ZAP USE Attributes INDEX Atr_name EXCLUSIVE NEW USE Inp_data EXCLUSIVE NEW;N_Rec = RECCOUNT() USE Inp_sh EXCLUSIVE NEW USE EventsKO EXCLUSIVE NEW;ZAP USE Obi_Zag EXCLUSIVE NEW;ZAP USE Obi_Kcl EXCLUSIVE NEW;ZAP USE Obi_Kpr EXCLUSIVE NEW;ZAP USE EventsTmp INDEX EventsTmp EXCLUSIVE NEW;ZAP *************************************************************************************************** **** 1/3: Формирование классификационных и описательных шкал и градаций на основе БД "Inp_data" ** *************************************************************************************************** aSay[1]:SetCaption(L('1/3: Формирование классификационных и описательных шкал и градаций на основе БД "Inp_data"')) * K_GradNClSc = Задано в диалоге // Количество градаций в числовой классификационной шкале * K_GradNOpSc = Задано в диалоге // Количество градаций в числовой описательной шкале K_N_GrClSc = K_N_ClSc * K_GradNClSc // Суммарное кол-во град.числовых класс.шкал K_N_GrOpSc = K_N_OpSc * K_GradNOpSc // Суммарное кол-во град.числовых опис. шкал K_N_GrClSc = IF(K_N_GrClSc < N_Rec, K_N_GrClSc, N_Rec) // Кол-во градаций шкалы не может быть больше числа объектов выборки K_N_GrOpSc = IF(K_N_GrOpSc < N_Rec, K_N_GrOpSc, N_Rec) // Кол-во градаций шкалы не может быть больше числа объектов выборки N_GrSc = MAX(K_GradNClSc, K_GradNOpSc) // Большее из кол-ва градаций числовых класс.и опис.шкал * DC_DebugQout( { K_GradNClSc, K_GradNOpSc, N_GrSc } ) PRIVATE aExcelClSc[K_GradNClSc,5] // Массив для рассчета, такой же как в Excel PRIVATE aMinGranInt[N_GrSc,N_Col] // Минимальные границы градаций числовых класс.и опис.шкал PRIVATE aMaxGranInt[N_GrSc,N_Col] // Максимальные границы градаций числовых класс.и опис.шкал PRIVATE aKGradCClSc[N_Col] // Кол-во градаций в текстовых классификационных шкалах PRIVATE aKGradCOpSc[N_Col] // Кол-во градаций в текстовых описательных шкалах * aExcelClSc[1,1] // Обозначение (наименование) интервала * aExcelClSc[1,2] // Суммарное число наблюдений по текущей шкале * aExcelClSc[1,3] // Число градаций в текущей шкале * aExcelClSc[1,4] // Расчетное число наблюдений на интервал * aExcelClSc[1,5] // Фактическое число наблюдений на интервал M_KodClSc = 0 M_KodGrCS = 0 M_KodOpSc = 0 M_KodGrOS = 0 mMaxInt = -99999999 mMaxDec = -99999999 FOR mCol=M_ClSc1 TO M_ClSc2 // Цикл по классификационным шкалам IF aErrorNum[mCol] // Если есть вариабельность SELECT Inp_data SET FILTER TO SET ORDER TO DBGOTOP() mVal = FIELDGET(mCol) IF VALTYPE(mVal)="C" // Текстовый столбец *********************************************************************** IF Flag_zer=1 // <<<===###################################### если Flag_zer=1, то посчитать число градаций с данными другим способом SET FILTER TO LEN(ALLTRIM(FIELDGET(mCol))) > 0 ELSE SET FILTER TO ENDIF INDEX ON FIELDGET(mCol) TO InpD_tmp UNIQUE COUNT TO aKGradCClSc[mCol] ** Если 0 и пробелы считать отсутствием данных <<<===############################################################# ********* ЕСЛИ В ТЕКСТОВОМ СТОЛБЦЕ НЕТ РАЗЛИЧИЯ ГРАДАЦИЙ, ТО ИГНОРИРОВАТЬ ЕГО ############ IF aKGradCClSc[mCol] = 1 * AADD(aErrorVar, '['+ALLTRIM(STR(mCol))+'] - "'+ALLTRIM(aInp_name[mCol])+'"') ELSE SELECT Class_Sc APPEND BLANK REPLACE Kod_ClSc WITH ++M_KodClSc REPLACE Name_ClSc WITH UPPER(ALLTRIM(aInp_name[mCol])) mNumGrad = 0 SELECT Inp_data DBGOTOP() DO WHILE .NOT. EOF() M_NameGrCS = ALLTRIM(STR(++mNumGrad,19)) + '/' + ALLTRIM(STR(aKGradCClSc[mCol],19)) + '-' + ALLTRIM(FIELDGET(mCol)) SELECT Gr_ClSc APPEND BLANK REPLACE Kod_ClSc WITH M_KodClSc REPLACE Kod_GrCS WITH ++M_KodGrCS REPLACE Name_GrCS WITH M_NameGrCS // Сформировать БД Classes M_NameCS = UPPER(ALLTRIM(aInp_name[mCol])) // Если в названии градации уже включено наим.шкалы, то повторно не включать его IF AT(M_NameCS, UPPER(M_NameGrCS)) = 0 M_Name = M_NameCS+"-"+M_NameGrCS ELSE M_Name = M_NameGrCS ENDIF mMaxLenCls = MAX( mMaxLenCls, LEN(ALLTRIM(M_Name))) // Максимальная длина наименования AADD(A_NameCls, ALLTRIM(M_Name)) SELECT Classes APPEND BLANK REPLACE Kod_cls WITH M_KodGrCS REPLACE Name_cls WITH M_Name REPLACE Kod_ClSc WITH M_KodClSc // Код класс.шкалы REPLACE N_ChrClSc WITH LEN(M_NameCS) // Кол-во символов в наим.класс.шкалы REPLACE Min_GrInt WITH 0 // Минимальная граница интервала REPLACE Max_GrInt WITH 0 // Максимальная граница интервала REPLACE Avr_GrInt WITH 0 // Среднее значение интервала SELECT Inp_data DBSKIP(1) ENDDO ENDIF ENDIF IF VALTYPE(mVal)="N" // Числовой столбец ************************************************************************ ********* ЕСЛИ В ЧИСЛОВОМ СТОЛБЦЕ НЕТ РАЗЛИЧИЯ ГРАДАЦИЙ, ТО ИГНОРИРОВАТЬ ЕГО ############ SET FILTER TO INDEX ON FIELDGET(mCol) TO InpD_tmp UNIQUE COUNT TO N_KGradCClSc SET ORDER TO IF N_KGradCClSc = 1 * AADD(aErrorVar, '['+ALLTRIM(STR(mCol))+'] - "'+ALLTRIM(aInp_name[mCol])+'"') ELSE mMaxInt = -99999999 mMaxDec = -99999999 A_inp := {} // Массив значений наблюдений по текущей шкале FOR i=1 TO N_Rec DBGOTO(i) mVal = FIELDGET(mCol) DO CASE CASE Flag_zer=1 IF mVal <> 0 // Нули считать отсутствием данных AADD (A_inp, mVal) mVal = ALLTRIM(REMRIGHT(STR(mVal,19,7),"0")) // Убрать пробелы впереди и подряд идущие нули справа mMaxInt = MAX(mMaxInt, AT('.', mVal)-1) // Найти максимальную длину целой части mMaxDec = MAX(mMaxDec, LEN(mVal)-AT('.', mVal)) // Найти максимальную длину дробной части ENDIF CASE Flag_zer=2 AADD (A_inp, mVal) mVal = ALLTRIM(REMRIGHT(STR(mVal,19,7),"0")) // Убрать пробелы впереди и подряд идущие нули справа mMaxInt = MAX(mMaxInt, AT('.', mVal)-1) // Найти максимальную длину целой части mMaxDec = MAX(mMaxDec, LEN(mVal)-AT('.', mVal)) // Найти максимальную длину дробной части ENDCASE NEXT mMaxDec = 7 mMaxInt = mMaxInt + mMaxDec + 1 ASORT(A_inp) // Сортировка всех значений наблюдений по текущей шкале в порядке возрастания aExcelClSc[1,1] = STR(1,LEN(ALLTRIM(STR(K_GradNClSc,19)))) + '/' + ALLTRIM(STR(K_GradNClSc,19)) // Обозначение интервала aExcelClSc[1,2] = LEN(A_inp) // Суммарное число наблюдений по текущей шкале aExcelClSc[1,3] = K_GradNClSc // Число градаций в текущей шкале aExcelClSc[1,4] = INT(aExcelClSc[1,2]/K_GradNClSc) // Расчетное число наблюдений на интервал aExcelClSc[1,5] = 0 // Фактическое число наблюдений на интервал aMinGranInt[1, mCol] = A_inp[1] // Нижняя граница 1-й градации // Сделать как в Excel-расчете адаптивных интервалов mNumGrad = 1 FOR j=1 TO aExcelClSc[1,2] // Цикл по значениям текущей шкалы IF aExcelClSc[mNumGrad,5] < aExcelClSc[mNumGrad,4] // Если фактическое число наблюдений в градации меньше расчетного, то суммировать 1 aExcelClSc[mNumGrad,5] = aExcelClSc[mNumGrad,5] + 1 aMaxGranInt[mNumGrad, mCol] = A_inp[j] // Считать очередное значение текущей шкалы верхней границей текущей градации IF mNumGrad+1 <= K_GradNClSc aMinGranInt[mNumGrad+1, mCol] = A_inp[j] // и нижней границей следующей градации, если она есть ENDIF // (добавить малую случ.компоненту, чтобы не было повторов наблюдений) ELSE // Иначе -перейти на следующую градацию, если она есть // и пересчитать число наблюдений на следующую градацию с учетом уже просчитанных IF mNumGrad+1 <= K_GradNClSc // Перейти на следующую градацию, если она есть mNumGrad++ aExcelClSc[mNumGrad,1] = STR(mNumGrad,LEN(ALLTRIM(STR(mNumGrad,19)))) + '/' + ALLTRIM(STR(K_GradNClSc,19)) // Обозначение интервала aExcelClSc[mNumGrad,2] = aExcelClSc[mNumGrad-1,2] - aExcelClSc[mNumGrad-1,5] // Осталось нераспределенных по интервалам наблюдений aExcelClSc[mNumGrad,3] = aExcelClSc[mNumGrad-1,3] - 1 // Интервалов осталось на 1 меньше aExcelClSc[mNumGrad,4] = INT(aExcelClSc[mNumGrad,2]/aExcelClSc[mNumGrad,3]) // Расчетное число наблюдений на очередной интервал aExcelClSc[mNumGrad,5] = 1 // Фактическое число наблюдений на интервал ENDIF ENDIF NEXT * DC_ArrayView( aExcelClSc ) mInpLen = LEN(A_inp) aMaxGranInt[mNumGrad, mCol] = A_inp[mInpLen] // Верхняя граница последней градации * DC_ArrayView( aMaxGranInt ) // Выдать в нередактируемом текстовом окне с прокруткой по клику на кнопке в окне диалога определения размерности модели DO CASE CASE M_Interval=1 M_TypeGr = '"Равные величины интервалов"' CASE M_Interval=2 M_TypeGr = '"Равное число событий в интервалах"' ENDCASE // Сюда вставить формирование записи всех БД, связанных с классами SELECT Class_Sc APPEND BLANK REPLACE Kod_ClSc WITH ++M_KodClSc REPLACE Name_ClSc WITH UPPER(ALLTRIM(aInp_name[mCol])) aNameGrNumSc = NameGrNumSc(N_GrCls) // Массив наименований градаций числовых классификационных шкал FOR mNumGrad=1 TO K_GradNClSc IF VALTYPE(aMinGranInt[mNumGrad, mCol])='N' .AND.; VALTYPE(aMaxGranInt[mNumGrad, mCol])='N' .AND.; VALTYPE(aExcelClSc [mNumGrad,5]) ='N' // Какие наименования ГРАДАЦИЙ числовых шкал использовать DO CASE CASE mNameGrNumSc= 1 // Только интервальные числовые значения M_NameGrCS = ALLTRIM(STR(mNumGrad,19))+"/"+; ALLTRIM(STR(K_GradNClSc,19))+"-{"+; ALLTRIM(STR(aMinGranInt[mNumGrad, mCol],19,7))+", "+; ALLTRIM(STR(aMaxGranInt[mNumGrad, mCol],19,7))+"}" CASE mNameGrNumSc= 2 // Только наименования интервальных числовых значений M_NameGrCS = aNameGrNumSc[mNumGrad] CASE mNameGrNumSc= 3 // И интервальные числовые значения, и их наименования M_NameGrCS = aNameGrNumSc[mNumGrad]+": "+; ALLTRIM(STR(mNumGrad,19))+"/"+; ALLTRIM(STR(K_GradNClSc,19))+"-{"+; ALLTRIM(STR(aMinGranInt[mNumGrad, mCol],19,7))+", "+; ALLTRIM(STR(aMaxGranInt[mNumGrad, mCol],19,7))+"}" ENDCASE // Формирование записи БД Gr_ClSc.dbf SELECT Gr_ClSc APPEND BLANK REPLACE Kod_ClSc WITH M_KodClSc REPLACE Kod_GrCS WITH ++M_KodGrCS REPLACE Name_GrCS WITH M_NameGrCS // Сформировать БД Classes M_NameCS = UPPER(ALLTRIM(aInp_name[mCol])) // Если в названии градации уже включено наим.шкалы, то повторно не включать его IF AT(M_NameCS, UPPER(M_NameGrCS)) = 0 M_Name = M_NameCS+"-"+M_NameGrCS ELSE M_Name = M_NameGrCS ENDIF mMaxLenCls = MAX( mMaxLenCls, LEN(ALLTRIM(M_Name))) // Максимальная длина наименования AADD(A_NameCls, ALLTRIM(M_Name)) SELECT Classes APPEND BLANK REPLACE Kod_cls WITH M_KodGrCS REPLACE Name_cls WITH M_Name REPLACE Kod_ClSc WITH M_KodClSc // Код класс.шкалы REPLACE N_ChrClSc WITH LEN(M_NameCS) // Кол-во символов в наим.класс.шкалы REPLACE Min_GrInt WITH aMinGranInt[mNumGrad, mCol] // Минимальная граница интервала REPLACE Max_GrInt WITH aMaxGranInt[mNumGrad, mCol] // Максимальная граница интервала REPLACE Avr_GrInt WITH aMinGranInt[mNumGrad, mCol]+(aMaxGranInt[mNumGrad, mCol]-aMinGranInt[mNumGrad, mCol])/2 // Среднее значение интервала ELSE aMess := {} AADD(aMess, L('Необходимо уменьшить число градаций в КЛАССИФИКАЦИОННЫХ шкалах,')) AADD(aMess, L('т.к. из-за недостатка данных появляются интервалы без наблюдений !!!')) LB_Warning(aMess) FlagErrorCls = .T. ENDIF NEXT ENDIF ENDIF ENDIF lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) NEXT // Выборка значений наблюдений по шкале mCol из БД Inp_data.dbf PRIVATE aExcelOpSc[K_GradNOpSc, 5] // Массив для рассчета, такой же как в Excel * aExcelOpSc[1,1] // Обозначение интервала * aExcelOpSc[1,2] // Суммарное число наблюдений по текущей шкале * aExcelOpSc[1,3] // Число градаций в текущей шкале * aExcelOpSc[1,4] // Расчетное число наблюдений на интервал * aExcelOpSc[1,5] // Фактическое число наблюдений на интервал FOR mCol=M_OpSc1 TO M_OpSc2 // Цикл по описательным шкалам IF aErrorNum[mCol] // Если есть вариабельность SELECT Inp_data SET FILTER TO SET ORDER TO DBGOTOP() mVal = FIELDGET(mCol) IF VALTYPE(mVal)="C" // Текстовый столбец *********************************************************************** IF Flag_zer=1 // <<<===###################################### если Flag_zer=1, то посчитать число градаций с данными другим способом SET FILTER TO LEN(ALLTRIM(FIELDGET(mCol))) > 0 ELSE SET FILTER TO ENDIF INDEX ON FIELDGET(mCol) TO InpD_tmp UNIQUE COUNT TO aKGradCOpSc[mCol] ********* ЕСЛИ В ТЕКСТОВОМ СТОЛБЦЕ НЕТ РАЗЛИЧИЯ ГРАДАЦИЙ, ТО ИГНОРИРОВАТЬ ЕГО ############ IF aKGradCClSc[mCol] = 1 * AADD(aErrorVar, '['+ALLTRIM(STR(mCol))+'] - "'+ALLTRIM(aInp_name[mCol])+'"') ELSE SELECT Opis_Sc APPEND BLANK REPLACE Kod_OpSc WITH ++M_KodOpSc REPLACE Name_OpSc WITH UPPER(ALLTRIM(aInp_name[mCol])) mNumGrad = 0 SELECT Inp_data DBGOTOP() DO WHILE .NOT. EOF() M_NameGrOS = ALLTRIM(STR(++mNumGrad,19)) + '/' + ALLTRIM(STR(aKGradCOpSc[mCol],19)) + '-' + ALLTRIM(FIELDGET(mCol)) SELECT Gr_OpSc APPEND BLANK REPLACE Kod_OpSc WITH M_KodOpSc REPLACE Kod_GrOS WITH ++M_KodGrOS REPLACE Name_GrOS WITH M_NameGrOS // Сформировать БД Attributes M_NameOS = UPPER(ALLTRIM(aInp_name[mCol])) // Если в названии градации уже включено наим.шкалы, то повторно не включать его IF AT(M_NameOS, UPPER(M_NameGrOS)) = 0 M_Name = M_NameOS+"-"+M_NameGrOS ELSE M_Name = M_NameGrOS ENDIF mMaxLenAtr = MAX( mMaxLenAtr, LEN(ALLTRIM(M_Name))) // Максимальная длина наименования AADD(A_NameAtr, ALLTRIM(M_Name)) SELECT Attributes APPEND BLANK REPLACE Kod_atr WITH M_KodGrOS REPLACE Name_atr WITH M_Name REPLACE Kod_OpSc WITH M_KodOpSc // Код класс.шкалы REPLACE N_ChrOpSc WITH LEN(M_NameOS) // Кол-во символов в наим.класс.шкалы REPLACE Min_GrInt WITH 0 // Минимальная граница интервала REPLACE Max_GrInt WITH 0 // Максимальная граница интервала REPLACE Avr_GrInt WITH 0 // Среднее значение интервала SELECT Inp_data DBSKIP(1) ENDDO ENDIF ENDIF IF VALTYPE(mVal)="N" // Числовой столбец ************************************************************************ ********* ЕСЛИ В ЧИСЛОВОМ СТОЛБЦЕ НЕТ РАЗЛИЧИЯ ГРАДАЦИЙ, ТО ИГНОРИРОВАТЬ ЕГО ############ SET FILTER TO INDEX ON FIELDGET(mCol) TO InpD_tmp UNIQUE COUNT TO N_KGradCClSc SET ORDER TO IF N_KGradCClSc = 1 * AADD(aErrorVar, '['+ALLTRIM(STR(mCol))+'] - "'+ALLTRIM(aInp_name[mCol])+'"') ELSE mMaxInt = -99999999 mMaxDec = -99999999 A_inp := {} // Массив значений наблюдений по текущей шкале FOR i=1 TO N_Rec DBGOTO(i) mVal = FIELDGET(mCol) DO CASE CASE Flag_zer=1 IF mVal <> 0 // Нули считать отсутствием данных AADD (A_inp, mVal) mVal = ALLTRIM(REMRIGHT(STR(mVal,19,7),"0")) // Убрать пробелы впереди и подряд идущие нули справа mMaxInt = MAX(mMaxInt, AT('.', mVal)-1) // Найти максимальную длину целой части mMaxDec = MAX(mMaxDec, LEN(mVal)-AT('.', mVal)) // Найти максимальную длину дробной части ENDIF CASE Flag_zer=2 AADD (A_inp, mVal) mVal = ALLTRIM(REMRIGHT(STR(mVal,19,7),"0")) // Убрать пробелы впереди и подряд идущие нули справа mMaxInt = MAX(mMaxInt, AT('.', mVal)-1) // Найти максимальную длину целой части mMaxDec = MAX(mMaxDec, LEN(mVal)-AT('.', mVal)) // Найти максимальную длину дробной части ENDCASE NEXT mMaxDec = 7 mMaxInt = mMaxInt + mMaxDec + 1 ASORT(A_inp) // Сортировка всех значений наблюдений по текущей шкале в порядке возрастания aExcelOpSc[1,1] = STR(1,LEN(ALLTRIM(STR(K_GradNOpSc,19)))) + '/' + ALLTRIM(STR(K_GradNOpSc,19)) // Обозначение интервала aExcelOpSc[1,2] = LEN(A_inp) // Суммарное число наблюдений по текущей шкале aExcelOpSc[1,3] = K_GradNOpSc // Число градаций в текущей шкале aExcelOpSc[1,4] = INT(aExcelOpSc[1,2]/K_GradNOpSc) // Расчетное число наблюдений на интервал aExcelOpSc[1,5] = 0 // Фактическое число наблюдений на интервал aMinGranInt[1, mCol] = A_inp[1] // Нижняя граница 1-й градации // Сделать как в Eccel-расчете адаптивных интервалов // ЗАЧЕМ ДЕЛАТЬ РАСЧЕТ ЕЩЕ РАЗ, КОГДА ОН УЖЕ СДЕЛАН, ДА ЕЩЕ В ЦИКЛЕ ############## mNumGrad = 1 FOR j=1 TO aExcelOpSc[1,2] // Цикл по значениям текущей шкалы IF aExcelOpSc[mNumGrad,5] < aExcelOpSc[mNumGrad,4] // Если фактическое число наблюдений в градации меньше расчетного, то суммировать 1 aExcelOpSc[mNumGrad,5] = aExcelOpSc[mNumGrad,5] + 1 aMaxGranInt[mNumGrad, mCol] = A_inp[j] // Считать очередное значение текущей шкалы верхней граничей текущей градации IF mNumGrad+1 <= K_GradNOpSc aMinGranInt[mNumGrad+1, mCol] = A_inp[j] // и нижней границей следующей градации, если она есть ENDIF ELSE // Иначе -перейти на следующую градацию, если она есть // и пересчитать число наблюдений на следующую градацию с учетом уже просчитанных IF mNumGrad+1 <= K_GradNOpSc // Перейти на следующую градацию, если она есть mNumGrad++ aExcelOpSc[mNumGrad,1] = STR(mNumGrad,LEN(ALLTRIM(STR(mNumGrad,19)))) + '/' + ALLTRIM(STR(K_GradNOpSc,19)) // Обозначение интервала aExcelOpSc[mNumGrad,2] = aExcelOpSc[mNumGrad-1,2] - aExcelOpSc[mNumGrad-1,5] // Осталось нераспределенных по интервалам наблюдений aExcelOpSc[mNumGrad,3] = aExcelOpSc[mNumGrad-1,3] - 1 // Интервалов осталось на 1 меньше aExcelOpSc[mNumGrad,4] = INT(aExcelOpSc[mNumGrad,2]/aExcelOpSc[mNumGrad,3]) // Расчетное число наблюдений на очередной интервал aExcelOpSc[mNumGrad,5] = 1 // Фактическое число наблюдений на интервал ENDIF ENDIF NEXT * DC_ArrayView( aExcelOpSc ) mInpLen = LEN(A_inp) aMaxGranInt[mNumGrad, mCol] = A_inp[mInpLen] // Верхняя граница последней градации // Выдать в нередактируемом текстовом окне с прокруткой по клику на кнопке в окне диалога определения размерности модели DO CASE CASE M_Interval=1 M_TypeGr = '"Равные величины интервалов"' CASE M_Interval=2 M_TypeGr = '"Равное число событий в интервалах"' ENDCASE // Сюда вставить добавление записей в БД, связанных с признаками SELECT Opis_Sc APPEND BLANK REPLACE Kod_OpSc WITH ++M_KodOpSc REPLACE Name_OpSc WITH UPPER(ALLTRIM(aInp_name[mCol])) aNameGrNumSc = NameGrNumSc(N_GrAtr) // Массив наименований градаций числовых описательных шкал FOR mNumGrad=1 TO K_GradNOpSc IF VALTYPE(aMinGranInt[mNumGrad, mCol])='N' .AND.; VALTYPE(aMaxGranInt[mNumGrad, mCol])='N' .AND.; VALTYPE(aExcelOpSc[mNumGrad,5]) ='N' // Какие наименования ГРАДАЦИЙ числовых шкал использовать DO CASE CASE mNameGrNumSc= 1 // Только интервальные числовые значения M_NameGrOS = ALLTRIM(STR(mNumGrad,19))+"/"+; ALLTRIM(STR(K_GradNOpSc,19))+"-{"+; ALLTRIM(STR(aMinGranInt[mNumGrad, mCol],19,7))+", "+; ALLTRIM(STR(aMaxGranInt[mNumGrad, mCol],19,7))+"}" CASE mNameGrNumSc= 2 // Только наименования интервальных числовых значений M_NameGrOS = aNameGrNumSc[mNumGrad] CASE mNameGrNumSc= 3 // И интервальные числовые значения, и их наименования M_NameGrOS = aNameGrNumSc[mNumGrad]+": "+; ALLTRIM(STR(mNumGrad,19))+"/"+; ALLTRIM(STR(K_GradNOpSc,19))+"-{"+; ALLTRIM(STR(aMinGranInt[mNumGrad, mCol],19,7))+", "+; ALLTRIM(STR(aMaxGranInt[mNumGrad, mCol],19,7))+"}" ENDCASE // Формирование записи БД Gr_OpSc.dbf SELECT Gr_OpSc APPEND BLANK REPLACE Kod_OpSc WITH M_KodOpSc REPLACE Kod_GrOS WITH ++M_KodGrOS REPLACE Name_GrOS WITH M_NameGrOS // Сформировать БД Attributes M_NameOS = UPPER(ALLTRIM(aInp_name[mCol])) // Если в названии градации уже включено наим.шкалы, то повторно не включать его IF AT(M_NameOS, UPPER(M_NameGrOS)) = 0 M_Name = M_NameOS+"-"+M_NameGrOS ELSE M_Name = M_NameGrOS ENDIF mMaxLenAtr = MAX( mMaxLenAtr, LEN(ALLTRIM(M_Name))) // Максимальная длина наименования AADD(A_NameAtr, ALLTRIM(M_Name)) SELECT Attributes APPEND BLANK REPLACE Kod_atr WITH M_KodGrOS REPLACE Name_atr WITH M_Name REPLACE Kod_OpSc WITH M_KodOpSc // Код класс.шкалы REPLACE N_ChrOpSc WITH LEN(M_NameOS) // Кол-во символов в наим.опис.шкалы REPLACE Min_GrInt WITH aMinGranInt[mNumGrad, mCol] // Минимальная граница интервала REPLACE Max_GrInt WITH aMaxGranInt[mNumGrad, mCol] // Максимальная граница интервала REPLACE Avr_GrInt WITH aMinGranInt[mNumGrad, mCol]+(aMaxGranInt[mNumGrad, mCol]-aMinGranInt[mNumGrad, mCol])/2 // Среднее значение интервала ELSE aMess := {} AADD(aMess, L('Необходимо уменьшить число градаций в ОПИСАТЕЛЬНЫХ шкалах,')) AADD(aMess, L('т.к. из-за недостатка данных появляются интервалы без наблюдений !!!')) * LB_Warning(aMess) FlagErrorAtr = .T. ENDIF NEXT ENDIF ENDIF ENDIF lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) NEXT // Запись и загрузка массивов: aExcelClSc, aExcelOpSc, aMinGranInt и aMaxGranInt aGradNSc := {} // Массив числа градаций числовых классификационных и описательных шкал AADD(aGradNSc, K_GradNClSc) AADD(aGradNSc, K_GradNOpSc) DC_ASave(aExcelClSc, "_aXlsClSc.arx") // Запись массива aExcelClSc DC_ASave(aExcelOpSc, "_aXlsOpSc.arx") // Запись массива aExcelOpSc * aExcelClSc = DC_ARestore("_aXlsClSc.arx") // Загрузка массива aExcelClSc * aExcelOpSc = DC_ARestore("_aXlsOpSc.arx") // Загрузка массива aExcelOpSc DC_ASave(aGradNSc, "_GradNSc.arx") // Запись массива aGradNSc * aGradNSc = DC_ARestore("_GradNSc.arx") // Загрузка массива aGradNSc DC_ASave(aMinGranInt, "_MinGranInt.arx") // Запись массива aMinGranInt DC_ASave(aMaxGranInt, "_MaxGranInt.arx") // Запись массива aMaxGranInt * aMinGranInt = DC_ARestore("_MinGranInt.arx") // Загрузка массива aMinGranInt * aMaxGranInt = DC_ARestore("_MaxGranInt.arx") // Загрузка массива aMaxGranInt StrFile(STR(mMaxInt), '_mMaxInt.txt') // Запись текстового файла с параметром mMaxInt StrFile(STR(mMaxDec), '_mMaxDec.txt') // Запись текстового файла с параметром mMaxDec * mMaxInt = VAL(FileStr('_mMaxInt.txt')) // Загрузка параметра mMaxInt из текстового файла * mMaxDec = VAL(FileStr('_mMaxDec.txt')) // Загрузка параметра mMaxDec из текстового файла StrFile(STR(mMaxLenCls), '_MaxLCls.txt') // Запись текстового файла с параметром mMaxLenCls StrFile(STR(mMaxLenAtr), '_MaxLAtr.txt') // Запись текстового файла с параметром mMaxLenAtr * mMaxLenCls = VAL(FileStr('_MaxLCls.txt')) // Загрузка параметра mMaxLenCls из текстового файла * mMaxLenAtr = VAL(FileStr('_MaxLAtr.txt')) // Загрузка параметра mMaxLenAtr из текстового файла DC_ASave(A_NameCls, "_aNameCls.arx") // Запись массива A_NameCls DC_ASave(A_NameAtr, "_aNameAtr.arx") // Запись массива A_NameAtr * A_NameCls = DC_ARestore("_aNameCls.arx") // Загрузка массива A_NameCls * A_NameAtr = DC_ARestore("_aNameAtr.arx") // Загрузка массива A_NameAtr DC_ASave(aKGradCClSc, "_KGrCClSc.arx") // Запись текстового файла с параметром aKGradCClSc[mCol] DC_ASave(aKGradCOpSc, "_KGrCOpSc.arx") // Запись текстового файла с параметром aKGradCOpSc[mCol] * aKGradCClSc = DC_ARestore("_KGrCClSc.arx") // Загрузка параметра aKGradCClSc[mCol] из текстового файла * aKGradCOpSc = DC_ARestore("_KGrCOpSc.arx") // Загрузка параметра aKGradCOpSc[mCol] из текстового файла // Запись БД наименований шкал и параметров их градаций // с последующим просмотром ее после определения кол-ва градаций класс.и описательных шкал * DC_GetProgress(oProgress2,nMax,nMax) * oDialog2:Destroy() aSay[1]:SetCaption(aSay[1]:caption+L(' - Готово ')) *************************************************************************************************** **** Конец формирования классификационных и описательных шкал и градаций на основе БД "Inp_data" * *************************************************************************************************** *************************************************************************************************** ########################################### **** 2/3: Генерация обучающей выборки и базы событий "EventsKO" на основе внешней БД "Inp_data" ** ########################################### *************************************************************************************************** ########################################### aSay[2]:SetCaption(L('2/3: Генерация обучающей выборки и базы событий "EventsKO" на основе внешней БД "Inp_data"')) ***** Создать индексные массивы для поиска CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW INDEX ON Name_cls TO Cls_name CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Attributes EXCLUSIVE NEW INDEX ON Name_atr TO Atr_name CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes INDEX Cls_name EXCLUSIVE NEW USE Attributes INDEX Atr_name EXCLUSIVE NEW USE Inp_data EXCLUSIVE NEW USE Obi_Zag EXCLUSIVE NEW;ZAP USE Obi_Kcl EXCLUSIVE NEW;ZAP USE Obi_Kpr EXCLUSIVE NEW;ZAP USE EventsKO EXCLUSIVE NEW;ZAP USE EventsKOs EXCLUSIVE NEW;ZAP mMaxLen = 15 // Определение максимальной длины базового кода M_KodObj = 0 SELECT Inp_data SET ORDER TO DBGOTOP() DO WHILE .NOT. EOF() ****** База заголовков SELECT Inp_data Fv = FIELDGET(1) // Наименование объекта обучающей выборки DO CASE CASE VALTYPE(Fv) = "N" // Числовые столбцы M_NameObj = ALLTRIM(STR(Fv,17)) CASE VALTYPE(Fv) = "C" // Символьные столбцы M_NameObj = ALLTRIM(Fv) CASE VALTYPE(Fv) = "D" // Столбец типа "Дата" M_NameObj = ALLTRIM(DTOC(Fv)) ENDCASE SELECT EventsKO APPEND BLANK REPLACE Name_obj WITH M_NameObj A_KodCls := {} // Массив кодов классов текущего объекта обучающей выборки FOR ff = M_ClSc1 TO M_ClSc2 // КЛАССИФИКАЦИОННЫЕ ШКАЛЫ SELECT Inp_data Fv = FIELDGET(ff) M_Recno = RECNO() DO CASE CASE FIELDTYPE(ff)="N" // Числовые столбцы aNameGrNumSc = NameGrNumSc(N_GrCls) // Массив наименований градаций числовых классификационных шкал * Fv = VAL(STR(Fv,19,6)) SELECT EventsKO * MsgBox(STR(mNameGrNumSc)) FOR gr=1 TO N_GrCls * F_MinGR = VAL(STR(aMinGranInt[gr,ff],19,7)) * F_MaxGR = VAL(STR(aMaxGranInt[gr,ff],19,7)) F_MinGR = aMinGranInt[gr,ff] F_MaxGR = aMaxGranInt[gr,ff] IF F_MinGR <= Fv .AND. Fv <= F_MaxGR // Какие наименования ГРАДАЦИЙ числовых шкал использовать DO CASE CASE mNameGrNumSc= 1 // Только интервальные числовые значения M_Name = ALLTRIM(UPPER(aInp_name[ff]))+"-"+; ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(K_GradNClSc,19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" CASE mNameGrNumSc= 2 // Только наименования интервальных числовых значений M_Name = ALLTRIM(UPPER(aInp_name[ff]))+"-"+aNameGrNumSc[gr] CASE mNameGrNumSc= 3 // И интервальные числовые значения, и их наименования M_Name = ALLTRIM(UPPER(aInp_name[ff]))+"-"+aNameGrNumSc[gr]+": "+; ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(K_GradNClSc,19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" ENDCASE M_KodCls = ASCAN(A_NameCls, M_Name) IF M_KodCls > 0 AADD(A_KodCls, M_KodCls) FIELDPUT(ff, M_KodCls) ENDIF EXIT // Исключить повторное кодирование того же значения в следующем интервале ENDIF NEXT CASE FIELDTYPE(ff) = "C" // Символьные столбцы SELECT EventsKO FOR mNumGrad=1 TO aKGradCClSc[ff] M_NameGrCS = ALLTRIM(STR(mNumGrad,19)) + '/' + ALLTRIM(STR(aKGradCClSc[ff],19)) + '-' + ALLTRIM(Fv) M_NameCS = UPPER(ALLTRIM(aInp_name[ff])) IF AT(M_NameCS, UPPER(M_NameGrCS)) = 0 M_Name = M_NameCS+"-"+M_NameGrCS ELSE M_Name = M_NameGrCS ENDIF M_KodCls = ASCAN(A_NameCls, M_Name) IF M_KodCls > 0 * IF ASCAN(A_KodCls, M_KodCls) = 0 AADD( A_KodCls, M_KodCls) FIELDPUT(ff, M_KodCls) * ENDIF mMaxLen = MAX(mMaxLen, LEN(ALLTRIM(STR(M_KodCls,19)))) EXIT // Исключить повторное кодирование того же значения в следующем интервале ENDIF NEXT * M_NameGrCS = ALLTRIM(Fv) * M_NameCS = UPPER(ALLTRIM(aInp_name[ff])) * // Если в названии градации уже включено наим.шкалы, то повторно не включать его * IF AT(M_NameCS, UPPER(M_NameGrCS)) = 0 * M_Name = M_NameCS+"-"+M_NameGrCS * ELSE * M_Name = M_NameGrCS * ENDIF * M_Name = ALLTRIM(UPPER(aInp_name[ff]))+"-"+M_NameGrCS * M_KodCls = ASCAN(A_NameCls, M_Name) * SELECT EventsKO * IF M_KodCls > 0 * AADD(A_KodCls, M_KodCls) * FIELDPUT(ff, M_KodCls) * mMaxLen = MAX(mMaxLen, LEN(ALLTRIM(STR(M_KodCls,19)))) * ENDIF ENDCASE NEXT aNameGrNumSc = NameGrNumSc(N_GrAtr) // Массив наименований градаций числовых описательных шкал A_KodAtr := {} // Массив кодов признаков текущего объекта обучающей выборки FOR ff=M_OpSc1 TO M_OpSc2 // ОПИСАТЕЛЬНЫЕ ШКАЛЫ SELECT Inp_data Fv = FIELDGET(ff) * DC_DebugQout( aErrorNum ) IF aErrorNum[ff] // Если есть вариабельность M_Recno = RECNO() DO CASE CASE FIELDTYPE(ff)="N" // Числовые столбцы ############### ЭТО НЕ ВСЕГДА РАБОТАЕТ * Fv = VAL(STR(Fv,19,6)) SELECT EventsKO FOR gr=1 TO N_GrAtr * F_MinGR = VAL(STR(aMinGranInt[gr,ff],19,7)) * F_MaxGR = VAL(STR(aMaxGranInt[gr,ff],19,7)) F_MinGR = aMinGranInt[gr,ff] F_MaxGR = aMaxGranInt[gr,ff] IF F_MinGR <= Fv .AND. Fv <= F_MaxGR // Какие наименования ГРАДАЦИЙ числовых шкал использовать DO CASE CASE mNameGrNumSc= 1 // Только интервальные числовые значения M_Name = ALLTRIM(UPPER(aInp_name[ff]))+"-"+; ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(K_GradNOpSc,19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" CASE mNameGrNumSc= 2 // Только наименования интервальных числовых значений M_Name = ALLTRIM(UPPER(aInp_name[ff]))+"-"+aNameGrNumSc[gr] CASE mNameGrNumSc= 3 // И интервальные числовые значения, и их наименования M_Name = ALLTRIM(UPPER(aInp_name[ff]))+"-"+aNameGrNumSc[gr]+": "+; ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(K_GradNOpSc,19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" ENDCASE M_KodAtr = ASCAN(A_NameAtr, M_Name) IF M_KodAtr > 0 * IF ASCAN(A_KodAtr, M_KodAtr) = 0 AADD( A_KodAtr, M_KodAtr) FIELDPUT(ff, M_KodAtr) * ENDIF mMaxLen = MAX(mMaxLen, LEN(ALLTRIM(STR(M_KodAtr,19)))) EXIT // Исключить повторное кодирование того же значения в следующем интервале ENDIF ENDIF NEXT CASE FIELDTYPE(ff) = "C" // Символьные столбцы SELECT EventsKO FOR mNumGrad=1 TO aKGradCOpSc[ff] M_NameGrOS = ALLTRIM(STR(mNumGrad,19)) + '/' + ALLTRIM(STR(aKGradCOpSc[ff],19)) + '-' + ALLTRIM(Fv) M_NameOS = UPPER(ALLTRIM(aInp_name[ff])) IF AT(M_NameOS, UPPER(M_NameGrOS)) = 0 M_Name = M_NameOS+"-"+M_NameGrOS ELSE M_Name = M_NameGrOS ENDIF M_KodAtr = ASCAN(A_NameAtr, M_Name) IF M_KodAtr > 0 * IF ASCAN(A_KodAtr, M_KodAtr) = 0 AADD( A_KodAtr, M_KodAtr) FIELDPUT(ff, M_KodAtr) * ENDIF mMaxLen = MAX(mMaxLen, LEN(ALLTRIM(STR(M_KodAtr,19)))) EXIT // Исключить повторное кодирование того же значения в следующем интервале ENDIF NEXT * M_NameGrOS = ALLTRIM(Fv) * M_NameOS = UPPER(ALLTRIM(aInp_name[ff])) * // Если в названии градации уже включено наим.шкалы, то повторно не включать его * IF AT(M_NameOS, UPPER(M_NameGrOS)) = 0 * M_Name = M_NameOS+"-"+M_NameGrOS * ELSE * M_Name = M_NameGrOS * ENDIF * M_Name = ALLTRIM(UPPER(aInp_name[ff]))+"-"+M_NameGrOS * M_KodAtr = ASCAN(A_NameAtr, M_Name) * SELECT EventsKO * IF M_KodAtr > 0 * AADD(A_KodAtr, M_KodAtr) * FIELDPUT(ff, M_KodAtr) * mMaxLen = MAX(mMaxLen, LEN(ALLTRIM(STR(M_KodAtr,19)))) * ENDIF ENDCASE ENDIF NEXT // Формирование записи БД заголовков объектов обучающей выборки SELECT Obi_Zag APPEND BLANK REPLACE Kod_obj WITH ++M_KodObj REPLACE Name_obj WITH M_NameObj ****** Запись массива кодов классов в БД Obi_Kcl * ASORT(A_KodCls) SELECT Obi_Kcl APPEND BLANK FIELDPUT(1,M_KodObj) IF LEN(A_KodCls) > 0 k=2 FOR jj=1 TO LEN(A_KodCls) IF k <= 5 FIELDPUT(k++,A_KodCls[jj]) ELSE k=2 APPEND BLANK FIELDPUT(1,M_KodObj) FIELDPUT(k++,A_KodCls[jj]) ENDIF NEXT ENDIF ****** Запись массива кодов признаков в БД Obi_Kpr * ASORT(A_KodAtr) SELECT Obi_Kpr APPEND BLANK FIELDPUT(1,M_KodObj) IF LEN(A_KodAtr) > 0 k=2 FOR jj=1 TO LEN(A_KodAtr) IF k <= 8 FIELDPUT(k++,A_KodAtr[jj]) ELSE k=2 APPEND BLANK FIELDPUT(1,M_KodObj) FIELDPUT(k++,A_KodAtr[jj]) ENDIF NEXT ENDIF lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) SELECT Inp_data DBSKIP(1) ENDDO aSay[2]:SetCaption(aSay[2]:caption+L(' - Готово ')) *************************************************************************************************** **** Конец генерации обучающей выборки и базы событий "EventsKO" на основе внешней БД "Inp_data" * *************************************************************************************************** CASE M_Interval = 2 .AND. M_Scenario // ################################################################################################## * aSay[1]:SetCaption(L('1/5: Формирование классификационных и описательных шкал и градаций на основе БД "Inp_data"')) // Как в адапт.инт.без сцен. * aSay[2]:SetCaption(L('2/5: Генерация базы событий "EventsKO" на основе внешней БД "Inp_data"') ) // Как в адапт.инт.без сцен. * aSay[3]:SetCaption(L('3/5: Доформирование класс.и опис.шкал и град.на основе БД "EventsKO" (сценарии)') ) // Как в равн.интер.со сценар. * aSay[4]:SetCaption(L('4/5: Генерация обучающей выборки на основе базы событий "EventsKO"') ) // Как в равн.интер.со сценар. * aSay[5]:SetCaption(L('5/5: Переиндексация всех 12 баз данных нового приложения') ) A_NameCls := {} // Массив наименований классов A_NameAtr := {} // Массив наименований признаков mMaxLenCls = 15 // Максимальная длина наименования класса mMaxLenAtr = 15 // Максимальная длина наименования признака // Запись и загрузка массивов aMinGranInt и aMaxGranInt * DC_ASave(aGradNSc, "_GradNSc.arx") // Запись массива aGradNSc aGradNSc = DC_ARestore("_GradNSc.arx") // Загрузка массива aGradNSc * DC_ASave(aMinGranInt, "_MinGranInt.arx") // Запись массива aMinGranInt * DC_ASave(aMaxGranInt, "_MaxGranInt.arx") // Запись массива aMaxGranInt aMinGranInt = DC_ARestore("_MinGranInt.arx") // Загрузка массива aMinGranInt aMaxGranInt = DC_ARestore("_MaxGranInt.arx") // Загрузка массива aMaxGranInt N_GrCls = aGradNSc[1] // Кол-во градаций в класс.шкале N_GrAtr = aGradNSc[2] // Кол-во градаций в опис. шкале mMaxLen = 15 *************************************************************************************************************** *** 1/5: Формирование классификационных и описательных шкал и градаций на основе БД "Inp_data" *************** *************************************************************************************************************** aSay[1]:SetCaption(L('1/5: Формирование классификационных и описательных шкал и градаций на основе БД "Inp_data"')) // Как в адапт.инт.без сцен. * K_GradNClSc = Задано в диалоге // Количество градаций в числовой классификационной шкале * K_GradNOpSc = Задано в диалоге // Количество градаций в числовой описательной шкале K_N_GrClSc = K_N_ClSc * K_GradNClSc // Суммарное кол-во град.числовых класс.шкал K_N_GrOpSc = K_N_OpSc * K_GradNOpSc // Суммарное кол-во град.числовых опис. шкал K_N_GrClSc = IF(K_N_GrClSc < N_Rec, K_N_GrClSc, N_Rec) // Кол-во градаций шкалы не может быть больше числа объектов выборки K_N_GrOpSc = IF(K_N_GrOpSc < N_Rec, K_N_GrOpSc, N_Rec) // Кол-во градаций шкалы не может быть больше числа объектов выборки N_GrSc = MAX(K_GradNClSc, K_GradNOpSc) // Большее из кол-ва градаций числовых класс.и опис.шкал * DC_DebugQout( { K_GradNClSc, K_GradNOpSc, N_GrSc } ) PRIVATE aExcelClSc[K_GradNClSc,5] // Массив для рассчета, такой же как в Excel PRIVATE aMinGranInt[N_GrSc,N_Col] // Минимальные границы градаций числовых класс.и опис.шкал PRIVATE aMaxGranInt[N_GrSc,N_Col] // Максимальные границы градаций числовых класс.и опис.шкал PRIVATE aKGradCClSc[N_Col] // Кол-во градаций в текстовых классификационных шкалах PRIVATE aKGradCOpSc[N_Col] // Кол-во градаций в текстовых описательных шкалах * aExcelClSc[1,1] // Обозначение (наименование) интервала * aExcelClSc[1,2] // Суммарное число наблюдений по текущей шкале * aExcelClSc[1,3] // Число градаций в текущей шкале * aExcelClSc[1,4] // Расчетное число наблюдений на интервал * aExcelClSc[1,5] // Фактическое число наблюдений на интервал M_KodClSc = 0 M_KodGrCS = 0 M_KodOpSc = 0 M_KodGrOS = 0 FOR mCol=M_ClSc1 TO M_ClSc2 // Цикл по классификационным шкалам IF aErrorNum[mCol] // Если есть вариабельность SELECT Inp_data SET FILTER TO SET ORDER TO DBGOTOP() mVal = FIELDGET(mCol) IF VALTYPE(mVal)="C" // Текстовый столбец *********************************************************************** IF Flag_zer=1 // <<<===###################################### если Flag_zer=1, то посчитать число градаций с данными другим способом SET FILTER TO LEN(ALLTRIM(FIELDGET(mCol))) > 0 ELSE SET FILTER TO ENDIF INDEX ON FIELDGET(mCol) TO InpD_tmp UNIQUE COUNT TO aKGradCClSc[mCol] ********* ЕСЛИ В ТЕКСТОВОМ СТОЛБЦЕ НЕТ РАЗЛИЧИЯ ГРАДАЦИЙ, ТО ИГНОРИРОВАТЬ ЕГО ############ IF aKGradCClSc[mCol] = 1 * AADD(aErrorVar, '['+ALLTRIM(STR(mCol))+'] - "'+ALLTRIM(aInp_name[mCol])+'"') ELSE SELECT Class_Sc APPEND BLANK REPLACE Kod_ClSc WITH ++M_KodClSc REPLACE Name_ClSc WITH UPPER(ALLTRIM(aInp_name[mCol])) mNumGrad = 0 SELECT Inp_data DBGOTOP() DO WHILE .NOT. EOF() M_NameGrCS = ALLTRIM(STR(++mNumGrad,19)) + '/' + ALLTRIM(STR(aKGradCClSc[mCol],19)) + '-' + ALLTRIM(FIELDGET(mCol)) SELECT Gr_ClSc APPEND BLANK REPLACE Kod_ClSc WITH M_KodClSc REPLACE Kod_GrCS WITH ++M_KodGrCS REPLACE Name_GrCS WITH M_NameGrCS // Сформировать БД Classes M_NameCS = UPPER(ALLTRIM(aInp_name[mCol])) // Если в названии градации уже включено наим.шкалы, то повторно не включать его IF AT(M_NameCS, UPPER(M_NameGrCS)) = 0 M_Name = M_NameCS+"-"+M_NameGrCS ELSE M_Name = M_NameGrCS ENDIF mMaxLenCls = MAX( mMaxLenCls, LEN(ALLTRIM(M_Name))) // Максимальная длина наименования AADD(A_NameCls, ALLTRIM(M_Name)) SELECT Classes APPEND BLANK REPLACE Kod_cls WITH M_KodGrCS REPLACE Name_cls WITH M_Name REPLACE Kod_ClSc WITH M_KodClSc // Код класс.шкалы REPLACE N_ChrClSc WITH LEN(M_NameCS) // Кол-во символов в наим.класс.шкалы REPLACE Min_GrInt WITH 0 // Минимальная граница интервала REPLACE Max_GrInt WITH 0 // Максимальная граница интервала REPLACE Avr_GrInt WITH 0 // Среднее значение интервала SELECT Inp_data DBSKIP(1) ENDDO ENDIF ENDIF IF VALTYPE(mVal)="N" // Числовой столбец ************************************************************************ SET FILTER TO INDEX ON FIELDGET(mCol) TO InpD_tmp UNIQUE COUNT TO N_KGradCClSc SET ORDER TO IF N_KGradCClSc = 1 * AADD(aErrorVar, '['+ALLTRIM(STR(mCol))+'] - "'+ALLTRIM(aInp_name[mCol])+'"') ELSE mMaxInt = -99999999 mMaxDec = -99999999 A_inp := {} // Массив значений наблюдений по текущей шкале FOR i=1 TO N_Rec DBGOTO(i) mVal = FIELDGET(mCol) DO CASE CASE Flag_zer=1 IF mVal <> 0 // Нули считать отсутствием данных AADD (A_inp, mVal) mVal = ALLTRIM(REMRIGHT(STR(mVal,19,7),"0")) // Убрать пробелы впереди и подряд идущие нули справа mMaxInt = MAX(mMaxInt, AT('.', mVal)-1) // Найти максимальную длину целой части mMaxDec = MAX(mMaxDec, LEN(mVal)-AT('.', mVal)) // Найти максимальную длину дробной части ENDIF CASE Flag_zer=2 AADD (A_inp, mVal) mVal = ALLTRIM(REMRIGHT(STR(mVal,19,7),"0")) // Убрать пробелы впереди и подряд идущие нули справа mMaxInt = MAX(mMaxInt, AT('.', mVal)-1) // Найти максимальную длину целой части mMaxDec = MAX(mMaxDec, LEN(mVal)-AT('.', mVal)) // Найти максимальную длину дробной части ENDCASE NEXT mMaxDec = 7 mMaxInt = mMaxInt + mMaxDec + 1 ASORT(A_inp) // Сортировка всех значений наблюдений по текущей шкале в порядке возрастания aExcelClSc[1,1] = STR(1,LEN(ALLTRIM(STR(K_GradNClSc,19)))) + '/' + ALLTRIM(STR(K_GradNClSc,19)) // Обозначение интервала aExcelClSc[1,2] = LEN(A_inp) // Суммарное число наблюдений по текущей шкале aExcelClSc[1,3] = K_GradNClSc // Число градаций в текущей шкале aExcelClSc[1,4] = INT(aExcelClSc[1,2]/K_GradNClSc) // Расчетное число наблюдений на интервал aExcelClSc[1,5] = 0 // Фактическое число наблюдений на интервал aMinGranInt[1, mCol] = A_inp[1] // Нижняя граница 1-й градации // Сделать как в Excel-расчете адаптивных интервалов mNumGrad = 1 FOR j=1 TO aExcelClSc[1,2] // Цикл по значениям текущей шкалы IF aExcelClSc[mNumGrad,5] < aExcelClSc[mNumGrad,4] // Если фактическое число наблюдений в градации меньше расчетного, то суммировать 1 aExcelClSc[mNumGrad,5] = aExcelClSc[mNumGrad,5] + 1 aMaxGranInt[mNumGrad, mCol] = A_inp[j] // Считать очередное значение текущей шкалы верхней границей текущей градации IF mNumGrad+1 <= K_GradNClSc aMinGranInt[mNumGrad+1, mCol] = A_inp[j] // и нижней границей следующей градации, если она есть ENDIF // (добавить малую случ.компоненту, чтобы не было повторов наблюдений) ELSE // Иначе -перейти на следующую градацию, если она есть // и пересчитать число наблюдений на следующую градацию с учетом уже просчитанных IF mNumGrad+1 <= K_GradNClSc // Перейти на следующую градацию, если она есть mNumGrad++ aExcelClSc[mNumGrad,1] = STR(mNumGrad,LEN(ALLTRIM(STR(mNumGrad,19)))) + '/' + ALLTRIM(STR(K_GradNClSc,19)) // Обозначение интервала aExcelClSc[mNumGrad,2] = aExcelClSc[mNumGrad-1,2] - aExcelClSc[mNumGrad-1,5] // Осталось нераспределенных по интервалам наблюдений aExcelClSc[mNumGrad,3] = aExcelClSc[mNumGrad-1,3] - 1 // Интервалов осталось на 1 меньше aExcelClSc[mNumGrad,4] = INT(aExcelClSc[mNumGrad,2]/aExcelClSc[mNumGrad,3]) // Расчетное число наблюдений на очередной интервал aExcelClSc[mNumGrad,5] = 1 // Фактическое число наблюдений на интервал ENDIF ENDIF NEXT * DC_ArrayView( aExcelClSc ) mInpLen = LEN(A_inp) aMaxGranInt[mNumGrad, mCol] = A_inp[mInpLen] // Верхняя граница последней градации * DC_ArrayView( aMaxGranInt ) // Выдать в нередактируемом текстовом окне с прокруткой по клику на кнопке в окне диалога определения размерности модели DO CASE CASE M_Interval=1 M_TypeGr = '"Равные величины интервалов"' CASE M_Interval=2 M_TypeGr = '"Равное число событий в интервалах"' ENDCASE // Сюда вставить формирование записи всех БД, связанных с классами SELECT Class_Sc APPEND BLANK REPLACE Kod_ClSc WITH ++M_KodClSc REPLACE Name_ClSc WITH UPPER(ALLTRIM(aInp_name[mCol])) FOR mNumGrad=1 TO K_GradNClSc IF VALTYPE(aMinGranInt[mNumGrad, mCol])='N' .AND.; VALTYPE(aMaxGranInt[mNumGrad, mCol])='N' .AND.; VALTYPE(aExcelClSc[mNumGrad,5]) ='N' // Сюда вставить формирование записи БД Gr_ClSc.dbf M_NameGrCS = ALLTRIM(STR(mNumGrad,19))+"/"+; ALLTRIM(STR(K_GradNClSc,19))+"-{"+; ALLTRIM(STR(aMinGranInt[mNumGrad, mCol],19,7))+", "+; ALLTRIM(STR(aMaxGranInt[mNumGrad, mCol],19,7))+"}" SELECT Gr_ClSc APPEND BLANK REPLACE Kod_ClSc WITH M_KodClSc REPLACE Kod_GrCS WITH ++M_KodGrCS REPLACE Name_GrCS WITH M_NameGrCS // Сформировать БД Classes M_NameCS = UPPER(ALLTRIM(aInp_name[mCol])) // Если в названии градации уже включено наим.шкалы, то повторно не включать его IF AT(M_NameCS, UPPER(M_NameGrCS)) = 0 M_Name = M_NameCS+"-"+M_NameGrCS ELSE M_Name = M_NameGrCS ENDIF mMaxLenCls = MAX( mMaxLenCls, LEN(ALLTRIM(M_Name))) // Максимальная длина наименования AADD(A_NameCls, ALLTRIM(M_Name)) SELECT Classes APPEND BLANK REPLACE Kod_cls WITH M_KodGrCS REPLACE Name_cls WITH M_Name REPLACE Kod_ClSc WITH M_KodClSc // Код класс.шкалы REPLACE N_ChrClSc WITH LEN(M_NameCS) // Кол-во символов в наим.класс.шкалы REPLACE Min_GrInt WITH aMinGranInt[mNumGrad, mCol] // Минимальная граница интервала REPLACE Max_GrInt WITH aMaxGranInt[mNumGrad, mCol] // Максимальная граница интервала REPLACE Avr_GrInt WITH aMinGranInt[mNumGrad, mCol]+(aMaxGranInt[mNumGrad, mCol]-aMinGranInt[mNumGrad, mCol])/2 // Среднее значение интервала ELSE aMess := {} AADD(aMess, L('Необходимо уменьшить число градаций в КЛАССИФИКАЦИОННЫХ шкалах,')) AADD(aMess, L('т.к. из-за недостатка данных появляются интервалы без наблюдений !!!')) LB_Warning(aMess) FlagErrorCls = .T. ENDIF NEXT ENDIF ENDIF ENDIF lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) NEXT // Выборка значений наблюдений по шкале mCol из БД Inp_data.dbf PRIVATE aExcelOpSc[K_GradNOpSc, 5] // Массив для рассчета, такой же как в Excel * aExcelOpSc[1,1] // Обозначение интервала * aExcelOpSc[1,2] // Суммарное число наблюдений по текущей шкале * aExcelOpSc[1,3] // Число градаций в текущей шкале * aExcelOpSc[1,4] // Расчетное число наблюдений на интервал * aExcelOpSc[1,5] // Фактическое число наблюдений на интервал FOR mCol=M_OpSc1 TO M_OpSc2 // Цикл по классификационным шкалам IF aErrorNum[mCol] // Если есть вариабельность SELECT Inp_data SET FILTER TO SET ORDER TO DBGOTOP() mVal = FIELDGET(mCol) IF VALTYPE(mVal)="C" // Текстовый столбец *********************************************************************** IF Flag_zer=1 // <<<===###################################### если Flag_zer=1, то посчитать число градаций с данными другим способом SET FILTER TO LEN(ALLTRIM(FIELDGET(mCol))) > 0 ELSE SET FILTER TO ENDIF INDEX ON FIELDGET(mCol) TO InpD_tmp UNIQUE COUNT TO aKGradCOpSc[mCol] ********* ЕСЛИ В ТЕКСТОВОМ СТОЛБЦЕ НЕТ РАЗЛИЧИЯ ГРАДАЦИЙ, ТО ИГНОРИРОВАТЬ ЕГО ############ IF aKGradCOpSc[mCol] = 1 * AADD(aErrorVar, '['+ALLTRIM(STR(mCol))+'] - "'+ALLTRIM(aInp_name[mCol])+'"') ELSE SELECT Opis_Sc APPEND BLANK REPLACE Kod_OpSc WITH ++M_KodOpSc REPLACE Name_OpSc WITH UPPER(ALLTRIM(aInp_name[mCol])) mNumGrad = 0 SELECT Inp_data DBGOTOP() DO WHILE .NOT. EOF() M_NameGrOS = ALLTRIM(STR(++mNumGrad,19)) + '/' + ALLTRIM(STR(aKGradCOpSc[mCol],19)) + '-' + ALLTRIM(FIELDGET(mCol)) SELECT Gr_OpSc APPEND BLANK REPLACE Kod_OpSc WITH M_KodOpSc REPLACE Kod_GrOS WITH ++M_KodGrOS REPLACE Name_GrOS WITH M_NameGrOS // Сформировать БД Attributes M_NameOS = UPPER(ALLTRIM(aInp_name[mCol])) // Если в названии градации уже включено наим.шкалы, то повторно не включать его IF AT(M_NameOS, UPPER(M_NameGrOS)) = 0 M_Name = M_NameOS+"-"+M_NameGrOS ELSE M_Name = M_NameGrOS ENDIF mMaxLenAtr = MAX( mMaxLenAtr, LEN(ALLTRIM(M_Name))) // Максимальная длина наименования AADD(A_NameAtr, ALLTRIM(M_Name)) SELECT Attributes APPEND BLANK REPLACE Kod_atr WITH M_KodGrOS REPLACE Name_atr WITH M_Name REPLACE Kod_OpSc WITH M_KodOpSc // Код класс.шкалы REPLACE N_ChrOpSc WITH LEN(M_NameOS) // Кол-во символов в наим.класс.шкалы REPLACE Min_GrInt WITH 0 // Минимальная граница интервала REPLACE Max_GrInt WITH 0 // Максимальная граница интервала REPLACE Avr_GrInt WITH 0 // Среднее значение интервала SELECT Inp_data DBSKIP(1) ENDDO ENDIF ENDIF IF VALTYPE(mVal)="N" // Числовой столбец ************************************************************************ ********* ЕСЛИ В ЧИСЛОВОМ СТОЛБЦЕ НЕТ РАЗЛИЧИЯ ГРАДАЦИЙ, ТО ИГНОРИРОВАТЬ ЕГО ############ SET FILTER TO INDEX ON FIELDGET(mCol) TO InpD_tmp UNIQUE COUNT TO N_KGradCClSc SET ORDER TO IF N_KGradCClSc = 1 * AADD(aErrorVar, '['+ALLTRIM(STR(mCol))+'] - "'+ALLTRIM(aInp_name[mCol])+'"') ELSE mMaxInt = -99999999 mMaxDec = -99999999 A_inp := {} // Массив значений наблюдений по текущей шкале FOR i=1 TO N_Rec DBGOTO(i) mVal = FIELDGET(mCol) DO CASE CASE Flag_zer=1 IF mVal <> 0 // Нули считать отсутствием данных AADD (A_inp, mVal) mVal = ALLTRIM(REMRIGHT(STR(mVal,19,7),"0")) // Убрать пробелы впереди и подряд идущие нули справа mMaxInt = MAX(mMaxInt, AT('.', mVal)-1) // Найти максимальную длину целой части mMaxDec = MAX(mMaxDec, LEN(mVal)-AT('.', mVal)) // Найти максимальную длину дробной части ENDIF CASE Flag_zer=2 AADD (A_inp, mVal) mVal = ALLTRIM(REMRIGHT(STR(mVal,19,7),"0")) // Убрать пробелы впереди и подряд идущие нули справа mMaxInt = MAX(mMaxInt, AT('.', mVal)-1) // Найти максимальную длину целой части mMaxDec = MAX(mMaxDec, LEN(mVal)-AT('.', mVal)) // Найти максимальную длину дробной части ENDCASE NEXT mMaxDec = 7 mMaxInt = mMaxInt + mMaxDec + 1 ASORT(A_inp) // Сортировка всех значений наблюдений по текущей шкале в порядке возрастания aExcelOpSc[1,1] = STR(1,LEN(ALLTRIM(STR(K_GradNOpSc,19)))) + '/' + ALLTRIM(STR(K_GradNOpSc,19)) // Обозначение интервала aExcelOpSc[1,2] = LEN(A_inp) // Суммарное число наблюдений по текущей шкале aExcelOpSc[1,3] = K_GradNOpSc // Число градаций в текущей шкале aExcelOpSc[1,4] = INT(aExcelOpSc[1,2]/K_GradNOpSc) // Расчетное число наблюдений на интервал aExcelOpSc[1,5] = 0 // Фактическое число наблюдений на интервал aMinGranInt[1, mCol] = A_inp[1] // Нижняя граница 1-й градации // Сделать как в Eccel-расчете адаптивных интервалов mNumGrad = 1 FOR j=1 TO aExcelOpSc[1,2] // Цикл по значениям текущей шкалы IF aExcelOpSc[mNumGrad,5] < aExcelOpSc[mNumGrad,4] // Если фактическое число наблюдений в градации меньше расчетного, то суммировать 1 aExcelOpSc[mNumGrad,5] = aExcelOpSc[mNumGrad,5] + 1 aMaxGranInt[mNumGrad, mCol] = A_inp[j] // Считать очередное значение текущей шкалы верхней граничей текущей градации IF mNumGrad+1 <= K_GradNOpSc aMinGranInt[mNumGrad+1, mCol] = A_inp[j] // и нижней границей следующей градации, если она есть ENDIF ELSE // Иначе -перейти на следующую градацию, если она есть // и пересчитать число наблюдений на следующую градацию с учетом уже просчитанных IF mNumGrad+1 <= K_GradNOpSc // Перейти на следующую градацию, если она есть mNumGrad++ aExcelOpSc[mNumGrad,1] = STR(mNumGrad,LEN(ALLTRIM(STR(mNumGrad,19)))) + '/' + ALLTRIM(STR(K_GradNOpSc,19)) // Обозначение интервала aExcelOpSc[mNumGrad,2] = aExcelOpSc[mNumGrad-1,2] - aExcelOpSc[mNumGrad-1,5] // Осталось нераспределенных по интервалам наблюдений aExcelOpSc[mNumGrad,3] = aExcelOpSc[mNumGrad-1,3] - 1 // Интервалов осталось на 1 меньше aExcelOpSc[mNumGrad,4] = INT(aExcelOpSc[mNumGrad,2]/aExcelOpSc[mNumGrad,3]) // Расчетное число наблюдений на очередной интервал aExcelOpSc[mNumGrad,5] = 1 // Фактическое число наблюдений на интервал ENDIF ENDIF NEXT * DC_ArrayView( aExcelOpSc ) mInpLen = LEN(A_inp) aMaxGranInt[mNumGrad, mCol] = A_inp[mInpLen] // Верхняя граница последней градации // Выдать в нередактируемом текстовом окне с прокруткой по клику на кнопке в окне диалога определения размерности модели DO CASE CASE M_Interval=1 M_TypeGr = '"Равные величины интервалов"' CASE M_Interval=2 M_TypeGr = '"Равное число событий в интервалах"' ENDCASE // Сюда вставить добавление записей в БД, связанных с признаками SELECT Opis_Sc APPEND BLANK REPLACE Kod_OpSc WITH ++M_KodOpSc REPLACE Name_OpSc WITH UPPER(ALLTRIM(aInp_name[mCol])) FOR mNumGrad=1 TO K_GradNOpSc IF VALTYPE(aMinGranInt[mNumGrad, mCol])='N' .AND.; VALTYPE(aMaxGranInt[mNumGrad, mCol])='N' .AND.; VALTYPE(aExcelOpSc[mNumGrad,5]) ='N' M_NameGrOS = ALLTRIM(STR(mNumGrad,19))+"/"+; ALLTRIM(STR(K_GradNOpSc,19))+"-{"+; ALLTRIM(STR(aMinGranInt[mNumGrad, mCol],19,7))+", "+; ALLTRIM(STR(aMaxGranInt[mNumGrad, mCol],19,7))+"}" SELECT Gr_OpSc APPEND BLANK REPLACE Kod_OpSc WITH M_KodOpSc REPLACE Kod_GrOS WITH ++M_KodGrOS REPLACE Name_GrOS WITH M_NameGrOS // Сформировать БД Attributes M_NameOS = UPPER(ALLTRIM(aInp_name[mCol])) // Если в названии градации уже включено наим.шкалы, то повторно не включать его IF AT(M_NameOS, UPPER(M_NameGrOS)) = 0 M_Name = M_NameOS+"-"+M_NameGrOS ELSE M_Name = M_NameGrOS ENDIF mMaxLenAtr = MAX( mMaxLenAtr, LEN(ALLTRIM(M_Name))) // Максимальная длина наименования AADD(A_NameAtr, ALLTRIM(M_Name)) SELECT Attributes APPEND BLANK REPLACE Kod_atr WITH M_KodGrOS REPLACE Name_atr WITH M_Name REPLACE Kod_OpSc WITH M_KodOpSc // Код класс.шкалы REPLACE N_ChrOpSc WITH LEN(M_NameOS) // Кол-во символов в наим.опис.шкалы REPLACE Min_GrInt WITH aMinGranInt[mNumGrad, mCol] // Минимальная граница интервала REPLACE Max_GrInt WITH aMaxGranInt[mNumGrad, mCol] // Максимальная граница интервала REPLACE Avr_GrInt WITH aMinGranInt[mNumGrad, mCol]+(aMaxGranInt[mNumGrad, mCol]-aMinGranInt[mNumGrad, mCol])/2 // Среднее значение интервала ELSE aMess := {} AADD(aMess, L('Необходимо уменьшить число градаций в ОПИСАТЕЛЬНЫХ шкалах,')) AADD(aMess, L('т.к. из-за недостатка данных появляются интервалы без наблюдений !!!')) * LB_Warning(aMess) FlagErrorAtr = .T. ENDIF NEXT ENDIF ENDIF ENDIF lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) NEXT * DC_GetProgress(oProgress2,nMax,nMax) * oDialog2:Destroy() aSay[1]:SetCaption(aSay[1]:caption+L(' - Готово ')) *************************************************************************************************** **** Конец формирования классификационных и описательных шкал и градаций на основе БД "Inp_data" * *************************************************************************************************** *************************************************************************************************** **** 2/5: Генерация базы событий "EventsKO" на основе внешней БД "Inp_data" *********************** *************************************************************************************************** aSay[2]:SetCaption(L('2/5: Генерация базы событий "EventsKO" на основе внешней БД "Inp_data"')) // Как в адапт.инт.без сцен. ***** Создать индексные массивы для поиска CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW INDEX ON Name_cls TO Cls_name CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Attributes EXCLUSIVE NEW INDEX ON Name_atr TO Atr_name CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE EventsTmp EXCLUSIVE NEW INDEX ON Name_obj TO EventsTmp *************************************************************************************************** ** Создание классов, соответствующих значениям точек будущих сценариев **************************** *************************************************************************************************** ** 1. Создание БД для сортировки сценариев по значениям точек (это сделать в самом начале, т.к. эту БД надо сразу и открывать) (СДЕЛАНО) ** 2. Заполнение БД для сортировки сценариев по значениям точек ** 3. Создание классификационных шкал значений точек всех шкал будущих сценариев ** 4. Создание градаций (классов) классификационной шкалы значений точек всех шкал будущих сценариев ** 5. Добавление в обучающую выборку классов и (объединение) значений факторов значений будущих сценариев (это сделать в п.4/5) *************************************************************************************************** ** 1. Создание БД для сортировки сценариев по финальным значениям (это сделать в самом начале, т.к. эту БД надо сразу и открывать) (СДЕЛАНО) * CrClsFinValFutScen = .T. // .T. - только для финальных значений будущих сценариев, .F. - для всех точек * mCreateAttPointPast = 1 * oGroup21 CAPTION L('Рассматривать отдельно точки прошлых сценариев? ' * mCreateAttPointPast VALUE 1 PROMPT L('Не рассматривать ' * mCreateAttPointPast VALUE 2 PROMPT L('Рассматривать, но только финальные точки' * mCreateAttPointPast VALUE 3 PROMPT L('Рассматривать все точки ' * mCreateClsPointFuture = 1 * oGroup22 CAPTION L('Рассматривать отдельно точки будущих сценариев? ' * mCreateClsPointFuture VALUE 1 PROMPT L('Не рассматривать ' * mCreateClsPointFuture VALUE 2 PROMPT L('Рассматривать, но только финальные точки' * mCreateClsPointFuture VALUE 3 PROMPT L('Рассматривать все точки ' * MsgBox(STR(mCreateClsPointFuture)) IF mCreateClsPointFuture > 1 .OR. mCreateAttPointPast > 1 CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций IF mCreateClsPointFuture > 1 COPY FILE ('Obi_Kcl.dbf') TO ('Obi_KclTmp.dbf') *** Определить максимальную длину наименования базовых классов mML = -999 USE Classes EXCLUSIVE NEW DBGOTOP() DO WHILE .NOT. EOF() mNameCls = ALLTRIM(Name_cls) IF AT("-FUTURE", mNameCls) = 0 mML = MAX(mML, LEN(mNameCls)) ELSE EXIT ENDIF DBSKIP(1) ENDDO aStructure := { { "KodClSc" , "N", 15, 0 }, ; // Код старой классификационной шкалы, соответствующей текущей точке сценария { "KodScen" , "N", 15, 0 }, ; // Код сценария { "NameScen" , "C", 255, 0 }, ; // Наименование сценария { "PointNumb" , "N", 15, 0 }, ; // Номер точки сценария, соответствующей классу { "KodValScen", "N", 15, 0 }, ; // Код значения сценария (в БД Classes) в текущей точке { "NameValSce", "C", mML, 0 }, ; // Наименование значения сценария (в БД Classes) в текущей точке { "NewKodCls" , "N", 15, 0 }, ; // Новый код класса, соответствующего значению сценария в текущей точке { "NEWNAMECLS", "C", 255, 0 }, ; // Новое наименование класса, соответствующего значению сценария в текущей точке { "NEWNAMEVSP", "C", 255, 0 }, ; // Новое наименование подкласса, соответствующего значению сценария в текущей точке { "NewKodClSc", "N", 15, 0 }, ; // Код новой классификационной шкалы, соответствующей текущей точке сценария { "NewNameCS" , "C", 255, 0 } } // Наименование новой классификационной шкалы, соответствующей текущей точке сценария DbCreate( "ValFutScen.dbf", aStructure ) DbCreate( "ValFutSTmp.dbf", aStructure ) ENDIF IF mCreateAttPointPast > 1 COPY FILE ('Obi_Kpr.dbf') TO ('Obi_KprTmp.dbf') *** Определить максимальную длину наименования базовых значений факторов mML = -999 USE Attributes EXCLUSIVE NEW DBGOTOP() DO WHILE .NOT. EOF() mNameAtr = ALLTRIM(Name_atr) IF AT("-PAST", mNameAtr) = 0 mML = MAX(mML, LEN(mNameAtr)) ELSE EXIT ENDIF DBSKIP(1) ENDDO aStructure := { { "KodOpSc" , "N", 15, 0 }, ; // Код старой описательной шкалы, соответствующей текущей точке сценария { "KodScen" , "N", 15, 0 }, ; // Код сценария { "NameScen" , "C", 255, 0 }, ; // Наименование сценария { "PointNumb" , "N", 15, 0 }, ; // Номер точки сценария, соответствующей значению фактора { "KodValScen", "N", 15, 0 }, ; // Код значения сценария (в БД Attributes) в текущей точке { "NameValSce", "C", mML, 0 }, ; // Наименование значения сценария (в БД Attributes) в текущей точке { "NewKodAtr" , "N", 15, 0 }, ; // Новый код значения фактора, соответствующего значению сценария в текущей точке { "NEWNAMEAtr", "C", 255, 0 }, ; // Новое наименование значение фактора, соответствующего значению сценария в текущей точке { "NEWNAMEVSP", "C", 255, 0 }, ; // Новое наименование подфактора, соответствующего значению сценария в текущей точке { "NewKodOpSc", "N", 15, 0 }, ; // Код новой описательной шкалы, соответствующей текущей точке сценария { "NewNameOS" , "C", 255, 0 } } // Наименование новой описательной шкалы, соответствующей текущей точке сценария DbCreate( "ValPastScen.dbf", aStructure ) DbCreate( "ValPastSTmp.dbf", aStructure ) ENDIF ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Class_Sc EXCLUSIVE NEW USE Gr_ClSc EXCLUSIVE NEW USE Classes INDEX Cls_name EXCLUSIVE NEW USE Opis_Sc EXCLUSIVE NEW USE Gr_OpSc EXCLUSIVE NEW USE Attributes INDEX Atr_name EXCLUSIVE NEW USE Inp_data EXCLUSIVE NEW USE Inp_sh EXCLUSIVE NEW USE EventsKO EXCLUSIVE NEW;ZAP USE EventsKOs EXCLUSIVE NEW;ZAP // Для отладки <<<===############### USE Obi_Zag EXCLUSIVE NEW;ZAP USE Obi_Kcl EXCLUSIVE NEW;ZAP USE Obi_Kpr EXCLUSIVE NEW;ZAP USE EventsTmp INDEX EventsTmp EXCLUSIVE NEW;ZAP IF mCreateClsPointFuture > 1 USE Obi_KclTmp EXCLUSIVE NEW;ZAP USE ValFutScen EXCLUSIVE NEW USE ValFutSTmp EXCLUSIVE NEW ENDIF IF mCreateAttPointPast > 1 USE Obi_KprTmp EXCLUSIVE NEW;ZAP USE ValPastScen EXCLUSIVE NEW USE ValPastSTmp EXCLUSIVE NEW ENDIF mMaxLen = 15 M_KodObj = 0 SELECT Inp_data SET ORDER TO DBGOTOP() DO WHILE .NOT. EOF() ****** База заголовков SELECT Inp_data Fv = FIELDGET(1) // Наименование объекта обучающей выборки DO CASE CASE VALTYPE(Fv) = "N" // Числовые столбцы M_NameObj = ALLTRIM(STR(Fv,17)) CASE VALTYPE(Fv) = "C" // Символьные столбцы M_NameObj = ALLTRIM(Fv) CASE VALTYPE(Fv) = "D" // Столбец типа "Дата" M_NameObj = ALLTRIM(DTOC(Fv)) ENDCASE SELECT EventsKO APPEND BLANK REPLACE Name_obj WITH M_NameObj A_KodCls := {} // Массив кодов классов текущего объекта обучающей выборки FOR ff = M_ClSc1 TO M_ClSc2 // КЛАССИФИКАЦИОННЫЕ ШКАЛЫ SELECT Inp_data Fv = FIELDGET(ff) M_Recno = RECNO() DO CASE CASE FIELDTYPE(ff)="N" // Числовые столбцы * Fv = VAL(STR(Fv,19,6)) SELECT EventsKO aNameGrNumSc = NameGrNumSc(N_GrCls) // Массив наименований градаций числовых шкал FOR gr=1 TO N_GrCls * F_MinGR = VAL(STR(aMinGranInt[gr,ff],19,7)) * F_MaxGR = VAL(STR(aMaxGranInt[gr,ff],19,7)) F_MinGR = aMinGranInt[gr,ff] F_MaxGR = aMaxGranInt[gr,ff] IF F_MinGR <= Fv .AND. Fv <= F_MaxGR // Какие наименования ГРАДАЦИЙ числовых шкал использовать DO CASE CASE mNameGrNumSc= 1 // Только интервальные числовые значения M_NameGrCS = ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(N_GrCls,19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" CASE mNameGrNumSc= 2 // Только наименования интервальных числовых значений M_NameGrCS = aNameGrNumSc[gr] CASE mNameGrNumSc= 3 // И интервальные числовые значения, и их наименования M_NameGrCS = aNameGrNumSc[gr]+": "+; ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(N_GrCls,19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" ENDCASE M_NameCS = UPPER(ALLTRIM(aInp_name[ff])) // Если в названии градации уже включено наим.шкалы, то повторно не включать его IF AT(M_NameCS, UPPER(M_NameGrCS)) = 0 M_Name = M_NameCS+"-"+M_NameGrCS ELSE M_Name = M_NameGrCS ENDIF M_KodCls = ASCAN(A_NameCls, M_Name) IF M_KodCls > 0 IF ASCAN(A_KodCls, M_KodCls) = 0 AADD( A_KodCls, M_KodCls) ENDIF FIELDPUT(ff, M_KodCls) mMaxLen = MAX(mMaxLen, LEN(ALLTRIM(STR(M_KodCls,19)))) EXIT // Исключить повторное кодирование того же значения в следующем интервале ENDIF ENDIF NEXT CASE FIELDTYPE(ff) = "C" // Символьные столбцы SELECT EventsKO FOR mNumGrad=1 TO aKGradCClSc[ff] M_NameGrCS = ALLTRIM(STR(mNumGrad,19)) + '/' + ALLTRIM(STR(aKGradCClSc[ff],19)) + '-' + ALLTRIM(Fv) M_NameCS = UPPER(ALLTRIM(aInp_name[ff])) IF AT(M_NameCS, UPPER(M_NameGrCS)) = 0 M_Name = M_NameCS+"-"+M_NameGrCS ELSE M_Name = M_NameGrCS ENDIF M_KodCls = ASCAN(A_NameCls, M_Name) IF M_KodCls > 0 * IF ASCAN(A_KodCls, M_KodCls) = 0 * AADD( A_KodCls, M_KodCls) * ENDIF FIELDPUT(ff, M_KodCls) mMaxLen = MAX(mMaxLen, LEN(ALLTRIM(STR(M_KodCls,19)))) EXIT // Исключить повторное кодирование того же значения в следующем интервале ENDIF NEXT ENDCASE lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) NEXT A_KodAtr := {} // Массив кодов признаков текущего объекта обучающей выборки FOR ff=M_OpSc1 TO M_OpSc2 // ОПИСАТЕЛЬНЫЕ ШКАЛЫ SELECT Inp_data IF aErrorNum[ff] // Если есть вариабельность Fv = FIELDGET(ff) DO CASE CASE FIELDTYPE(ff)="N" // Числовые столбцы * Fv = VAL(STR(Fv,19,6)) SELECT EventsKO aNameGrNumSc = NameGrNumSc(N_GrAtr) // Массив наименований градаций числовых шкал FOR gr=1 TO N_GrAtr * F_MinGR = VAL(STR(aMinGranInt[gr,ff],19,7)) * F_MaxGR = VAL(STR(aMaxGranInt[gr,ff],19,7)) F_MinGR = aMinGranInt[gr,ff] F_MaxGR = aMaxGranInt[gr,ff] IF F_MinGR <= Fv .AND. Fv <= F_MaxGR // Какие наименования ГРАДАЦИЙ числовых шкал использовать DO CASE CASE mNameGrNumSc= 1 // Только интервальные числовые значения M_NameGrOS = ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(N_GrAtr,19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" CASE mNameGrNumSc= 2 // Только наименования интервальных числовых значений M_NameGrOS = aNameGrNumSc[gr] CASE mNameGrNumSc= 3 // И интервальные числовые значения, и их наименования M_NameGrOS = aNameGrNumSc[gr]+": "+; ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(N_GrAtr,19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" ENDCASE M_NameOS = UPPER(ALLTRIM(aInp_name[ff])) // Если в названии градации уже включено наим.шкалы, то повторно не включать его IF AT(M_NameOS, UPPER(M_NameGrOS)) = 0 M_Name = M_NameOS+"-"+M_NameGrOS ELSE M_Name = M_NameGrOS ENDIF M_KodAtr = ASCAN(A_NameAtr, M_Name) IF M_KodAtr > 0 * IF ASCAN(A_KodAtr, M_KodAtr) = 0 * AADD( A_KodAtr, M_KodAtr) * ENDIF FIELDPUT(ff, M_KodAtr) mMaxLen = MAX(mMaxLen, LEN(ALLTRIM(STR(M_KodAtr,19)))) EXIT // Исключить повторное кодирование того же значения в следующем интервале ENDIF ENDIF NEXT CASE FIELDTYPE(ff) = "C" // Символьные столбцы SELECT EventsKO FOR mNumGrad=1 TO aKGradCOpSc[ff] M_NameGrOS = ALLTRIM(STR(mNumGrad,19)) + '/' + ALLTRIM(STR(aKGradCOpSc[ff],19)) + '-' + ALLTRIM(Fv) M_NameOS = UPPER(ALLTRIM(aInp_name[ff])) IF AT(M_NameOS, UPPER(M_NameGrOS)) = 0 M_Name = M_NameOS+"-"+M_NameGrOS ELSE M_Name = M_NameGrOS ENDIF M_KodAtr = ASCAN(A_NameAtr, M_Name) IF M_KodAtr > 0 * IF ASCAN(A_KodAtr, M_KodAtr) = 0 * AADD( A_KodAtr, M_KodAtr) * ENDIF FIELDPUT(ff, M_KodAtr) mMaxLen = MAX(mMaxLen, LEN(ALLTRIM(STR(M_KodAtr,19)))) EXIT // Исключить повторное кодирование того же значения в следующем интервале ENDIF NEXT ENDCASE ENDIF lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) NEXT SELECT Inp_data DBSKIP(1) ENDDO aSay[2]:SetCaption(aSay[2]:caption+L(' - Готово ')) *************************************************************************************************** **** Конец генерации базы событий "EventsKO" на основе внешней БД "Inp_data" ********************* *************************************************************************************************** *************************************************************************************************** ################################################################ **** 3/5: Доформирование классиф.и описат.шкал и градаций на основе БД "EventsKO" (сценарии) ****** ВОТ ЭТО И НАДО ПРОВЕРЯТЬ И ДУБЛИРОВАТЬ <<<===################### *************************************************************************************************** ################################################################ aSay[3]:SetCaption(L('3/5: Доформирование классиф.и описат.шкал и градаций на основе БД "EventsKO" (сценарии)')) SELECT Classes ;mMaxLenKCls = LEN(ALLTRIM(STR(RECCOUNT()))) // максимальное число разрядов в градациях базовых классификацинных шкал для кода класса SELECT Attributes;mMaxLenKAtr = LEN(ALLTRIM(STR(RECCOUNT()))) // максимальное число разрядов в градациях базовых описательных шкал для кода признака FOR ff=2 TO N_ColInpData // Начало цикла по полям Inp_data.dbf ******************************************** SELECT EventsKO IF aErrorNum[ff] // Если есть вариабельность Fv = FIELDGET(ff) DO CASE CASE M_ClSc1 <= ff .AND. ff <= M_ClSc2 // КЛАССИФИКАЦИОННЫЕ ШКАЛЫ: SELECT Class_Sc;DBGOBOTTOM();M_KodClSc = Kod_ClSc SELECT Gr_ClSc ;DBGOBOTTOM();M_KodGrCS = Kod_GrCS SELECT Opis_Sc ;DBGOBOTTOM();M_KodOpSc = Kod_OpSc SELECT Gr_OpSc ;DBGOBOTTOM();M_KodGrOS = Kod_GrOS SELECT EventsKO N_Rec = RECCOUNT() N_Col = FCOUNT() * PAST FUTURE FOR N_Gorizont = mGorizMin TO mGorizMax mScen = A_FNRus[ff] + '-FUTURE'+ALLTRIM(STR(N_Gorizont)) SELECT Class_Sc APPEND BLANK REPLACE Kod_ClSc WITH ++M_KodClSc REPLACE Name_ClSc WITH mScen SELECT EventsTmp;ZAP // Сформировать массив сценариев для текущей шкалы // <<<===######################################### aEventsTmp := {} // Массив для недопущения повторов сценариев // Цикл по текущей дате (записи) от 1-й до предпоследней * MsgBox('Горизонт='+STR(N_Gorizont)) // <<<===###################################### FOR M_Recno=1 TO N_Rec mScen = A_FNRus[ff] + '-FUTURE'+ALLTRIM(STR(N_Gorizont)) + '-' SELECT EventsKO DBGOTO(M_Recno) DBSKIP(1) // Код текущей записи тоже включать в сценарий? mGorizont = 1 DO WHILE .NOT. EOF() .AND. mGorizont <= N_Gorizont // Градации класс.шкалы ************************************ mFV = FIELDGET(ff) IF mFV > 0 mSimb = STRTRAN(STR(mFV,mMaxLenKCls),' ','0') IF LEN(mSimb) > 0 mt = mScen + mSimb + IF(mGorizont 0 mSimb = STRTRAN(STR(mFV,mMaxLenKAtr),' ','0') IF LEN(mSimb) > 0 mt = mScen + mSimb + IF(mGlubina < N_Glubina,',','') ++mGlubina mScen = ALLTRIM(SUBSTR(mt,1,255)) ENDIF ENDIF DBSKIP(1) ENDDO IF mGlubina = N_Glubina + 1 IF ASCAN(aEventsTmp, mt) = 0 // Если такого сценария еще нет в справочнике - занести его AADD (aEventsTmp, mt) SELECT EventsTmp APPEND BLANK REPLACE Name_Obj WITH mt ENDIF ENDIF NEXT // Рассортировать массив сценариев для текущей шкалы и внести его в базы данных SELECT EventsTmp INDEX ON Name_Obj TO Events_NO DBGOTOP() DO WHILE .NOT. EOF() M_NameGrOS = ALLTRIM(Name_Obj) SELECT Gr_OpSc APPEND BLANK REPLACE Kod_OpSc WITH M_KodOpSc REPLACE Kod_GrOS WITH ++M_KodGrOS REPLACE Name_GrOS WITH M_NameGrOS // Сформировать БД Classes M_NameOS = A_FNRus[ff] + '-PAST'+ALLTRIM(STR(N_Glubina)) // Если в названии градации уже включено наим.шкалы, то повторно не включать его IF AT(M_NameOS, UPPER(M_NameGrOS)) = 0 M_Name = M_NameOS+"-"+M_NameGrOS ELSE M_Name = M_NameGrOS ENDIF mMaxLenAtr = MAX( mMaxLenAtr, LEN(ALLTRIM(M_Name))) // Максимальная длина наименования AADD(A_NameAtr, ALLTRIM(M_Name)) // Массив наименований признаков SELECT Attributes APPEND BLANK REPLACE Kod_atr WITH M_KodGrOS REPLACE Name_atr WITH M_Name REPLACE Kod_OpSc WITH M_KodOpSc // Код класс.шкалы REPLACE N_ChrOpSc WITH LEN(M_NameOS) // Кол-во символов в наим.класс.шкалы SELECT EventsTmp DBSKIP(1) ENDDO lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) NEXT // <<<===######################################### ENDCASE ENDIF NEXT DC_ASave(A_NameCls, M_NewAppl+"\A_NameCls.arx") DC_ASave(A_NameAtr, M_NewAppl+"\A_NameAtr.arx") *************************************************************************************************** ** Создание классов, соответствующих значениям точек будущих сценариев **************************** *************************************************************************************************** ** 1. Создание БД для сортировки сценариев по значениям точек (это сделать в самом начале, т.к. эту БД надо сразу и открывать) (СДЕЛАНО) ** 2. Заполнение БД для сортировки сценариев по значениям точек ** 3. Создание классификационных шкал значений точек всех шкал будущих сценариев ** 4. Создание градаций (классов) классификационной шкалы значений точек всех шкал будущих сценариев ** 5. Добавление в обучающую выборку классов и (объединение) значений факторов значений будущих сценариев (это сделать в п.4/5) *************************************************************************************************** * MsgBox(STR(mCreateClsPointFuture)) IF mCreateClsPointFuture > 1 * aStructure := { { "KodClSc" , "N", 15, 0 }, ; // Код старой классификационной шкалы, соответствующей текущей точке сценария * { "KodScen" , "N", 15, 0 }, ; // Код сценария * { "NameScen" , "C", 255, 0 }, ; // Наименование сценария * { "PointNumb" , "N", 15, 0 }, ; // Номер точки сценария, соответствующей классу * { "KodValScen", "N", 15, 0 }, ; // Код значения сценария (в БД Classes) в текущей точке * { "NameValSce", "C", mML, 0 }, ; // Наименование значения сценария (в БД Classes) в текущей точке * { "NewKodCls" , "N", 15, 0 }, ; // Новый код класса, соответствующего значению сценария в текущей точке * { "NEWNAMECLS", "C", 255, 0 }, ; // Новое наименование класса, соответствующего значению сценария в текущей точке * { "NEWNAMEVSP", "C", 255, 0 }, ; // Новое наименование подкласса, соответствующего значению сценария в текущей точке * { "NewKodClSc", "N", 15, 0 }, ; // Код новой классификационной шкалы, соответствующей текущей точке сценария * { "NewNameCS" , "C", 255, 0 } } // Наименование новой классификационной шкалы, соответствующей текущей точке сценария * DbCreate( "ValFutScen.dbf", aStructure ) * DbCreate( "ValFutSTmp.dbf", aStructure ) ** 2. Заполнение БД для сортировки сценариев по финальным значениям ** Можно сделать цикл по точкам значений и учитывать не только финальные, а все значения <<<===################ SELECT Gr_ClSc DBGOBOTTOM() mKodMaxCls = KOD_GRCS DBGOTOP() DO WHILE .NOT. EOF() mKOD_CLSC = KOD_CLSC mKOD_GRCS = KOD_GRCS mNAME_GRCS = ALLTRIM(NAME_GRCS) mPos = AT("-FUTURE", mNAME_GRCS) IF mPos > 0 * OPEN-FUTURE3-1,1,1 mPos = RAT('-', mNAME_GRCS) mNameScen = SUBSTR(mNAME_GRCS, mPos+1, LEN(mNAME_GRCS)-mPos) mNewNameCS = SUBSTR(mNAME_GRCS, 1, mPos-1) mNPoints = NUMTOKEN(mNameScen, ',') // Фактическое кол-во точек в сценарии ******* Цикл по точкам сценария ************** * oGroup22 CAPTION L('Рассматривать отдельно точки будущих сценариев? ' * mCreateClsPointFuture VALUE 1 PROMPT L('Не рассматривать ' * mCreateClsPointFuture VALUE 2 PROMPT L('Рассматривать, но только финальные точки' * mCreateClsPointFuture VALUE 3 PROMPT L('Рассматривать все точки ' mPoint1 = IF(mCreateClsPointFuture=3, 1, mNPoints) FOR mPoint=mPoint1 TO mNPoints mKodValScen = VAL(TOKEN(mNameScen, mPoint)) // Код значения сценария (в БД Classes) в текущей точке mRecno = RECNO() DBGOTO(mKodValScen) mNameValSce = ALLTRIM(NAME_GRCS) // Наименование значения сценария (в БД Classes) в текущей точке DBGOTO(mRecno) SELECT ValFutSTmp APPEND BLANK REPLACE KodClSc WITH mKOD_CLSC REPLACE KodScen WITH mKOD_GRCS REPLACE NameScen WITH mNAME_GRCS REPLACE PointNumb WITH mPoint REPLACE KodValScen WITH mKodValScen REPLACE NameValSce WITH mNameValSce REPLACE NEWNAMECLS WITH mNewNameCS+'-Point'+ALLTRIM(STR(mPoint))+'-'+ALLTRIM(mNameValSce) // Новое наименование класса, соответствующего значению точки сценария REPLACE NEWNAMEVSP WITH mNAME_GRCS+'-Point'+ALLTRIM(STR(mPoint))+'-'+ALLTRIM(mNameValSce) // Новое наименование подкласса, соответствующего значению точки сценария REPLACE NewNameCS WITH mNewNameCS+'-Point'+ALLTRIM(STR(mPoint)) // Наименование новой классификационной шкалы, соответствующей значению точки сценария SELECT Gr_ClSc NEXT ENDIF DBSKIP(1) ENDDO ****** Физическая сортировка БД ValFutScen.dbf по полю: KodValScen SELECT Class_Sc DBGOBOTTOM() mLen = LEN(ALLTRIM(STR(Kod_ClSc))) SELECT ValFutSTmp INDEX ON STRTRAN(STR(KodClSc,mLen),' ','0')+ALLTRIM(NEWNAMECLS) TO ValFutSTmp DBGOTOP() DO WHILE .NOT. EOF() ar := {} FOR j=1 TO FCOUNT() AADD(ar, FIELDGET(j)) NEXT SELECT ValFutScen APPEND BLANK FOR j=1 TO LEN(ar) FIELDPUT(j, ar[j]) NEXT SELECT ValFutSTmp DBSKIP(1) ENDDO ****** Кодирование новых классов NEWKODCLS, соответствующих значениям точек сценариев ****** Кодирование новых классификационных шкал, соответствующих значениям точек сценариев SELECT Class_Sc DBGOBOTTOM() mKodMaxCS = Kod_ClSc SELECT ValFutScen DBGOTOP() mKodValScen = KodValScen REPLACE NEWKODCLS WITH ++mKodMaxCls mNEWNAMECS = NEWNAMECS REPLACE NEWKODCLSC WITH ++mKodMaxCS DBSKIP(1) DO WHILE .NOT. EOF() IF mKodValScen = KodValScen REPLACE NEWKODCLS WITH mKodMaxCls ELSE REPLACE NEWKODCLS WITH ++mKodMaxCls mKodValScen = KodValScen ENDIF IF mNEWNAMECS = NEWNAMECS REPLACE NEWKODCLSC WITH mKodMaxCS ELSE REPLACE NEWKODCLSC WITH ++mKodMaxCS mNEWNAMECS = NEWNAMECS ENDIF DBSKIP(1) ENDDO ** 3. Создание классификационных шкал значений точек всех шкал будущих сценариев SELECT ValFutScen DBGOTOP() aNewKodClSc := {} // Исключение повторов шкал mNEWKODCLSC = NEWKODCLSC mNEWNAMECS = ALLTRIM(NEWNAMECS) AADD (aNewKodClSc, mNEWNAMECS) SELECT Class_Sc APPEND BLANK REPLACE Kod_ClSc WITH mNEWKODCLSC REPLACE Name_ClSc WITH mNEWNAMECS SELECT ValFutScen DBSKIP(1) DO WHILE .NOT. EOF() * IF ASCAN(aNewKodClSc, mNEWKODCLSC) = 0 * AADD (aNewKodClSc, mNEWKODCLSC) IF mNEWKODCLSC <> NEWKODCLSC mNEWKODCLSC = NEWKODCLSC mNEWNAMECS = ALLTRIM(NEWNAMECS) SELECT Class_Sc APPEND BLANK REPLACE Kod_ClSc WITH mNEWKODCLSC REPLACE Name_ClSc WITH mNEWNAMECS SELECT ValFutScen ENDIF * ENDIF DBSKIP(1) ENDDO ** 4. Создание градаций (классов) классификационной шкалы финальных значений всех шкал будущих сценариев (Gr_ClSc, Classes) aKodCls := {} SELECT ValFutScen DBGOTOP() DO WHILE .NOT. EOF() mNEWKODCLS = NEWKODCLS mNEWNAMECLS = ALLTRIM(NEWNAMECLS) mNEWKODCLSC = NEWKODCLSC IF ASCAN(aKodCls, mNEWKODCLS) = 0 // Исключение повторов классов AADD (aKodCls, mNEWKODCLS) SELECT Gr_ClSc APPEND BLANK REPLACE KOD_CLSC WITH mNEWKODCLSC REPLACE KOD_GRCS WITH mNEWKODCLS REPLACE NAME_GRCS WITH mNEWNAMECLS SELECT Classes APPEND BLANK REPLACE KOD_CLSC WITH mNEWKODCLSC REPLACE KOD_CLS WITH mNEWKODCLS REPLACE NAME_CLS WITH mNEWNAMECLS REPLACE N_CHRCLSC WITH LEN(ALLTRIM(mNEWNAMECLS)) SELECT ValFutScen ENDIF DBSKIP(1) ENDDO ** 5. Добавление в обучающую выборку классов и (объединение) значений факторов значений точек будущих сценариев (это сделать в п.4/5) ** Вопрос: какие значения факторов обуславливают данное значение точки сценария? ** Ответ: все значерия факторов, обуславливающих все сценарии с таким значением данной точки. ENDIF *************************************************************************************************** ** Создание значений факторов, соответствующих значениям точек прошлых сценариев ****************** *************************************************************************************************** ** 1. Создание БД для сортировки сценариев по значениям точек (это сделать в самом начале, т.к. эту БД надо сразу и открывать) (СДЕЛАНО) ** 2. Заполнение БД для сортировки сценариев по значениям точек ** 3. Создание описательных шкал значений точек всех шкал прошлых сценариев ** 4. Создание градаций (значений факторов) описательной шкалы значений точек всех шкал прошлых сценариев ** 5. Добавление в обучающую выборку значений факторов и (объединение) значений прошлых сценариев (это сделать в п.4/5) *************************************************************************************************** * MsgBox(STR(mCreateClsPointFuture)) IF mCreateAttPointPast > 1 // <<<===#################################################################### * aStructure := { { "KodOpSc" , "N", 15, 0 }, ; // Код старой описательной шкалы, соответствующей текущей точке сценария * { "KodScen" , "N", 15, 0 }, ; // Код сценария * { "NameScen" , "C", 255, 0 }, ; // Наименование сценария * { "PointNumb" , "N", 15, 0 }, ; // Номер точки сценария, соответствующей значению фактора * { "KodValScen", "N", 15, 0 }, ; // Код значения сценария (в БД Attributes) в текущей точке * { "NameValSce", "C", mML, 0 }, ; // Наименование значения сценария (в БД Attributes) в текущей точке * { "NewKodAtr" , "N", 15, 0 }, ; // Новый код значения фактора, соответствующего значению сценария в текущей точке * { "NEWNAMEAtr", "C", 255, 0 }, ; // Новое наименование значение фактора, соответствующего значению сценария в текущей точке * { "NEWNAMEVSP", "C", 255, 0 }, ; // Новое наименование подфактора, соответствующего значению сценария в текущей точке * { "NewKodOpSc", "N", 15, 0 }, ; // Код новой описательной шкалы, соответствующей текущей точке сценария * { "NewNameOS" , "C", 255, 0 } } // Наименование новой описательной шкалы, соответствующей текущей точке сценария * DbCreate( "ValPastScen.dbf", aStructure ) * DbCreate( "ValPastSTmp.dbf", aStructure ) ** 2. Заполнение БД для сортировки сценариев по значениям точек сценариев ** Можно сделать цикл по точкам значений и учитывать не только финальные, а все значения <<<===################ SELECT Gr_OpSc DBGOBOTTOM() mKodMaxAtr = KOD_GROS DBGOTOP() DO WHILE .NOT. EOF() mKOD_OPSC = KOD_OPSC mKOD_GROS = KOD_GROS mNAME_GROS = ALLTRIM(NAME_GROS) mPos = AT("-PAST", mNAME_GROS) IF mPos > 0 * OPEN-PAST-1,1,1 mPos = RAT('-', mNAME_GROS) mNameScen = SUBSTR(mNAME_GROS, mPos+1, LEN(mNAME_GROS)-mPos) mNewNameOS = SUBSTR(mNAME_GROS, 1, mPos-1) mNPoints = NUMTOKEN(mNameScen, ',') // Фактическое кол-во точек в сценарии ******* Цикл по точкам сценария ************** * DCGROUP oGroup21 CAPTION L('Рассматривать отдельно точки прошлых сценариев? ' * DCRADIO mCreateAttPointPast VALUE 1 PROMPT L('Не рассматривать ' * DCRADIO mCreateAttPointPast VALUE 2 PROMPT L('Рассматривать, но только финальные точки' * DCRADIO mCreateAttPointPast VALUE 3 PROMPT L('Рассматривать все точки ' mPoint1 = IF(mCreateAttPointPast=3, 1, mNPoints) FOR mPoint=mPoint1 TO mNPoints mKodValScen = VAL(TOKEN(mNameScen, mPoint)) // Код значения сценария (в БД Classes) в текущей точке mRecno = RECNO() DBGOTO(mKodValScen) mNameValSce = ALLTRIM(NAME_GROS) // Наименование значения сценария (в БД Classes) в текущей точке DBGOTO(mRecno) SELECT ValPastSTmp APPEND BLANK REPLACE KodOpSc WITH mKOD_OPSC REPLACE KodScen WITH mKOD_GROS REPLACE NameScen WITH mNAME_GROS REPLACE PointNumb WITH mPoint REPLACE KodValScen WITH mKodValScen REPLACE NameValSce WITH mNameValSce REPLACE NEWNAMEATR WITH mNewNameOS+'-Point'+ALLTRIM(STR(mPoint))+'-'+ALLTRIM(mNameValSce) // Новое наименование значения фактора, соответствующего значению точки сценария REPLACE NEWNAMEVSP WITH mNAME_GROS+'-Point'+ALLTRIM(STR(mPoint))+'-'+ALLTRIM(mNameValSce) // Новое наименование значения подфактора, соответствующего значению точки сценария REPLACE NewNameOS WITH mNewNameOS+'-Point'+ALLTRIM(STR(mPoint)) // Наименование новой описательной шкалы, соответствующей значению точки сценария SELECT Gr_OpSc NEXT ENDIF DBSKIP(1) ENDDO ****** Физическая сортировка БД ValPastScen.dbf по полю: KodValScen SELECT Opis_Sc DBGOBOTTOM() mLen = LEN(ALLTRIM(STR(Kod_OpSc))) SELECT ValPastSTmp INDEX ON STRTRAN(STR(KodOpSc,mLen),' ','0')+ALLTRIM(NEWNAMEATR) TO ValPastSTmp DBGOTOP() DO WHILE .NOT. EOF() ar := {} FOR j=1 TO FCOUNT() AADD(ar, FIELDGET(j)) NEXT SELECT ValPastScen APPEND BLANK FOR j=1 TO LEN(ar) FIELDPUT(j, ar[j]) NEXT SELECT ValPastSTmp DBSKIP(1) ENDDO ****** Кодирование новых значений факторов NEWKODATR, соответствующих значениям точек сценариев ****** Кодирование новых описательных шкал, соответствующих значениям точек сценариев SELECT Opis_Sc DBGOBOTTOM() mKodMaxOS = Kod_OpSc SELECT ValPastScen DBGOTOP() mKodValScen = KodValScen REPLACE NEWKODATR WITH ++mKodMaxAtr mNEWNAMEOS = NEWNAMEOS REPLACE NEWKODOPSC WITH ++mKodMaxOS DBSKIP(1) DO WHILE .NOT. EOF() IF mKodValScen = KodValScen REPLACE NEWKODATR WITH mKodMaxAtr ELSE REPLACE NEWKODATR WITH ++mKodMaxAtr mKodValScen = KodValScen ENDIF IF mNEWNAMEOS = NEWNAMEOS REPLACE NEWKODOPSC WITH mKodMaxOS ELSE REPLACE NEWKODOPSC WITH ++mKodMaxOS mNEWNAMEOS = NEWNAMEOS ENDIF DBSKIP(1) ENDDO ** 3. Создание описательных шкал значений точек всех шкал будущих сценариев SELECT ValPastScen DBGOTOP() aNewKodOpSc := {} // Исключение повторов шкал mNEWKODOPSC = NEWKODOPSC mNEWNAMEOS = ALLTRIM(NEWNAMEOS) AADD (aNewKodOpSc, mNEWNAMEOS) SELECT Opis_Sc APPEND BLANK REPLACE Kod_OpSc WITH mNEWKODOPSC REPLACE Name_OpSc WITH mNEWNAMEOS SELECT ValPastScen DBSKIP(1) DO WHILE .NOT. EOF() * IF ASCAN(aNewKodOpSc, mNEWKODOPSC) = 0 * AADD (aNewKodOpSc, mNEWKODOPSC) IF mNEWKODOPSC <> NEWKODOPSC mNEWKODOPSC = NEWKODOPSC mNEWNAMEOS = ALLTRIM(NEWNAMEOS) SELECT Opis_Sc APPEND BLANK REPLACE Kod_OpSc WITH mNEWKODOPSC REPLACE Name_OpSc WITH mNEWNAMEOS SELECT ValPastScen ENDIF * ENDIF DBSKIP(1) ENDDO ** 4. Создание градаций (классов) описательной шкалы значений точек всех шкал будущих сценариев (Gr_OpSc, Attributes) aKodAtr := {} SELECT ValPastScen DBGOTOP() DO WHILE .NOT. EOF() mNEWKODATR = NEWKODATR mNEWNAMEATR = ALLTRIM(NEWNAMEATR) mNEWKODOPSC = NEWKODOPSC IF ASCAN(aKodAtr, mNEWKODATR) = 0 // Исключение повторов классов AADD (aKodAtr, mNEWKODATR) SELECT Gr_OpSc APPEND BLANK REPLACE KOD_OPSC WITH mNEWKODOPSC REPLACE KOD_GROS WITH mNEWKODATR REPLACE NAME_GROS WITH mNEWNAMEATR SELECT Attributes APPEND BLANK REPLACE KOD_OPSC WITH mNEWKODOPSC REPLACE KOD_ATR WITH mNEWKODATR REPLACE NAME_ATR WITH mNEWNAMEATR REPLACE N_CHROPSC WITH LEN(ALLTRIM(mNEWNAMEATR)) SELECT ValPastScen ENDIF DBSKIP(1) ENDDO ** 5. Добавление в обучающую выборку классов и (объединение) значений факторов значений точек прошлых сценариев (это сделать в п.4/5) ** Вопрос: какие значения факторов обуславливают данное значение точки сценария? ** Ответ: все значерия факторов, обуславливающих все сценарии с таким значением данной точки. ENDIF aSay[3]:SetCaption(aSay[3]:caption+L(' - Готово ')) *************************************************************************************************** **** Конец доформирования классиф.и описат.шкал и градаций на основе БД "EventsKO" (сценарии) **** *************************************************************************************************** *************************************************************************************************** **** 4/5: Генерация обучающей выборки на основе базы событий "EventsKO" *************************** *************************************************************************************************** aSay[4]:SetCaption(L('4/5: Генерация обучающей выборки на основе базы событий "EventsKO"')) SELECT EventsKO DBGOTOP() n = 0 DO WHILE .NOT. EOF() // Формирование записи БД заголовков объектов обучающей выборки M_Recno = RECNO() M_KodObj = M_Recno M_NameObj = Name_obj SELECT Obi_Zag APPEND BLANK REPLACE Kod_obj WITH M_KodObj REPLACE Name_obj WITH M_NameObj *** Формирование массива кодов классов из БД EventsKO SELECT EventsKO A_KodCls := {} // Массив базовых кодов классов текущего объекта обучающей выборки FOR ff = M_ClSc1 TO M_ClSc2 DBGOTO(M_Recno) Fv = FIELDGET(ff) AADD(A_KodCls, Fv) FOR N_Gorizont = mGorizMin TO mGorizMax mScen = A_FNRus[ff] + '-FUTURE'+ALLTRIM(STR(N_Gorizont)) + '-' SELECT EventsKO DBGOTO(M_Recno) DBSKIP(1) // Код текущей записи тоже включать в сценарий? mGorizont = 1 DO WHILE .NOT. EOF() .AND. mGorizont <= N_Gorizont // Градации класс.шкалы ************************************ mFV = FIELDGET(ff) IF mFV > 0 mSimb = STRTRAN(STR(mFV,mMaxLenKCls),' ','0') IF LEN(mSimb) > 0 mt = mScen + mSimb + IF(mGorizont 0 // Если такой сценарий есть в справочнике - занести его код в объект обучающей выборки * IF ASCAN(A_KodCls, M_KodCls) = 0 // Каждый код вносить только 1 раз AADD( A_KodCls, M_KodCls) * ENDIF ENDIF ENDIF NEXT NEXT ******* Формирование массива кодов признаков из базы событий EventsKO SELECT EventsKO A_KodAtr = {} // Массив кодов признаков текущего объекта обучающей выборки FOR ff=M_OpSc1 TO M_OpSc2 // Начало цикла по полям БД DBGOTO(M_Recno) IF aErrorNum[ff] // Если есть вариабельность DBGOTO(M_Recno) Fv = FIELDGET(ff) AADD(A_KodAtr, Fv) FOR N_Glubina = mGlubMin TO mGlubMax mScen = A_FNRus[ff] + '-PAST'+ALLTRIM(STR(N_Glubina)) + '-' SELECT EventsKO mGlubina = 1 DBGOTO(M_Recno-N_Glubina+1) * DBSKIP(1) // Код текущей записи тоже включать в сценарий? DO WHILE .NOT. EOF() .AND. mGlubina <= N_Glubina // Градации класс.шкалы ************************************ mFV = FIELDGET(ff) IF mFV > 0 mSimb = STRTRAN(STR(mFV,mMaxLenKAtr),' ','0') IF LEN(mSimb) > 0 mt = mScen + mSimb + IF(mGlubina < N_Glubina,',','') ++mGlubina mScen = ALLTRIM(SUBSTR(mt,1,255)) ENDIF ENDIF DBSKIP(1) ENDDO IF mGlubina = N_Glubina + 1 M_KodAtr = ASCAN(A_NameAtr, mScen) IF M_KodCls > 0 // Если такой сценарий есть в справочнике - занести его код в объект обучающей выборки * IF ASCAN(A_KodAtr, M_KodAtr) = 0 AADD( A_KodAtr, M_KodAtr) * ENDIF ENDIF ENDIF NEXT ENDIF NEXT * DC_DebugQout( A_KodCls, A_KodAtr ) ****** Запись массива кодов классов в БД Obi_Kcl * ASORT(A_KodCls) SELECT Obi_Kcl APPEND BLANK FIELDPUT(1,M_KodObj) IF LEN(A_KodCls) > 0 k=2 FOR jj=1 TO LEN(A_KodCls) IF k <= 5 FIELDPUT(k++,A_KodCls[jj]) ELSE k=2 APPEND BLANK FIELDPUT(1,M_KodObj) FIELDPUT(k++,A_KodCls[jj]) ENDIF NEXT ENDIF ****** Запись массива кодов признаков в БД Obi_Kpr * ASORT(A_KodAtr) SELECT Obi_Kpr APPEND BLANK FIELDPUT(1,M_KodObj) IF LEN(A_KodAtr) > 0 k=2 FOR jj=1 TO LEN(A_KodAtr) IF k <= 8 FIELDPUT(k++,A_KodAtr[jj]) ELSE k=2 APPEND BLANK FIELDPUT(1,M_KodObj) FIELDPUT(k++,A_KodAtr[jj]) ENDIF NEXT ENDIF ****** Формирование массивов кодов классов и признаков для БД EventsKOs. ДЛЯ ОТЛАДКИ РЕЖИМА: "СЦЕНАРНЫЙ МЕТОД АСК-АНАЛИЗА" ****** Копирование кодов базовых классов и базовых признаков EventsKO => EventsKOs SELECT EventsKO DBGOTOP() DO WHILE .NOT. EOF() IF mRecSizeEvKOs * (n+1) > 2 * 10^9 // Не создавать файл больше 2 Гб EXIT ELSE aR := {} FOR j=1 TO FCOUNT()-2 AADD(aR, FIELDGET(j)) NEXT n++ SELECT EventsKOs APPEND BLANK // <<<===########################### FOR j=1 TO LEN(aR) FIELDPUT(j, aR[j]) NEXT ENDIF SELECT EventsKO DBSKIP(1) ENDDO SELECT EventsKOs IF M_Recno <= RECCOUNT() DBGOTO(M_Recno) ****** Запись массива кодов классов в БД EventsKOs ********************** mKodCls = '' nKodCls = LEN(A_KodCls) FOR j=1 TO nKodCls IF A_KodCls[j] > 0 mKodCls = mKodCls + '[' + ALLTRIM(STR(A_KodCls[j])) + ']-' + A_NameCls[A_KodCls[j]] + IF(j255,'...','') ****** Запись массива кодов признаков в БД EventsKOs ******************** mKodAtr = '' nKodAtr = LEN(A_KodAtr) FOR j=1 TO nKodAtr IF A_KodAtr[j] > 0 mKodAtr = mKodAtr + '[' + ALLTRIM(STR(A_KodAtr[j])) + ']-' + A_NameAtr[A_KodAtr[j]] + IF(j255,'...','') ENDIF lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) SELECT EventsKO DBGOTO(M_Recno) DBSKIP(1) ENDDO *********************************************************************************** ***** Коды сценариев и значений точек сценариев в БД EventsKO.dbf не добавляются!!! *********************************************************************************** *************************************************************************************************** ** Создание классов, соответствующих значениям точек будущих сценариев **************************** *************************************************************************************************** ** 1. Создание БД для сортировки сценариев по значениям точек (это сделать в самом начале, т.к. эту БД надо сразу и открывать) (СДЕЛАНО) ** 2. Заполнение БД для сортировки сценариев по значениям точек ** 3. Создание классификационных шкал значений точек всех шкал будущих сценариев ** 4. Создание градаций (классов) классификационной шкалы значений точек всех шкал будущих сценариев ** 5. Добавление в обучающую выборку классов и (объединение) значений факторов значений будущих сценариев (это сделать в п.4/5) <<<===################ *************************************************************************************************** ** 5. Добавление в обучающую выборку классов и (объединение) значений факторов значений точек будущих сценариев (это сделать в п.4/5) ** Вопрос: какие значения факторов обуславливают данное значение точки сценария? ** Ответ: все значерия факторов, обуславливающих все сценарии с таким значением данной точки. IF mCreateClsPointFuture > 1 *** Формирование SCV-файла с кодами сценариев, соответствующих точке будущего сценария CrLf = CHR(13)+CHR(10) // Конец строки (записи) set printer to ('ValFutScen.txt') set device to printer set printer on set console off SELECT ValFutScen DBGOTOP() mNEWKODCLS = NEWKODCLS mString = ALLTRIM(STR(mNEWKODCLS))+',' DO WHILE .NOT. EOF() IF mNEWKODCLS = NEWKODCLS // Накопление кодов сценариев, соответствующих значению точки mString = mString + ALLTRIM(STR(KODSCEN))+',' ELSE ??SUBSTR(mString, 1, LEN(mString)-1)+CrLf mNEWKODCLS = NEWKODCLS mString = ALLTRIM(STR(mNEWKODCLS))+',' mString = mString + ALLTRIM(STR(KODSCEN))+',' ENDIF DBSKIP(1) ENDDO ??SUBSTR(mString, 1, LEN(mString)-1) *** Перенаправление вывода на консоль Set device to screen Set printer off Set printer to Set console on ************************************************************************************** ** Добавление в обучающую выборку наблюдений с кодами классов, соответствующих значениям точек будущего сценария и признаками, соответсвующими сценариям **** Если в наблюдении встречается код сценария, то добавлять в коды классов наблюдения код значения точки * Файл: ValFutScen.txt * * 34,7,8,9,10 * 35,11,12,13,14,15,16 * 36,17,18,19 * 37,7,8,11,12 * 38,9,10,13,14,15,17 * 39,16,18,19 * 40,7,9,11,13 * 41,8,10,12,14,17,18 * 42,15,16,19 * 43,20,21,22,23 * 44,24,25,26,27,28,29,30 * 45,31,32,33 * 46,20,21,24,25 * 47,22,23,26,27,28,31 * 48,29,30,32,33 * 49,20,22,24,26 * 50,21,23,25,27,29,31,32 * 51,28,30,33 ******* Цикл по строкам текстового файла ****************************************************** aKodCls := {} nHandle := DC_txtOpen( 'ValFutScen.txt' ) DO WHILE !DC_TxtEOF( nHandle ) // Начало цикла по строкам mLine = ALLTRIM(DC_TxtLine( nHandle )) // Выделить строку из текстового файла mKodCls = VAL(TOKEN(mLine, ",", 1)) AADD(aKodCls,mKodCls) mKodScen = 'aKodScen'+ALLTRIM(STR(mKodCls)) &mKodScen := {} FOR w=2 TO NUMTOKEN(mLine,",") // Разделитель между показателями - запятая AADD(&mKodScen, VAL(TOKEN(mLine, ",", w))) NEXT DC_TxtSkip( nHandle, 1 ) ENDDO DC_TxtClose( nHandle ) SELECT ObI_Kcl DBGOTOP() DO WHILE .NOT. EOF() mRecno = RECNO() mKodObj = KOD_OBJ A_KodCls := {} mFlag = .F. FOR j=1 TO 5 mVal = FIELDGET(1+j) IF VALTYPE(mVal) = 'N' IF mVal > 0 FOR i=1 TO LEN(aKodCls) mKodScen = 'aKodScen'+ALLTRIM(STR(aKodCls[i])) IF ASCAN(&mKodScen, mVal) > 0 AADD(A_KodCls, aKodCls[i]) mFlag = .T. ENDIF NEXT ENDIF ENDIF NEXT IF mFlag ****** Запись массива кодов классов в БД Obi_Kcl M_KodObj = mKodObj APPEND BLANK FIELDPUT(1,M_KodObj) IF LEN(A_KodCls) > 0 k=2 FOR jj=1 TO LEN(A_KodCls) IF k <= 5 FIELDPUT(k++,A_KodCls[jj]) ELSE k=2 APPEND BLANK FIELDPUT(1,M_KodObj) FIELDPUT(k++,A_KodCls[jj]) ENDIF NEXT ENDIF A_KodCls := {} ENDIF DBGOTO(mRecno) DBSKIP(1) ENDDO ***** Физическая сортировка БД ObI_Kcl.dbf обучающей выборки SELECT Obi_Zag DBGOBOTTOM() mLen = LEN(ALLTRIM(STR(Kod_obj))) SELECT Obi_Kcl INDEX ON STRTRAN(STR(Kod_obj,mLen),' ','0') TO Obi_KclTmp DBGOTOP() DO WHILE .NOT. EOF() ar := {} FOR j=1 TO FCOUNT() AADD(ar, FIELDGET(j)) NEXT SELECT Obi_KclTmp APPEND BLANK FOR j=1 TO LEN(ar) FIELDPUT(j, ar[j]) NEXT SELECT Obi_Kcl DBSKIP(1) ENDDO CLOSE Obi_Kcl CLOSE Obi_KclTmp COPY FILE ('Obi_KclTmp.dbf') TO ('Obi_Kcl.dbf') ENDIF *************************************************************************************************** ** Создание классов, соответствующих значениям точек прошлых сценариев **************************** *************************************************************************************************** ** 1. Создание БД для сортировки сценариев по значениям точек (это сделать в самом начале, т.к. эту БД надо сразу и открывать) (СДЕЛАНО) ** 2. Заполнение БД для сортировки сценариев по значениям точек ** 3. Создание классификационных шкал значений точек всех шкал будущих сценариев ** 4. Создание градаций (классов) классификационной шкалы значений точек всех шкал будущих сценариев ** 5. Добавление в обучающую выборку классов и (объединение) значений факторов значений будущих сценариев (это сделать в п.4/5) <<<===################ *************************************************************************************************** ** 5. Добавление в обучающую выборку классов и (объединение) значений факторов значений точек будущих сценариев (это сделать в п.4/5) ** Вопрос: какие значения факторов обуславливают данное значение точки сценария? ** Ответ: все значерия факторов, обуславливающих все сценарии с таким значением данной точки. IF mCreateAttPointPast > 1 *** Формирование SCV-файла с кодами сценариев, соответствующих точке будущего сценария CrLf = CHR(13)+CHR(10) // Конец строки (записи) set printer to ('ValPastScen.txt') set device to printer set printer on set console off SELECT ValPastScen DBGOTOP() mNEWKODATR = NEWKODATR mString = ALLTRIM(STR(mNEWKODATR))+',' DO WHILE .NOT. EOF() IF mNEWKODATR = NEWKODATR // Накопление кодов сценариев, соответствующих значению точки mString = mString + ALLTRIM(STR(KODSCEN))+',' ELSE ??SUBSTR(mString, 1, LEN(mString)-1)+CrLf mNEWKODATR = NEWKODATR mString = ALLTRIM(STR(mNEWKODATR))+',' mString = mString + ALLTRIM(STR(KODSCEN))+',' ENDIF DBSKIP(1) ENDDO ??SUBSTR(mString, 1, LEN(mString)-1) *** Перенаправление вывода на консоль Set device to screen Set printer off Set printer to Set console on ************************************************************************************** ** Добавление в обучающую выборку наблюдений с кодами классов, соответствующих значениям точек прошлого сценария и признаками, соответствующими сценариям **** Если в наблюдении встречается код сценария, то добавлять в коды классов наблюдения код значения точки * Файл: ValPastScen.txt (фрагмент) * * 146,25,26,27,28 * 147,29,30,31,32,33,34,35 * 148,36,37,38 * 149,25,26,29,30 * 150,27,28,31,32,33,36 * 151,34,35,37,38 * 152,25,27,29,31 * 153,26,28,30,32,34,36,37 * 154,33,35,38 * 155,39,40,41,42 * 156,43,44,45,46,47,48,49 * 157,50,51,52 * 158,39,40,43,44 * 159,41,42,45,46,47,50 * 160,48,49,51,52 * 161,39,41,43,45 * 162,40,42,44,46,48,50,51 * 163,47,49,52 * 164,53,54,55,56,57,58,59,60 * 165,61,62,63,64,65,66,67 * ........................... ******* Цикл по строкам текстового файла ****************************************************** aKodCls := {} nHandle := DC_txtOpen( 'ValPastScen.txt' ) DO WHILE !DC_TxtEOF( nHandle ) // Начало цикла по строкам mLine = ALLTRIM(DC_TxtLine( nHandle )) // Выделить строку из текстового файла mKodAtr = VAL(TOKEN(mLine, ",", 1)) AADD(aKodAtr,mKodAtr) mKodScen = 'aKodScen'+ALLTRIM(STR(mKodAtr)) &mKodScen := {} FOR w=2 TO NUMTOKEN(mLine,",") // Разделитель между показателями - запятая AADD(&mKodScen, VAL(TOKEN(mLine, ",", w))) NEXT DC_TxtSkip( nHandle, 1 ) ENDDO DC_TxtClose( nHandle ) SELECT ObI_Kpr DBGOTOP() DO WHILE .NOT. EOF() mRecno = RECNO() mKodObj = KOD_OBJ A_KodAtr := {} mFlag = .F. FOR j=1 TO 8 mVal = FIELDGET(1+j) IF VALTYPE(mVal) = 'N' IF mVal > 0 FOR i=1 TO LEN(aKodAtr) mKodScen = 'aKodScen'+ALLTRIM(STR(aKodAtr[i])) IF ASCAN(&mKodScen, mVal) > 0 AADD(A_KodAtr, aKodAtr[i]) mFlag = .T. ENDIF NEXT ENDIF ENDIF NEXT IF mFlag ****** Запись массива кодов классов в БД Obi_Kpr M_KodObj = mKodObj APPEND BLANK FIELDPUT(1,M_KodObj) IF LEN(A_KodAtr) > 0 k=2 FOR jj=1 TO LEN(A_KodAtr) IF k <= 8 FIELDPUT(k++,A_KodAtr[jj]) ELSE k=2 APPEND BLANK FIELDPUT(1,M_KodAtr) FIELDPUT(k++,A_KodAtr[jj]) ENDIF NEXT ENDIF A_KodAtr := {} ENDIF DBGOTO(mRecno) DBSKIP(1) ENDDO ***** Физическая сортировка БД ObI_Kpr.dbf обучающей выборки SELECT Obi_Zag DBGOBOTTOM() mLen = LEN(ALLTRIM(STR(Kod_obj))) SELECT Obi_Kpr INDEX ON STRTRAN(STR(Kod_obj,mLen),' ','0') TO Obi_KprTmp DBGOTOP() DO WHILE .NOT. EOF() ar := {} FOR j=1 TO FCOUNT() AADD(ar, FIELDGET(j)) NEXT SELECT Obi_KprTmp APPEND BLANK FOR j=1 TO LEN(ar) FIELDPUT(j, ar[j]) NEXT SELECT Obi_Kpr DBSKIP(1) ENDDO CLOSE Obi_Kpr CLOSE Obi_KprTmp COPY FILE ('Obi_KprTmp.dbf') TO ('Obi_Kpr.dbf') ENDIF aSay[4]:SetCaption(aSay[4]:caption+L(' - Готово ')) // Запись и загрузка массивов: aExcelClSc, aExcelOpSc, aMinGranInt и aMaxGranInt aGradNSc := {} // Массив числа градаций числовых классификационных и описательных шкал AADD(aGradNSc, K_GradNClSc) AADD(aGradNSc, K_GradNOpSc) DC_ASave(aExcelClSc, "_aXlsClSc.arx") // Запись массива aExcelClSc DC_ASave(aExcelOpSc, "_aXlsOpSc.arx") // Запись массива aExcelOpSc * aExcelClSc = DC_ARestore("_aXlsClSc.arx") // Загрузка массива aExcelClSc * aExcelOpSc = DC_ARestore("_aXlsOpSc.arx") // Загрузка массива aExcelOpSc DC_ASave(aGradNSc, "_GradNSc.arx") // Запись массива aGradNSc * aGradNSc = DC_ARestore("_GradNSc.arx") // Загрузка массива aGradNSc DC_ASave(aMinGranInt, "_MinGranInt.arx") // Запись массива aMinGranInt DC_ASave(aMaxGranInt, "_MaxGranInt.arx") // Запись массива aMaxGranInt * aMinGranInt = DC_ARestore("_MinGranInt.arx") // Загрузка массива aMinGranInt * aMaxGranInt = DC_ARestore("_MaxGranInt.arx") // Загрузка массива aMaxGranInt StrFile(STR(mMaxInt), '_mMaxInt.txt') // Запись текстового файла с параметром mMaxInt StrFile(STR(mMaxDec), '_mMaxDec.txt') // Запись текстового файла с параметром mMaxDec * mMaxInt = VAL(FileStr('_mMaxInt.txt')) // Загрузка параметра mMaxInt из текстового файла * mMaxDec = VAL(FileStr('_mMaxDec.txt')) // Загрузка параметра mMaxDec из текстового файла StrFile(STR(mMaxLenCls), '_MaxLCls.txt') // Запись текстового файла с параметром mMaxLenCls StrFile(STR(mMaxLenAtr), '_MaxLAtr.txt') // Запись текстового файла с параметром mMaxLenAtr * mMaxLenCls = VAL(FileStr('_MaxLCls.txt')) // Загрузка параметра mMaxLenCls из текстового файла * mMaxLenAtr = VAL(FileStr('_MaxLAtr.txt')) // Загрузка параметра mMaxLenAtr из текстового файла DC_ASave(A_NameCls, "_aNameCls.arx") // Запись массива A_NameCls DC_ASave(A_NameAtr, "_aNameAtr.arx") // Запись массива A_NameAtr * A_NameCls = DC_ARestore("_aNameCls.arx") // Загрузка массива A_NameCls * A_NameAtr = DC_ARestore("_aNameAtr.arx") // Загрузка массива A_NameAtr DC_ASave(aKGradCClSc, "_KGrCClSc.arx") // Запись текстового файла с параметром aKGradCClSc[mCol] DC_ASave(aKGradCOpSc, "_KGrCOpSc.arx") // Запись текстового файла с параметром aKGradCOpSc[mCol] * aKGradCClSc = DC_ARestore("_KGrCClSc.arx") // Загрузка параметра aKGradCClSc[mCol] из текстового файла * aKGradCOpSc = DC_ARestore("_KGrCOpSc.arx") // Загрузка параметра aKGradCOpSc[mCol] из текстового файла // Запись БД наименований шкал и параметров их градаций // с последующим просмотром ее после определения кол-ва градаций класс.и описательных шкал *************************************************************************************************** **** Конец генерации обучающей выборки на основе базы событий "EventsKO" ************************** *************************************************************************************************** ENDCASE *######################################################################################################################################### *######################################################################################################################################### ENDIF // Конец режима 1 (создание шкал и ввод обучающей выборки) ******************************************************************************* ** ГЕНЕРАЦИЯ РАСПОЗНАВАЕМОЙ ВЫБОРКИ ******************************************* ################################################### ******************************************************************************* IF Regim = 2 DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы aErrorNum = DC_ARestore(Disk_dir +"\_ErrorNum.arx") * DC_ASave(aErrorNum , Disk_dir +"\_ErrorNum.arx") DIRCHANGE(M_PathAppl) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Class_Sc EXCLUSIVE NEW USE Opis_Sc EXCLUSIVE NEW USE Inp_data EXCLUSIVE NEW;N_ColID = FCOUNT() USE Inp_rasp EXCLUSIVE NEW;N_ColIR = FCOUNT() IF N_ColID <> N_ColIR * MsgBox(STR(N_ColID)+STR(N_ColIR)) aMess := {} AADD(aMess, L('Файл распознаваемой выборки: "Inp_rasp" должен иметь')) AADD(aMess, L('такую же структуру, как файл исходных данных: "Inp_data" !!!')) AADD(aMess, L('Фактически же в "Inp_rasp" # столбцов, а в "Inp_data" $ !!!')) aMess[3] = STRTRAN(aMess[3],"#",ALLTRIM(STR(N_ColIR,19))) aMess[3] = STRTRAN(aMess[3],"$",ALLTRIM(STR(N_ColID,19))) LB_Warning(aMess) Help2322xls() Running(.F.) RETURN NIL ENDIF ********* Загрузить файл Inp_name.txt и сформировать массив: A_FNRus M_InpName = ALLTRIM(FILESTR('Inp_name.txt')) // Загрузка Inp_name.txt CrLf = CHR(13)+CHR(10) // Конец строки (абзаца) (CrLf) M_InpName = " " + CrLf + STRTRAN(M_InpName,CHR(26),"") + CrLf *LB_Warning(M_InpName) A_FNRus := {} aInp_name := {} FOR ff=1 TO NUMTOKEN(M_InpName,CrLf) AADD(A_FNRus , SUBSTR(UPPER(ALLTRIM(TOKEN(M_InpName,CrLf,ff))),1,255)) // Ограничение длины наименования шкалы 255 символов AADD(aInp_name, SUBSTR(UPPER(ALLTRIM(TOKEN(M_InpName,CrLf,ff))),1,255)) // Ограничение длины наименования шкалы 255 символов NEXT SELECT Inp_rasp IF LEN(A_FNRus) <> FCOUNT() aMess := {} AADD(aMess, L('Строк в "Inp_name.txt" должно быть столько же, сколько ШКАЛ в "Inp_rasp.dbf!"')) AADD(aMess, L('Фактически же в "Inp_name.txt" (#) строк, а в "Inp_rasp.dbf" ($) шкал"')) AADD(aMess, L('Возможно, надо убрать переносы строк в наименованиях колонок в Excel-файле')) aMess[2] = STRTRAN(Mess[2],"#", ALLTRIM(STR(LEN(A_FNRus),9))) aMess[2] = STRTRAN(Mess[2],"$", ALLTRIM(STR(FCOUNT()-1,9))) LB_Warning(aMess) Running(.F.) RETURN NIL ENDIF * ********* Вместо этого ############### * ********* Сформировать массив: A_FNRus * A_FNRus := {} * AADD(A_FNRus, 'Object') * SELECT Class_Sc * DO WHILE .NOT. EOF() * AADD(A_FNRus, ALLTRIM(Name_ClSc)) * DBSKIP(1) * ENDDO * SELECT Opis_Sc * DO WHILE .NOT. EOF() * AADD(A_FNRus, ALLTRIM(Name_OpSc)) * DBSKIP(1) * ENDDO * ************************************** // Загрузить параметры текущей модели IF FILE(Disk_dir+"\_2_3_2_2.arx") aSoftInt = DC_ARestore(M_PathAppl+"\_2_3_2_2.arx") ELSE LB_Warning(L('В текущем приложении не создано моделей в 3-й подсистеме')) Running(.F.) RETURN NIL ENDIF N_GrCls = INT(K_N_GrClSc/K_N_ClSc) // Кол-во градаций в класс.шкале N_GrAtr = INT(K_N_GrOpSc/K_N_OpSc) // Кол-во градаций в опис. шкале ******************************************************************************************** ******************************************************************************************** // Начало отсчета времени для прогнозирования длительности исполнения SELECT Inp_rasp SET FILTER TO SET ORDER TO DO CASE CASE M_Interval = 1 .AND. .NOT. M_Scenario // *************************************************************************************************# Wsego = RECCOUNT() +; // 1/2: Генерация распознаваемой выборки и базы событий "EventsKR" на основе БД "Inp_rasp" 3 // 2/2: Переиндексация всех баз данных нового приложения * aSay[1]:SetCaption(L('1/2: Генерация распознаваемой выборки и базы событий "EventsKR" на основе БД "Inp_rasp"') * aSay[2]:SetCaption(L('2/2: Переиндексация всех баз данных нового приложения') ******************************************************************************************** // Отображение стадии исполнения. Будет написано прямо в окне Progress-bar @ 0,0 DCGROUP oGroup1 CAPTION L('Стадии исполнения процесса') FONT "6.Helv" SIZE 105, 3.5 PARENT oTabPage1 @ 5,0 DCGROUP oGroup2 CAPTION L('Прогноз времени исполнения') FONT "6.Helv" SIZE 105, 5.0 PARENT oTabPage2 s = 1 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 1] FONT "10.Helv" // 1 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 2] FONT "10.Helv" // 2 s++ @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay97 FONT "10.HelvBold" s++ @0.2+s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay98 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @1.5+s ,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay99 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE CASE M_Interval = 1 .AND. M_Scenario // ################################################################################################## Wsego = RECCOUNT() +; // 1/3: Генерация базы событий "EventsKR" на основе внешней БД "Inp_rasp" RECCOUNT() +; // 2/3: Генерация распознаваемой выборки на основе базы событий "EventsKR" 3 // 3/3: Переиндексация распознаваемой выборки' * aSay[1]:SetCaption(L('1/3: Генерация базы событий "EventsKR" на основе внешней БД "Inp_rasp"') // Как в адапт.инт.без сцен. * aSay[2]:SetCaption(L('2/3: Генерация распознаваемой выборки на основе базы событий "EventsKR"') // Как в равн.интер.со сценар. * aSay[3]:SetCaption(L('3/3: Переиндексация распознаваемой выборки') ******************************************************************************************** // Отображение стадии исполнения. Будет написано прямо в окне Progress-bar @ 0,0 DCGROUP oGroup1 CAPTION L('Стадии исполнения процесса') FONT "6.Helv" SIZE 105, 4.5 PARENT oTabPage1 @ 6,0 DCGROUP oGroup2 CAPTION L('Прогноз времени исполнения') FONT "6.Helv" SIZE 105, 5.0 PARENT oTabPage2 s = 1 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 1] FONT "10.Helv" // 1 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 2] FONT "10.Helv" // 2 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 3] FONT "10.Helv" // 3 s++ @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay97 FONT "10.HelvBold" s++ @0.2+s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay98 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @1.5+s ,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay99 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE CASE M_Interval = 2 .AND. .NOT. M_Scenario // ************************************************************************************************** Wsego = (M_ClSc2-M_ClSc1+1)*RECCOUNT() +; // 1/2: Генерация распознаваемой выборки и базы соб."EventsKR" на основе базы "Inp_rasp" (M_OpSc2-M_OpSc1+1)*RECCOUNT() +; 3 // 2/2: Переиндексация распознаваемой выборки * aSay[1]:SetCaption(L('1/2: Генерация распознаваемой выборки и базы соб."EventsKR" на основе базы "Inp_rasp"') * aSay[2]:SetCaption(L('2/2: Переиндексация распознаваемой выборки') ******************************************************************************************** // Отображение стадии исполнения. Будет написано прямо в окне Progress-bar @ 0,0 DCGROUP oGroup1 CAPTION L('Стадии исполнения процесса') FONT "6.Helv" SIZE 105, 3.5 PARENT oTabPage1 @ 5,0 DCGROUP oGroup2 CAPTION L('Прогноз времени исполнения') FONT "6.Helv" SIZE 105, 5.0 PARENT oTabPage2 s = 1 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 1] FONT "10.Helv" // 1 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 2] FONT "10.Helv" // 2 s++ @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay97 FONT "10.HelvBold" s++ @0.2+s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay98 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @1.5+s ,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay99 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE CASE M_Interval = 2 .AND. M_Scenario // ************************************************************************************************** Wsego = (M_ClSc2-M_ClSc1+1)*RECCOUNT() +; // 1/3: Генерация базы событий "EventsKR" на основе внешней БД "Inp_rasp" (M_OpSc2-M_OpSc1+1)*RECCOUNT() +; RECCOUNT() +; // 2/3: Генерация распознаваемой выборки на основе базы событий "EventsKR" 3 // 3/3: Переиндексация распознаваемой выборки * aSay[1]:SetCaption(L('1/3: Генерация базы событий "EventsKR" на основе внешней БД "Inp_rasp"') // Как в адапт.инт.без сцен. * aSay[2]:SetCaption(L('2/3: Генерация распознаваемой выборки на основе базы событий "EventsKR"') // Как в равн.интер.со сценар. * aSay[3]:SetCaption(L('3/3: Переиндексация распознаваемой выборки') ******************************************************************************************** // Отображение стадии исполнения. Будет написано прямо в окне Progress-bar @ 0,0 DCGROUP oGroup1 CAPTION L('Стадии исполнения процесса') FONT "6.Helv" SIZE 105, 4.5 PARENT oTabPage1 @ 6,0 DCGROUP oGroup2 CAPTION L('Прогноз времени исполнения') FONT "6.Helv" SIZE 105, 5.0 PARENT oTabPage2 s = 1 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 1] FONT "10.Helv" // 1 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 2] FONT "10.Helv" // 2 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 3] FONT "10.Helv" // 3 s++ @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay97 FONT "10.HelvBold" s++ @0.2+s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay98 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @1.5+s ,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay99 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE ENDCASE @s , 1 DCPROGRESS oProgress SIZE 95,1.5 PERCENT ; EVERY 1 ; // Кол-во обновлений изображения (в функции самой регулируеся обновление изображений через 0,1 секунды) MAXCOUNT Wsego ; COLOR GRA_CLR_CYAN // Цвет полосы @s++,97 DCPUSHBUTTON CAPTION L('&Cancel') ; ACTION {||lOk:=.T.} OBJECT oButton ; SIZE 7,1.5 DCREAD GUI ; TITLE L('2.3.2.2. Процесс импорта данных из внешней БД "Inp_rasp" в систему "ЭЙДОС-X++"'); PARENT @oDialog ; FIT ; EXIT ; MODAL oDialog:show() ******************************************************************************************** Time_progress = 0 // Прошло секунд с начала процесса // Процесс может идти больше суток, поэтому для определения // во всех случаях вычисляется время, прошедшее с начала года T_Mess1 = L("Начало:")+" "+TIME() // Начало Sec_1 = (DOY(DATE())-1)*86400+SECONDS() PUBLIC T1 := (DOY(DATE())-1)*86400+SECONDS() // Время предыдущей индикации процесса исполнения PUBLIC T2 := (DOY(DATE())-1)*86400+SECONDS()+1 // Текущее время (1-й раз оно заметно больше T1 чтобы было отображение) PUBLIC T1tp := T1 PUBLIC T2tp := T2 ******************************************************************************************** *######################################################################################################################################### *######################################################################################################################################### DO CASE CASE M_Interval = 1 .AND. .NOT. M_Scenario // ################################################################################################## * aSay[1]:SetCaption(L('1/2: Генерация распознаваемой выборки и базы событий "EventsKR" на основе БД "Inp_rasp"') * aSay[2]:SetCaption(L('2/2: Переиндексация всех баз данных нового приложения') // Записать массивы Inp_sh, Classes и Attributes * DC_ASave(aMinSH, M_NewAppl+"\aMinSH.arx") * DC_ASave(aMaxSH, M_NewAppl+"\aMaxSH.arx") * DC_ASave(aDelta, M_NewAppl+"\aDelta.arx") * DC_ASave(A_NameCls, M_NewAppl+"\A_NameCls.arx") * DC_ASave(A_NameAtr, M_NewAppl+"\A_NameAtr.arx") // Загрузить массивы Inp_sh, Classes и Attributes aMinSH = DC_ARestore(M_PathAppl+"\aMinSH.arx") aMaxSH = DC_ARestore(M_PathAppl+"\aMaxSH.arx") aDelta = DC_ARestore(M_PathAppl+"\aDelta.arx") // Если обучающая и распознаваемая выборка разные, то и aMinSH, aMaxSH и aDelta разные A_NameCls = DC_ARestore(M_PathAppl+"\A_NameCls.arx") A_NameAtr = DC_ARestore(M_PathAppl+"\A_NameAtr.arx") * LB_Warning(A_NameAtr) // ############################################### * StrFile(STR(mMaxLenCls), '_MaxLCls.txt') // Запись текстового файла с параметром mMaxLenCls * StrFile(STR(mMaxLenAtr), '_MaxLAtr.txt') // Запись текстового файла с параметром mMaxLenAtr mMaxLenCls = VAL(FileStr('_MaxLCls.txt')) // Загрузка параметра mMaxLenCls из текстового файла mMaxLenAtr = VAL(FileStr('_MaxLAtr.txt')) // Загрузка параметра mMaxLenAtr из текстового файла *************************************************************************************************** ######################################### **** 1/2: Генерация распознаваемой выборки и базы событий "EventsKR" на основе БД "Inp_rasp" *********** ######################################### *************************************************************************************************** ######################################### aSay[1]:SetCaption(L('1/2: Генерация распознаваемой выборки и базы событий "EventsKR" на основе БД "Inp_rasp"')) ***** Создать индексные массивы для поиска CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW INDEX ON Name_cls TO Cls_name CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Attributes EXCLUSIVE NEW INDEX ON Name_atr TO Atr_name CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes INDEX Cls_name EXCLUSIVE NEW USE Attributes INDEX Atr_name EXCLUSIVE NEW USE Inp_rasp EXCLUSIVE NEW USE Inp_sh EXCLUSIVE NEW USE EventsKR EXCLUSIVE NEW;ZAP USE EventsKRs EXCLUSIVE NEW;ZAP // <<<===########### для отладки USE Rso_Zag EXCLUSIVE NEW;ZAP USE Rso_Kcl EXCLUSIVE NEW;ZAP USE Rso_Kpr EXCLUSIVE NEW;ZAP ****** Данные для расчета минимальных размеров полей, достаточных для размещения данных ****** В будущем наверное надо сделать EventsKO.txt или EventsKO.csv SELECT EventsKR aStrEventsKR := { { "Name_obj" , "C",250, 0} } FOR j=2 TO FCOUNT() Fv = FIELDGET(1) // Наименование объекта обучающей выборки DO CASE CASE VALTYPE(Fv) = "N" // Числовые столбцы AADD(aStrEventsKR, { FIELDNAME(j), FIELDTYPE(j), FIELDSIZE(j), FIELDDECI(j) }) CASE VALTYPE(Fv) = "C" // Символьные столбцы AADD(aStrEventsKR, { FIELDNAME(j), FIELDTYPE(j), -99999999999, 0 }) CASE VALTYPE(Fv) = "D" // Столбец типа "Дата" AADD(aStrEventsKR, { FIELDNAME(j), "D", -99999999999, 0 }) ENDCASE NEXT SELECT EventsKR FOR j=1 TO N_Obj APPEND BLANK NEXT M_KodObj = 0 SELECT Inp_rasp;N_Obj = RECCOUNT() SET ORDER TO DBGOTOP() DO WHILE .NOT. EOF() ****** База заголовков SELECT Inp_rasp Fv = FIELDGET(1) // Наименование объекта обучающей выборки DO CASE CASE VALTYPE(Fv) = "N" // Числовые столбцы M_NameObj = ALLTRIM(STR(Fv,250)) CASE VALTYPE(Fv) = "C" // Символьные столбцы M_NameObj = ALLTRIM(Fv) CASE VALTYPE(Fv) = "D" // Столбец типа "Дата" M_NameObj = ALLTRIM(DTOC(Fv)) ENDCASE M_KodObj = RECNO() *** Формирование массива кодов классов из БД Inp_data A_KodCls := {} // Массив кодов классов текущего объекта обучающей выборки SELECT EventsKR DBGOTO(M_KodObj) REPLACE Name_obj WITH M_NameObj FOR ff = M_ClSc1 TO M_ClSc2 SELECT Inp_rasp IF aErrorNum[ff] // Если есть вариабельность в колонке Inp_data Fv = FIELDGET(ff) DO CASE CASE FIELDTYPE(ff)="N" // Числовые столбцы * Fv = VAL(STR(Fv,19,6)) ****** Формирование кодов классов SELECT EventsKR aNameGrNumSc = NameGrNumSc(N_GrCls) // Массив наименований градаций числовых шкал FOR gr = 1 TO N_GrCls * F_MinGR = VAL(STR(aMinSH[ff]+(gr-1)*aDelta[ff],19,7)) * F_MaxGR = VAL(STR(aMinSH[ff]+(gr )*aDelta[ff],19,7)) F_MinGR = aMinSH[ff]+(gr-1)*aDelta[ff] F_MaxGR = aMinSH[ff]+(gr )*aDelta[ff] IF F_MinGR <= Fv .AND. Fv <= F_MaxGR // Какие наименования ГРАДАЦИЙ числовых шкал использовать DO CASE CASE mNameGrNumSc= 1 // Только интервальные числовые значения M_Name = ALLTRIM(UPPER(A_FNRus[ff]))+"-"+; ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(N_GrCls,19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" CASE mNameGrNumSc= 2 // Только наименования интервальных числовых значений M_Name = ALLTRIM(UPPER(A_FNRus[ff]))+"-"+aNameGrNumSc[gr] CASE mNameGrNumSc= 3 // И интервальные числовые значения, и их наименования M_Name = ALLTRIM(UPPER(A_FNRus[ff]))+"-"+aNameGrNumSc[gr]+": "+; ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(N_GrCls,19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" ENDCASE M_KodCls = ASCAN(A_NameCls, M_Name) IF M_KodCls > 0 AADD(A_KodCls, M_KodCls) FIELDPUT(ff, M_KodCls) ENDIF EXIT // Исключить повторное кодирование того же значения в следующем интервале ENDIF NEXT CASE FIELDTYPE(ff) = "C" // Символьные столбцы // ############################## Здесь вставить формирование класс.шкал и град. с символами и разделителями ################################### * DO CASE * CASE mTxtCSField = 1 // Значения рассматриваются как целое * CASE mTxtCSField = 2 // Значения рассматриваются как состоящие из элементов - символов * CASE mTxtCSField = 3 // Значения рассматриваются как состоящие из элементов, разделенных разделителем * mTxtCSSep // Разделитель * ENDCASE DO CASE CASE mTxtCSField = 1 // Значения рассматриваются как целое M_NameGrCS = ALLTRIM(Fv) M_Name = ALLTRIM(UPPER(A_FNRus[ff]))+"-"+M_NameGrCS M_KodCls = ASCAN(A_NameCls, M_Name) SELECT EventsKR // при mTxtCSField = 2 или 3 в EventsKO записывать коды через разделитель IF M_KodCls > 0 AADD(A_KodCls, M_KodCls) * FIELDPUT(ff, ALLTRIM(STR(M_KodCls,19))) FIELDPUT(ff, M_KodCls) ENDIF CASE mTxtCSField = 2 // Значения рассматриваются как состоящие из элементов - символов #################################### Fv = ALLTRIM(FIELDGET(ff)) SELECT EventsKR // при mTxtCSField = 2 или 3 в EventsKO записывать коды через разделитель FOR w=1 TO LEN(Fv) M_Symb = ASC(SUBSTR(Fv, w, 1)) M_KodCls = ASCAN(A_SymbCls, M_Symb) IF M_KodCls > 0 AADD(A_KodCls, M_KodCls) FIELDPUT(ff, M_KodCls) aStrEventsKO[ff,4] = MAX(aStrEventsKO[ff,4], LEN(ALLTRIM(Fv+" "+ALLTRIM(STR(M_KodCls,19))))) // 3 ENDIF NEXT CASE mTxtCSField = 3 // Значения рассматриваются как состоящие из элементов, разделенных разделителем ##################### Fv = ALLTRIM(FIELDGET(ff)) SELECT EventsKR // при mTxtCSField = 2 или 3 в EventsKO записывать коды через разделитель FOR w=1 TO NumToken( Fv ) mWord = TOKEN(Fv,,w) IF LEN(ALLTRIM(mWord)) > 0 // Слова короче 4 символов не рассматривать M_Name = ALLTRIM(UPPER(A_FNRus[ff]))+"-"+mWord M_KodCls = ASCAN(A_NameCls, M_Name) IF M_KodCls > 0 AADD(A_KodCls, M_KodCls) FIELDPUT(ff, M_KodCls) MemoAtr = Fv + " " + ALLTRIM(STR(M_KodCls,15)) aStrEventsKO[ff,4] = MAX(aStrEventsKO[ff,4], LEN(ALLTRIM(Fv+" "+ALLTRIM(STR(M_KodCls,19))))) // 3 ENDIF ENDIF NEXT ENDCASE ENDCASE ENDIF NEXT ******* Формирование массива кодов признаков из БД Inp_rasp A_KodAtr = {} FOR ff=M_OpSc1 TO M_OpSc2 // Начало цикла по полям БД Inp_data SELECT Inp_rasp IF aErrorNum[ff] // Если есть вариабельность <===########## В распознаваемой выборке вариабельность в колнке необязательна Fv = FIELDGET(ff) DO CASE CASE FIELDTYPE(ff)="N" // Числовые столбцы * Fv = VAL(STR(Fv,19,6)) SELECT EventsKR aNameGrNumSc = NameGrNumSc(N_GrAtr) // Массив наименований градаций числовых шкал FOR gr = 1 TO N_GrAtr * F_MinGR = VAL(STR(aMinSH[ff]+(gr-1)*aDelta[ff],19,7)) * F_MaxGR = VAL(STR(aMinSH[ff]+(gr )*aDelta[ff],19,7)) F_MinGR = aMinSH[ff]+(gr-1)*aDelta[ff] F_MaxGR = aMinSH[ff]+(gr )*aDelta[ff] IF F_MinGR <= Fv .AND. Fv <= F_MaxGR // Какие наименования ГРАДАЦИЙ числовых шкал использовать DO CASE CASE mNameGrNumSc= 1 // Только интервальные числовые значения M_Name = ALLTRIM(UPPER(A_FNRus[ff]))+"-"+; ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(N_GrAtr,19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" CASE mNameGrNumSc= 2 // Только наименования интервальных числовых значений M_Name = ALLTRIM(UPPER(A_FNRus[ff]))+"-"+aNameGrNumSc[gr] CASE mNameGrNumSc= 3 // И интервальные числовые значения, и их наименования M_Name = ALLTRIM(UPPER(A_FNRus[ff]))+"-"+aNameGrNumSc[gr]+": "+; ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(N_GrAtr,19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" ENDCASE M_KodAtr = ASCAN(A_NameAtr, M_Name) IF M_KodAtr > 0 AADD(A_KodAtr, M_KodAtr) FIELDPUT(ff, M_KodAtr) ENDIF EXIT // Исключить повторное кодирование того же значения в следующем интервале ENDIF NEXT CASE FIELDTYPE(ff) = "C" // Символьные столбцы ######################################################## // ############################## Здесь вставить формирование опис.шкал и град. с символами и разделителями ################################### * DO CASE * CASE mTxtOSField = 1 // Значения рассматриваются как целое * CASE mTxtOSField = 2 // Значения рассматриваются как состоящие из элементов - символов * CASE mTxtOSField = 3 // Значения рассматриваются как состоящие из элементов, разделенных разделителем * mTxtOSSep // Разделитель * ENDCASE DO CASE CASE mTxtOSField = 1 // Значения рассматриваются как целое M_NameGrOS = ALLTRIM(Fv) M_Name = ALLTRIM(UPPER(A_FNRus[ff]))+"-"+M_NameGrOS M_KodAtr = ASCAN(A_NameAtr, M_Name) IF M_KodAtr > 0 AADD(A_KodAtr, M_KodAtr) SELECT EventsKR FIELDPUT(ff, M_KodAtr) ENDIF CASE mTxtOSField = 2 // Значения рассматриваются как состоящие из элементов - символов #################################### Fv = ALLTRIM(FIELDGET(ff)) SELECT EventsKR // при mTxtCSField = 2 или 3 в EventsKO записывать коды через разделитель FOR w=1 TO LEN(Fv) M_Symb = ASC(SUBSTR(Fv, w, 1)) M_KodAtr = ASCAN(A_SymbAtr, M_Symb) IF M_KodAtr > 0 AADD(A_KodAtr, M_KodAtr) FIELDPUT(ff, M_KodAtr) aStrEventsKO[ff,4] = MAX(aStrEventsKO[ff,4], LEN(ALLTRIM(Fv+" "+ALLTRIM(STR(M_KodAtr,19))))) // 3 ENDIF NEXT CASE mTxtOSField = 3 // Значения рассматриваются как состоящие из элементов, разделенных разделителем ##################### Fv = ALLTRIM(FIELDGET(ff)) SELECT EventsKR // при mTxtCSField = 2 или 3 в EventsKO записывать коды через разделитель FOR w=1 TO NumToken( Fv ) mWord = TOKEN(Fv,,w) IF LEN(ALLTRIM(mWord)) > 0 // Слова короче 4 символов не рассматривать M_Name = ALLTRIM(UPPER(A_FNRus[ff]))+"-"+mWord M_KodAtr = ASCAN(A_NameAtr, M_Name) IF M_KodAtr > 0 AADD(A_KodAtr, M_KodAtr) FIELDPUT(ff, M_KodAtr) MemoAtr = Fv + " " + ALLTRIM(STR(M_KodAtr,15)) aStrEventsKO[ff,4] = MAX(aStrEventsKO[ff,4], LEN(ALLTRIM(Fv+" "+ALLTRIM(STR(M_KodAtr,19))))) // 3 ENDIF ENDIF NEXT ENDCASE ENDCASE ENDIF NEXT // Формирование записи БД заголовков объектов обучающей выборки SELECT Rso_Zag APPEND BLANK REPLACE Kod_obj WITH M_KodObj REPLACE Name_obj WITH M_NameObj ****** Запись массива кодов признаков в БД Obi_Kcl * ASORT(A_KodCls) SELECT Rso_Kcl // И точно также записать EventsKO.dbf APPEND BLANK FIELDPUT(1,M_KodObj) IF LEN(A_KodCls) > 0 k=2 FOR jj=1 TO LEN(A_KodCls) IF k <= 5 FIELDPUT(k++,A_KodCls[jj]) ELSE k=2 APPEND BLANK FIELDPUT(1,M_KodObj) FIELDPUT(k++,A_KodCls[jj]) ENDIF NEXT ENDIF ****** Запись массива кодов признаков в БД Obi_Kpr * ASORT(A_KodAtr) SELECT Rso_Kpr APPEND BLANK FIELDPUT(1,M_KodObj) IF LEN(A_KodAtr) > 0 k=2 FOR jj=1 TO LEN(A_KodAtr) IF k <= 8 FIELDPUT(k++,A_KodAtr[jj]) ELSE k=2 APPEND BLANK FIELDPUT(1,M_KodObj) FIELDPUT(k++,A_KodAtr[jj]) ENDIF NEXT ENDIF lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) SELECT Inp_rasp DBSKIP(1) ENDDO * DC_DebugQout( A_NameAtr ) ****** Сделать размеры текстовых полей в БД EventsKR минимальными достаточными для размещения данных * CLOSE EventsKR * DC_DBFILE( DC_SETDCLIP(),"EventsKR.dbf", ,,,'DBFNTX',, aStrEventsKR) // Обновление структуры БД с сохранением информации * USE EventsKR EXCLUSIVE NEW * Сделал мемо-поле для особой интерпретации текстовых полей aSay[1]:SetCaption(aSay[1]:caption+L(' - Готово ')) *************************************************************************************************** **** Конец генерации распознаваемой выборки и базы событий "EventsKR" на основе БД "Inp_rasp" ***** *************************************************************************************************** CASE M_Interval = 1 .AND. M_Scenario // ################################################################################################## * aSay[1]:SetCaption(L('1/2: Создание базы событий "EventsKR" из "Inp_rasp" с кодами событий вместо значений шкал')) * aSay[2]:SetCaption(L('2/2: Генерация распознаваемой выборки на основе базы событий "EventsKR"')) // Записать массивы Inp_sh, Classes и Attributes * DC_ASave(aMinSH, M_NewAppl+"\aMinSH.arx") * DC_ASave(aMaxSH, M_NewAppl+"\aMaxSH.arx") * DC_ASave(aDelta, M_NewAppl+"\aDelta.arx") * DC_ASave(A_NameCls, M_NewAppl+"\A_NameCls.arx") * DC_ASave(A_NameAtr, M_NewAppl+"\A_NameAtr.arx") // Загрузить массивы Inp_sh, Classes и Attributes aMinSH = DC_ARestore(M_PathAppl+"\aMinSH.arx") aMaxSH = DC_ARestore(M_PathAppl+"\aMaxSH.arx") aDelta = DC_ARestore(M_PathAppl+"\aDelta.arx") A_NameCls = DC_ARestore(M_PathAppl+"\A_NameCls.arx") A_NameAtr = DC_ARestore(M_PathAppl+"\A_NameAtr.arx") * StrFile(STR(mMaxLenCls), '_MaxLCls.txt') // Запись текстового файла с параметром mMaxLenCls * StrFile(STR(mMaxLenAtr), '_MaxLAtr.txt') // Запись текстового файла с параметром mMaxLenAtr mMaxLenCls = VAL(FileStr('_MaxLCls.txt')) // Загрузка параметра mMaxLenCls из текстового файла mMaxLenAtr = VAL(FileStr('_MaxLAtr.txt')) // Загрузка параметра mMaxLenAtr из текстового файла *************************************************************************************************** ######################################### **** 1/2: Создание базы событий "EventsKR" из "Inp_rasp" с кодами событий вместо значений шкал **** ######################################### *************************************************************************************************** ######################################### aSay[1]:SetCaption(L('1/2: Создание базы событий "EventsKR" из "Inp_rasp" с кодами событий вместо значений шкал')) ***** Создать индексные массивы для поиска CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW INDEX ON Name_cls TO Cls_name CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Attributes EXCLUSIVE NEW INDEX ON Name_atr TO Atr_name CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE EventsTmp EXCLUSIVE NEW INDEX ON Name_obj TO EventsTmp CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Class_Sc EXCLUSIVE NEW USE Gr_ClSc EXCLUSIVE NEW USE Classes INDEX Cls_name EXCLUSIVE NEW USE Opis_Sc EXCLUSIVE NEW USE Gr_OpSc EXCLUSIVE NEW USE Attributes INDEX Atr_name EXCLUSIVE NEW USE Inp_rasp EXCLUSIVE NEW USE Inp_sh EXCLUSIVE NEW USE EventsKR EXCLUSIVE NEW;ZAP USE EventsKRs EXCLUSIVE NEW;ZAP // Для отладки <<<===############### USE Rso_Zag EXCLUSIVE NEW;ZAP USE Rso_Kcl EXCLUSIVE NEW;ZAP USE Rso_Kpr EXCLUSIVE NEW;ZAP USE EventsTmp INDEX EventsTmp EXCLUSIVE NEW;ZAP SELECT Classes ;mMaxLenKCls = LEN(ALLTRIM(STR(RECCOUNT()))) // максимальное число разрядов в градациях базовых классификацинных шкал для кода класса SELECT Attributes;mMaxLenKAtr = LEN(ALLTRIM(STR(RECCOUNT()))) // максимальное число разрядов в градациях базовых описательных шкал для кода признака ******* Определить максимальное число разрядов в градациях базовых классификацинных шкал для кода класса SELECT Classes SET FILTER TO AT('-FUTURE',Name_cls) = 0 COUNT TO mNRec mMaxLenKCls = LEN(ALLTRIM(STR(mNRec))) // максимальное число разрядов в градациях базовых классификацинных шкал для кода класса SET FILTER TO ******* Определить максимальное число разрядов в градациях базовых описательных шкал для кода признака SELECT Attributes SET FILTER TO AT('-PAST',Name_atr) = 0 COUNT TO mNRec mMaxLenKAtr = LEN(ALLTRIM(STR(mNRec))) // максимальное число разрядов в градациях базовых классификацинных шкал для кода класса SET FILTER TO mMaxLen = 15 M_KodObj = 0 SELECT Inp_rasp SET ORDER TO DBGOTOP() DO WHILE .NOT. EOF() ****** База заголовков SELECT Inp_rasp Fv = FIELDGET(1) // Наименование объекта обучающей выборки DO CASE CASE VALTYPE(Fv) = "N" // Числовые столбцы M_NameObj = ALLTRIM(STR(Fv,17)) CASE VALTYPE(Fv) = "C" // Символьные столбцы M_NameObj = ALLTRIM(Fv) CASE VALTYPE(Fv) = "D" // Столбец типа "Дата" M_NameObj = ALLTRIM(DTOC(Fv)) ENDCASE M_KodObj = RECNO() SELECT EventsKR APPEND BLANK REPLACE Name_obj WITH M_NameObj *** Формирование массива кодов классов из БД Inp_rasp * A_KodCls := {} // Массив кодов классов текущего объекта обучающей выборки FOR ff = M_ClSc1 TO M_ClSc2 SELECT Inp_rasp Fv = FIELDGET(ff) DO CASE CASE FIELDTYPE(ff)="N" // Числовые столбцы * Fv = VAL(STR(Fv,19,6)) ****** Формирование кодов классов SELECT EventsKR aNameGrNumSc = NameGrNumSc(N_GrCls) // Массив наименований градаций числовых шкал FOR gr = 1 TO N_GrCls * F_MinGR = VAL(STR(aMinSH[ff]+(gr-1)*aDelta[ff],19,7)) * F_MaxGR = VAL(STR(aMinSH[ff]+(gr )*aDelta[ff],19,7)) F_MinGR = aMinSH[ff]+(gr-1)*aDelta[ff] F_MaxGR = aMinSH[ff]+(gr )*aDelta[ff] IF F_MinGR <= Fv .AND. Fv <= F_MaxGR // Какие наименования ГРАДАЦИЙ числовых шкал использовать DO CASE CASE mNameGrNumSc= 1 // Только интервальные числовые значения M_Name = ALLTRIM(UPPER(A_FNRus[ff]))+"-"+; ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(N_GrCls,19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" CASE mNameGrNumSc= 2 // Только наименования интервальных числовых значений M_Name = ALLTRIM(UPPER(A_FNRus[ff]))+"-"+aNameGrNumSc[gr] CASE mNameGrNumSc= 3 // И интервальные числовые значения, и их наименования M_Name = ALLTRIM(UPPER(A_FNRus[ff]))+"-"+aNameGrNumSc[gr]+": "+; ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(N_GrCls,19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" ENDCASE M_KodCls = ASCAN(A_NameCls, M_Name) IF M_KodCls > 0 * AADD(A_KodCls, M_KodCls) FIELDPUT(ff, M_KodCls) mMaxLen = MAX(mMaxLen, LEN(ALLTRIM(STR(M_KodCls,19)))) ENDIF EXIT // Исключить повторное кодирование того же значения в следующем интервале ENDIF NEXT CASE FIELDTYPE(ff) = "C" // Символьные столбцы M_NameGrCS = ALLTRIM(Fv) M_Name = ALLTRIM(UPPER(A_FNRus[ff]))+"-"+M_NameGrCS M_KodCls = ASCAN(A_NameCls, M_Name) IF M_KodCls > 0 * AADD(A_KodCls, M_KodCls) SELECT EventsKR FIELDPUT(ff, M_KodCls) mMaxLen = MAX(mMaxLen, LEN(ALLTRIM(STR(M_KodCls,19)))) ENDIF ENDCASE NEXT ******* Формирование массива кодов признаков из БД Inp_rasp * A_KodAtr = {} FOR ff=M_OpSc1 TO M_OpSc2 // Начало цикла по полям БД Inp_rasp SELECT Inp_rasp IF aErrorNum[ff] // Если есть вариабельность Fv = FIELDGET(ff) DO CASE CASE FIELDTYPE(ff)="N" // Числовые столбцы * Fv = VAL(STR(Fv,19,6)) SELECT EventsKR aNameGrNumSc = NameGrNumSc(N_GrAtr) // Массив наименований градаций числовых шкал FOR gr = 1 TO N_GrAtr * F_MinGR = VAL(STR(aMinSH[ff]+(gr-1)*aDelta[ff],19,7)) * F_MaxGR = VAL(STR(aMinSH[ff]+(gr )*aDelta[ff],19,7)) F_MinGR = aMinSH[ff]+(gr-1)*aDelta[ff] F_MaxGR = aMinSH[ff]+(gr )*aDelta[ff] IF F_MinGR <= Fv .AND. Fv <= F_MaxGR // Какие наименования ГРАДАЦИЙ числовых шкал использовать DO CASE CASE mNameGrNumSc= 1 // Только интервальные числовые значения M_Name = ALLTRIM(UPPER(A_FNRus[ff]))+"-"+; ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(N_GrAtr,19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" CASE mNameGrNumSc= 2 // Только наименования интервальных числовых значений M_Name = ALLTRIM(UPPER(A_FNRus[ff]))+"-"+aNameGrNumSc[gr] CASE mNameGrNumSc= 3 // И интервальные числовые значения, и их наименования M_Name = ALLTRIM(UPPER(A_FNRus[ff]))+"-"+aNameGrNumSc[gr]+": "+; ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(N_GrAtr,19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" ENDCASE M_KodAtr = ASCAN(A_NameAtr, M_Name) IF M_KodAtr > 0 * AADD(A_KodAtr, M_KodAtr) FIELDPUT(ff, M_KodAtr) mMaxLen = MAX(mMaxLen, LEN(ALLTRIM(STR(M_KodAtr,19)))) ENDIF EXIT // Исключить повторное кодирование того же значения в следующем интервале ENDIF NEXT CASE FIELDTYPE(ff) = "C" // Символьные столбцы M_NameGrOS = ALLTRIM(Fv) M_Name = ALLTRIM(UPPER(A_FNRus[ff]))+"-"+M_NameGrOS M_KodAtr = ASCAN(A_NameAtr, M_Name) IF M_KodAtr > 0 * AADD(A_KodAtr, M_KodAtr) SELECT EventsKR FIELDPUT(ff, M_KodAtr) mMaxLen = MAX(mMaxLen, LEN(ALLTRIM(STR(M_KodAtr,19)))) ENDIF ENDCASE ENDIF NEXT lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) SELECT Inp_rasp DBSKIP(1) ENDDO aSay[2]:SetCaption(aSay[2]:caption+L(' - Готово ')) *************************************************************************************************** **** Конец генерации распознаваемой выборки и базы событий "EventsKR" на основе БД "Inp_rasp" ***** *************************************************************************************************** *************************************************************************************************** **** 2/2: Генерация распознаваемой выборки на основе базы событий "EventsKR" ********************** *************************************************************************************************** aSay[2]:SetCaption(L('2/2: Генерация распознаваемой выборки на основе базы событий "EventsKR"')) SELECT EventsKR DBGOTOP() n = 0 DO WHILE .NOT. EOF() // Формирование записи БД заголовков объектов распознаваемой выборки M_Recno = RECNO() M_KodObj = M_Recno M_NameObj = Name_obj SELECT Rso_Zag APPEND BLANK REPLACE Kod_obj WITH M_KodObj REPLACE Name_obj WITH M_NameObj *** Формирование массива кодов классов из БД EventsKR SELECT EventsKR A_KodCls := {} // Массив базовых кодов классов текущего объекта распознаваемой выборки FOR ff = M_ClSc1 TO M_ClSc2 DBGOTO(M_Recno) Fv = FIELDGET(ff) AADD(A_KodCls, Fv) FOR N_Gorizont = mGorizMin TO mGorizMax mScen = A_FNRus[ff] + '-FUTURE'+ALLTRIM(STR(N_Gorizont)) + '-' SELECT EventsKR DBGOTO(M_Recno) DBSKIP(1) // Код текущей записи тоже включать в сценарий? mGorizont = 1 DO WHILE .NOT. EOF() .AND. mGorizont <= N_Gorizont // Градации класс.шкалы ************************************ mFV = FIELDGET(ff) IF mFV > 0 mSimb = STRTRAN(STR(mFV,mMaxLenKCls),' ','0') IF LEN(mSimb) > 0 mt = mScen + mSimb + IF(mGorizont 0 // Если такой сценарий есть в справочнике - занести его код в объект распознаваемой выборки * IF ASCAN(A_KodCls, M_KodCls) = 0 // Каждый код вносить только 1 раз AADD( A_KodCls, M_KodCls) * ENDIF ENDIF ENDIF NEXT NEXT ******* Формирование массива кодов признаков из базы событий EventsKR SELECT EventsKR A_KodAtr = {} // Массив кодов признаков текущего объекта распознаваемой выборки FOR ff=M_OpSc1 TO M_OpSc2 // Начало цикла по полям БД DBGOTO(M_Recno) IF aErrorNum[ff] // Если есть вариабельность DBGOTO(M_Recno) Fv = FIELDGET(ff) AADD(A_KodAtr, Fv) FOR N_Glubina = mGlubMin TO mGlubMax mScen = A_FNRus[ff] + '-PAST'+ALLTRIM(STR(N_Glubina)) + '-' SELECT EventsKR mGlubina = 1 DBGOTO(M_Recno-N_Glubina+1) * DBSKIP(1) // Код текущей записи тоже включать в сценарий? DO WHILE .NOT. EOF() .AND. mGlubina <= N_Glubina // Градации класс.шкалы ************************************ mFV = FIELDGET(ff) IF mFV > 0 mSimb = STRTRAN(STR(mFV,mMaxLenKAtr),' ','0') IF LEN(mSimb) > 0 mt = mScen + mSimb + IF(mGlubina < N_Glubina,',','') ++mGlubina mScen = ALLTRIM(SUBSTR(mt,1,255)) ENDIF ENDIF DBSKIP(1) ENDDO IF mGlubina = N_Glubina + 1 M_KodAtr = ASCAN(A_NameAtr, mScen) IF M_KodCls > 0 // Если такой сценарий есть в справочнике - занести его код в объект распознаваемой выборки * IF ASCAN(A_KodAtr, M_KodAtr) = 0 AADD( A_KodAtr, M_KodAtr) * ENDIF ENDIF ENDIF NEXT ENDIF NEXT * DC_DebugQout( A_KodCls, A_KodAtr ) ****** Запись массива кодов классов в БД Rso_Kcl * ASORT(A_KodCls) SELECT Rso_Kcl APPEND BLANK FIELDPUT(1,M_KodObj) IF LEN(A_KodCls) > 0 k=2 FOR jj=1 TO LEN(A_KodCls) IF k <= 5 FIELDPUT(k++,A_KodCls[jj]) ELSE k=2 APPEND BLANK FIELDPUT(1,M_KodObj) FIELDPUT(k++,A_KodCls[jj]) ENDIF NEXT ENDIF ****** Запись массива кодов признаков в БД Rso_Kpr * ASORT(A_KodAtr) SELECT Rso_Kpr APPEND BLANK FIELDPUT(1,M_KodObj) IF LEN(A_KodAtr) > 0 k=2 FOR jj=1 TO LEN(A_KodAtr) IF k <= 8 FIELDPUT(k++,A_KodAtr[jj]) ELSE k=2 APPEND BLANK FIELDPUT(1,M_KodObj) FIELDPUT(k++,A_KodAtr[jj]) ENDIF NEXT ENDIF ****** Формирование массивов кодов классов и признаков для БД EventsKRs. ДЛЯ ОТЛАДКИ РЕЖИМА: "СЦЕНАРНЫЙ МЕТОД АСК-АНАЛИЗА" ****** Копирование кодов базовых классов и базовых признаков EventsKR => EventsKRs * MsgBox(STR(mRecSizeEvKRs)) SELECT EventsKR DBGOTOP() DO WHILE .NOT. EOF() * MsgBox(STR(mRecSizeEvKRs * (n+1))) IF mRecSizeEvKRs * (n+1) > 2*10^9 // Не создавать файл больше 2 Гб EXIT ELSE aR := {} FOR j=1 TO FCOUNT()-2 AADD(aR, FIELDGET(j)) NEXT n++ SELECT EventsKRs APPEND BLANK // <<<===########################### FOR j=1 TO LEN(aR) FIELDPUT(j, aR[j]) NEXT ENDIF SELECT EventsKR DBSKIP(1) ENDDO SELECT EventsKRs IF M_Recno <= RECCOUNT() DBGOTO(M_Recno) ****** Запись массива кодов классов в БД EventsKRs ********************** mKodCls = '' nKodCls = LEN(A_KodCls) FOR j=1 TO nKodCls IF A_KodCls[j] > 0 mKodCls = mKodCls + '[' + ALLTRIM(STR(A_KodCls[j])) + ']-' + A_NameCls[A_KodCls[j]] + IF(j255,'...','') ****** Запись массива кодов признаков в БД EventsKRs ******************** mKodAtr = '' nKodAtr = LEN(A_KodAtr) FOR j=1 TO nKodAtr IF A_KodAtr[j] > 0 mKodAtr = mKodAtr + '[' + ALLTRIM(STR(A_KodAtr[j])) + ']-' + A_NameAtr[A_KodAtr[j]] + IF(j255,'...','') ENDIF lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) SELECT EventsKR DBGOTO(M_Recno) DBSKIP(1) ENDDO aSay[2]:SetCaption(aSay[2]:caption+L(' - Готово ')) *************************************************************************************************** **** Конец генерации распознаваемой выборки на основе базы событий "EventsKR" ********************* *************************************************************************************************** CASE M_Interval = 2 .AND. .NOT. M_Scenario // ################################################################################################## // ################################################################################################## * aSay[1]:SetCaption(L('1/2: Генерация распознаваемой выборки и базы событий "EventsKR" на основе внешней БД "Inp_rasp"')) * aSay[2]:SetCaption(L('2/2: Переиндексация распознаваемой выборки')) // Запись и загрузка массивов: aExcelClSc, aExcelOpSc, aMinGranInt и aMaxGranInt, A_NameCls и A_NameAtr * DC_ASave(aExcelClSc, "_aXlsClSc.arx") // Запись массива aExcelClSc * DC_ASave(aExcelOpSc, "_aXlsOpSc.arx") // Запись массива aExcelOpSc aExcelClSc = DC_ARestore("_aXlsClSc.arx") // Загрузка массива aExcelClSc aExcelOpSc = DC_ARestore("_aXlsOpSc.arx") // Загрузка массива aExcelOpSc * DC_ASave(aMinGranInt, "_MinGranInt.arx") // Запись массива aMinGranInt * DC_ASave(aMaxGranInt, "_MaxGranInt.arx") // Запись массива aMaxGranInt * DC_ASave(aGradNSc, "_GradNSc.arx") // Запись массива aGradNSc aGradNSc = DC_ARestore("_GradNSc.arx") // Загрузка массива aGradNSc aMinGranInt = DC_ARestore("_MinGranInt.arx") // Загрузка массива aMinGranInt aMaxGranInt = DC_ARestore("_MaxGranInt.arx") // Загрузка массива aMaxGranInt * DC_ASave(A_NameCls, "_aNameCls.arx") // Запись массива A_NameCls * DC_ASave(A_NameAtr, "_aNameAtr.arx") // Запись массива A_NameAtr A_NameCls = DC_ARestore("_aNameCls.arx") // Загрузка массива A_NameCls A_NameAtr = DC_ARestore("_aNameAtr.arx") // Загрузка массива A_NameAtr * StrFile(STR(mMaxLenCls), '_MaxLCls.txt') // Запись текстового файла с параметром mMaxLenCls * StrFile(STR(mMaxLenAtr), '_MaxLAtr.txt') // Запись текстового файла с параметром mMaxLenAtr mMaxLenCls = VAL(FileStr('_MaxLCls.txt')) // Загрузка параметра mMaxLenCls из текстового файла mMaxLenAtr = VAL(FileStr('_MaxLAtr.txt')) // Загрузка параметра mMaxLenAtr из текстового файла * StrFile(STR(mMaxInt), '_mMaxInt.txt') // Запись текстового файла с параметром mMaxInt * StrFile(STR(mMaxDec), '_mMaxDec.txt') // Запись текстового файла с параметром mMaxDec mMaxInt = VAL(FileStr('_mMaxInt.txt')) // Загрузка параметра mMaxInt из текстового файла mMaxDec = VAL(FileStr('_mMaxDec.txt')) // Загрузка параметра mMaxDec из текстового файла * DC_ASave(aInp_name, "_Inp_name.arx") // Запись массива наименований шкал (колонок) в виде файла aInp_name = DC_ARestore("_Inp_name.arx") // Загрузка массива наименований шкал (колонок) из файла * DC_ASave(aKGradCClSc, "_KGrCClSc.arx") // Запись текстового файла с параметром aKGradCClSc[mCol] * DC_ASave(aKGradCOpSc, "_KGrCOpSc.arx") // Запись текстового файла с параметром aKGradCOpSc[mCol] aKGradCClSc = DC_ARestore("_KGrCClSc.arx") // Загрузка параметра aKGradCClSc[mCol] из текстового файла aKGradCOpSc = DC_ARestore("_KGrCOpSc.arx") // Загрузка параметра aKGradCOpSc[mCol] из текстового файла N_GrCls = aGradNSc[1] // Кол-во градаций в класс.шкале N_GrAtr = aGradNSc[2] // Кол-во градаций в опис. шкале ********************************************************************************************************* **** 1/2: Генерация распознаваемой выборки и базы событий "EventsKR" на основе внешней БД "Inp_rasp" **** ********************************************************************************************************* aSay[1]:SetCaption(L('1/2: Генерация распозн.выборки и базы событий "EventsKR" на основе внешней БД "Inp_rasp"')) ***** Создать индексные массивы для поиска CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW INDEX ON Name_cls TO Cls_name CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Attributes EXCLUSIVE NEW INDEX ON Name_atr TO Atr_name CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes INDEX Cls_name EXCLUSIVE NEW USE Attributes INDEX Atr_name EXCLUSIVE NEW USE Inp_rasp EXCLUSIVE NEW USE Rso_Zag EXCLUSIVE NEW;ZAP USE Rso_Kcl EXCLUSIVE NEW;ZAP USE Rso_Kpr EXCLUSIVE NEW;ZAP USE EventsKR EXCLUSIVE NEW;ZAP M_KodObj = 0 SELECT Inp_rasp SET ORDER TO DBGOTOP() DO WHILE .NOT. EOF() ****** База заголовков SELECT Inp_rasp Fv = FIELDGET(1) // Наименование объекта распознаваемой выборки DO CASE CASE VALTYPE(Fv) = "N" // Числовые столбцы M_NameObj = ALLTRIM(STR(Fv,17)) CASE VALTYPE(Fv) = "C" // Символьные столбцы M_NameObj = ALLTRIM(Fv) CASE VALTYPE(Fv) = "D" // Столбец типа "Дата" M_NameObj = ALLTRIM(DTOC(Fv)) ENDCASE SELECT Rso_Zag APPEND BLANK REPLACE Kod_obj WITH ++M_KodObj REPLACE Name_obj WITH M_NameObj SELECT EventsKR APPEND BLANK REPLACE Name_obj WITH M_NameObj A_KodCls := {} // Массив кодов классов текущего объекта распознаваемой выборки FOR ff = M_ClSc1 TO M_ClSc2 // КЛАССИФИКАЦИОННЫЕ ШКАЛЫ SELECT Inp_rasp Fv = FIELDGET(ff) M_Recno = RECNO() DO CASE CASE FIELDTYPE(ff)="N" // Числовые столбцы * Fv = VAL(STR(Fv,19,6)) SELECT EventsKR FOR gr=1 TO N_GrCls * F_MinGR = VAL(STR(aMinGranInt[gr,ff],19,7)) * F_MaxGR = VAL(STR(aMaxGranInt[gr,ff],19,7)) F_MinGR = aMinGranInt[gr,ff] F_MaxGR = aMaxGranInt[gr,ff] IF F_MinGR <= Fv .AND. Fv <= F_MaxGR M_Name = ALLTRIM(UPPER(aInp_name[ff]))+"-"+; ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(K_GradNClSc,19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" M_KodCls = ASCAN(A_NameCls, M_Name) * IF M_KodCls > 0 AADD(A_KodCls, M_KodCls) * ENDIF FIELDPUT(ff, M_KodCls) EXIT // Исключить повторное кодирование того же значения в следующем интервале ENDIF NEXT CASE FIELDTYPE(ff) = "C" // Символьные столбцы SELECT EventsKR FOR mNumGrad=1 TO aKGradCClSc[ff] M_NameGrCS = ALLTRIM(STR(mNumGrad,19)) + '/' + ALLTRIM(STR(aKGradCClSc[ff],19)) + '-' + ALLTRIM(Fv) M_NameCS = UPPER(ALLTRIM(aInp_name[ff])) IF AT(M_NameCS, UPPER(M_NameGrCS)) = 0 M_Name = M_NameCS+"-"+M_NameGrCS ELSE M_Name = M_NameGrCS ENDIF M_KodCls = ASCAN(A_NameCls, M_Name) IF M_KodCls > 0 * IF ASCAN(A_KodCls, M_KodCls) = 0 AADD( A_KodCls, M_KodCls) * ENDIF FIELDPUT(ff, M_KodCls) * mMaxLen = MAX(mMaxLen, LEN(ALLTRIM(STR(M_KodCls,19)))) EXIT // Исключить повторное кодирование того же значения в следующем интервале ENDIF NEXT ENDCASE lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) NEXT A_KodAtr := {} // Массив кодов признаков текущего объекта распознаваемой выборки FOR ff=M_OpSc1 TO M_OpSc2 // ОПИСАТЕЛЬНЫЕ ШКАЛЫ SELECT Inp_rasp IF aErrorNum[ff] // Если есть вариабельность <===########## В распознаваемой выборке вариабельность в колнке необязательна Fv = FIELDGET(ff) M_Recno = RECNO() DO CASE CASE FIELDTYPE(ff)="N" // Числовые столбцы ############### ЭТО НЕ ВСЕГДА РАБОТАЕТ * Fv = VAL(STR(Fv,19,6)) SELECT EventsKR FOR gr=1 TO N_GrAtr * F_MinGR = VAL(STR(aMinGranInt[gr,ff],19,7)) * F_MaxGR = VAL(STR(aMaxGranInt[gr,ff],19,7)) F_MinGR = aMinGranInt[gr,ff] F_MaxGR = aMaxGranInt[gr,ff] IF F_MinGR <= Fv .AND. Fv <= F_MaxGR M_Name = ALLTRIM(UPPER(aInp_name[ff]))+"-"+; ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(K_GradNOpSc,19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" M_KodAtr = ASCAN(A_NameAtr, M_Name) IF M_KodAtr > 0 * IF ASCAN(A_KodAtr, M_KodAtr) = 0 AADD( A_KodAtr, M_KodAtr) * ENDIF FIELDPUT(ff, M_KodAtr) * mMaxLen = MAX(mMaxLen, LEN(ALLTRIM(STR(M_KodAtr,19)))) EXIT // Исключить повторное кодирование того же значения в следующем интервале ENDIF ENDIF NEXT CASE FIELDTYPE(ff) = "C" // Символьные столбцы SELECT EventsKR FOR mNumGrad=1 TO aKGradCOpSc[ff] M_NameGrOS = ALLTRIM(STR(mNumGrad,19)) + '/' + ALLTRIM(STR(aKGradCOpSc[ff],19)) + '-' + ALLTRIM(Fv) M_NameOS = UPPER(ALLTRIM(aInp_name[ff])) IF AT(M_NameOS, UPPER(M_NameGrOS)) = 0 M_Name = M_NameOS+"-"+M_NameGrOS ELSE M_Name = M_NameGrOS ENDIF M_KodAtr = ASCAN(A_NameAtr, M_Name) IF M_KodAtr > 0 * IF ASCAN(A_KodAtr, M_KodAtr) = 0 AADD( A_KodAtr, M_KodAtr) * ENDIF FIELDPUT(ff, M_KodAtr) * mMaxLen = MAX(mMaxLen, LEN(ALLTRIM(STR(M_KodAtr,19)))) EXIT // Исключить повторное кодирование того же значения в следующем интервале ENDIF NEXT ENDCASE ENDIF lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) NEXT ****** Запись массива кодов классов в БД Rso_Kcl * ASORT(A_KodCls) SELECT Rso_Kcl APPEND BLANK FIELDPUT(1,M_KodObj) IF LEN(A_KodCls) > 0 k=2 FOR jj=1 TO LEN(A_KodCls) IF k <= 5 FIELDPUT(k++,A_KodCls[jj]) ELSE k=2 APPEND BLANK FIELDPUT(1,M_KodObj) FIELDPUT(k++,A_KodCls[jj]) ENDIF NEXT ENDIF ****** Запись массива кодов признаков в БД Rso_Kpr * ASORT(A_KodAtr) SELECT Rso_Kpr APPEND BLANK FIELDPUT(1,M_KodObj) IF LEN(A_KodAtr) > 0 k=2 FOR jj=1 TO LEN(A_KodAtr) IF k <= 8 FIELDPUT(k++,A_KodAtr[jj]) ELSE k=2 APPEND BLANK FIELDPUT(1,M_KodObj) FIELDPUT(k++,A_KodAtr[jj]) ENDIF NEXT ENDIF SELECT Inp_rasp DBSKIP(1) ENDDO aSay[1]:SetCaption(aSay[1]:caption+L(' - Готово ')) ********************************************************************************************************* **** Конец генерации распознаваемой выборки и базы событий "EventsKR" на основе внешней БД "Inp_rasp" *** ********************************************************************************************************* CASE M_Interval = 2 .AND. M_Scenario // ################################################################################################## * aSay[1]:SetCaption(L('1/3: Генерация базы событий "EventsKR" на основе внешней БД "Inp_rasp"')) // Как в адапт.инт.без сцен. * aSay[2]:SetCaption(L('2/3: Генерация распознаваемой выборки на основе базы событий "EventsKR"')) // Как в равн.интер.со сценар. * aSay[3]:SetCaption(L('3/3: Переиндексация распознаваемой выборки')) *************************************************************************************************** **** 1/3: Генерация базы событий "EventsKR" на основе внешней БД "Inp_rasp" *********************** *************************************************************************************************** aSay[1]:SetCaption(L('1/3: Генерация базы событий "EventsKR" на основе внешней БД "Inp_rasp"')) // Как в адапт.инт.без сцен. // Запись и загрузка массивов: aExcelClSc, aExcelOpSc, aMinGranInt и aMaxGranInt, A_NameCls и A_NameAtr * DC_ASave(aExcelClSc, "_aXlsClSc.arx") // Запись массива aExcelClSc * DC_ASave(aExcelOpSc, "_aXlsOpSc.arx") // Запись массива aExcelOpSc aExcelClSc = DC_ARestore("_aXlsClSc.arx") // Загрузка массива aExcelClSc aExcelOpSc = DC_ARestore("_aXlsOpSc.arx") // Загрузка массива aExcelOpSc * DC_ASave(aMinGranInt, "_MinGranInt.arx") // Запись массива aMinGranInt * DC_ASave(aMaxGranInt, "_MaxGranInt.arx") // Запись массива aMaxGranInt * DC_ASave(aGradNSc, "_GradNSc.arx") // Запись массива aGradNSc aGradNSc = DC_ARestore("_GradNSc.arx") // Загрузка массива aGradNSc aMinGranInt = DC_ARestore("_MinGranInt.arx") // Загрузка массива aMinGranInt aMaxGranInt = DC_ARestore("_MaxGranInt.arx") // Загрузка массива aMaxGranInt * DC_ASave(A_NameCls, "_aNameCls.arx") // Запись массива A_NameCls * DC_ASave(A_NameAtr, "_aNameAtr.arx") // Запись массива A_NameAtr A_NameCls = DC_ARestore("_aNameCls.arx") // Загрузка массива A_NameCls A_NameAtr = DC_ARestore("_aNameAtr.arx") // Загрузка массива A_NameAtr * StrFile(STR(mMaxLenCls), '_MaxLCls.txt') // Запись текстового файла с параметром mMaxLenCls * StrFile(STR(mMaxLenAtr), '_MaxLAtr.txt') // Запись текстового файла с параметром mMaxLenAtr mMaxLenCls = VAL(FileStr('_MaxLCls.txt')) // Загрузка параметра mMaxLenCls из текстового файла mMaxLenAtr = VAL(FileStr('_MaxLAtr.txt')) // Загрузка параметра mMaxLenAtr из текстового файла * StrFile(STR(mMaxInt), '_mMaxInt.txt') // Запись текстового файла с параметром mMaxInt * StrFile(STR(mMaxDec), '_mMaxDec.txt') // Запись текстового файла с параметром mMaxDec mMaxInt = VAL(FileStr('_mMaxInt.txt')) // Загрузка параметра mMaxInt из текстового файла mMaxDec = VAL(FileStr('_mMaxDec.txt')) // Загрузка параметра mMaxDec из текстового файла * DC_ASave(aInp_name, "_Inp_name.arx") // Запись массива наименований шкал (колонок) в виде файла aInp_name = DC_ARestore("_Inp_name.arx") // Загрузка массива наименований шкал (колонок) из файла * DC_ASave(aKGradCClSc, "_KGrCClSc.arx") // Запись текстового файла с параметром aKGradCClSc[mCol] * DC_ASave(aKGradCOpSc, "_KGrCOpSc.arx") // Запись текстового файла с параметром aKGradCOpSc[mCol] aKGradCClSc = DC_ARestore("_KGrCClSc.arx") // Загрузка параметра aKGradCClSc[mCol] из текстового файла aKGradCOpSc = DC_ARestore("_KGrCOpSc.arx") // Загрузка параметра aKGradCOpSc[mCol] из текстового файла N_GrCls = aGradNSc[1] // Кол-во градаций в класс.шкале N_GrAtr = aGradNSc[2] // Кол-во градаций в опис. шкале ***** Создать индексные массивы для поиска CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW INDEX ON Name_cls TO Cls_name CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Attributes EXCLUSIVE NEW INDEX ON Name_atr TO Atr_name CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes INDEX Cls_name EXCLUSIVE NEW USE Attributes INDEX Atr_name EXCLUSIVE NEW USE Inp_rasp EXCLUSIVE NEW USE Rso_Zag EXCLUSIVE NEW;ZAP USE Rso_Kcl EXCLUSIVE NEW;ZAP USE Rso_Kpr EXCLUSIVE NEW;ZAP USE EventsKR EXCLUSIVE NEW;ZAP USE EventsKRs EXCLUSIVE NEW;ZAP SELECT Classes ;mMaxLenKCls = LEN(ALLTRIM(STR(RECCOUNT()))) // максимальное число разрядов в градациях базовых классификацинных шкал для кода класса SELECT Attributes;mMaxLenKAtr = LEN(ALLTRIM(STR(RECCOUNT()))) // максимальное число разрядов в градациях базовых описательных шкал для кода признака mMaxLen = 15 M_KodObj = 0 SELECT Inp_rasp SET ORDER TO DBGOTOP() DO WHILE .NOT. EOF() ****** База заголовков SELECT Inp_rasp Fv = FIELDGET(1) // Наименование объекта распознаваемой выборки DO CASE CASE VALTYPE(Fv) = "N" // Числовые столбцы M_NameObj = ALLTRIM(STR(Fv,17)) CASE VALTYPE(Fv) = "C" // Символьные столбцы M_NameObj = ALLTRIM(Fv) CASE VALTYPE(Fv) = "D" // Столбец типа "Дата" M_NameObj = ALLTRIM(DTOC(Fv)) ENDCASE SELECT EventsKR APPEND BLANK REPLACE Name_obj WITH M_NameObj A_KodCls := {} // Массив кодов классов текущего объекта распознаваемой выборки FOR ff = M_ClSc1 TO M_ClSc2 // КЛАССИФИКАЦИОННЫЕ ШКАЛЫ SELECT Inp_rasp Fv = FIELDGET(ff) M_Recno = RECNO() DO CASE CASE FIELDTYPE(ff)="N" // Числовые столбцы * Fv = VAL(STR(Fv,19,6)) SELECT EventsKR aNameGrNumSc = NameGrNumSc(N_GrCls) // Массив наименований градаций числовых шкал FOR gr=1 TO N_GrCls * F_MinGR = VAL(STR(aMinGranInt[gr,ff],19,7)) * F_MaxGR = VAL(STR(aMaxGranInt[gr,ff],19,7)) F_MinGR = aMinGranInt[gr,ff] F_MaxGR = aMaxGranInt[gr,ff] IF F_MinGR <= Fv .AND. Fv <= F_MaxGR // Какие наименования ГРАДАЦИЙ числовых шкал использовать DO CASE CASE mNameGrNumSc= 1 // Только интервальные числовые значения M_NameGrCS = ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(N_GrCls,19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" CASE mNameGrNumSc= 2 // Только наименования интервальных числовых значений M_NameGrCS = aNameGrNumSc[gr] CASE mNameGrNumSc= 3 // И интервальные числовые значения, и их наименования M_NameGrCS = aNameGrNumSc[gr]+": "+; ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(N_GrCls,19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" ENDCASE M_NameCS = UPPER(ALLTRIM(aInp_name[ff])) // Если в названии градации уже включено наим.шкалы, то повторно не включать его IF AT(M_NameCS, UPPER(M_NameGrCS)) = 0 M_Name = M_NameCS+"-"+M_NameGrCS ELSE M_Name = M_NameGrCS ENDIF M_KodCls = ASCAN(A_NameCls, M_Name) IF M_KodCls > 0 IF ASCAN(A_KodCls, M_KodCls) = 0 AADD( A_KodCls, M_KodCls) ENDIF FIELDPUT(ff, M_KodCls) mMaxLen = MAX(mMaxLen, LEN(ALLTRIM(STR(M_KodCls,19)))) EXIT // Исключить повторное кодирование того же значения в следующем интервале ENDIF ENDIF NEXT CASE FIELDTYPE(ff) = "C" // Символьные столбцы SELECT EventsKR FOR mNumGrad=1 TO aKGradCClSc[ff] M_NameGrCS = ALLTRIM(STR(mNumGrad,19)) + '/' + ALLTRIM(STR(aKGradCClSc[ff],19)) + '-' + ALLTRIM(Fv) M_NameCS = UPPER(ALLTRIM(aInp_name[ff])) IF AT(M_NameCS, UPPER(M_NameGrCS)) = 0 M_Name = M_NameCS+"-"+M_NameGrCS ELSE M_Name = M_NameGrCS ENDIF M_KodCls = ASCAN(A_NameCls, M_Name) IF M_KodCls > 0 * IF ASCAN(A_KodCls, M_KodCls) = 0 * AADD( A_KodCls, M_KodCls) * ENDIF FIELDPUT(ff, M_KodCls) mMaxLen = MAX(mMaxLen, LEN(ALLTRIM(STR(M_KodCls,19)))) EXIT // Исключить повторное кодирование того же значения в следующем интервале ENDIF NEXT ENDCASE lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) NEXT A_KodAtr := {} // Массив кодов признаков текущего объекта распознаваемой выборки FOR ff=M_OpSc1 TO M_OpSc2 // ОПИСАТЕЛЬНЫЕ ШКАЛЫ SELECT Inp_rasp IF aErrorNum[ff] // Если есть вариабельность Fv = FIELDGET(ff) DO CASE CASE FIELDTYPE(ff)="N" // Числовые столбцы * Fv = VAL(STR(Fv,19,6)) SELECT EventsKR aNameGrNumSc = NameGrNumSc(N_GrAtr) // Массив наименований градаций числовых шкал FOR gr=1 TO N_GrAtr * F_MinGR = VAL(STR(aMinGranInt[gr,ff],19,7)) * F_MaxGR = VAL(STR(aMaxGranInt[gr,ff],19,7)) F_MinGR = aMinGranInt[gr,ff] F_MaxGR = aMaxGranInt[gr,ff] IF F_MinGR <= Fv .AND. Fv <= F_MaxGR // Какие наименования ГРАДАЦИЙ числовых шкал использовать DO CASE CASE mNameGrNumSc= 1 // Только интервальные числовые значения M_NameGrOS = ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(N_GrAtr,19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" CASE mNameGrNumSc= 2 // Только наименования интервальных числовых значений M_NameGrOS = aNameGrNumSc[gr] CASE mNameGrNumSc= 3 // И интервальные числовые значения, и их наименования M_NameGrOS = aNameGrNumSc[gr]+": "+; ALLTRIM(STR(gr,19))+"/"+; ALLTRIM(STR(N_GrAtr,19))+"-{"+; ALLTRIM(STR(F_MinGR,19,7))+", "+; ALLTRIM(STR(F_MaxGR,19,7))+"}" ENDCASE M_NameOS = UPPER(ALLTRIM(aInp_name[ff])) // Если в названии градации уже включено наим.шкалы, то повторно не включать его IF AT(M_NameOS, UPPER(M_NameGrOS)) = 0 M_Name = M_NameOS+"-"+M_NameGrOS ELSE M_Name = M_NameGrOS ENDIF M_KodAtr = ASCAN(A_NameAtr, M_Name) IF M_KodAtr > 0 * IF ASCAN(A_KodAtr, M_KodAtr) = 0 * AADD( A_KodAtr, M_KodAtr) * ENDIF FIELDPUT(ff, M_KodAtr) mMaxLen = MAX(mMaxLen, LEN(ALLTRIM(STR(M_KodAtr,19)))) EXIT // Исключить повторное кодирование того же значения в следующем интервале ENDIF ENDIF NEXT CASE FIELDTYPE(ff) = "C" // Символьные столбцы SELECT EventsKR FOR mNumGrad=1 TO aKGradCOpSc[ff] M_NameGrOS = ALLTRIM(STR(mNumGrad,19)) + '/' + ALLTRIM(STR(aKGradCOpSc[ff],19)) + '-' + ALLTRIM(Fv) M_NameOS = UPPER(ALLTRIM(aInp_name[ff])) IF AT(M_NameOS, UPPER(M_NameGrOS)) = 0 M_Name = M_NameOS+"-"+M_NameGrOS ELSE M_Name = M_NameGrOS ENDIF M_KodAtr = ASCAN(A_NameAtr, M_Name) IF M_KodAtr > 0 * IF ASCAN(A_KodAtr, M_KodAtr) = 0 * AADD( A_KodAtr, M_KodAtr) * ENDIF FIELDPUT(ff, M_KodAtr) mMaxLen = MAX(mMaxLen, LEN(ALLTRIM(STR(M_KodAtr,19)))) EXIT // Исключить повторное кодирование того же значения в следующем интервале ENDIF NEXT ENDCASE ENDIF lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) NEXT SELECT Inp_rasp DBSKIP(1) ENDDO aSay[1]:SetCaption(aSay[1]:caption+L(' - Готово ')) *************************************************************************************************** **** Конец генерации базы событий "EventsKR" на основе внешней БД "Inp_rasp" ********************** *************************************************************************************************** *************************************************************************************************** **** 2/3: Генерация распознаваемой выборки на основе базы событий "EventsKR" ********************** *************************************************************************************************** aSay[2]:SetCaption(L('2/3: Генерация распознаваемой выборки на основе базы событий "EventsKR"')) SELECT EventsKR DBGOTOP() n = 0 DO WHILE .NOT. EOF() // Формирование записи БД заголовков объектов распознаваемой выборки M_Recno = RECNO() M_KodObj = M_Recno M_NameObj = Name_obj SELECT Rso_Zag APPEND BLANK REPLACE Kod_obj WITH M_KodObj REPLACE Name_obj WITH M_NameObj *** Формирование массива кодов классов из БД EventsKR SELECT EventsKR A_KodCls := {} // Массив базовых кодов классов текущего объекта распознаваемой выборки FOR ff = M_ClSc1 TO M_ClSc2 DBGOTO(M_Recno) Fv = FIELDGET(ff) AADD(A_KodCls, Fv) FOR N_Gorizont = mGorizMin TO mGorizMax mScen = A_FNRus[ff] + '-FUTURE'+ALLTRIM(STR(N_Gorizont)) + '-' SELECT EventsKR DBGOTO(M_Recno) DBSKIP(1) // Код текущей записи тоже включать в сценарий? mGorizont = 1 DO WHILE .NOT. EOF() .AND. mGorizont <= N_Gorizont // Градации класс.шкалы ************************************ mFV = FIELDGET(ff) IF mFV > 0 mSimb = STRTRAN(STR(mFV,mMaxLenKCls),' ','0') IF LEN(mSimb) > 0 mt = mScen + mSimb + IF(mGorizont 0 // Если такой сценарий есть в справочнике - занести его код в объект распознаваемой выборки * IF ASCAN(A_KodCls, M_KodCls) = 0 // Каждый код вносить только 1 раз AADD( A_KodCls, M_KodCls) * ENDIF ENDIF ENDIF NEXT NEXT ******* Формирование массива кодов признаков из базы событий EventsKR SELECT EventsKR A_KodAtr = {} // Массив кодов признаков текущего объекта распознаваемой выборки FOR ff=M_OpSc1 TO M_OpSc2 // Начало цикла по полям БД DBGOTO(M_Recno) IF aErrorNum[ff] // Если есть вариабельность DBGOTO(M_Recno) Fv = FIELDGET(ff) AADD(A_KodAtr, Fv) FOR N_Glubina = mGlubMin TO mGlubMax mScen = A_FNRus[ff] + '-PAST'+ALLTRIM(STR(N_Glubina)) + '-' SELECT EventsKR mGlubina = 1 DBGOTO(M_Recno-N_Glubina+1) * DBSKIP(1) // Код текущей записи тоже включать в сценарий? DO WHILE .NOT. EOF() .AND. mGlubina <= N_Glubina // Градации класс.шкалы ************************************ mFV = FIELDGET(ff) IF mFV > 0 mSimb = STRTRAN(STR(mFV,mMaxLenKAtr),' ','0') IF LEN(mSimb) > 0 mt = mScen + mSimb + IF(mGlubina < N_Glubina,',','') ++mGlubina mScen = ALLTRIM(SUBSTR(mt,1,255)) ENDIF ENDIF DBSKIP(1) ENDDO IF mGlubina = N_Glubina + 1 M_KodAtr = ASCAN(A_NameAtr, mScen) IF M_KodCls > 0 // Если такой сценарий есть в справочнике - занести его код в объект распознаваемой выборки * IF ASCAN(A_KodAtr, M_KodAtr) = 0 AADD( A_KodAtr, M_KodAtr) * ENDIF ENDIF ENDIF NEXT ENDIF NEXT * DC_DebugQout( A_KodCls, A_KodAtr ) ****** Запись массива кодов классов в БД Rso_Kcl * ASORT(A_KodCls) SELECT Rso_Kcl APPEND BLANK FIELDPUT(1,M_KodObj) IF LEN(A_KodCls) > 0 k=2 FOR jj=1 TO LEN(A_KodCls) IF k <= 5 FIELDPUT(k++,A_KodCls[jj]) ELSE k=2 APPEND BLANK FIELDPUT(1,M_KodObj) FIELDPUT(k++,A_KodCls[jj]) ENDIF NEXT ENDIF ****** Запись массива кодов признаков в БД Rso_Kpr * ASORT(A_KodAtr) SELECT Rso_Kpr APPEND BLANK FIELDPUT(1,M_KodObj) IF LEN(A_KodAtr) > 0 k=2 FOR jj=1 TO LEN(A_KodAtr) IF k <= 8 FIELDPUT(k++,A_KodAtr[jj]) ELSE k=2 APPEND BLANK FIELDPUT(1,M_KodObj) FIELDPUT(k++,A_KodAtr[jj]) ENDIF NEXT ENDIF ****** Формирование массивов кодов классов и признаков для БД EventsKRs. ДЛЯ ОТЛАДКИ РЕЖИМА: "СЦЕНАРНЫЙ МЕТОД АСК-АНАЛИЗА" ****** Копирование кодов базовых классов и базовых признаков EventsKR => EventsKRs SELECT EventsKR DBGOTOP() DO WHILE .NOT. EOF() IF mRecSizeEvKRs * (n+1) > 2 * 10^9 // Не создавать файл больше 2 Гб EXIT ELSE aR := {} FOR j=1 TO FCOUNT()-2 AADD(aR, FIELDGET(j)) NEXT n++ SELECT EventsKRs APPEND BLANK // <<<===########################### FOR j=1 TO LEN(aR) FIELDPUT(j, aR[j]) NEXT ENDIF SELECT EventsKR DBSKIP(1) ENDDO SELECT EventsKRs IF M_Recno <= RECCOUNT() DBGOTO(M_Recno) ****** Запись массива кодов классов в БД EventsKRs ********************** mKodCls = '' nKodCls = LEN(A_KodCls) FOR j=1 TO nKodCls IF A_KodCls[j] > 0 mKodCls = mKodCls + '[' + ALLTRIM(STR(A_KodCls[j])) + ']-' + A_NameCls[A_KodCls[j]] + IF(j255,'...','') ****** Запись массива кодов признаков в БД EventsKRs ******************** mKodAtr = '' nKodAtr = LEN(A_KodAtr) FOR j=1 TO nKodAtr IF A_KodAtr[j] > 0 mKodAtr = mKodAtr + '[' + ALLTRIM(STR(A_KodAtr[j])) + ']-' + A_NameAtr[A_KodAtr[j]] + IF(j255,'...','') ENDIF lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) SELECT EventsKR DBGOTO(M_Recno) DBSKIP(1) ENDDO aSay[2]:SetCaption(aSay[2]:caption+L(' - Готово ')) *************************************************************************************************** **** Конец генерации распознаваемой выборки на основе базы событий "EventsKR" ************************** *************************************************************************************************** ENDCASE *######################################################################################################################################### *######################################################################################################################################### ENDIF // Конец режима 2 (ввод распознаваемой выборки) ******************************************************************************* ** КОНЕЦ ГЕНЕРАЦИИ РАСПОЗНАВАЕМОЙ ВЫБОРКИ ************************************* ################################################### ******************************************************************************* *************************************************************************************************************************** // Заново создаются все необходимые для работы системы индексные массивы общесистемных баз данных // (находящихся в папке с исполнимым модулем системы), а также баз данных текущего приложения, // необходимые для работы с ним, взято из F5_7() *************************************************************************************************************************** // Шкалы, градации и обучающая выборка ********************************************************************************* IF Regim = 1 // Генерация шкал, градаций и обучающей выборки ************************ IF M_Interval=1.AND..NOT.M_Scenario;aSay[3]:SetCaption(L('3/3: Переиндексация всех баз данных нового приложения'));ENDIF IF M_Interval=1.AND. M_Scenario;aSay[5]:SetCaption(L('5/5: Переиндексация всех баз данных нового приложения'));ENDIF IF M_Interval=2.AND..NOT.M_Scenario;aSay[3]:SetCaption(L('3/3: Переиндексация всех баз данных нового приложения'));ENDIF IF M_Interval=2.AND. M_Scenario;aSay[5]:SetCaption(L('5/5: Переиндексация всех баз данных нового приложения'));ENDIF GenNtxClass() // Классификационные шкалы и градации lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) GenNtxClSc() // Классификационные шкалы lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) GenNtxGrClSc() // Градации классификационных шкал lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) GenNtxAttr() // Описательные шкалы и градации lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) GenNtxOpSc() // Описательные шкалы lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) GenNtxGrOpSc() // Градации описательных шкал lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) GenNtxObiZag() // Заголовки объектов обучающей выборки lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) GenNtxObiKcl() // Коды классов объектов обучающей выборки lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) GenNtxObiKpr() // Коды признаков объектов обучающей выборки lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) GenNtxRsoZag() // Заголовки объектов распознаваемой выборки lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) GenNtxRsoKcl() // Коды классов объектов распознаваемой выборки lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) GenNtxRsoKpr() // Коды признаков объектов распознаваемой выборки lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) IF M_Interval=1.AND..NOT.M_Scenario;aSay[3]:SetCaption(aSay[3]:caption+L(' - Готово '));ENDIF IF M_Interval=1.AND. M_Scenario;aSay[5]:SetCaption(aSay[5]:caption+L(' - Готово '));ENDIF IF M_Interval=2.AND..NOT.M_Scenario;aSay[3]:SetCaption(aSay[3]:caption+L(' - Готово '));ENDIF IF M_Interval=2.AND. M_Scenario;aSay[5]:SetCaption(aSay[5]:caption+L(' - Готово '));ENDIF ENDIF // Распознаваемая выборка ************************************************************************************************ IF Regim = 2 IF M_Interval=1.AND..NOT.M_Scenario;aSay[2]:SetCaption(L('2/2: Переиндексация всех баз данных распознаваемой выборки'));ENDIF IF M_Interval=1.AND. M_Scenario;aSay[3]:SetCaption(L('3/3: Переиндексация всех баз данных распознаваемой выборки'));ENDIF IF M_Interval=2.AND..NOT.M_Scenario;aSay[2]:SetCaption(L('2/2: Переиндексация всех баз данных распознаваемой выборки'));ENDIF IF M_Interval=2.AND. M_Scenario;aSay[3]:SetCaption(L('3/3: Переиндексация всех баз данных распознаваемой выборки'));ENDIF GenNtxRsoZag() // Заголовки объектов распознаваемой выборки lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) GenNtxRsoKcl() // Коды классов объектов распознаваемой выборки lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) GenNtxRsoKpr() // Коды признаков объектов распознаваемой выборки lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) IF M_Interval=1.AND..NOT.M_Scenario;aSay[2]:SetCaption(aSay[2]:caption+L(' - Готово '));ENDIF IF M_Interval=1.AND. M_Scenario;aSay[3]:SetCaption(aSay[3]:caption+L(' - Готово '));ENDIF IF M_Interval=2.AND..NOT.M_Scenario;aSay[2]:SetCaption(aSay[2]:caption+L(' - Готово '));ENDIF IF M_Interval=2.AND. M_Scenario;aSay[3]:SetCaption(aSay[3]:caption+L(' - Готово '));ENDIF ENDIF lOk = Time_Progress (Wsego, Wsego, oProgress, lOk ) // Гарантированные 100% *************************************************************************************************************************** *** Окончание переиндексации всех баз данных нового приложения ************************************************************ *************************************************************************************************************************** ******** Сформировать в БД Class_Sc информацию по числу классов и начальным и конечным кодам классов в класс.шкале aMess := {} mFlagCls = ClSc_Ngr() IF !mFlagCls AADD(aMess, L(' ')) AADD(aMess, L('Классификационные шкалы не сформированы.')) ENDIF ******** Сформировать в БД Opis_Sc информацию по числу признаков и начальным и конечным кодам признаков в опис.шкале mFlagAtr = OpSc_Ngr() IF !mFlagAtr AADD(aMess, L(' ')) AADD(aMess, L('Описательные шкалы не сформированы.')) ENDIF IF !mFlagCls .OR. !mFlagAtr AADD(aMess, L(' ')) AADD(aMess, L('Варианты действия:')) AADD(aMess, L('- попробуйте считать нули и пробелы значащими;')) AADD(aMess, L('- заменить числовые шкалы аналогичыми текстовыми;')) AADD(aMess, L('- изменить диапазоны классификационных и описательных шкал;')) AADD(aMess, L('- задать адаптивные интервалы (разного размера с примерно равным числом наблюдений).')) LB_Warning(aMess, L('2.3.2.2. Универсальный программный интерфейс импорта данных в систему "ЭЙДОС-X++"')) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF **************************************************************************************************** *Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time *nMax = N_InpFiles *Mess = L('2.3.2.6. Объединение нескольких файлов исходных данных в один' *@ 4,5 DCPROGRESS oProgress SIZE 70,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 *DCREAD GUI TITLE Mess PARENT @oDialog FIT EXIT *oDialog:show() *nTime = 0 *DC_GetProgress(oProgress,0,nMax) *FOR ff=1 TO N_InpFiles * DC_GetProgress(oProgress, ++nTime, nMax) *NEXT **MsgBox('STOP') *DC_GetProgress(oProgress,nMax,nMax) *oDialog:Destroy() *Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time **************************************************************************************************** ** Сформировать БД средних по классам Inp_davr.dbf с такой же структурой, как Inp_data ** но столбцы классов сделать текстового типа и записать туда нименования классов из справочника IF mClsAvr .AND. Regim = 1 ** Если ввод исходных данных был из Inp_data.dbf сделать эти файлы в папке приложения и в ..\Aid_data\Inp_data\: aInp_name = DC_ARestore("_Inp_name.arx") // Загрузка массива наименований шкал (колонок) из файла aColumnNames = DC_ARestore("_ColumnNames.arx") // Загрузка массива наименований шкал (колонок) из файла N_Col = LEN(aInp_name) // Число колонок в БД EventsKO CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций COPY FILE ("EventsKO.dbf") TO ("EventsTmp.dbf") CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Inp_data EXCLUSIVE NEW;N_Obj = RECCOUNT() nMax = N_Cls + N_Obj + N_Obj * ( M_ClSc2 - M_ClSc1 + 1 ) Mess = L('Формирование базы средних по классам: "Inp_davr.dbf"') @ 4,5 DCPROGRESS oProgr SIZE 70,1.1 MAXCOUNT nMax COLOR aColor[153] PERCENT EVERY 100 DCREAD GUI TITLE Mess PARENT @oDial FIT EXIT oDial:show() nTime = 0 DC_GetProgress(oProgr,0,nMax) ****** Сформировать массив наименований классов SELECT Classes aNameCls := {} mLenNObj = -9999999 DBGOTOP() DO WHILE .NOT. EOF() AADD(aNameCls, ALLTRIM(Name_cls)) mLenNObj = MAX(mLenNObj, LEN(L('Среднее по классу: ')+ALLTRIM(Name_cls))) DC_GetProgress(oProgr, ++nTime, nMax) DBSKIP(1) ENDDO ***** Создание БД Inp_davr.dbf с минимальной достаточной длиной наименования объекта обуч.выборки CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Inp_data EXCLUSIVE NEW * COPY STRUCTURE TO Inp_davr.dbf aStruct := DbStruct() aStructure := { { "Name_obj" , "C", mLenNObj, 0 } } * FOR j = 2 TO FCOUNT() FOR j = 2 TO LEN(aStruct)-1 AADD(aStructure, aStruct[j] ) NEXT DbCreate( 'Inp_davr', aStructure ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE EventsTmp EXCLUSIVE NEW;N_Obj = RECCOUNT() USE Inp_data EXCLUSIVE NEW USE Inp_davr EXCLUSIVE NEW ****** Подготовить БД EventsTmp: вместо наименования объекта обуч.выборки записать номер записи в исходной БД SELECT EventsTmp PRIVATE aInpDavr[FCOUNT()] DBGOTOP() DO WHILE .NOT. EOF() FIELDPUT(1, STRTRAN(STR(RECNO(),15),' ','0')) DC_GetProgress(oProgr, ++nTime, nMax) DBSKIP(1) ENDDO FOR ff = M_ClSc1 TO M_ClSc2 // Цикл по столбцам классов ****** Сортировать EventsTmp по кодам классов, а данные брать из соответствующих записей Inp_data ****** суммировать их и подсчитывать их количество, пока не поменяется код класса, ****** а как только поменяется - сразу записывать среднее в БД Inp_davr, обнулять массив и счетчик и продолжать далее для всех столбцов классов SELECT EventsTmp INDEX ON STR(FIELDGET(ff),15) TO Inp_davr DBGOTOP() nNZap = 0 mRecno = VAL(FIELDGET(1)) mKodCls = FIELDGET(ff) AFILL(aInpDavr, 0) DO WHILE .NOT. EOF() IF mKodCls = FIELDGET(ff) ++nNZap SELECT Inp_data DBGOTO(mRecno) FOR j = 1 TO FCOUNT() // Цикл по всем столбцам IF FIELDTYPE(j) = 'N' aInpDavr[j] = aInpDavr[j] + FIELDGET(j) ENDIF NEXT ELSE SELECT Inp_davr APPEND BLANK FOR j = 1 TO FCOUNT() // Цикл по всем числовым столбцам IF FIELDTYPE(j) = 'N' FIELDPUT(j, aInpDavr[j]/nNZap) ENDIF NEXT IF mKodCls > 0 FIELDPUT(1, 'Среднее по классу: '+aNameCls[mKodCls]) ENDIF SELECT EventsTmp nNZap = 0 mRecno = VAL(FIELDGET(1)) mKodCls = FIELDGET(ff) AFILL(aInpDavr, 0) ++nNZap SELECT Inp_data DBGOTO(mRecno) FOR j = 1 TO FCOUNT() // Цикл по всем столбцам IF FIELDTYPE(j) = 'N' aInpDavr[j] = aInpDavr[j] + FIELDGET(j) ENDIF NEXT ENDIF DC_GetProgress(oProgr, ++nTime, nMax) SELECT EventsTmp DBSKIP(1) mRecno = VAL(FIELDGET(1)) ENDDO SELECT Inp_davr APPEND BLANK FOR j = 1 TO FCOUNT() // Цикл по всем числовым столбцам IF FIELDTYPE(j) = 'N' FIELDPUT(j, aInpDavr[j]/nNZap) ENDIF NEXT IF mKodCls > 0 FIELDPUT(1, 'Среднее по классу: '+aNameCls[mKodCls]) ENDIF NEXT * MsgBox('STOP') DC_GetProgress(oProgr,nMax,nMax) oDial:Destroy() **** Скопировать в папку Inp_data файлы с наименованиями колонок: Inp_nameAll.txt, Inp_name.txt, _ColumnNames.arx DIRCHANGE(Disk_dir) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Appls EXCLUSIVE NEW SELECT Appls DBGOTOP() FlagAppl = .T. DO WHILE .NOT. EOF() IF LEN(ALLTRIM(BY_DEFAULT )) > 0 FlagAppl = .F. mApplName = ALLTRIM(Name_Appl) mPathAppl = ALLTRIM(Path_appl) ENDIF DBSKIP(1) ENDDO CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций Name_SS = mPathAppl+"Inp_data.dbf" Name_DD = Disk_dir +"\AID_DATA\Inp_data\Inp_data.dbf" * MsgBox(Name_SS) * MsgBox(Name_DD) COPY FILE (Name_SS) TO (Name_DD) Name_SS = mPathAppl+"Inp_davr.dbf" Name_DD = Disk_dir +"\AID_DATA\Inp_data\Inp_davr.dbf" COPY FILE (Name_SS) TO (Name_DD) Name_SS = mPathAppl +"Inp_name.txt" Name_DD = Disk_dir +"\AID_DATA\Inp_data\Inp_name.txt" COPY FILE (Name_SS) TO (Name_DD) Name_SS = mPathAppl +"Inp_nameAll.txt" Name_DD = Disk_dir +"\AID_DATA\Inp_data\Inp_nameAll.txt" COPY FILE (Name_SS) TO (Name_DD) Name_SS = mPathAppl +"_ColumnNames.arx" Name_DD = Disk_dir +"\AID_DATA\Inp_data\_ColumnNames.arx" COPY FILE (Name_SS) TO (Name_DD) * ***** Запись БД Inp_davr в виде Excel-файла с именами колонок из Inp_data.xls * ***** Попробовать преобразовать Inp_davr.dbf и _ColumnNames.arx в Inp_davr.xls * DIRCHANGE(Disk_dir +"\AID_DATA\Inp_data\") * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * USE Inp_davr EXCLUSIVE NEW * SELECT Inp_davr * aColumnNames = DC_ARestore("_ColumnNames.arx") // Загрузка массива наименований шкал (колонок) из файла * cExcelFile = Disk_dir +"\AID_DATA\Inp_data\Inp_davr.xls" // Необходимо полное имя * DC_WorkArea2Excel(cExcelFile,,,,,,,,, aColumnNames ) // Модифицированная функция Роджера ENDIF ***************************************************************************************************** DO CASE CASE Regim = 1 Mess = L("ПРОЦЕСС ФОРМАЛИЗАЦИИ ПРЕДМЕТНОЙ ОБЛАСТИ ЗАВЕРШЕН УСПЕШНО !!!") CASE Regim = 2 Mess = L("ПРОЦЕСС ГЕНЕРАЦИИ РАСПОЗНАВАЕМОЙ ВЫБОРКИ ЗАВЕРШЕН УСПЕШНО!!!") ENDCASE Running(.T.) // Чтобы не могли запустить какой-нибудь режим пока висит окно окончания работы oSay97:SetCaption(Mess) oSay97:SetCaption(oSay97:Caption) oButton:SetCaption(L('&Ok')) // Деструктурирование окна отображения графического Progress-bar oButton:activate := {||PostAppEvent(xbeP_Close,,,oDialog)} //<<<<<< Add This DC_AppEvent( @lOk ) oDialog:Destroy() ** В Aidos-X это ограничение отсутствует, а в Aidos-XD есть ***************************************** *IF LEN(A_NameCls) > 2035 * aMess := {} * AADD(aMess, L('В процессе формализации предметной области получилось # классов, что более 2035 !')) * aMess[1] = STRTRAN(aMess[1], "#", ALLTRIM(STR(LEN(A_NameCls)))) * AADD(aMess, L('При таком количестве классов синтез модели в 3-й подсистеме невозможен и надо его уменьшить.')) * AADD(aMess, L("Для этого нужно уменьшить количество интервалов в числовых шкалах и/или горизонт прогнозирования")) * LB_Warning(aMess, L('2.3.2.2. Универсальный программный интерфейс импорта данных в систему "ЭЙДОС-X++"')) *ENDIF ** ЕСЛИ В СТОЛБЦЕ НЕТ РАЗЛИЧИЯ ГРАДАЦИЙ, ТО ИГНОРИРОВАТЬ ЕГО ################################################# IF M_XlsDbf=3 // Inp_data.dbf *************************************************************************************************** **** Проверить все колонки Inp_data.dbf (а в Inp_rasp.dbf просто их обходит) на вариабельность значений, **** Сделать массив номеров колонок со значениями: .T., если есть варибельность, и .F., если ее нет **** При формализации пр.олбл. записать этот массив в виде файла arx, а при расп. скачать и использовать **** Если такие колонки есть, то сделать об этом сообщение (типа того, что есть в конце), **** При всех обработках клонок пропускать эти колонки DO CASE CASE Regim=1 DIRCHANGE(Disk_dir +"\AID_DATA\Inp_data\") CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Inp_data EXCLUSIVE NEW SELECT Inp_data PRIVATE aErrorNum[FCOUNT()] AFILL(aErrorNum,.F.) // Массив для обхода колонок, в которых нет варабельности FOR ff=2 TO FCOUNT() DBGOTOP() mFv = FIELDGET(ff) DO WHILE .NOT. EOF() IF mFv <> FIELDGET(ff) // Если значение поля в первой записи отличается от какого-нибудь другого aErrorNum[ff] = .T. EXIT ENDIF DBSKIP(1) ENDDO NEXT *** Отладка ************** *DC_DebugQout( aInp_name ) *LB_Warning(aInp_name) *LB_Warning(aErrorNum) aErrorVar := {} // Номера и имена колонок, в которых нет варабельности (для сообщения) IF LEN(aInp_name) > 0 FOR ff=2 TO LEN(aErrorNum) IF .NOT. aErrorNum[ff] IF ff-1 <= LEN(aInp_name) AADD(aErrorVar, '['+ALLTRIM(STR(ff))+'] - "'+ALLTRIM(aInp_name[ff])+'"') ENDIF ENDIF NEXT ENDIF ** Записать массив на диск DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы aErrorNum = DC_ARestore(Disk_dir +"\_ErrorNum.arx") * DC_ASave(aErrorNum , Disk_dir +"\_ErrorNum.arx") DIRCHANGE(Disk_dir +"\AID_DATA\Inp_data\") CASE Regim=2 ** Загрузить массив с диска DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы aErrorNum = DC_ARestore(Disk_dir +"\_ErrorNum.arx") * DC_ASave(aErrorNum , Disk_dir +"\_ErrorNum.arx") DIRCHANGE(Disk_dir +"\AID_DATA\Inp_data\") CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Inp_rasp EXCLUSIVE NEW SELECT Inp_rasp ENDCASE *************************************************************************************************** ENDIF IF Regim=1 // Только если не Inp_rasp IF LEN(aErrorVar) > 0 aMess := {} AADD(aMess, L('В процессе формализации предметной области обнаружилось')+' '+ALLTRIM(STR(LEN(aErrorVar)))+' '+L('шкал(ы), без вариабельности градаций, т.е. у них значения всех градаций одинаковые,')) AADD(aMess, L('Поэтому эти шкалы были проигнорированы, т.е. не были использованы для формирования классификационных и описательных шкал и градаций:')) AADD(aMess, L(' ')) FOR j=1 TO LEN(aErrorVar) AADD(aMess, ALLTRIM(aErrorVar[j])) NEXT AADD(aMess, L(' ')) AADD(aMess, L('Варианты действий:')) AADD(aMess, L('- удалить эти шкалы из файла: "Inp_data";')) AADD(aMess, L('- ввести в эти шкалы значения градаций;')) AADD(aMess, L('- считать нули и пробелы значащими, а не отсутствием данных')) AADD(aMess, L(' если при этом сами данные представлены не нулями и пробелами;')) AADD(aMess, L('- ничего не делать (все равно все будет работать).')) LB_Warning(aMess, L('2.3.2.2. Универсальный программный интерфейс импорта данных в систему "ЭЙДОС-X++"')) ENDIF ENDIF oScr := DC_WaitOn(L('Расчет числа градаций в классифкационных и описательных шкалах'),,,,,,,,,,,.F.) IF ApplChange("") // Перейти в папку выбранного приложения или выйти из системы LB_Warning(L("Необходимо задать (выбрать) хотя бы одно текущее приложение !!!")) Running(.F.) RETURN NIL ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Class_Sc EXCLUSIVE NEW USE Gr_ClSc EXCLUSIVE NEW USE Classes EXCLUSIVE NEW USE Opis_Sc EXCLUSIVE NEW USE Gr_OpSc EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW MinMaxGrOpSc() MinMaxGrClSc() DC_Impl(oScr) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL * ################################################################################### * Здесь заканчивается программный интерфейс с внешними базами данных F2_3_2_2() * ################################################################################### **************************************************************** ******** Помощь по режиму 2_3_2_2 для dbf-файлов исходных данных **************************************************************** FUNCTION Help2322dbf() aHelp := {} AADD(aHelp, L('Режим 2.3.2.2 УНИВЕРСАЛЬНЫЙ ПРОГРАММНЫЙ ИНТЕРФЕЙС ИМПОРТА ДАННЫХ ИЗ ВНЕШНЕЙ БАЗЫ ДАННЫХ ')) AADD(aHelp, L('"INP_DATA.DBF" В СИСТЕМУ "ЭЙДОС-Х++" И ФОРМАЛИЗАЦИИ ПРЕДМЕТНОЙ ОБЛАСТИ. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Данный программный интерфейс обеспечивает автоматическое формирование классификационных и описательных шкал и градаций, а')) AADD(aHelp, L('также обучающей и распознаваемой выборки, т.е. формализацию предметной области, на основе DBF-файла с исходными данными ')) AADD(aHelp, L('приведенного ниже стандарта. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Этот DBF-файл должен иметь имя: INP_DATA.DBF и может быть получен в Excel (до версии 2003), или OpenOffice Calc если ')) AADD(aHelp, L('выбрать *Сохранить как* и задать тип файла: DBF 4, dBASE IV. Каждая строка этого файла содержит данные об одном объекте ')) AADD(aHelp, L('обучающей выборки. Столбцы являются классификационными и описательными шкалами и могут быть текстового (номинального), ')) AADD(aHelp, L('целого (порядкового) или числового типа (с десятичными знаками). Если в столбце числового типа все знаки после запятой ')) AADD(aHelp, L('значений во всех строках равны нулю, то столбец считается целого типа. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('1-й столбец содержит наименование источника данных длиной <=255 символов. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Столбцы со 2-го по N-й являются классификационными шкалами и содержат информацию о классах, к которым принадлежат объекты')) AADD(aHelp, L('обучающей выборки. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Столбцы с N+1 по последний являются описательными шкалами и содержат информацию о признаках, характеризующих эти объекты.')) AADD(aHelp, L(' ')) AADD(aHelp, L('Русские наименования классификационных и описательных ШКАЛ должны быть СТРОКАМИ в файле с именем INP_NAME.TXT стандарта: ')) AADD(aHelp, L('MS DOS(кириллица).Чтобы получить файл INP_NAME.TXT из Excel-файла INP_DATA.XLS необходимо выделить строку с ')) AADD(aHelp, L('наименованиями столбцов блоком и перенести ее в Word, а затем преобразовать таблицу в текст с разделителем - знаком ')) AADD(aHelp, L('абзаца и сохранить Word-файл как INP_NAME.TXT текст MS-DOS. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Файлы: INP_DATA.DBF и INP_NAME.TXT должны находиться в папке: /AID_DATA/Inp_data/ ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Система находит минимальное и максимальное числовые значения в каждом числовом столбце и формирует заданное количество ')) AADD(aHelp, L('числовых интервалов. Затем числовые значения заменяются их интервальными значениями. Каждое УНИКАЛЬНОЕ текстовое или ')) AADD(aHelp, L('интервальное числовое значение считается градацией классификационной или описательной шкалы, характеризующей объект. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Затем с использованием этой информации генерируется обучающая или распознаваемая выборка (файл: EventsKO.DBF), каждый ')) AADD(aHelp, L('объект которой соответствует одной строке файла исходных данных INP_DATA.DBF и содержит коды классов, соответствующие ')) AADD(aHelp, L('фактам совпадения числовых или уникальных текстовых значений классов с градациями классификационных шкал (только для ')) AADD(aHelp, L('обучающей выборки), и коды признаков, соответствующие фактам совпадения числовых или уникальных текстовых значений ')) AADD(aHelp, L('признаков с градациями описательных шкал. ')) mHelpMax = -999;FOR h=1 TO LEN(aHelp);mHelpMax = MAX(mHelpMax, LEN(ALLTRIM(aHelp[h])));NEXT s=1;d=0.9;@0,0 DCGROUP oGroup1 CAPTION L(' ') SIZE mHelpMax-10, LEN(aHelp)*d+1.5 FOR h=1 TO LEN(aHelp);@s,2 DCSAY aHelp[h] SIZE 0 PARENT ogroup1;s=s+d;NEXT DCREAD GUI TO lExit FIT MODAL TITLE L('Помощь по режиму 2.3.2.2 для случая dbf-файлов исходных данных. (C) Система "ЭЙДОС-X++"') RETURN NIL ************************************************************************************************** ***************************************************************************** **************************************************************** ******** Помощь по режиму 2_3_2_2 для xls-файлов исходных данных **************************************************************** FUNCTION Help2322xls() aHelp := {} AADD(aHelp, L('Режим 2.3.2.2: Универсальный программный интерфейс импорта данных из внешней базы ')) AADD(aHelp, L('данных "Inp_data.xls" в систему "Эйдос-X++" и формализации предметной области. ')) AADD(aHelp, L('- Данный программный интерфейс обеспечивает формализацию предметной области, т.е. анализ файла исходных данных Inp_data.xls(x), ')) AADD(aHelp, L('формирование классификационных и описательных шкал и градаций, а затем кодирование файла исходных с их использованием. ')) AADD(aHelp, L('- Файл исходных данных должен иметь имя: Inp_data.xls(x), а файл распознаваемой выборки имя: Inp_rasp.xls(x). Файлы Inp_data.xls(x) и')) AADD(aHelp, L('Inp_rasp.xls(x) должны находиться в папке ../AIDOS-X/AID_DATA/Inp_data/. Эти файлы имеют совершенно одинаковую структуру. ')) AADD(aHelp, L(' - 1-я строка этого файла должна содержать наименования колонок на любом языке, в т.ч. и русском. Эти наименования должны быть во ')) AADD(aHelp, L('всех колонках, при этом переносы по словам разрешены, а объединение ячеек, разрыв строки знак абзаца не допускаются. Эти наименования')) AADD(aHelp, L('должны быть короткими, но понятными, т.к.они будут в выходных формах, а к ним еще будут добавляться наименования градаций. В числовых')) AADD(aHelp, L('шкалах надо ОБЯЗАТЕЛЬНО указывать единицы измерения и число знаков после запятой в колонке должно быть ОДИНАКОВОЕ. ')) AADD(aHelp, L('- 1-я колонка содержит наименование объекта обучающей выборки или наименование наблюдения. Оно может быть длинным: до 255 символов. ')) AADD(aHelp, L('- Каждая строка этого файла, начиная со 2-й, содержит данные об одном объекте обучающей выборки или одном наблюдении. В MS Excel-2003')) AADD(aHelp, L('в листе может быть до 65536 строк и до 256 колонок. В листе MS Excel-2010 и более поздних возможно до 1048576 строк и 16384 колонок. ')) AADD(aHelp, L(' - Столбцы, начиная со 2-го, являются классификационными и описательными шкалами и могут быть текстового (номинального / порядкового)')) AADD(aHelp, L('или числового типа (с десятичными знаками после запятой). ')) AADD(aHelp, L(' - Столбцу присваивается числовой тип, если все значения его ячеек числового типа. Если хотя бы одно значение является текстовым (не ')) AADD(aHelp, L('числом, в т.ч. пробелом), то столбцу присваивается текстовый тип. Это означает, что нули должны быть указаны нулями, а не пробелами. ')) AADD(aHelp, L('- Столбцы со 2-го по N-й являются классификационными шкалами (выходными параметрами) и содержат данные о классах (будущих состояниях ')) AADD(aHelp, L('объекта управления), к которым принадлежат объекты обучающей выборки. ')) AADD(aHelp, L('- Столбцы с N+1 по последний являются описательными шкалами (свойствами или факторами) и содержат данные о признаках (т.е. значениях ')) AADD(aHelp, L('свойств или значениях факторов), характеризующих объекты обучающей выборки. ')) AADD(aHelp, L('- В результате работы режима формируется файл INP_NAME.TXT стандарта MS DOS (кириллица), в котором наименования классификационных и ')) AADD(aHelp, L('описательных шкал являются СТРОКАМИ. Система формирует классификационные и описательные шкалы и градации. Для этого в каждом числовом')) AADD(aHelp, L('столбце система находит минимальное и максимальное числовые значения и формирует заданное количество числовых интервалов, после чего ')) AADD(aHelp, L('числовые значения заменяются их интервальными значениями. В текстовых столбцах система находит уникальные текстовые значения. Каждое ')) AADD(aHelp, L('УНИКАЛЬНОЕ интервальное числовое или текстовое значение считается градацией классификационной или описательной шкалы, характеризующей')) AADD(aHelp, L('объект. В каждой шкале ее градации сортируются по алфавиту. С использованием шкал и градаций кодируются исходные данные в результате ')) AADD(aHelp, L('чего генерируется обучающая выборка, каждый объект которой соответствует одной строке файла исходных данных NP_DATA и содержит коды ')) AADD(aHelp, L('классов, соответствующие фактам совпадения числовых или уникальных текстовых значений классов с градациями классификационных шкал и ')) AADD(aHelp, L('коды признаков, соответствующие фактам совпадения числовых или уникальных текстовых значений признаков с градациями описательных шкал')) AADD(aHelp, L('- Распознаваемая выборка формируется на основе файла INP_RASP аналогично, за исключением того, что классификационные и описательные ')) AADD(aHelp, L('шкалы и градации не создаются, а используются ранее созданные в модели, и базы распознаваемой выборки могут не включать коды классов,')) AADD(aHelp, L('если столбцы классов в файле INP_RASP были пустыми. Структура файла INP_RASP должна быть такая же, как INP_DATA, т.е. они должны ')) AADD(aHelp, L('ПОЛНОСТЬЮ совпадать по наименованиям столбцов, но могут иметь разное количество строк с разными значениями в них. ')) mHelpMax = -999;FOR h=1 TO LEN(aHelp);mHelpMax = MAX(mHelpMax, LEN(ALLTRIM(aHelp[h])));NEXT s=1;d=0.8;@0,0 DCGROUP oGroup1 CAPTION L(' ') SIZE mHelpMax-15, LEN(aHelp)*d+1.5 FOR h=1 TO LEN(aHelp);@s,2 DCSAY aHelp[h] SIZE 0 PARENT ogroup1;s=s+d;NEXT *DCREAD GUI TO lExit FIT MODAL TITLE L('Помощь по режиму: 2.2. (C) Система "ЭЙДОС-X++"') s=s+1.5*d @s,0 DCGROUP oGroup2 CAPTION L('Принцип организации таблицы исходных данных:') SIZE mHelpMax-15, 10.2 **** Если файл существует изображения и его контрольная сумма совпадает, то он отображается cFile = Disk_dir+"\Help2322.jpg" IF FILE(cFile) IF FILECHECK(cFile) = 9243019 @20,13.2 DCSTATIC TYPE XBPSTATIC_TYPE_BITMAP CAPTION cFile SIZE 800,132 PIXEL PARENT oGroup2 ELSE Mess = L('Графический файл: "#" поврежден и не может быть отображен! Контрольная сумма: "$" ') Mess = STRTRAN(Mess, "#", cFile) Mess = STRTRAN(Mess, "$", ALLTRIM(STR(FILECHECK(cFile),19))) // Отображение контрольной суммы файлы LB_Warning(Mess) ENDIF ENDIF ***** СДЕЛАТЬ <<<===############################## @7.9, 1.9 DCPUSHBUTTON CAPTION L('Определения основных терминов и профилактика типичных ошибок при подготовке Excel-файла исходных данных') SIZE mHelpMax-19, 1.5 ACTION {||Help2322err()} FONT( '10.Helvetica Bold') PARENT oGroup2 ***** СДЕЛАТЬ <<<===############################## DCREAD GUI FIT TITLE L('Помощь по режиму 2.3.2.2 для случая Excel-файлов исходных данных') ReTURN nil **************************************************************** ******** Помощь по режиму 2_3_2_2 для xls-файлов исходных данных **************************************************************** FUNCTION Help2322err() aHelp := {} AADD(aHelp, L('Режим 2.3.2.2: Универсальный программный интерфейс импорта данных из внешней базы данных "Inp_data.xls(x)" в систему "Эйдос-X++" ')) AADD(aHelp, L('ТЕРМИНЫ АСК-АНАЛИЗА И СИСТЕМЫ "ЭЙДОС": ')) AADD(aHelp, L('Шкала представляет собой способ формализации предметной области. Используется числовые и текстовые шкалы, при этом текстовые могут ')) AADD(aHelp, L('быть номинальными и порядковыми. На номинальных шкалах есть только отношения эквивалентности и неэквивалентности, на порядковых,кроме ')) AADD(aHelp, L('того еще отношения "больше", "меньше", а на числовых - кроме того могут выполняться все арифметические операции. Каждый объект выборки')) AADD(aHelp, L('(наблюдение) описан с одной стороны своими признаками, а с другой -принадлежностью к некоторым обобщающим категориям (классам). Такая ')) AADD(aHelp, L('структура описания называется онтологией или фреймом экземпляром и является базовой для всех моделей представления знаний. ')) AADD(aHelp, L('В АСК-анализе и системе "Эйдос" используется три интерпретации шкал и градаций: универсальная, статическая и динамическая: ')) AADD(aHelp, L('- в универсальной интерпретации: признаки - это градации описательных шкал; ')) AADD(aHelp, L('- в статической интерпретации: описательная шкала - это свойство, а градация (признак) - это степень выраженности этого свойства; ')) AADD(aHelp, L('- в динамической интерпретации: описательная шкала - это фактор, а градация (признак) - это значение фактора; ')) AADD(aHelp, L('- в универсальной интерпретации: классы - это градации классификационных шкал; ')) AADD(aHelp, L('- в статической интерпретации: классификационная шкала - способ классификации обобщающих категорий (классов), к которым в настоящем ')) AADD(aHelp, L('времени по отношению к признакам относятся состояния объекта моделирования; ')) AADD(aHelp, L('- в динамической интерпретации: классификационная шкала - способ классификации обобщающих категорий (классов), к которым в будущем ')) AADD(aHelp, L('времени по отношению к признакам относятся состояния объекта прогнозирования или управления; ')) AADD(aHelp, L('ПРОФИЛАКТИКА ОШИБОК В ФАЙЛЕ ИСХОДНЫХ ДАННЫХ: ')) AADD(aHelp, L('- 1-я строка файла "Inp_data.xls(x)" должна содержать наименования колонок. Эти наименования должны быть во всех колонках, при этом ')) AADD(aHelp, L('переносы по словам разрешены, а объединение ячеек, разрыв строки знак абзаца и неалфавитные символы не допускаются. Эти наименования ')) AADD(aHelp, L('должны быть короткими, но понятными, т.к.они будут в выходных формах, а к ним еще будут добавляться наименования градаций. В числовых ')) AADD(aHelp, L('шкалах надо обязательно указывать единицы измерения. Число знаков после запятой в числовой колонке должно быть одинаковым. ')) AADD(aHelp, L('- 1-я колонка содержит наименование объекта обучающей выборки или наименование наблюдения. Оно может быть длинным: до 255 символов. ')) AADD(aHelp, L('- Столбцы, начиная со 2-го, являются классификационными и описательными шкалами и могут быть текстового (номинального / порядкового) ')) AADD(aHelp, L('или числового типа (со знаками после запятой). Чтобы текстовая шкала была порядковой, нужно чтобы при сортировке по алфавиту градации ')) AADD(aHelp, L('этой шкалы образовывали осмысленную последовательность от минимального значения до максимального. Например, текстовая шкала "Размер" ')) AADD(aHelp, L('с градациями: "очень малое", "малое", "среднее", "большое", "очень большое", будет номинальной шкалой, т.к.при сортировке по алфавиту ')) AADD(aHelp, L('они расположатся в порядке: "большое", "малое", "очень большое", "очень малое", "среднее".Чтобы шкала "Размер" стала порядковой нужно ')) AADD(aHelp, L('в этим градациям присвоить следующие значения: "1/5-очень малое", "2/5-малое", "3/5-среднее", "4/5-большое", "5/5-очень большое". ')) AADD(aHelp, L('- Столбцу присваивается числовой тип, если все значения его ячеек числового типа. Если хотя бы одно значение является текстовым (не ')) AADD(aHelp, L('числом, в т.ч. пробелом), то столбцу присваивается текстовый тип. Это означает, что нули должны быть указаны нулями, а не пробелами. ')) AADD(aHelp, L('Если в системе "Эйдос" в режимах 2.1, 2.2 посмотреть на градации классификационных и описательных шкал, которые должны быть числовыми,')) AADD(aHelp, L('то сразу будет видно, в какой форме представлены числа: числовыми диапазонами или прямо числами. Если числовыми диапазонами, значит в ')) AADD(aHelp, L('файле исходных данных в этом отношении все правильно, если же числами, то возможно в Excel-файле нужно заменить десятичные точки на ')) AADD(aHelp, L('запятые, а также найти и исправить нечисловые данные в числовых по смыслу колонках. Быстро найти их можно перейдя на последнюю строку ')) AADD(aHelp, L('файла исходных данных и задав расчет суммы колонки. В формуле будет видно с какой строки идет расчет суммы. Если со 2-й, то значит ')) AADD(aHelp, L('все верно, иначе будет указана строка, в которой находится нечисловое значение. ')) AADD(aHelp, L('- Система "Эйдос" работает с областью данных файла исходных данных, которую можно выделить блоком, поставив курсор в ячейку A1, нажав ')) AADD(aHelp, L('Ctrl+Home, а затем зажав клавиши Shift+Ctrl нажать End. Если этот блок выходит за пределы области таблицы, фактически занятой данными ')) AADD(aHelp, L('надо скопировать эту фактическую область данных в буфер обмена, создать новый лист и скопировать в него, а исходный лист удалить. ')) AADD(aHelp, L('- Иногда бывает полезно сбросить все форматирование Excel-таблицы исходных данных. Это можно сделать в MS Excel. А можно скопировать ')) AADD(aHelp, L('таблицу в MS Word, а потом обратно в MS Excel. ')) mHelpMax = -999;FOR h=1 TO LEN(aHelp);mHelpMax = MAX(mHelpMax, LEN(ALLTRIM(aHelp[h])));NEXT s=1;d=0.8;@0,0 DCGROUP oGroup1 CAPTION L(' ') SIZE mHelpMax-15, LEN(aHelp)*d+1.5 FOR h=1 TO LEN(aHelp);@s,2 DCSAY aHelp[h] SIZE 0 PARENT ogroup1;s=s+d;NEXT *DCREAD GUI TO lExit FIT MODAL TITLE L('Помощь по режиму: 2.2. (C) Система "ЭЙДОС-X++"') s=s+1.2*d @s,0 DCGROUP oGroup2 CAPTION L('Принцип организации таблицы исходных данных:') SIZE mHelpMax-15, 8.2 **** Если файл существует изображения и его контрольная сумма совпадает, то он отображается cFile = Disk_dir+"\Help2322.jpg" IF FILE(cFile) IF FILECHECK(cFile) = 9243019 @20,13.5 DCSTATIC TYPE XBPSTATIC_TYPE_BITMAP CAPTION cFile SIZE 800,132 PIXEL PARENT oGroup2 ELSE Mess = L('Графический файл: "#" поврежден и не может быть отображен! Контрольная сумма: "$" ') Mess = STRTRAN(Mess, "#", cFile) Mess = STRTRAN(Mess, "$", ALLTRIM(STR(FILECHECK(cFile),19))) // Отображение контрольной суммы файлы LB_Warning(Mess) ENDIF ENDIF DCREAD GUI FIT TITLE L('Помощь по режиму 2.3.2.2 для случая Excel-файлов исходных данных') ReTURN nil ***************************************************************************** ******** Помощь по режиму 2_3_2_2 для CSV-файлов исходных данных ***************************************************************************** FUNCTION Help2322csv() LOCAL GetList[0], cText TEXT INTO cText WRAP "\n" TRIMMED Помощь по CSV => DBF конвертеру файлов автоматизированного программного интефейса 2.3.2.2. В папке для исходных данных: c:/Aidos-X/AID_DATA/Inp_data должен быть csv-файл исходных данных с именем: Inp_data.csv. Этот файл может сдержать примерно до 10-12 миллионов записей или даже более, в зависимости от числа полей. Если все данные из CSV-файла не поместятся в файле Inp_data.dbf, который может иметь размер только до 2 Гб, то об этом будет выдано сообщение. Поля могут быть текстового и числового типа. В первой строке csv-файла должны быть наименования ВСЕХ полей, разделенные запятой. Наименования полей нужно проанализировать, чтобы понять, какие поля являются наименованиями описательных шкал, а какие - наименованиями классификационных шкал. Эти наименования полей можно взять из 1-й строки csv-файла с помощью любого текстового редактора. Иногда наименования полей в csv-файле бывают в кавычках. Конвертер их убирает. Можно также преобразовать csv-файл в dbf в режиме 2.3.2.10 и открыть его в MS Excel-2003. У более поздних версий Экселя к сожалению нет dbf-xls конвертера. Эта информация необходима для задания диапазонов классификационных и описательных шкал в режиме 2.3.2.2. В последующих строках могут строки со значениями полей, разделенные запятыми. Внутри значения поля запятые недопустимы. Но такое бывает в некоторых CSV-файлах. Если они будут там встречаться, то соответствие значений полей с их наименованиями нарушится. В концах строк csv-файла должны быть символы конца абзаца CrLf. Сам файл может быть на любом языке (в кодировке OEM 866), но наименования полей должны быть латинскими буквами. В результате работы конвертера в той же папке исходных данных формируется два файла: Inp_data.dbf и Inp_name.txt, а затем управление автоматически передается на ввод данных из dbf-файлов. Таким образом, CSV => DBF конвертер представляет собой прединтерфейс режима ввода исходных данных из dbf-файлов в автоматизированном программном интерфейсе 2.3.2.2. Иногда бывает, что работа данного конвертора неудовлетворительна, например когда в csv-файле представлены числа в формате с плавающий запятой (в показательной форме). Тогда рекомендую csv-xls онлайн конвертеры: https://convertio.co/ru/csv-xls/ или https://onlineconvertfree.com/ru/convert-format/csv-to-xls/. Благодарность разработчику "brandelh" с форума: https://www.xbaseforum.de за помощь по разработке данного конвертера. ENDTEXT @ 0,0 DCSTATIC TYPE XBPSTATIC_TYPE_TEXT SIZE 0 ; CAPTION cText FORMATTED ; FONT '8.Lucida Console' ; COLOR GRA_CLR_BLACK, GRA_CLR_WHITE DCREAD GUI FIT TITLE L('Помощь по режиму 2_3_2_2 для CSV-файлов исходных данных') ReTURN nil ******************************************************************************* ******** Хелп по сценарному АСК-анализу *************************************** ******************************************************************************* FUNCTION Help2322ScenASKA() *DCSETFONT TO '10.Helv Bold' s=1 d=0.8 @s,1 DCSAY L('Когда сценарный метод АСК-анализа не применяется, то записи файла исходных данных "Inp_data" рассматриваются сами по себе ') SAYSIZE 0;s=s+d @s,1 DCSAY L('независмо друг от друга. Если же он применяется, то как классы рассматриваются сценарии изменения значений полей классифи-') SAYSIZE 0;s=s+d @s,1 DCSAY L('кационных шкал на заданное количество записей вперед от текущей записи (горизонт прогнозирования), а за значения факторов ') SAYSIZE 0;s=s+d @s,1 DCSAY L('принимаются сценарии изменения значений полей описательных шкал на заданное их количество назад (глубина предыстории). ') SAYSIZE 0;s=s+2*d @s,1 DCSAY L('Чтобы рассмотрение сценариев изменения значений шкал было осмысленным записи в файле исходных данных "Inp_data" должны ') SAYSIZE 0;s=s+d @s,1 DCSAY L('упорядочены каким-либо образом, например по времени (временные ряды). ') SAYSIZE 0;s=s+2*d @s,1 DCSAY L('Подробное теоретическое описание сценарного АСК-анализа с детальными численными примерами приведено в работах автора: ') SAYSIZE 0;s=s+2*d @s,1 DCSAY L('Lutsenko E.V. Script ASC-analysis as a method for developing generalized basic functions and weight coefficients for the ') SAYSIZE 0;s=s+d @s,1 DCSAY L(' decomposition of a state function of an arbitrary concrete object or situation in the theorem by A. N. Kolmogorov (1957) ') SAYSIZE 0;s=s+d @s,1 DCSAY L(' // August 2020, DOI: 10.13140/RG.2.2.28017.92007, LicenseCC BY-SA 4.0, ') SAYSIZE 0;s=s+d @s,1 DCSAY L('https://www.researchgate.net/publication/343365649') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'https://www.researchgate.net/publication/343365649', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} ;s=s+2*d @s,1 DCSAY L('Lutsenko E.V. Forecasting in financial markets using scenario-based ASC-analysis and the Eidos system (using the example ') SAYSIZE 0;s=s+d @s,1 DCSAY L(' of Google shares) // July 2021, DOI: 10.13140/RG.2.2.28157.08168, LicenseCC BY-SA 4.0 ') SAYSIZE 0;s=s+d @s,1 DCSAY L('https://www.researchgate.net/publication/353157032') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'https://www.researchgate.net/publication/353157032', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} ;s=s+2*d @s,1 DCSAY L('Lutsenko E.V. ASC-analysis and the Eidos system as a method and tools for solving problems // November 2021, ') SAYSIZE 0;s=s+d @s,1 DCSAY L('DOI: 10.13140/RG.2.2.29823.74407, License CC BY 4.0, ') SAYSIZE 0;s=s+d @s,1 DCSAY L('https://www.researchgate.net/publication/353555996') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'https://www.researchgate.net/publication/353555996', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} ;s=s+2*d @s,1 DCSAY L('Lutsenko E.V., Korzhakov V.E. Subsystem of intellectual system" Eidos-X++", which implements the scenario method ') SAYSIZE 0;s=s+d @s,1 DCSAY L('of system-cognitive analysis ("Eidos-scenarios") // March 2019, ') SAYSIZE 0;s=s+d @s,1 DCSAY L('https://www.researchgate.net/publication/331745001') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'https://www.researchgate.net/publication/331745001', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} ;s=s+2*d @s,1 DCSAY L('Lutsenko E.V. Forecasting the values and scenarios of changes in the future economic indicators of the holding using ') SAYSIZE 0;s=s+d @s,1 DCSAY L('scenario ASC-analysis // January 2022, DOI: 10.13140/RG.2.2.10006.47684, LicenseCC BY 4.0, ') SAYSIZE 0;s=s+d @s,1 DCSAY L('https://www.researchgate.net/publication/357671568') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'https://www.researchgate.net/publication/357671568', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} ;s=s+2*d DCREAD GUI FIT TITLE L('Хелп по сценарному АСК-анализу') RETURN nil ***************************************************************************** ****************************************************************************************************************************************************************************************************** ******** 2.3.2.11. Прогнозирование событий по астрофакторам методом Н.А.Чередниченко // (C) Универсальная когнитивная аналитическая система "ЭЙДОС-X++", beta-version, rel: 15:24 10.10.2021. // (C) д.э.н., к.т.н., профессор Луценко Евгений Вениаминович, Россия, Краснодар. *The Eidos-X++ system differs from other artificial intelligence systems in the following parameters: *- it was developed in a universal setting, independent of the subject area. Therefore, it is universal and can be applied in many subject areas (http://lc.kubagro.ru/aidos/index.htm); *- it is in full open free access (http://lc.kubagro.ru/aidos/_Aidos-X.htm) and has all the relevant source texts (http://lc.kubagro.ru/__AIDOS-X.txt); *- it is one of the first domestic systems of artificial intelligence of the personal level, i.e. it does not take special training in the field of technologies of artificial intelligence from the user (there is an act of introduction of system "Eidos" in 1987) (http://lc.kubagro.ru/aidos/aidos02/PR-4.htm); *- it provides stable identification in a comparable form of strength and direction of cause-effect relationships in incomplete noisy interdependent (nonlinear) data of very large dimension of numerical and non-numerical nature, measured in different types of scales (nominal, ordinal and numerical) and in different units of measurement (i.e. does not impose strict requirements to the data that cannot be performed, and processes the data that can); *- it contains a large number of local (supplied with the installation) and cloud educational and scientific applications (currently 31 and 270 (http://aidos.byethost5.com/Source_data_applications/WebAppls.htm), respectively) (http://lc.kubagro.ru/aidos/Presentation_Aidos-online.pdf); *- it supports on-line environment of knowledge accumulation and is widely used all over the world (http://aidos.byethost5.com/map5.php); *- it provides multilingual interface support in 51 languages. The language databases are included in the installation and can be replenished automatically; *- the most time-consuming, computationally, are the operations of the synthesis models and implements recognition using graphic processing unit (GPU) where some tasks can only support up to several thousand times; the solution of these tasks is intelligent processing of big data, big information and big knowledge; *- it provides transformation of the initial empirical data into information, and its knowledge and solution using this knowledge of classification problems, decision support and research of the subject area by studying its system-cognitive model, generating a very large number of tabular and graphical output forms (development of cognitive graphics), many of which have no analogues in other systems (examples of forms can be found in: http://lc.kubagro.ru/aidos/aidos18_LLS/aidos18_LLS.pdf); *- it well imitates the human style of thinking: gives the results of the analysis, understandable to experts according to their experience, intuition and professional competence. *- instead of making almost impossible demands on the source data (such as the normality of distribution, absolute accuracy and complete repetitions of all combinations of factor values and their complete independence and additivity), the automated system-cognitive analysis (ASC-analysis) offers to process this data without any preliminary processing and thereby transform it into information, and then transform this information into knowledge by applying it to achieve goals (i.e. for the management) and solving problems of classification, decision support, and meaningful empirical research of the domain being modeled. *What is the strength of the approach implemented in Eidos system? The strength is implementing an approach whose effectiveness does not depend on what we think about the subject area or whether we think at all. It generates models directly based on empirical data, rather than based on our understanding of the mechanisms for implementing patterns in this data. This is why Eidos models are effective, even if our understanding of the subject area is incorrect or totally absent. *And this as well is the weakness of this approach implemented in Eidos system. Models of the Eidos system are phenomenological models, i.e. they do not reflect the mechanisms of determination, but only the fact and nature of determination. *РЕФЕРАТ *Программа: Система когнитивного прогнозирования сейсмичности на основе астрономических данных "Aidos-Temblors" (System "Aidos-Temblors") *Аннотация: Программа предназначена для прогнозирования уровня сейсмичности на основе астрономических данных. *Программа может использоваться в государственных и негосударственных организациях всех правовых форм, заинтересованных в прогнозировании сейсмичности на Земле и в устранении последствий событий (МЧС), а также гражданами. *Функциональные возможности программы: *- обеспечивает достоверное прогнозирование сейсмичности на планете и в регионах по методу Н.А.Чередниченко; *- формирует прогноз на любой заданный период с временным разрешением до суток, на основе когнитивного анализа ретроспективных данных по сейсмической активности за весь период научных наблюдений и выявления силы и направления причинно-следственных связей между космической средой и сейсмической активностью. *Программа позволяет осуществлять ежедневный мониторинг накопления сейсмической энергии в кластерах сейсмических очагов. *Язык: Alaska-2.0 (xBase++) *Объём программы: 22 МБ *Операционная система MS Windows XP, 7, 8, 10 и выше ************************************************************************************************************************* #include "inkey.ch" #include "dcdir.ch" #include "appevent.ch" #include "xbp.ch" #include "dll.ch" #include "dccursor.ch" #Include "thread.ch" #include "class.ch" #include "dmlb.ch" #include "fileio.ch" #include "dctree.ch" *#include "SystemMetrics.ch" *#include "axcdxcmx.ch" // Графика ActiveX #include "collat.ch" #include "common.ch" #include "dbedit.ch" #include "Dbfdbe.ch" #include "dcapp.ch" #include "dcbitmap.ch" #include "dccargo.ch" #include "dcdialog.ch" #include "dcdir.ch" #include "dcfiles.ch" #include "dcgra.ch" #include "dcgraph.ch" // графика #include "BdColors.Ch" // графика #include "dccolors.ch" // графика #include "dcprint.ch" // графика #include "Dcicon.ch" #include "dcmsg.ch" #include "dcpick.ch" #include "deldbe.ch" #include "directry.ch" #include "dmlb.ch" #include "express.ch" #include "fileio.ch" #include "font.ch" #include "gra.ch" #include "inkey.ch" #include "memvar.ch" #include "natmsg.ch" #include "prompt.ch" #include '_dcdbfil.ch' #include "set.ch" #include "std.ch" #include "xbp.ch" #include '_dcappe.ch' #include 'dcscope.ch' #include '_dcstru.ch' #include 'dcfields.ch' #include 'dccolor.ch' *#include "Fileio.ch" // Max_DB *#include "rmchart.ch" // Графика ActiveX #include "dcads.ch" #pragma Library( "ASINet10.lib" ) // 2.0 // Для альтернативного и неальтернативного выбора в просмотре таблиц *#define BMP_CHECKED "check1.bmp" *#define BMP_UNCHECKED "check2.bmp" *#define BMP_RACHECKED "radio1.bmp" *#define BMP_RAUNCHECKED "radio2.bmp" *#include "test.ch" #define BMP_CHECKED 10002 #define BMP_UNCHECKED 10003 #define BMP_RACHECKED 10004 #define BMP_RAUNCHECKED 10005 #pragma library( "ascom10.lib" ) #pragma library( "dclip1.lib" ) #pragma library( "dclip2.lib" ) #pragma library( "dclipx.lib" ) #pragma library( "xbtbase1.lib" ) #pragma library( "xbtbase2.lib" ) #pragma library( "xppui2.lib" ) #pragma library( "XPPRT0.LIB" ) #Pragma Library("Taskbar.lib") #xtranslate NTrim() => LTrim(Str()) #define USE_HTTPCLIENT // comment out to try Method2 //#include "Imgview.ch" /* * We use user defined events */ #define xbeDS_DirChanged xbeP_User + 100 #define xbeFS_FileMarked xbeP_User + 101 #define xbeFS_FileSelected xbeP_User + 102 #define DCAREAMSG_1 'Invalid Expression in Index Key:' /* * This directive calculates a centered position */ #xtrans CenterPos( , ) => ; { Int( (\[1] - \[1]) / 2 ) ; , Int( (\[2] - \[2]) / 2 ) } #define DC_RDDMSG_1 'Invalid RDD selection - '+cSuperRdd #define DC_RDDMSG_2 'DBE Name Description' #define DC_RDDMSG_3 'Select a Database Driver' *#define ADSDBE_MEMOFILE_EXT (DBE_USER+1) // RO *#define ADSDBE_INDEX_EXT (DBE_USER+2) // RW *#define ADSDBE_TBL_MODE (DBE_USER+3) // RW *#define ADSDBE_LOCK_MODE (DBE_USER+4) // RW *#define ADSDBE_RIGHTS_MODE (DBE_USER+5) // RW *#define ADSDBE_MEMOBLOCKSIZE (DBE_USER+6) // RW *#define ADSDBE_PASSWORD (DBE_USER+7) // RW // Return types of ADSDBE_TBL_MODE *#define ADSDBE_NTX 1 *#define ADSDBE_CDX 2 *#define ADSDBE_ADT 3 // Для опредедения разрешения монитора от Джимми #define DESKTOPVERTRES 117 #define DESKTOPHORZRES 118 // Excel Orientation #DEFINE xlLandscape 2 #DEFINE xlPortrait 1 #DEFINE xlWorkbookNormal -4143 #DEFINE xlCellTypeLastCell 11 #DEFINE SRCCOPY 0xCC0020 // Для быстрой графики Роджера #define KEYEVENTF_KEYUP 0x02 #define VK_MENU 0x12 #define VK_SNAPSHOT 0x2C #DEFINE VK_LBUTTON 0x01 #DEFINE VK_RBUTTON 0x02 * Для CSV=>DBF конвертера *#include "ot4xb.ch" // => ot4xb.dll => www.xbwin.com #ifndef CRLF #define CRLF chr(13)+chr(10) #endif * Klasse zum sequentiellen Einlesen groбer Dateien *#IF .t. // zum Einbinden in eigenes Projekt, .f. setzen ! STATIC snHdll *********************************************************************** *********************************************************************** FUNCTION F2_3_2_11() LOCAL GetList[0], GetOptions, nColor, oMessageBox, oMenuWords, oDlg, ; oMenuBar,oMenu1,oMenu2,oMenu3,oMenu4,oMenu5,oMenu6,oMenu7,; oMenu3_3, nKey := 0, oWebBrowser Running(.T.) DIRCHANGE(Disk_dir+"/AID_DATA/Inp_data/") cExcelFakt = '' IF File("Inp_fakt.xls") PUBLIC cExcelFakt := "Inp_fakt.xls" ELSE mMess = 'Отсутствует файл: "Inp_fakt.xls"' ENDIF IF File("Inp_fakt.xlsx") PUBLIC cExcelFakt := "Inp_fakt.xlsx" ELSE mMess = 'Отсутствует файл: "Inp_fakt.xlsx"' ENDIF * IF LEN(cExcelFakt) = 0 * DC_WinAlert( mMess ) * mFlag = .T. * ENDIF DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы PRIVATE a23211[8] IF FILE("_23211.arx") // Параметры диалога F2_3_2_12() a23211 = DC_ARestore("_23211.arx") PUBLIC mNumMod := a23211[1] PUBLIC mRegim := a23211[2] PUBLIC mWindow := a23211[3] PUBLIC mXSize := a23211[4] PUBLIC mYSize := a23211[5] PUBLIC mLineWidth := a23211[6] PUBLIC mGamma := a23211[7] PUBLIC mAlfa := a23211[8] ELSE PUBLIC mNumMod := 1 PUBLIC mRegim := 2 PUBLIC mWindow := 7 PUBLIC mXSize := 1800 PUBLIC mYSize := 900 PUBLIC mLineWidth := 7 PUBLIC mGamma := 1 PUBLIC mAlfa := 1 a23211[1] = mNumMod a23211[2] = mRegim a23211[3] = mWindow a23211[4] = mXSize a23211[5] = mYSize a23211[6] = mLineWidth a23211[7] = mGamma a23211[8] = mAlfa DC_ASave(a23211, "_23211.arx") ENDIF ******************************************************************************************* ****** 0. Задать текущую стат.модель или модель знаний ******************************************************************************************* ****** Задание текущей модели @ 0, 0 DCGROUP oGroup1 CAPTION L('Задайте текущую статистическую или системно-когнитивную модель') SIZE 90,13.5 @ 1, 1 DCSAY L('Статистические базы:' ) PARENT oGroup1 @ 2, 3 DCRADIO mNumMod VALUE 1 PROMPT L('1. ABS - частный критерий: количество встреч сочетаний: "класс-признак" у объектов обуч.выборки') PARENT oGroup1 @ 3, 3 DCRADIO mNumMod VALUE 2 PROMPT L('2. PRC1 - частный критерий: усл. вероятность i-го признака среди признаков объектов j-го класса ') PARENT oGroup1 @ 4, 3 DCRADIO mNumMod VALUE 3 PROMPT L('3. PRC2 - частный критерий: условная вероятность i-го признака у объектов j-го класса ') PARENT oGroup1 @ 5.2,1 DCSAY L('Системно-когнитивные модели (Базы знаний):' ) PARENT oGroup1 @ 6, 3 DCRADIO mNumMod VALUE 4 PROMPT L('4. INF1 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC1 ') PARENT oGroup1 @ 7, 3 DCRADIO mNumMod VALUE 5 PROMPT L('5. INF2 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC2 ') PARENT oGroup1 @ 8, 3 DCRADIO mNumMod VALUE 6 PROMPT L('6. INF3 - частный критерий: Xи-квадрат, разности между фактическими и ожидаемыми абс.частотами ') PARENT oGroup1 @ 9, 3 DCRADIO mNumMod VALUE 7 PROMPT L('7. INF4 - частный критерий: ROI (Return On Investment); вероятности из PRC1 ') PARENT oGroup1 @10, 3 DCRADIO mNumMod VALUE 8 PROMPT L('8. INF5 - частный критерий: ROI (Return On Investment); вероятности из PRC2 ') PARENT oGroup1 @11, 3 DCRADIO mNumMod VALUE 9 PROMPT L('9. INF6 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC1 ') PARENT oGroup1 @12, 3 DCRADIO mNumMod VALUE 10 PROMPT L('10.INF7 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC2 ') PARENT oGroup1 d1 = 45 @14, 0 DCGROUP oGroup2 CAPTION L('') SIZE 90.0, 2.7 @ 1, 3 DCRADIO mRegim VALUE 1 PROMPT L('1. Синтез и верификация модели ') PARENT oGroup2 @ 1,d1 DCRADIO mRegim VALUE 2 PROMPT L('2. Синтез модели и прогнозирование ') PARENT oGroup2 d2 = 25 @17, 0 DCGROUP oGroup3 CAPTION L('Задайте параметры линейного сглаживания кривой интенсивности прогнозируемых событий:') SIZE 90.0, 5.7 // задача 2 @ 1, 3 DCSAY L('Интервал сглаживания:') PARENT oGroup3; @ 1,d2 DCGET mWindow PICTURE "####" PARENT oGroup3 @ 2, 3 DCSAY L('Толщина линии:') PARENT oGroup3; @ 2,d2 DCGET mLineWidth PICTURE "####" PARENT oGroup3 @ 3, 3 DCRADIO mGamma VALUE 1 PROMPT L('1. Теплая гамма ') PARENT oGroup3 @ 4, 3 DCRADIO mGamma VALUE 2 PROMPT L('2. Холодная гамма ') PARENT oGroup3 @ 0.8,d1 DCPUSHBUTTON CAPTION L('Помощь') SIZE LEN(L('Перерисовать график с другими параметрами'))-3, 1.5 ACTION {||Help23211() , DC_GetRefresh(GetList)} PARENT oGroup3 @ 2.8,d1 DCPUSHBUTTON CAPTION L('Сравнить прогноз с фактом') SIZE LEN(L('Перерисовать график с другими параметрами'))-3, 1.5 ACTION {||CompForeFact1() , DC_GetRefresh(GetList)} PARENT oGroup3 d3 = 23 IF LEN(cExcelFakt) > 0 @23, 0 DCGROUP oGroup4 CAPTION L('Задайте интервал сглаживания кривой фактических событий:') SIZE 90.0, 2.7 // задача 2 @ 1, 3 DCSAY L('Интервал сглаживания:') PARENT oGroup4;@ 1,d2 DCGET mAlfa PICTURE "####" PARENT oGroup4 d3 = 26 ENDIF @d3, 0 DCGROUP oGroup5 CAPTION L('Задайте размер изображения в пикселях (не более 4K):') SIZE 90.0, 3.5 @ 1, 3 DCSAY L("Размер по X:") PARENT oGroup5; @ 1,d2 DCGET mXSize PICTURE "####" PARENT oGroup5 @ 2, 3 DCSAY L("Размер по Y:") PARENT oGroup5; @ 2,d2 DCGET mYSize PICTURE "####" PARENT oGroup5 @ 1.2,d1 DCPUSHBUTTON CAPTION L('Перерисовать график с другими параметрами') SIZE LEN(L('Перерисовать график с другими параметрами'))-3, 1.5 ACTION {||Chart23211(.T.) , DC_GetRefresh(GetList)} PARENT oGroup5 d4 = d3 + 4 @d4 , 0 DCGROUP oGroup6 CAPTION L('Исправление расположения минимумов прогноза и рисование графиков прогнозов резонансных событий:') SIZE 90.0, 3.5 // задача 2 @ 1.2, 3 DCPUSHBUTTON CAPTION L('Исправить расположение минимумов') SIZE LEN(L('Перерисовать график с другими параметрами'))-3, 1.5 ACTION {||EditMinProgn1() , DC_GetRefresh(GetList)} PARENT oGroup6 @ 1.2,d1 DCPUSHBUTTON CAPTION L('График ПРОГРАММА') SIZE LEN(L('График ПРОГРАММА'))+3, 1.5 ACTION {||Chart23211r('Prog'), DC_GetRefresh(GetList)} PARENT oGroup6 @ 1.2,d1+21 DCPUSHBUTTON CAPTION L('График ЭКСПЕРТ' ) SIZE LEN(L('График ЭКСПЕРТ' ))+3, 1.5 ACTION {||Chart23211r('Hand'), DC_GetRefresh(GetList)} PARENT oGroup6 DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; OPTIONS GetOptions ; ADDBUTTONS; MODAL ; TITLE L('2.3.2.11. Прогнозирование событий методом Н.А.Чередниченко') ******************************************************************** IF lExit ** Button Ok ELSE ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ******************************************************************** Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } M_Inf = UPPER(Ar_Model[mNumMod]) mFlagErr = .F. IF 1 <= mNumMod .AND. mNumMod <= 10 ELSE LB_Warning(L("Необходимо задать одну из моделей для расчетов !!! ")) mFlagErr = .T. ENDIF IF mFlagErr ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF *************************************** DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы mWindow = IF(mWindow>0,mWindow, 7) // Окно может быть только больше нуля mWindow = IF(mWindow=2*INT(mWindow/2),mWindow++, mWindow) // Окно может быть только нечетным mXSize = IF(mXSize<1800,1800,mXSize ) mXSize = IF(mXSize>4096,4096,mXSize ) mYSize = IF(mYSize< 900, 900,mYSize ) mYSize = IF(mYSize>4096,4096,mYSize ) mLineWidth = IF(mLineWidth=2*INT(mLineWidth/2),mLineWidth++, mLineWidth) // Толщина сглаженной линии может быть только нечетным mLineWidth = IF(mLineWidth<5,5,mLineWidth) mLineWidth = IF(mLineWidth>9,9,mLineWidth) * mAlfa = IF(mAlfa>1,1,mAlfa ) * mAlfa = IF(mAlfa<0,0,mAlfa ) mAlfa = IF(mAlfa>0,mAlfa, 7) // Окно может быть только больше нуля (для сглаживания центрированным скользящим средним) mAlfa = IF(mAlfa=2*INT(mAlfa/2),mAlfa++, mAlfa) // Окно может быть только нечетным a23211[1] = mNumMod a23211[2] = mRegim a23211[3] = mWindow a23211[4] = mXSize a23211[5] = mYSize a23211[6] = mLineWidth a23211[7] = mGamma a23211[8] = mAlfa DC_ASave(a23211, "_23211.arx") ******************************************************************* *** Создание БД Inp_data.dbf из файлов: "Input1.xls" и "Input2.xls" ******************************************************************* CLoseAll() DIRCHANGE(Disk_dir+"/AID_DATA/Inp_data/") *IF mRegim = 1 // Синтез и верификация модели, т.е. вместо Inp_rasp.dbf использовать Inp_data.dbf, т.е. просто скопировать Inp_data.dbf ===> Inp_rasp.dbf * COPY FILE ('Inp_data.dbf') TO ('Inp_rasp.dbf') *ENDIF mFlag = .F. cExcelFile1 = '' IF File("Input1.xls") PUBLIC cExcelFile1 := "Input1.xls" ELSE mMess = 'Отсутствует файл: "Input1.xls"' ENDIF IF File("Input1.xlsx") PUBLIC cExcelFile1 := "Input1.xlsx" ELSE mMess = 'Отсутствует файл: "Input1.xlsx"' ENDIF IF LEN(cExcelFile1) = 0 DC_WinAlert( mMess ) mFlag = .T. ENDIF cExcelFile2 = '' IF File("Input2.xls") PUBLIC cExcelFile2 := "Input2.xls" ELSE mMess = 'Отсутствует файл: "Input2.xls"' ENDIF IF File("Input2.xlsx") PUBLIC cExcelFile2 := "Input2.xlsx" ELSE mMess = 'Отсутствует файл: "Input2.xlsx"' ENDIF IF LEN(cExcelFile2) = 0 DC_WinAlert( mMess ) mFlag = .T. ENDIF cExcelFakt = '' IF File("Inp_fakt.xls") PUBLIC cExcelFakt := "Inp_fakt.xls" ELSE mMess = 'Отсутствует файл: "Inp_fakt.xls"' ENDIF IF File("Inp_fakt.xlsx") PUBLIC cExcelFakt := "Inp_fakt.xlsx" ELSE mMess = 'Отсутствует файл: "Inp_fakt.xlsx"' ENDIF *IF LEN(cExcelFakt) = 0 * DC_WinAlert( mMess ) * mFlag = .T. *ENDIF // Синтез модели и прогнозирование, т.е. для синтеза использовать Inp_data, а для распознавания Inp_rasp (должен присутствовать, а при верифкации он создается просто копированием Inp_data) IF mRegim = 2 cExcelFile3 = '' IF File("Inp_rasp.xls") PUBLIC cExcelFile3 := "Inp_rasp.xls" ELSE mMess = 'Отсутствует файл: "Inp_rasp.xls"' ENDIF IF File("Inp_rasp.xlsx") PUBLIC cExcelFile3 := "Inp_rasp.xlsx" ELSE mMess = 'Отсутствует файл: "Inp_rasp.xlsx"' ENDIF IF LEN(cExcelFile3) = 0 DC_WinAlert( mMess ) mFlag = .T. ENDIF ENDIF IF mFlag ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW Running(.F.) RETURN nil ENDIF *PUBLIC mDbaseName1 := "Input1" *PUBLIC mDbaseName2 := "Input2" *PUBLIC mDbaseName3 := "Inp_temp" *PUBLIC cDbaseFile1 := "Input1.dbf" *PUBLIC cDbaseFile2 := "Input2.dbf" *PUBLIC cDbaseFile3 := "Inp_temp.dbf" // Конвертация XLS-файлов в DBF *DC_ASave(aStructure, "_Structure.arx") // Запись в LC_Excel2WorkArea() массива структуры создаваемого файла *DC_ASave(aFieldName, "_FieldName.arx") // Запись в LC_Excel2WorkArea() массива имен полей создаваемого файла LC_Excel2WorkArea( cExcelFile1 ) aStructure1 = DC_ARestore('_Structure.arx') aFields1 = DC_ARestore('_FieldName.arx') FOR j=1 TO LEN(aStructure1) aStructure1[j,1] = aFields1[j] NEXT LC_Excel2WorkArea( cExcelFile2 ) *** Максимально увеличить размер полей в aStructure2 <===############## aStructure2 = DC_ARestore('_Structure.arx') aFields2 = DC_ARestore('_FieldName.arx') FOR j=2 TO LEN(aStructure2) aStructure2[j,1] = aFields2[j] NEXT *LB_Warning(aStructure2) IF LEN(cExcelFakt) > 0 LC_Excel2WorkArea( cExcelFakt ) ENDIF **** Формирование текстовых файлов с именами полей для ввода Inp_data.dbf в систему в режиме 2.3.2.2. **** Наименования колонок с 1-й по последнюю aInp_name := aFields1 // Массив имен всех полей Inp_data.dbf FOR j=2 TO LEN(aFields2) // Без поля "Дата" AADD(aInp_name, aFields2[j] ) NEXT CrLf = CHR(13)+CHR(10) // Конец строки (абзаца) (CrLf) mCol_name = "" FOR j=1 TO LEN(aInp_name) // 1-ю колонку включаем в Inp_nameAll.txt, для других целей mNameJ = ALLTRIM(aInp_name[j]) mNameJ = UPPER(SUBSTR(mNameJ,1,1)) + SUBSTR(mNameJ,2) // Сделать первые символы заголовков колонок большими, а остальные оставить как есть mCol_name = mCol_name + mNameJ + CrLf NEXT StrFile(mCol_name, 'Inp_nameAll.txt') // Добавить путь на папку Inp_data **** Наименования колонок со 2-й по последнюю mCol_name = "" FOR j=2 TO LEN(aInp_name) // 1-ю колонку не включаем в Inp_name.txt, т.к. это инф.об источнике данных, а не шкала mNameJ = ALLTRIM(aInp_name[j]) mNameJ = UPPER(SUBSTR(mNameJ,1,1)) + SUBSTR(mNameJ,2) // Сделать первые символы заголовков колонок большими, а остальные оставить как есть mCol_name = mCol_name + mNameJ + CrLf NEXT StrFile(mCol_name, 'Inp_name.txt') // Создание объединенной базы данных с именами полей из исходных баз данных, но пропустив 1-е поле (Дата) во 2-м файле aStructure3 := aStructure1 *FOR j=2 TO 11 // 1-я задача // 11 = 10 астропараметров + 1 дата FOR j=2 TO 43 // 2-я задача // 43 = 42 астропараметров + 1 дата *FOR j=2 TO LEN(aStructure2) // 2-я задача // 43 = 42 астропараметров + 1 дата * AADD(aStructure3, { aStructure2[j,1], aStructure2[j,2], aStructure2[j,3], aStructure2[j,4] } ) // <===################ * имя поля тип данных поля размер поля число знаков после запятой AADD(aStructure3, { aStructure2[j,1], 'N', 19, 7 } ) // <===################ NEXT DbCreate('Inp_temp', aStructure3 ) // Создание объединенной БД DbCreate('Inp_data', aStructure3 ) // Создание объединенной БД DbCreate('Inp_rasp', aStructure3 ) // Создание объединенной БД для 1-го листа Bala и просто для распознавания стандартными средствами Эйдос *********** БД Bala ****** aStructure4 := aStructure2 *FOR j=2 TO 11 // 1-я задача // 11 = 10 астропараметров + 1 дата FOR j=2 TO 43 // 2-я задача // 43 = 42 астропараметров + 1 дата *FOR j=2 TO LEN(aStructure2) // 2-я задача // 43 = 42 астропараметров + 1 дата * AADD(aStructure4, { '_'+aStructure2[j,1], aStructure2[j,2], aStructure2[j,3], aStructure2[j,4] } ) // <===################ Имена полей не могут повторяться, поэтому '_' * имя поля размер поля тип данных поля число знаков после запятой AADD(aStructure4, { '_'+aStructure2[j,1], 'N', 19, 7 } ) // <===################ Имена полей не могут повторяться, поэтому '_' NEXT j=11 AADD(aStructure4, { 'Progn_Poln', 'N', 19, 7 } ) // Прогноз полный AADD(aStructure4, { 'Progn_Avr' , 'N', 19, 7 } ) // Прогноз полный сглаженный AADD(aStructure4, { 'ZMT_fakt' , 'N', 19, 7 } ) // Интенсивность фактически произошедших ЗМТ (если ЗМТ не было - 0) из файла Inp_fakt.xls // задача 2 AADD(aStructure4, { 'ZMTAvrFakt', 'N', 19, 7 } ) // Интенсивность фактически произошедших ЗМТ (если ЗМТ не было - 0), сглаженная // задача 2 AADD(aStructure4, { 'PrognNNorm', 'N', 19, 7 } ) // Прогноз полный, ненормированный DbCreate('Bala', aStructure4 ) // Создание результирующей БД Bala.dbf AADD(aStructure4, { 'Progn_N' , 'N', 19, 7 } ) AADD(aStructure4, { 'Progn_NI' , 'N', 19, 7 } ) AADD(aStructure4, { 'SumInt_ZMT', 'N', 19, 7 } ) AADD(aStructure4, { 'INT_ZMT_NI', 'N', 19, 7 } ) AADD(aStructure4, { 'ProgAvrMin', 'C', 3, 0 } ) AADD(aStructure4, { 'PRAVKA_MIN', 'C', 3, 0 } ) // Дополнительные поля для ручного исправления расположения минимумов прогноза и перерасчета резонансов AADD(aStructure4, { 'PR_PROGNNI', 'N', 19, 7 } ) AADD(aStructure4, { 'P_INTZMTNI', 'N', 19, 7 } ) DbCreate('PrognReson', aStructure4 ) // Создание результирующей БД PrognReson.dbf для прогнозирования резонансов CLoseAll() USE Input1 EXCLUSIVE NEW INDEX ON FIELDGET(1) TO Input1 CLoseAll() USE Input2 EXCLUSIVE NEW INDEX ON FIELDGET(1) TO Input2 IF FILE( cExcelFakt ) CLoseAll() USE Inp_fakt EXCLUSIVE NEW INDEX ON FIELDGET(1) TO Inp_fakt ENDIF CLoseAll() USE Input1 INDEX Input1 EXCLUSIVE NEW;N_Col1 = FCOUNT();N_Rec1=RECCOUNT() USE Input2 INDEX Input2 EXCLUSIVE NEW;N_Col2 = FCOUNT();N_Rec2=RECCOUNT() USE Inp_temp EXCLUSIVE NEW;N_Col3 = FCOUNT() ***** Отображение стадии исполнения в кратком варианте ***************************************** *nMax = 4*N_Rec1 // 1-я задача nMax = 3*N_Rec1 // 2-я задача nTime = 0 @ 4,5 DCPROGRESS oProgressm SIZE 90,1.1 MAXCOUNT nMax COLOR GRA_CLR_BLUE PERCENT EVERY 100 mMess = 'Объединение файлов: "'+cExcelFile1+'" и "'+cExcelFile2+'" по 1-му полю в БД: "Inp_data.dbf"' DCREAD GUI TITLE mMess PARENT @oDialogm FIT EXIT oDialogm:show() DC_GetProgress(oProgressm,0,nMax) ************************************************************************************************ ************** Только если 1-я задача *SELECT Input1 *DBGOTOP() *DO WHILE .NOT. EOF() * FIELDPUT(7, 3+1.5*FIELDGET(6)-3.5*LOG(FIELDGET(5))/LOG(10)) // Расчет интенсивности ЗМТ * DC_GetProgress(oProgressm, ++nTime, nMax) * DBSKIP(1) *ENDDO SELECT Input1 DBGOTOP() DO WHILE .NOT. EOF() ar := {} FOR j=1 TO N_Col1 AADD(ar, FIELDGET(j)) NEXT SELECT Input2;SET ORDER TO 1;T=DBSEEK(ar[1]) // Если запись с таким ключом найдена во 2-й БД, IF T // добавить ее и записать в 3-ю объединенную БД FOR j=2 TO N_Col2 AADD(ar, FIELDGET(j)) NEXT SELECT Inp_temp APPEND BLANK FOR j=1 TO N_Col3 FIELDPUT(j, ar[j]) NEXT ENDIF DC_GetProgress(oProgressm, ++nTime, nMax) SELECT Input1 DBSKIP(1) ENDDO ***** Сортировка Inp_temp => Inp_data ********* CLoseAll() USE Inp_temp EXCLUSIVE NEW INDEX ON SUBSTR(FIELDGET(1),7,4)+SUBSTR(FIELDGET(1),4,2)+SUBSTR(FIELDGET(1),1,2) TO Inp_temp // ГГГГММДД CLoseAll() USE Inp_temp INDEX Inp_temp EXCLUSIVE NEW USE Inp_data EXCLUSIVE NEW SELECT Inp_temp SET ORDER TO 1 DBGOTOP() DO WHILE .NOT. EOF() ar := {} FOR j=1 TO N_Col3 AADD(ar, FIELDGET(j)) NEXT SELECT Inp_data APPEND BLANK FOR j=1 TO LEN(ar) FIELDPUT(j, ar[j]) NEXT DC_GetProgress(oProgressm, ++nTime, nMax) SELECT Inp_temp DBSKIP(1) ENDDO mSummaINT100 = 0 // Для последующих расчетов SELECT Inp_data DBGOTOP() DO WHILE .NOT. EOF() mSummaINT100 = mSummaINT100 + INT_ZMT // для 1-й задачи * mSummaINT100 = mSummaINT100 + SUMM_MG // для 2-й задачи DC_GetProgress(oProgressm, ++nTime, nMax) DBSKIP(1) ENDDO StrFile(ALLTRIM(STR(RECCOUNT())), 'N_Obj.txt') ****** Добавление в Inp_data.dbf 2-х записей с теоретически минимальными и максимальными значениями описательных шкал с датой на 1 и на 2 меньше минимальной *CLoseAll() *USE Inp_data EXCLUSIVE NEW *INDEX ON SUBSTR(FIELDGET(1),7,4)+SUBSTR(FIELDGET(1),4,2)+SUBSTR(FIELDGET(1),1,2) TO Inp_temp // ГГГГММДД *CLoseAll() *USE Inp_data INDEX Inp_temp EXCLUSIVE NEW *SELECT Inp_data *SET ORDER TO 1 *DBGOTOP() *mDate = CTOD(FIELDGET(1)) *aMin := {0.00,0.00000,-23.60000,0.95000,0.98000,0.00000,-28.80000,11.80000,356200.00000,0.00000,-23.60000,-0.26000,0.00000,-5.35000,-3.70000,0.00000,-26.00000,-1.40000,0.50000,0.00000,-28.00000,-0.64000,0.25000,0.00000,-29.50000,-0.45000,0.35000,0.00000,-23.70000,-1.50000,3.85000,0.00000,-23.50000,-0.09000,8.02000,0.00000,-23.85000,-0.04600,17.00000,0.00000,-22.60000,-0.03000,28.80000} *APPEND BLANK *FIELDPUT(1, STRTRAN(DTOC(mDate-1),'-','.')) *FOR j=1 TO LEN(aMin) * FIELDPUT(j+1,aMin[j]) *NEXT *aMax := {0.00,360.00000,23.60000,1.02500,1.02000,360.00000,28.80000,15.39500,407700.00000,360.00000,23.60000,0.04000,360.00000,5.35000,6.40000,360.00000,26.00000,2.30000,1.50000,360.00000,28.30000,1.27000,1.75000,360.00000,28.00000,0.85000,2.70000,360.00000,23.70000,0.26000,6.70000,360.00000,23.50000,1.40000,11.07000,360.00000,24.50000,0.06800,22.30000,360.00000,23.00000,0.04500,31.50000} *APPEND BLANK *FIELDPUT(1, STRTRAN(DTOC(mDate-2),'-','.')) *FOR j=1 TO LEN(aMax) * FIELDPUT(j+1,aMax[j]) *NEXT DC_GetProgress(oProgressm,nMax,nMax) oDialogm:Destroy() CLoseAll() ERASE("Inp_temp.dbf") COPY FILE ('Inp_data.dbf') TO ('Inp_data.xls') *COPY FILE ('Inp_data.dbf') TO ('Inp_data.xlsx') *aMess := {} *AADD(aMess, 'Файлы: "'+cExcelFile1+'" и "'+cExcelFile2+'" объединены по полю "Дата"') *AADD(aMess, 'в БД: "Inp_data.dbf". Этот файл открывается в MS Excel.') *LB_Warning(aMess, 'Система "Эйдос"' ) **************************************************** *** Формализация предметной области и синтез моделей **************************************************** DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы Эйдос * IF FILE("_2_3_2_2.arx") * aSoftInt = DC_ARestore("_2_3_2_2.arx") // Если параметры были заданы ранее, то использовать их * Regim = aSoftInt[ 1] * Flag_zer = aSoftInt[ 2] * M_ClSc1 = aSoftInt[ 3] * M_ClSc2 = aSoftInt[ 4] * M_OpSc1 = aSoftInt[ 5] * M_OpSc2 = aSoftInt[ 6] * N_SKGrCl = aSoftInt[ 7] * N_SKGrPr = aSoftInt[ 8] * K_N_ClSc = aSoftInt[ 9] * K_N_OpSc = aSoftInt[10] * K_N_GrClSc = aSoftInt[11] * K_N_GrOpSc = aSoftInt[12] * M_ObAnk = aSoftInt[13] * N_Chast = aSoftInt[14] * M_Interval = aSoftInt[15] * M_Scenario = aSoftInt[16] * K_GradNClSc = aSoftInt[17] // Количество градаций в числовой классификационной шкале * K_GradNOpSc = aSoftInt[18] // Количество градаций в числовой описательной шкале * mGorizMin = aSoftInt[19] * mGorizMax = aSoftInt[20] * mGlubMin = aSoftInt[21] * mGlubMax = aSoftInt[22] * M_ChastObi = aSoftInt[23] * M_ChastRso = aSoftInt[24] * N_ChastObi = aSoftInt[25] * N_ChastRso = aSoftInt[26] * M_XlsDbf = aSoftInt[27] * mTxtCSField = aSoftInt[28] // Способ интерпретации значений текстовых полей - классификационных шкал файла исходных данных * mTxtOSField = aSoftInt[29] // Способ интерпретации значений текстовых полей - описательных шкал файла исходных данных * mTxtCSSep = aSoftInt[30] * mTxtOSSep = aSoftInt[31] ** mScenario = aSoftInt[32] // mScenario=1 Не применять сценарный метод АСК-анализа и спец.интерпретацию TXT-полей (старый вариант) * mScenario = aSoftInt[32] // mScenario=1 Не применять сценарный метод АСК-анализа * mSpecInterprCls = aSoftInt[33] // .T. - Применить спец.интерпретацию текстовых полей классов, .F. - не применять * mSpecInterprAtr = aSoftInt[34] // .T. - Применить спец.интерпретацию текстовых полей признаков, .F. - не применять * mNameGrNumSc= aSoftInt[35] // Какие наименования ГРАДАЦИЙ числовых шкал использовать * mClsAvr = aSoftInt[36] // .F. - делать модель из Inp_data, .T. - делать модель из Inp_data_avr * mSortUnqCls = aSoftInt[37] // Выделять уникальные значения классов и сортировать, 1-да, 2-нет * mLemmatCls = IF(mSpecInterprCls,aSoftInt[38],2) // Проводить лемматизацию классов, 1-да, 2-нет * mSortUnqGos = aSoftInt[39] // Выделять уникальные значения признаков и сортировать, 1-да, 2-нет * mLemmatGos = IF(mSpecInterprAtr,aSoftInt[40],2) // Проводить лемматизацию классов, 1-да, 2-нет * ELSE Regim = 1 // Формализации ПО или ген.расп.выб. Flag_zer = 2 // Считать нули и пробелы отсутствием данных? [1]-да, [2]-нет N_Chast = 1 // На сколько частей N разбивать обучающую или распознаваемую выборку (в зависимости от Regim) M_ClSc1 = 2 // Номер начального столбца диапазона классификационных шкал // Задача 2 M_ClSc2 = 2 // Номер конечного столбца диапазона классификационных шкал // Задача 2 M_OpSc1 = 3 // Номер начального столбца диапазона описательных шкал // Задача 2 M_OpSc2 = 44 // Номер конечного столбца диапазона описательных шкал // Задача 2 M_ObAnk = 3 // Создавать анкеты исходной выборки по строкам Inp_data-[1], по классам-[2], и 1-е, и 2-е [3] M_Interval = 1 // 1-равные интервалы, 2-адаптивные интервалы (с примерно равным количеством наблюдений, по Котельникову) N_SKGrCl = 5 N_SKGrPr = 5 K_N_ClSc = 1 K_N_OpSc = 1 K_N_GrClSc = 3 // Количество градаций в числовой классификационной шкале // Задача 2 K_N_GrOpSc = 360 // Количество градаций в числовой описательной шкале // Задача 2 M_Scenario = .F. mGorizMin = 5 mGorizMax = 5 mGlubMin = 5 mGlubMax = 5 K_GradNClSc = 3 // Задача 2 K_GradNOpSc = 360 // Задача 2 M_ChastObi = .F. M_ChastRso = .F. N_ChastObi = 1 N_ChastRso = 1 M_XlsDbf = 3 mTxtCSField = 1 // Способ интерпретации значений текстовых полей - классификационных шкал файла исходных данных mTxtOSField = 1 // Способ интерпретации значений текстовых полей - описательных шкал файла исходных данных mTxtCSSep = " " // Разделитель элементов классификационных шкал, если mTxtCSField=3 mTxtOSSep = " " // Разделитель элементов описательных шкал, если mTxtOSField=3 * mScenario = 1 // mScenario=1 Не применять сценарный метод АСК-анализа и спец.интерпретацию TXT-полей (старый вариант) mScenario = 1 // Не применять сценарный метод АСК-анализа mSpecInterprCls = .F. // .T. - Применить спец.интерпретацию текстовых полей классов, .F. - не применять mSpecInterprAtr = .F. // .T. - Применить спец.интерпретацию текстовых полей признаков, .F. - не применять mNameGrNumSc= 1 // Какие наименования ГРАДАЦИЙ числовых шкал использовать mClsAvr = .F. // .F. - делать модель из Inp_data, .T. - делать модель из Inp_data_avr mSortUnqCls = 1 // Выделять уникальные значения классов и сортировать, 1-да, 2-нет mLemmatCls = 2 // Проводить лемматизацию классов, 1-да, 2-нет mSortUnqGos = 1 // Выделять уникальные значения признаков и сортировать, 1-да, 2-нет mLemmatGos = 2 // Проводить лемматизацию признаков, 1-да, 2-нет // Сохранить файл с информацией о заданых параметрах программного интерфейса в текущей директории системы PRIVATE aSoftInt[40] aSoftInt[ 1] = Regim aSoftInt[ 2] = Flag_zer aSoftInt[ 3] = M_ClSc1 aSoftInt[ 4] = M_ClSc2 aSoftInt[ 5] = M_OpSc1 aSoftInt[ 6] = M_OpSc2 aSoftInt[ 7] = N_SKGrCl aSoftInt[ 8] = N_SKGrPr aSoftInt[ 9] = K_N_ClSc aSoftInt[10] = K_N_OpSc aSoftInt[11] = K_N_GrClSc aSoftInt[12] = K_N_GrOpSc aSoftInt[13] = M_ObAnk aSoftInt[14] = N_Chast aSoftInt[15] = M_Interval aSoftInt[16] = M_Scenario aSoftInt[17] = K_GradNClSc // Количество градаций в числовой классификационной шкале aSoftInt[18] = K_GradNOpSc // Количество градаций в числовой описательной шкале aSoftInt[19] = mGorizMin aSoftInt[20] = mGorizMax aSoftInt[21] = mGlubMin aSoftInt[22] = mGlubMax aSoftInt[23] = M_ChastObi aSoftInt[24] = M_ChastRso aSoftInt[25] = N_ChastObi aSoftInt[26] = N_ChastRso aSoftInt[27] = M_XlsDbf aSoftInt[28] = mTxtCSField aSoftInt[29] = mTxtOSField aSoftInt[30] = mTxtCSSep aSoftInt[31] = mTxtOSSep * aSoftInt[32] = mScenario // mScenario=1 Не применять сценарный метод АСК-анализа и спец.интерпретацию TXT-полей (старый вариант) aSoftInt[32] = mScenario // mScenario=1 Не применять сценарный метод АСК-анализа aSoftInt[33] = mSpecInterprCls // Применить спец.интерпретацию текстовых полей классов aSoftInt[34] = mSpecInterprAtr // Применить спец.интерпретацию текстовых полей признаков aSoftInt[35] = mNameGrNumSc // Какие наименования ГРАДАЦИЙ числовых шкал использовать aSoftInt[36] = mClsAvr // .F. = модель без усреднения по классам aSoftInt[37] = mSortUnqCls // Выделять уникальные значения классов и сортировать, 1-да, 2-нет aSoftInt[38] = IF(mSpecInterprCls,mLemmatCls,2) // Проводить лемматизацию классов, 1-да, 2-нет aSoftInt[39] = mSortUnqGos // Выделять уникальные значения признаков и сортировать, 1-да, 2-нет aSoftInt[40] = IF(mSpecInterprAtr,mLemmatGos,2) // Проводить лемматизацию признаков, 1-да, 2-нет DC_ASave(aSoftInt , "_2_3_2_2.arx") * ENDIF *** Создать новое пустое приложение с заданным имененем ****************************************** * mApplName = L('Прогнозирование событий по астрофакторам в модели: "')+ALLTRIM(Ar_Model[mNumMod])+'", '+; * IF(M_Interval=1,L('равн.'),L('адапт.'))+L('интервалы,')+' '+; // Эти параметры не могут в наименовании приложения, т.к. они задаются позже формирования имени приложения * ALLTRIM(STR(K_GradNClSc))+' '+L('град.в кл.шкалах,')+' '+; // Или надо менять имя приложения прямо в базе приложения после задания этих параметров * ALLTRIM(STR(K_GradNOpSc))+' '+L('град.в оп.шкалах') mApplName = L('Прогнозирование событий по астрофакторам в модели: "')+ALLTRIM(Ar_Model[mNumMod])+'"' M_NewAppl = ADD_ZAPPL(mApplName) *** Передача параметров расчета для графика DIRCHANGE(M_NewAppl) // Перейти в папку с БД новой модели и создать БД формализации предметной области: GenDbfClSc(.F.) // Классификационные шкалы GenDbfGrClSc(.F.) // Градации классификационных шкал GenDbfClass(.F.) // Классификационные шкалы и градации GenDbfOpSc(.F.) // Описательные шкалы GenDbfGrOpSc(.F.) // Градации описательных шкал GenDbfAttr(.F.) // Описательные шкалы и градации GenDbfObiZag() // Заголовки объектов обучающей выборки GenDbfObiKcl() // Коды классов объектов обучающей выборки GenDbfObiKpr() // Коды признаков объектов обучающей выборки GenDbfRsoZag() // Заголовки объектов распознаваемой выборки GenDbfRsoKcl() // Коды классов объектов распознаваемой выборки GenDbfRsoKpr() // Коды признаков объектов распознаваемой выборки F2_3_2_2(mApplName,"") // Запуск универсального программного интерфейса с внешними базами данных DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы Эйдос DC_ASave(aSoftInt , "_2_3_2_2.arx") // Сохранить возможно измененные параметры Running(.F.) *** Передача заданных параметров расчета для графика DIRCHANGE(Disk_dir+"/AID_DATA/Inp_data/") * StrFile(ALLTRIM(STR(RECCOUNT())), 'N_Obj.txt') N_Obj = VAL(FileStr('N_Obj.txt')) * MsgBox(STR(N_Obj)) DIRCHANGE(M_NewAppl) // Перейти в папку с БД новой модели и создать БД формализации предметной области: ar := {} AADD(ar, mNumMod) AADD(ar, M_Interval) AADD(ar, K_GradNClSc) AADD(ar, K_GradNOpSc) AADD(ar, N_Obj) DC_ASave(ar, "_23211chart.arx") * ar = DC_ARestore("_23211chart.arx") ********* Поменять имя приложения прямо в базе приложения после задания этих параметров ********** mApplName = L('Прогнозирование событий по астрофакторам в модели: "')+ALLTRIM(Ar_Model[mNumMod])+'", '+; IF(M_Interval=1,L('равн.'),L('адапт.'))+L('интервалы,')+' '+; // Эти параметры не могут в наименовании приложения, т.к. они задаются позже формирования имени приложения ALLTRIM(STR(K_GradNClSc))+' '+L('град.в кл.шкалах,')+' '+; // Или надо менять имя приложения прямо в базе приложения после задания этих параметров ALLTRIM(STR(K_GradNOpSc))+' '+L('град.в оп.шкалах') DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы Эйдос CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Appls EXCLUSIVE NEW SELECT Appls DBGOTOP() DO WHILE .NOT. EOF() IF LEN(ALLTRIM(BY_DEFAULT)) > 0 REPLACE NAME_APPL WITH mApplName EXIT ENDIF DBSKIP(1) ENDDO DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций ****** Формирование и запись txt-файла параметров модуля синтеза моделей ************************* cFile = "Model_sint_settings.txt" // <===######################################################## aPar := {} AADD(aPar,'Show_progress *') AADD(aPar,'Show_statistics_(milliseconds) 3000') AADD(aPar,'_') DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы Эйдос ERASE(cFile) CrLf = CHR(13)+CHR(10) // Конец строки (записи) mPar = '';FOR j=1 TO LEN(aPar);mPar=mPar+aPar[j]+CrLf;NEXT StrFile(mPar,cFile) LC_RunShell("Model_sint.exe", 89882657) // Модуль синтеза моделей *########################################################################################## *** ИСПРАВИТЬ МОДЕЛЬ PRC2, посчитанную на GPU: КАК В F3_2CPU (НА СТР.14011) *** <<<===##### *########################################################################################## * oScr := DC_WaitOn(L('Дорасчет модели PRC2. Немного подождите'),,,,,,,,,,,.F.) DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Attributes EXCLUSIVE NEW USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() // №1, N_Cls ################################ USE Gr_OpSc EXCLUSIVE NEW;N_Gos = RECCOUNT() // №2, N_Gos ################################ USE Opis_Sc EXCLUSIVE NEW * ###########################################################################* mLenNameMax = CreateStructAll() // Создание файлов структур баз данных всех моделей // Открытие текстовых баз данных ******************************************** *DC_ASave(aInfStruct, "_PrcStruct.arx") // Когда БД создается - записывать структуру, когда открывается - считывать aInfStruct = DC_ARestore("_PrcStruct.arx") ************************************************* ***** Формирование пустой записи N_Col = N_Cls+6 // Число полей CrLf = CHR(13)+CHR(10) // Конец строки (записи) Lc_buf = "" FOR j=1 TO N_Col * S = IF(j=2*INT(j/2),"#","X") // Для отладки S = " " // Для работы Lc_buf = Lc_buf + REPLICATE(S, aInfStruct[j,3]) NEXT Lc_buf = Lc_buf + CrLf Len_LcBuf = LEN(Lc_buf) ****** Создаем стат.базы и базы знаний (7 по частным критериям знаний) Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } PRIVATE nHandle[LEN(Ar_Model)] FOR z=1 TO 3 nHandle[z] := FOpen( Ar_Model[z]+".txt", FO_READWRITE ) // Открыть все текстовые базы данных ######################################## NEXT **** Рассчет массива начальных позиций полей в строке PRIVATE aPos[N_Col] aPos[1] = 1 FOR j=2 TO N_Col aPos[j] = aPos[j-1] + aInfStruct[j-1,3] NEXT * ########################################################################### * N = VAL(LC_FieldGet( Ar_Model[1]+".txt", nHandle[1], N_Gos+1, N_Cls+3 )) // Сумма числа признаков из Abs.txt NObj = VAL(LC_FieldGet( Ar_Model[1]+".txt", nHandle[1], N_Gos+4, N_Cls+3 )) // Сумма числа объектов из Abs.txt *** Prc2.txt ****************************** *** Запись столбца "Безусловная вероятность" IF NObj > 0 *** Запись столбца "Безусловная вероятность" FOR i=1 TO N_Gos // №9, N_Gos ################################ Ni = VAL(LC_FieldGet( Ar_Model[1]+".txt", nHandle[1], i, N_Cls+3 )) // Сумма Ni из Abs.txt IF Ni <> 0 String = STR(Ni/NObj*100, aInfStruct[N_Cls+3,3], aInfStruct[N_Cls+3,4] ) LC_FieldPut( Ar_Model[3]+".txt", nHandle[3], i, N_Cls+3, String ) ENDIF NEXT ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций FOR z=1 TO 3 FClose( nHandle[z] ) // Закрытие dbf и txt баз данных ###################################### NEXT * DC_Impl(oScr) *########################################################################################## ************************************************************************************************** F5_5(.F.) // Преобразовать в txt = > dbf Running(.F.) oScr := DC_WaitOn(L('Расчет баз данных: "ABS_Syla_Planet", "Grint"'),,,,,,,,,,,.F.) *** Расчет Силы Планет в файле: ABS_Syla_Planet ************************************************* *** В этом файле - 720 строк - (по числу градаций описательных шкал) и 29 столбцов. *** Первые 15 столбцов - копирую и переношу данные из полученного в режиме 3.1 файла ABS. *** В столбцах 16-27 - автоматически идет расчет силы планет по количеству и Интенсивности ЗМТ в каждой из 12 Градаций классификационных шкал. *** Столбец 28 (Summa_INT) - суммируются результаты столбцов 16-27. *** Столбец 29 (Syla_Planet)- Получаем искомый суммарный результат. Расчет в этом столбце - по формуле: *** =AB2*O2*1000/718,18, где 718,18 - это суммарная интенсивность ЗМТ из файла , это - сумма по столбцу 7 - (Int_ZMT) DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } M_Inf = UPPER(Ar_Model[mNumMod]) * MsgBox(STR(mNumMod)+' '+M_Inf) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Attributes EXCLUSIVE NEW;N_Atr = RECCOUNT() USE (M_Inf) EXCLUSIVE NEW *** Создать БД: ABS_Syla_Planet ************* mFN = -999 SELECT Attributes DBGOTOP() DO WHILE .NOT. EOF() mFN = MAX(mFN, LEN(ALLTRIM(Name_atr))) DBSKIP(1) ENDDO aStructure := { { "Kod_pr", "N", 15, 0 },; { "Name" , "C", mFN, 0 } } FOR j=1 TO N_Cls FieldName = "CLS"+ALLTRIM(STR(j,15)) AADD(aStructure, { FieldName, "N", 19, 1 }) NEXT AADD(aStructure, { "SUMMA", "N" , 19, 1 } ) FOR j=1 TO N_Cls FieldName = "SumINT_"+ALLTRIM(STR(j,15)) AADD(aStructure, { FieldName, "N", 19, 7 }) NEXT AADD(aStructure, { "Summa_INT" , "N", 19, 7 } ) AADD(aStructure, { "SylaPlanet", "N", 19, 7 } ) DbCreate( 'ABS_Syla_Planet', aStructure ) *** Перенос информации из Abs в БД: ABS_Syla_Planet ************* CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Attributes EXCLUSIVE NEW;N_Atr = RECCOUNT() USE (M_Inf) EXCLUSIVE NEW USE ABS_Syla_Planet EXCLUSIVE NEW SELECT (M_Inf) FOR r=1 TO N_Atr DBGOTO(r) ar := {} FOR j=1 TO FCOUNT()-2 AADD(ar, FIELDGET(j)) NEXT SELECT ABS_Syla_Planet APPEND BLANK FOR j=1 TO LEN(ar) FIELDPUT(j, ar[j]) NEXT SELECT (M_Inf) NEXT *** Расчет в БД: ABS_Syla_Planet ******************************** <<<===################## * ****** Для задачи 1 **** * SELECT ABS_Syla_Planet * DBGOTOP() * DO WHILE .NOT. EOF() * mSumma_INT = 0 * FOR j=1 TO N_Cls * mNij = FIELDGET(2+j) * FIELDPUT(3+N_Cls+j, mNij*j) * mSumma_INT = mSumma_INT + mNij*j * NEXT * REPLACE Summa_INT WITH mSumma_INT * DBSKIP(1) * ENDDO * SELECT ABS_Syla_Planet * DBGOTOP() * DO WHILE .NOT. EOF() * REPLACE SylaPlanet WITH Summa_INT * Summa * 1000 / mSummaINT100 * DBSKIP(1) * ENDDO ****** Для задачи 2 **** *** Надо сделать расчет весовых коэффицентов для любого числа классов ***** * IF N_Cls = 3 * PRIVATE aWeightCoefficients[3] * aWeightCoefficients[1] = 29.99 * aWeightCoefficients[2] = 59.99 * aWeightCoefficients[3] = 89.99 * ELSE aWeightCoefficients := {} FOR j=1 TO N_Cls AADD(aWeightCoefficients, 90/N_Cls*j) NEXT * ENDIF SELECT ABS_Syla_Planet /// <<<===################## DBGOTOP() DO WHILE .NOT. EOF() mSumma_INT = 0 FOR j=1 TO N_Cls mNij = FIELDGET(2+j) FIELDPUT(3+N_Cls+j, mNij*aWeightCoefficients[j]) mSumma_INT = mSumma_INT + mNij*aWeightCoefficients[j] NEXT REPLACE Summa_INT WITH mSumma_INT DBSKIP(1) ENDDO SELECT ABS_Syla_Planet DBGOTOP() DO WHILE .NOT. EOF() REPLACE SylaPlanet WITH Summa_INT * Summa * 1000 / mSummaINT100 DBSKIP(1) ENDDO *** Делаем файл: Bala.dbf *************************************** *** 1-й лист файла Bala. С файлом A_base ничего делать не надо. Но мы его переименовали в Inp_rasp и сделали по структуре таким же, как Inp_data.dbf *** Это сделано для того, чтобы можно было: 1) использовать для создания модели стандартные средства системы Эйдос, 2) использовать Inp_data вместо Inp_rasp при верификации модели *** На 2-м листе - Grint - переносим скопированные из файла Attributes , полученному после расчетов в режиме 3.1 - 3 столбца: *** NAME_ATR, MIN_GRINT, MAX_GRINT. А в 4-й столбец - Syla_Planet - копируем полученные нами данные из последнего столбца Файла . *** При этом переношу я эти данные, так как в последнем столбце есть формула, через промежуточный файл Excel, иначе будет появляться ошибка (ссылка). aStructure := { { "Kod_atr" , "N", 15, 0 },; { "Name_atr" , "C", mFN, 0 },; { "Min_grint" , "N", 19, 7 },; { "Max_grint" , "N", 19, 7 },; { "SylaPlanet", "N", 19, 7 } } DbCreate( 'Grint', aStructure ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Attributes EXCLUSIVE NEW;N_Atr = RECCOUNT() USE (M_Inf) EXCLUSIVE NEW USE ABS_Syla_Planet EXCLUSIVE NEW USE Grint EXCLUSIVE NEW SELECT Attributes DBGOTOP() DO WHILE .NOT. EOF() mRecno = RECNO() mKodAtr = Kod_atr mNameAtr = Name_atr mMinGrInt = Min_grint mMaxGrInt = Max_grint SELECT ABS_Syla_Planet DBGOTO(mRecno) mSylaPlanet = SylaPlanet SELECT Grint APPEND BLANK REPLACE Kod_atr WITH mKodAtr REPLACE Name_atr WITH mNameAtr REPLACE Min_grint WITH mMinGrInt REPLACE Max_grint WITH mMaxGrInt REPLACE SylaPlanet WITH mSylaPlanet SELECT Attributes DBSKIP(1) ENDDO DC_Impl(oScr) *** На третьем листе файла , который называется так же, строк - столько же, как и на первом листе: Inp_rasp.xls (A_Base), по числу дней года, и первые 11 столбцов *** - тоже с первого листа. Я не знаю, может быть, их можно удалить, эти столбцы, но вот я сделала так, и уже не решаюсь что-то менять. *** В следующих столбцах 12-21 - По формуле: =ВПР(B2;Grint!$B$2:$D$73;3;1) будет идти расчет на каждый прогнозный день, в зависимости от того, в какой интервал из 72 градаций *** описательных шкал попадает тот или иной астропараметр из будущего. Таким образом, на 3 листе Bala в столбцах 12-21 (они выделены голубым цветом) мы получаем прогноз (силу планет) *** на каждый прогнозный день 2019 гг. DIRCHANGE(Disk_dir+"/AID_DATA/Inp_data/") IF mRegim = 1 // Синтез и верификация модели, т.е. вместо Inp_rasp.dbf использовать Inp_data.dbf, т.е. просто скопировать Inp_data.dbf ===> Inp_rasp.dbf COPY FILE ('Inp_data.dbf') TO ('Inp_rasp.dbf') ENDIF IF mRegim = 2 // Это нужно делать только если задано прогнозирование, а не верификация. Дальше все одинаково LC_Excel2WorkArea( cExcelFile3 ) // Inp_rasp.xls(x) ===>Inp_rasp.dbf ENDIF oScr := DC_WaitOn(L('Расчет баз данных: "Bala", "Rasp_PROGNOZ"'),,,,,,,,,,,.F.) ********** Перенос информации из БД Inp_rasp.dbf в БД: Bala.dbf ************* CLoseAll() USE Bala EXCLUSIVE NEW INDEX ON FIELDGET(1) TO Bala // Для занесения информации о фактически произошедших ЗМТ CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Inp_rasp EXCLUSIVE NEW USE Bala INDEX Bala EXCLUSIVE NEW SELECT Inp_rasp DBGOTOP() DO WHILE .NOT. EOF() ar := {} AADD(ar, FIELDGET(1)) FOR j=8 TO FCOUNT() // задача 2 AADD(ar, FIELDGET(j)) // <===############################################################# NEXT * LB_Warning(ar) SELECT Bala;SET ORDER TO 1 APPEND BLANK FOR j=1 TO LEN(ar) FIELDPUT(j, ar[j]) // Дает ошибку на большой обучающей выборке (около 100 тыс.объектов) <===##################### NEXT REPLACE ZMT_fakt WITH 0 SELECT Inp_rasp DBSKIP(1) ENDDO ********** Перенос информации из БД Inp_fakt.dbf в БД: Bala.dbf и нормировка к прогнозируемым ********** IF FILE( cExcelFakt ) USE Inp_fakt INDEX Inp_fakt EXCLUSIVE NEW mSumIntFaktZMT = 0 SELECT Inp_fakt DBGOTOP() DO WHILE .NOT. EOF() mDate = FIELDGET(1) mIntZMT = FIELDGET(7) SELECT Bala;SET ORDER TO 1;T=DBSEEK(mDate) IF T REPLACE ZMT_fakt WITH mIntZMT mSumIntFaktZMT = mSumIntFaktZMT + mIntZMT ENDIF SELECT Inp_fakt DBSKIP(1) ENDDO ENDIF *** Скопировать БД Bala.dbf из папки Inp_data в папку текущего приложения *** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций COPY FILE ("Bala.dbf") TO (M_PathAppl+"Bala.dbf") DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Grint EXCLUSIVE NEW USE Bala EXCLUSIVE NEW USE Opis_Sc EXCLUSIVE NEW // Перенести значения полей (NAME_ATR, MIN_GRINT, MAX_GRINT, Syla_Planet) из Grint.dbf в массивы aNAME_ATR := {} aMIN_GRINT := {} aMAX_GRINT := {} aSyla_Planet := {} SELECT Grint DBGOTOP() DO WHILE .NOT. EOF() AADD(aNAME_ATR , ALLTRIM(NAME_ATR)) AADD(aMIN_GRINT , MIN_GRINT ) AADD(aMAX_GRINT , MAX_GRINT ) AADD(aSyla_Planet, SYLAPLANET) DBSKIP(1) ENDDO // Создать массивы диапазонов градаций шкал (NAME_OPSC, KODGR_MIN, KODGR_MAX) aNAME_OPSC := {} aKODGR_MIN := {} aKODGR_MAX := {} SELECT Opis_Sc DBGOTOP() DO WHILE .NOT. EOF() AADD(aNAME_OPSC, ALLTRIM(NAME_OPSC)) AADD(aKODGR_MIN, KODGR_MIN ) AADD(aKODGR_MAX, KODGR_MAX ) DBSKIP(1) ENDDO *** В следующих столбцах 12-21 - По формуле: =ВПР(B2;Grint!$B$2:$D$73;3;1) будет идти расчет на каждый прогнозный день, в зависимости от того, в какой интервал из 72 градаций *** описательных шкал попадает тот или иной астропараметр из будущего. Таким образом, на 3 листе Bala в столбцах 12-21 (они выделены голубым цветом) мы получаем прогноз (силу планет) *** на каждый прогнозный день 2019 гг. mNOpSc = LEN(aNAME_OPSC) // Число описательных шкал SELECT Bala DBGOTOP() DO WHILE .NOT. EOF() FOR ap = 1 TO mNOpSc // Код астропараметра mValAP = FIELDGET(1+ap) // Знач.астропараметра из БД FOR j=aKODGR_MIN[ap] TO aKODGR_MAX[ap] // Поиск в нужном диапазоне IF aMIN_GRINT[j] <= mValAP .AND. mValAP <= aMAX_GRINT[j] FIELDPUT(1+mNOpSc+ap, aSyla_Planet[j]) EXIT ENDIF NEXT NEXT DBSKIP(1) ENDDO *** Делаем файл: Rasp_PROGNOZ *********************************** ***** Последний прогнозный файл - . В нем столько же строк - по числу дней 2019 г, столбцы 1-21 - перенесены с листа файла , ***** тоже через промежуточный файл Excel, и пока с теми же ошибками, здесь я их исправляю вручную, и получаю уже такой файл: CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций COPY FILE ("Bala.dbf") TO ("Rasp_PROGNOZ.dbf") ****** Исправление непосчитанных ячеек CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rasp_PROGNOZ EXCLUSIVE NEW SELECT Rasp_PROGNOZ FOR ap = 1 TO mNOpSc // Код астропараметра DBGOTOP() DO WHILE .NOT. EOF() mValAPold = FIELDGET(1+mNOpSc+ap) // Знач.астропараметра из БД за текущий день DBSKIP(1) mValAPnew = FIELDGET(1+mNOpSc+ap) // Знач.астропараметра из БД за следующий день IF mValAPnew = 0 FIELDPUT(1+mNOpSc+ap, mValAPold) ENDIF ENDDO NEXT **** Расчет итогового столбца *********************************** SELECT Rasp_PROGNOZ DBGOTOP() DO WHILE .NOT. EOF() mPROGN_POLN = 0 FOR ap = 1 TO mNOpSc // Код астропараметра mPROGN_POLN = mPROGN_POLN + FIELDGET(1+mNOpSc+ap) NEXT REPLACE PROGN_POLN WITH mPROGN_POLN REPLACE PrognNNorm WITH mPROGN_POLN DBSKIP(1) ENDDO ******************************************************************************************** ****** НОРМИРОВАНИЕ ПРОГНОЗА И ФАКТА ******************************************************* ******************************************************************************************** DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения aVal := {} // Полный прогноз (высокочастотный) aFakt := {} // Факт CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rasp_PROGNOZ EXCLUSIVE NEW SELECT Rasp_PROGNOZ DBGOTOP() DO WHILE .NOT. EOF() AADD(aVal , PROGN_POLN) AADD(aFakt, ZMT_FAKT) DBSKIP(1) ENDDO n = LEN(aFakt) *********************************************************************** * Экспоненциальное сглаживание линейно нормированного логарифма факта: * - логарифм для уменьшения влияния низкочастотных выбросов; * - линейное нормирование для отображения значений в область: 0 - 1; * - экспоненциальное сглаживание для удаления уменьшения влияния высокочастотных выбросов (сила сглаживания задается в диалоге от полного его отсутствия до максимального: до одной прямой линии). *********************************************************************** aLogFakt := {} // Логарифм факта (в лог.шкале выбросы играют меньшую роль) aLineNormLogFakt := {} // Линейное нормирование логарифма факта (отображение в область: 0-1) aExpSmLineNormLF := {} // Экспоненциальное сглаживание линейного нормирования логарифма факта (ЗАМЕНИТЬ СГЛАЖИВАНИЕМ ЦЕНТРИРОВАННЫМ СКОЛЬЗЯЩИМ СРЕДНИМ) <===######### // Логарифм факта (в лог.шкале выбросы играют меньшую роль) mMinFakt = +99999999 mMaxFakt = -99999999 FOR j=1 TO n mMinFakt = MIN(mMinFakt, aFakt[j]) mMaxFakt = MAX(mMaxFakt, aFakt[j]) NEXT * FOR j=1 TO n * AADD(aLogFakt, IF(aFakt[j]>0,LOG(aFakt[j]),LOG(mMinFakt))) * NEXT aLogFakt = aFakt // Линейное нормирование логарифма факта (отображение в область: 0-1) mMinLogFakt = +99999999 mMaxLogFakt = -99999999 FOR j=1 TO n mMinLogFakt = MIN(mMinLogFakt, aLogFakt[j]) mMaxLogFakt = MAX(mMaxLogFakt, aLogFakt[j]) NEXT FOR j=1 TO n AADD(aLineNormLogFakt, (aLogFakt[j] - mMinLogFakt) / (mMaxLogFakt - mMinLogFakt)) NEXT // Экспоненциальное сглаживание линейного нормирования логарифма факта ****** ЗАМЕНИТЬ НА ЦЕНТРИРОВАННОЕ ЛИНЕЙНОЕ СГЛАЖИВАНИЕ СКОЛЬЗЯЩИМ СРЕДНИМ <===########### * mAlfa = 0.8 * AADD(aExpSmLineNormLF, aLineNormLogFakt[1]) * FOR j=2 TO n * AADD(aExpSmLineNormLF, mAlfa * aLineNormLogFakt[j] + ( 1 - mAlfa ) * aExpSmLineNormLF[j-1] ) * NEXT // ЦЕНТРИРОВАННОЕ ЛИНЕЙНОЕ СГЛАЖИВАНИЕ СКОЛЬЗЯЩИМ СРЕДНИМ <===########### PRIVATE aAvrFakt[n] // Длина исходного массива AFILL(aAvrFakt, 0) * aAvr[1] = aVal[1] // Чтобы 1-й элемент сглаженного массива были точно равен 1-му элементу несглаженного массива <===###### Когда верификация * mWindow = 7 // Интервал (окно) сглаживания (месяц) (задается в диалоге) IF mAlfa > 1 aAvrFakt = aLineNormLogFakt // Чтобы 1-й элемент сглаженного массива были точно равен 1-му элементу несглаженного массива <===###### Когда верификация ENDIF hw = (mAlfa-1)/2 // Размах окна влево и вправо от текущей позиции FOR i=2 TO n // Организовываем цикл по числу элементов mSumY = 0 ** Определение начала и конца окна IF i<=hw // если индекс меньше половины окна, мы находимся в начале массива, нужно брать окно меньшего размера k1=1 // в качестве начала окна берем первый элемент k2=2*i-1 // конец окна z=k2 // текущий размер окна ELSEIF i+hw>n // если индекс+половина окна больше n - мы приближаемся к концу массива и размер окна также нужно уменьшать k1=i-n+i // начало окна k2=n // конец окна - последний элемент массива z=k2-k1 // размер окна ELSE // если первые два условия не выполняются, мы в середине массива k1=i-hw k2=i+hw z=mAlfa ENDIF FOR j = INT(k1) TO INT(k2) // организуем цикл от начала до конца окна mSumY = mSumY + aLineNormLogFakt[j] // <===######################## дает ошибку когда окно четное? NEXT aAvrFakt[i] = mSumY / z * aAvrFakt[i] = IF(aAvrFakt[i]Y_MaxF,Y_MaxF,aAvrFakt[i]) NEXT ************* Нормирование значений: ValNorm = (Val-Min)/(Max-Min) mMinVal = +99999999 mMaxVal = -99999999 mMinFakt = +99999999 mMaxFakt = -99999999 mMinAvrFakt = +99999999 mMaxAvrFakt = -99999999 FOR j=1 TO n mMinVal = MIN(mMinVal , aVal [j]) mMaxVal = MAX(mMaxVal , aVal [j]) mMinFakt = MIN(mMinFakt , aFakt [j]) mMaxFakt = MAX(mMaxFakt , aFakt [j]) mMinAvrFakt = MIN(mMinAvrFakt, aAvrFakt[j]) mMaxAvrFakt = MAX(mMaxAvrFakt, aAvrFakt[j]) NEXT FOR j=1 TO n aVal [j] = (aVal [j] - mMinVal ) / (mMaxVal - mMinVal ) aFakt[j] = (aFakt [j] - mMinFakt ) / (mMaxFakt - mMinFakt ) aAvrFakt[j] = (aAvrFakt[j] - mMinAvrFakt) / (mMaxAvrFakt - mMinAvrFakt) NEXT ****** Записать результаты нормирования прогноза и сглаживания факта в БД SELECT Rasp_PROGNOZ j = 0 DBGOTOP() DO WHILE .NOT. EOF() j++ REPLACE Progn_poln WITH aVal [j] REPLACE ZMT_fakt WITH aFakt [j] REPLACE ZMTAvrFakt WITH aAvrFakt[j] DBSKIP(1) ENDDO ******************************************************************************************** ****** СГЛАЖИВАНИЕ ПРОГНОЗА **************************************************************** ******************************************************************************************** Y_MinF = +99999999 // Минимальное значение Y отображаемой функции Y_MaxF = -99999999 // Максимальное значение Y отображаемой функции FOR j=1 TO n Y_MinF = MIN(Y_MinF, aVal [j]) Y_MaxF = MAX(Y_MaxF, aVal [j]) Y_MinF = MIN(Y_MinF, aFakt[j]) Y_MaxF = MAX(Y_MaxF, aFakt[j]) NEXT n = LEN(aVal) mWindow = INT(IF(mWindow < n, mWindow, n/2)) // окно сглаживания не может быть больше половины длины массива значений IF mWindow > 0 ******* Расчет сглаженной кривой aAvr *** (http://habr.com/post/134375/) ********** * %в случае, если размер окна четный, увеличиваем его на 1 для симметрии; * window = 5; * if(mod(window,2)==0) * window=window+1; * end * hw=(window-1)/2; %размах окна влево и вправо от текущей позиции * n=length(Signal); * result=zeros(n,1); * result(1)=SN(1); %первый элемент берем из исходного массива SN как есть * for i=2:n %организовываем цикл по числу элементов * init_sum = 0; * if(i<=hw) %если индекс меньше половины окна, мы находимся в начале массива, * %нужно брать окно меньшего размера * k1=1; %в качестве начала окна берем первый элемент * k2=2*i-1; %конец окна * z=k2; %текущий размер окна * elseif (i+hw>n) %если индекс+половина окна больше n - мы приближаемся к концу массива и размер окна * %также нужно уменьшать * k1=i-n+i; %начало окна * k2=n; %конец окна - последний элемент массива * z=k2-k1; %размер окна * else %если первые два условия не выполняются, мы в середине массива * k1=i-hw; * k2=i+hw; * z=window; * end * for j=k1:k2 %организуем цикл от начала до конца окна * init_sum=init_sum+SN(j); %складываем все элементы * end * result(i)=init_sum/(z); %и делим на текущий размер окна * end PRIVATE aAvr[n] // Длина исходного массива * aAvr[1] = aVal[1] // Чтобы 1-й элемент сглаженного массива были точно равен 1-му элементу несглаженного массива <===###### Когда верификация * mWindow = 7 // Интервал (окно) сглаживания (месяц) (задается в диалоге) aAvr = aVal // Чтобы 1-й элемент сглаженного массива были точно равен 1-му элементу несглаженного массива <===###### Когда верификация hw = (mWindow-1)/2 // Размах окна влево и вправо от текущей позиции FOR i=2 TO n // Организовываем цикл по числу элементов mSumY = 0 ** Определение начала и конца окна IF i<=hw // если индекс меньше половины окна, мы находимся в начале массива, нужно брать окно меньшего размера k1=1 // в качестве начала окна берем первый элемент k2=2*i-1 // конец окна z=k2 // текущий размер окна ELSEIF i+hw>n // если индекс+половина окна больше n - мы приближаемся к концу массива и размер окна также нужно уменьшать k1=i-n+i // начало окна k2=n // конец окна - последний элемент массива z=k2-k1 // размер окна ELSE // если первые два условия не выполняются, мы в середине массива k1=i-hw k2=i+hw z=mWindow ENDIF FOR j = INT(k1) TO INT(k2) // организуем цикл от начала до конца окна mSumY = mSumY + aVal[j] // <===######################## дает ошибку когда окно четное? NEXT aAvr[i] = mSumY / z aAvr[i] = IF(aAvr[i]Y_MaxF,Y_MaxF,aAvr[i]) NEXT ENDIF ******************************************************************************************** ****** Записать сглаженный прогноз в БД SELECT Rasp_PROGNOZ j = 0 DBGOTOP() DO WHILE .NOT. EOF() j++ REPLACE Progn_avr WITH aAvr[j] DBSKIP(1) ENDDO ******************************************************************************************** ******************************************************************************************** *** РАСЧЕТ PrognReson.dbf ******************************************************************************************** ***** Подготовка данных для расчета ****************** DIRCHANGE(Disk_dir+"/AID_DATA/Inp_data/") CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций COPY FILE ("PrognReson.dbf") TO (M_PathAppl+"PrognReson.dbf") ERASE("PrognReson.dbf") CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций aFakt := {} IF FILE('Inp_fakt.dbf') USE Inp_fakt EXCLUSIVE NEW // <<<===##################################### SELECT Inp_fakt DBGOTOP() DO WHILE .NOT. EOF() AADD(aFakt, FIELDGET(7)) DBSKIP(1) ENDDO ENDIF DIRCHANGE(M_PathAppl) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rasp_PROGNOZ EXCLUSIVE NEW USE PrognReson EXCLUSIVE NEW;ZAP SELECT Rasp_PROGNOZ r = 0 DBGOTOP() DO WHILE .NOT. EOF() ar := {} FOR j=1 TO FCOUNT() AADD(ar, FIELDGET(j)) NEXT SELECT PrognReson APPEND BLANK FOR j=1 TO LEN(ar) FIELDPUT(j, ar[j]) NEXT IF LEN(aFakt) > 0 REPLACE SumINT_ZMT WITH aFakt[++r] // <<<===##################################### ENDIF SELECT Rasp_PROGNOZ DBSKIP(1) ENDDO ***** Расчет ***************************************** aPrognAvr := {} aPrognMin := {} SELECT PrognReson DBGOTOP() DO WHILE .NOT. EOF() REPLACE PROGN_N WITH PROGNNNORM / 10000 AADD(aPrognAvr, PROGN_AVR) AADD(aPrognMin, '') DBSKIP(1) ENDDO ***** Поиск минимумов: ***** Если среднее N значений aPrognAvr раньше текущего И среднее N значений aPrognAvr раньше позже текущего больше него, то это минимум n = 2 FOR j=n+1 TO LEN(aPrognAvr)-n mAvrNdo = 0 FOR i=j-n TO j-1 mAvrNdo = mAvrNdo + aPrognAvr[i] NEXT mAvrNdo = mAvrNdo / n mAvrNpo = 0 FOR i=j+1 TO j+n mAvrNpo = mAvrNpo + aPrognAvr[i] NEXT mAvrNpo = mAvrNpo / n IF mAvrNdo > aPrognAvr[j] .AND. aPrognAvr[j] < mAvrNpo aPrognMin[j] = 'MIN' ENDIF NEXT r = 0 SELECT PrognReson DBGOTOP() DO WHILE .NOT. EOF() REPLACE ProgAvrMin WITH aPrognMin[++r] DBSKIP(1) ENDDO mPrognNI = 0 mIntZmtNI = 0 SELECT PrognReson DBGOTOP() DO WHILE .NOT. EOF() IF ProgAvrMin = 'MIN' mPrognNI = 0 mIntZmtNI = 0 ENDIF mPrognNI = mPrognNI + PROGN_N mIntZmtNI = mIntZmtNI + SUMINT_ZMT REPLACE PROGN_NI WITH mPrognNI REPLACE INT_ZMT_NI WITH mIntZmtNI DBSKIP(1) ENDDO DC_Impl(oScr) ******************************************* Chart23211(.F.) // Рисуем график ******************************************* aMess := {} AADD(aMess, L('РАСЧЕТ УСПЕШНО ЗАВЕРШЕН! Созданы следующие базы данных (все БД открываются в MS Excel):')) AADD(aMess, L('- файлы: "'+cExcelFile1+'" и "')+cExcelFile2+L('" объединены по полю "Дата" в БД: "')+Disk_dir+'"\AID_DATA\Inp_data\Inp_data.dbf".') AADD(aMess, L('- в папке текущего приложения:')+' '+M_PathAppl+' '+'находятся базы данных:') AADD(aMess, L('- "ABS_Syla_Planet.DBF", "Grint.dbf", "Bala.dbf" и "Rasp_PROGNOZ.dbf".')) AADD(aMess, L('- графическая форма записана в папке:')+' '+M_PathAppl+L('Events.')) LB_Warning(aMess, 'Система "Эйдос"' ) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW Running(.F.) RETURN nil **************************************************************************************** FUNCTION Help23211() DCSETFONT TO '10.Helv' s=1 D=0.8 @ s, 1 DCSAY L('Режим "2.3.2.11". Прогноз событий по астропараметрам по Н.А.Чередниченко. ') FONT '12.HelvBold' SAYSIZE 0;s=s+D @ s, 1 DCSAY L(' ') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('Методика прогнозирования сейсмичности основана на том, что сейсмогенез на планете зависит в основном от влияния космической среды. Солнце, Луна, планеты Солнечной Системы, и даже элементы их орбитального ') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('движения способны вызывать вполне ощутимые результаты в виде сейсмических событий. В режиме 2.3.2.12 прогнозирование основано на воздействии на сейсмогенез 10 пар Лунно-планетарных взаимоотношений, режим ') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('2.3.2.11 расширяет возможности оператора по прогнозированию сейсмичности, так как в этом режиме спектр астрономических показателей расширен до 42 астропараметров. В данном режиме возможно использование для ') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('прогнозирования таких показателей орбитального движения космических тел, как эклиптикальные долготы, склонения, скорости орбитального движения и дистанции от Земли - для Солнца, Луны, планет от Меркурия - ') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('до Нептуна, а также эклиптикальные долготы, скорости движения и склонения для лунного восходящего узла и апогея. При расчетах в режиме 2.3.2.11 возможно использовать весь спектр или определенные астрономи- ') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('ческие показатели, а также выбрать число классов и градаций описательных шкал. Чем продолжительнее и полнее статистическая база исследуемых сейсмособытий, тем точнее выявляется зависимость сейсмогенеза - ') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('от динамики космических факторов. Методика прогнозирования основана на том факте, что при исследовании зависимости сейсмических событий - от астрономических показателей космических тел, весь спектр классов ') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('неравномерно распределяется по градациям описательных шкал таким образом, что при одних строго определенных градациях астрономических параметров землетрясений не происходит вообще, а при других - они ') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('происходят в большом числе случаев. Такое распределение классов сейсмособытий по градациям признаков послужило основанием для определения Силы планет и численного моделирования прогноза сейсмичности, ') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('реализованного в режиме 2.3.2.11. Каждый из 42 астропараметров (или астрономических показателей орбитального движения небесных тел) динамично изменяется вследствие годового обращения Земли вокруг Солнца, ') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('движения планет и Луны, поэтому при наступлении в прогностическом периоде такой комбинации градаций признаков, при которой не происходило землетрясений в прошлом, можно ожидать, что землетрясений не будет, ') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('а при возникновении в прогнозируемом временном периоде такой комбинации градаций признаков, которая соответствовала максимальной Силе планет в ретроспективном периоде, можно ожидать возникновения соответ- ') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('ствующих сейсмособытий. Прогнозная форма в режиме 2.3.2.11 выдается в виде 2-d и полярного графиков-прогнозов для исследуемого региона или мира, на которых представлены сейсмические циклы повышения и сниже-') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('ния уровня сейсмичности. Эти циклы появляются вследствие наложения низкочастотных и высокочастотных гармоник, создаваемых динамически изменяющимся воздействием различных небесных тел в открытой системе ') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('Земля-Космос. Высокочастотные пики в сейсмических циклах означают вероятные всплески сейсмичности, разрядку сейсмических очагов. Так как методика прогнозирования событий является универсальной, возможно ') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('также использование режима 2.3.2.11 для прогнозирования многих глобальных процессов, таких как динамика магнитного поля, климатические аномалии, динамика полюса Земли и других. ') SAYSIZE 0;s=s+D s=s+D @ s, 1 DCSAY L('Непосредственно работе режима 2.3.2.11 посвящены публикации:') SAYSIZE 0;s=s+D s=s+D DCSETFONT TO '6.Helv' @ s, 1 DCSAY L('Cherednychenko N.A., Lutsenko E.V., ASC-ANALYSIS OF THE IMPACT OF THE SPACE ENVIRONMENT ON SEISMOGENESIS AND PREDICTION OF SEISMICITY BASED ON ASTRONOMICAL DATA IN THE PROGRAM "AIDOS-TEMBLORS", February 2021, DOI: 10.13140/RG.2.2.24506.52165') FONT '6.Helv' SAYSIZE 0;s=s+D @ s, 1 DCSAY L('https://www.researchgate.net/publication/349215614_ASC-ANALYSIS_OF_THE_IMPACT_OF_THE_SPACE_ENVIRONMENT_ON_SEISMOGENESIS_AND_PREDICTION_OF_SEISMICITY_BASED_ON_ASTRONOMICAL_DATA_IN_THE_PROGRAM_AIDOS-TEMBLORS') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'https://www.researchgate.net/publication/349215614_ASC-ANALYSIS_OF_THE_IMPACT_OF_THE_SPACE_ENVIRONMENT_ON_SEISMOGENESIS_AND_PREDICTION_OF_SEISMICITY_BASED_ON_ASTRONOMICAL_DATA_IN_THE_PROGRAM_AIDOS-TEMBLORS', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} FONT '6.Helv' ;s=s+D s=s+D DCSETFONT TO '10.Helv' @ s, 1 DCSAY L('Lutsenko E.V., Cherednychenko N.A. Cognitive seismicity prediction system based on astronomical data "Aidos-Temblors" (System " Aidos-Temblors"), February 2021. DOI: 10.13140/RG.2.2.35747.58403, License CC BY-SA 4.0') FONT '6.Helv' SAYSIZE 0;s=s+D @ s, 1 DCSAY L('https://www.researchgate.net/publication/349554510_Cognitive_seismicity_prediction_system_based_on_astronomical_data_Aidos-Temblors_System_Aidos-Temblors') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'https://www.researchgate.net/publication/349554510_Cognitive_seismicity_prediction_system_based_on_astronomical_data_Aidos-Temblors_System_Aidos-Temblors', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} FONT '6.Helv' ;s=s+D s=s+D @ s, 1 DCSAY L('Lutsenko E.V., Trounev A.P. AI SYSTEM FOR COGNITIVE PREDICTION. CHAPTER I. SEISMIC MODELS, December 2020, DOI: 10.13140/RG.2.2.34745.39524, License: CC BY-SA 4.0, ') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('https://www.researchgate.net/publication/347881661_AI_SYSTEM_FOR_COGNITIVE_PREDICTION_CHAPTER_I_SEISMIC_MODELS') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'https://www.researchgate.net/publication/347881661_AI_SYSTEM_FOR_COGNITIVE_PREDICTION_CHAPTER_I_SEISMIC_MODELS', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)};s=s+D s=s+D @ s, 1 DCSAY L('Луценко Е. В. Методология системно-когнитивного прогнозирования сейсмичности : монография / Е. В. Луценко, А. П. Трунев, Н. А. Чередниченко; под общ. ред. В. И. Лойко. ') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('- Краснодар : КубГАУ, 2020. - 532 с., ISBN 978-5-907294-89-9, DOI 10.13140/RG.2.2.29617.33122 - Режим доступа:') SAYSIZE 0 @ s, 1 DCSAY L('https://www.researchgate.net/publication/340116509_METHODOLOGY_OF_SYSTEM-COGNITIVE_FORECASTING_OF_SEISMICITY') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'https://www.researchgate.net/publication/340116509_METHODOLOGY_OF_SYSTEM-COGNITIVE_FORECASTING_OF_SEISMICITY', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)};s=s+D s=s+D @ s, 1 DCSAY L('Луценко Е.В. Резонансный сейсмогенез и системно-когнитивное прогнозирование сейсмичности : монография /Е.В.Луценко, А.П.Трунев, Н.А.Чередниченко; под общ.ред. В.И.Лойко. ') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('- Краснодар : КубГАУ, 2019. - 256 с. - Режим доступа:') SAYSIZE 0 @ s, 1 DCSAY L('https://www.researchgate.net/publication/335992085_RESONANT_SEISMOGENIC_AND_SYSTEMIC-COGNITIVE_PREDICTION_OF_SEISMICITY') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'https://www.researchgate.net/publication/335992085_RESONANT_SEISMOGENIC_AND_SYSTEMIC-COGNITIVE_PREDICTION_OF_SEISMICITY', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)};s=s+D s=s+D @ s, 1 DCSAY L('Луценко Е. В. Методика системно-когнитивного прогнозирования сейсмичности (на примере региона Италии) / Е. В. Луценко, А. П. Трунев, Н. А. Чередниченко - Краснодар : ') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('КубГАУ, 2019. - 33 с. - Режим доступа:') SAYSIZE 0 @ s, 1 DCSAY L('https://www.researchgate.net/publication/336580243_METHOD_of_SYSTEM-COGNITIVE_PREDICTION_of_SEISMICITY_on_the_example_of_the_region_of_Italy') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'https://www.researchgate.net/publication/336580243_METHOD_of_SYSTEM-COGNITIVE_PREDICTION_of_SEISMICITY_on_the_example_of_the_region_of_Italy', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)};s=s+D s=s+D @ s, 1 DCSAY L('а также облачное Эйдос-приложение № 255, которое можно установить в режиме 1.3. "Скачать приложение из облака"') SAYSIZE 0;s=s+D DCREAD GUI FIT MODAL TITLE L('Помощь по режиму "2.3.2.11". Прогноз событий по астрофакторам методом Н.А.Чередниченко') RETURN NIL **************************************************************************************** ******** Сравнение прогноза ЗМТ с фактом стандартными средствами системы "Эйдос" **************************************************************************************** FUNCTION CompForeFact1() Running(.F.) *** Проверка наличия приложения и файла: Rasp_PROGNOZ.dbf в папке текущего приложения, выдача сообщения, если чего-нибудь не хватает *** Проверка наличия модели DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы Эйдос CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Appls EXCLUSIVE NEW IF RECCOUNT() = 0 LB_Warning('Нет файла: "Rasp_PROGNOZ.dbf". Необходимо сначала создать модель!') RETURN nil ENDIF SELECT Appls DBGOTOP() DO WHILE .NOT. EOF() IF LEN(ALLTRIM(BY_DEFAULT)) > 0 M_PathAppl = ALLTRIM(Path_Appl) // Путь на текущее приложение EXIT ENDIF DBSKIP(1) ENDDO DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения IF .NOT. FILE('Rasp_PROGNOZ.dbf') LB_Warning('Нет файла: "Rasp_PROGNOZ.dbf". Необходимо сначала создать модель!') RETURN nil ENDIF *** Копирование файла Rasp_PROGNOZ.dbf из папки текущего приложения в папку Inp_data с именем Inp_data.dbf и создание файлов наименований полей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций COPY FILE ("Rasp_PROGNOZ.dbf") TO (Disk_dir+"/AID_DATA/Inp_data/"+"Inp_data.dbf") CrLf = CHR(13)+CHR(10) // Конец строки (записи) * 'DATE' // 01 mInpName = 'MO_SUN' + CrLf +; // 02 'MO_MA' + CrLf +; // 03 'MO_JUP' + CrLf +; // 04 'MO_SAT' + CrLf +; // 05 'MO_UR' + CrLf +; // 06 'MO_NEP' + CrLf +; // 07 'MO_RAHU' + CrLf +; // 08 'MO_APOG' + CrLf +; // 09 'MO_MER' + CrLf +; // 10 'MO_VEN' + CrLf +; // 11 '_MO_SUN' + CrLf +; // 12 Дальше описательные шкалы '_MO_MA' + CrLf +; // 13 '_MO_JUP' + CrLf +; // 14 '_MO_SAT' + CrLf +; // 15 '_MO_UR' + CrLf +; // 16 '_MO_NEP' + CrLf +; // 17 '_MO_RAHU' + CrLf +; // 18 '_MO_APOG' + CrLf +; // 19 '_MO_MER' + CrLf +; // 20 '_MO_VEN' + CrLf +; // 21 'PROGN_POLN' + CrLf +; // 22 Дальше классификационные шкалы 'PROGN_AVR' + CrLf +; // 23 'ZMT_FAKT' + CrLf +; // 24 'ZMTAVRFAKT' + CrLf +; // 25 'PROGNNNORM' // 26 DIRCHANGE(Disk_dir+"\AID_DATA\Inp_data\") // Перейти в папку Inp_data StrFile(mInpName , "Inp_name.txt") // Запись текстового файла "Inp_name.txt" mInpNameAll = 'Date' + CrLf + mInpName StrFile(mInpNameAll, "Inp_nameAll.txt") // Запись текстового файла "Inp_name.txt" *** Подготовка параметров режима 2.3.2.2. Regim = 1 // Формализации ПО или ген.расп.выб. Flag_zer = 2 // Считать нули и пробелы отсутствием данных? [1]-да, [2]-нет N_Chast = 1 // На сколько частей N разбивать обучающую или распознаваемую выборку (в зависимости от Regim) M_ClSc1 = 2 // Номер начального столбца диапазона классификационных шкал // Задача 2 M_ClSc2 = 2 // Номер конечного столбца диапазона классификационных шкал // Задача 2 M_OpSc1 = 3 // Номер начального столбца диапазона описательных шкал // Задача 2 M_OpSc2 = 44 // Номер конечного столбца диапазона описательных шкал // Задача 2 M_ObAnk = 3 // Создавать анкеты исходной выборки по строкам Inp_data-[1], по классам-[2], и 1-е, и 2-е [3] M_Interval = 1 // 1-равные интервалы, 2-адаптивные интервалы (с примерно равным количеством наблюдений, по Котельникову) N_SKGrCl = 5 N_SKGrPr = 5 K_N_ClSc = 1 K_N_OpSc = 1 K_N_GrClSc = 3 // Количество градаций в числовой классификационной шкале // Задача 2 K_N_GrOpSc = 360 // Количество градаций в числовой описательной шкале // Задача 2 M_Scenario = .F. mGorizMin = 5 mGorizMax = 5 mGlubMin = 5 mGlubMax = 5 K_GradNClSc = 3 // Задача 2 K_GradNOpSc = 360 // Задача 2 M_ChastObi = .F. M_ChastRso = .F. N_ChastObi = 1 N_ChastRso = 1 M_XlsDbf = 3 mTxtCSField = 1 // Способ интерпретации значений текстовых полей - классификационных шкал файла исходных данных mTxtOSField = 1 // Способ интерпретации значений текстовых полей - описательных шкал файла исходных данных mTxtCSSep = " " // Разделитель элементов классификационных шкал, если mTxtCSField=3 mTxtOSSep = " " // Разделитель элементов описательных шкал, если mTxtOSField=3 * mScenario = 1 // mScenario=1 Не применять сценарный метод АСК-анализа и спец.интерпретацию TXT-полей (старый вариант) mScenario = 1 // Не применять сценарный метод АСК-анализа mSpecInterprCls = .F. // .T. - Применить спец.интерпретацию текстовых полей классов, .F. - не применять mSpecInterprAtr = .F. // .T. - Применить спец.интерпретацию текстовых полей признаков, .F. - не применять mNameGrNumSc= 1 // Какие наименования ГРАДАЦИЙ числовых шкал использовать mClsAvr = .F. // .F. - делать модель из Inp_data, .T. - делать модель из Inp_data_avr mSortUnqCls = 1 // Выделять уникальные значения классов и сортировать, 1-да, 2-нет mLemmatCls = 2 // Проводить лемматизацию классов, 1-да, 2-нет mSortUnqGos = 1 // Выделять уникальные значения признаков и сортировать, 1-да, 2-нет mLemmatGos = 2 // Проводить лемматизацию признаков, 1-да, 2-нет // Сохранить файл с информацией о заданых параметрах программного интерфейса в текущей директории системы PRIVATE aSoftInt[40] aSoftInt[ 1] = Regim aSoftInt[ 2] = Flag_zer aSoftInt[ 3] = M_ClSc1 aSoftInt[ 4] = M_ClSc2 aSoftInt[ 5] = M_OpSc1 aSoftInt[ 6] = M_OpSc2 aSoftInt[ 7] = N_SKGrCl aSoftInt[ 8] = N_SKGrPr aSoftInt[ 9] = K_N_ClSc aSoftInt[10] = K_N_OpSc aSoftInt[11] = K_N_GrClSc aSoftInt[12] = K_N_GrOpSc aSoftInt[13] = M_ObAnk aSoftInt[14] = N_Chast aSoftInt[15] = M_Interval aSoftInt[16] = M_Scenario aSoftInt[17] = K_GradNClSc // Количество градаций в числовой классификационной шкале aSoftInt[18] = K_GradNOpSc // Количество градаций в числовой описательной шкале aSoftInt[19] = mGorizMin aSoftInt[20] = mGorizMax aSoftInt[21] = mGlubMin aSoftInt[22] = mGlubMax aSoftInt[23] = M_ChastObi aSoftInt[24] = M_ChastRso aSoftInt[25] = N_ChastObi aSoftInt[26] = N_ChastRso aSoftInt[27] = M_XlsDbf aSoftInt[28] = mTxtCSField aSoftInt[29] = mTxtOSField aSoftInt[30] = mTxtCSSep aSoftInt[31] = mTxtOSSep * aSoftInt[32] = mScenario // mScenario=1 Не применять сценарный метод АСК-анализа и спец.интерпретацию TXT-полей (старый вариант) aSoftInt[32] = mScenario // mScenario=1 Не применять сценарный метод АСК-анализа aSoftInt[33] = mSpecInterprCls // Применить спец.интерпретацию текстовых полей классов aSoftInt[34] = mSpecInterprAtr // Применить спец.интерпретацию текстовых полей признаков aSoftInt[35] = mNameGrNumSc // Какие наименования ГРАДАЦИЙ числовых шкал использовать aSoftInt[36] = mClsAvr // .F. = модель без усреднения по классам aSoftInt[37] = mSortUnqCls // Выделять уникальные значения классов и сортировать, 1-да, 2-нет aSoftInt[38] = IF(mSpecInterprCls,mLemmatCls,2) // Проводить лемматизацию классов, 1-да, 2-нет aSoftInt[39] = mSortUnqGos // Выделять уникальные значения признаков и сортировать, 1-да, 2-нет aSoftInt[40] = IF(mSpecInterprAtr,mLemmatGos,2) // Проводить лемматизацию признаков, 1-да, 2-нет DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы DC_ASave(aSoftInt , "_2_3_2_2.arx") *** Создать новое пустое приложение с заданным имененем ****************************************** mApplName = L('Сравнение прогноза событий методом Чередниченко Н.А. с фактом') M_NewAppl = ADD_ZAPPL(mApplName) DIRCHANGE(M_NewAppl) // Перейти в папку с БД новой модели и создать БД формализации предметной области: GenDbfClSc(.F.) // Классификационные шкалы GenDbfGrClSc(.F.) // Градации классификационных шкал GenDbfClass(.F.) // Классификационные шкалы и градации GenDbfOpSc(.F.) // Описательные шкалы GenDbfGrOpSc(.F.) // Градации описательных шкал GenDbfAttr(.F.) // Описательные шкалы и градации GenDbfObiZag() // Заголовки объектов обучающей выборки GenDbfObiKcl() // Коды классов объектов обучающей выборки GenDbfObiKpr() // Коды признаков объектов обучающей выборки GenDbfRsoZag() // Заголовки объектов распознаваемой выборки GenDbfRsoKcl() // Коды классов объектов распознаваемой выборки GenDbfRsoKpr() // Коды признаков объектов распознаваемой выборки DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы Эйдос DC_ASave(aSoftInt , "_2_3_2_2.arx") F2_3_2_2(mApplName,"") // Запуск универсального программного интерфейса с внешними базами данных DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций F3_5('GPU','SintRec','3.3') // Синтез и верификация всех моделей F4_2_2_1() // Расчет матрицы сходства классов F4_2_2_2() // Визуализация когн.диаграммы сходства классов F4_2_2_3() // Расчет и визуализация дендрограммы агломеративной когнитивной кластеризации классов aMess := {} AADD(aMess, 'Еще можно исследовать модель в режимах:') AADD(aMess, '4.4.8, 4.4.9, 4.4.10, 4.4.11, 4.5 и других') LB_Warning(aMess,'(C) Система "Эйдос"') Running(.F.) RETURN nil ***************************************************************** ******** Рисуем график ****************************************** ***************************************************************** FUNCTION Chart23211(mDialog) * oScr := DC_WaitOn('Немного подождите! Идет формирование изображения в памяти и его масштабирование',,,,,,,,,,,.F.) *** Проверки наличия приложения ****************************** DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE PathGrAp EXCLUSIVE NEW;N_GrAp = RECCOUNT() USE Appls EXCLUSIVE NEW;N_Appls = RECCOUNT() USE Users EXCLUSIVE NEW;N_Users = RECCOUNT() IF N_GrAp = 0 // Если нет групп приложений - ничего не делать LB_Warning(L("В режиме 1.5 нет ни одной группы приложений !!!")) Running(.F.) RETURN(.T.) ENDIF IF N_Users = 0 // Если нет пользователей - ничего не делать LB_Warning(L("В режиме 1.2 не задано ни одного пользователя !!!")) Running(.F.) RETURN(.T.) ENDIF IF N_Appls = 0 // Если нет приложений - ничего не делать LB_Warning(L("В диспетчере приложений 1.3 нет ни одного приложения !!!")) Running(.F.) RETURN(.T.) ENDIF ****** Если приложение есть, то перейти в него *************** SELECT Appls PUBLIC M_PathAppl := "" PUBLIC M_NameAppl := "" DBGOTOP() DO WHILE .NOT. EOF() IF LEN(ALLTRIM(By_default)) > 0 REPLACE By_default WITH "W" M_PathAppl = ALLTRIM(Path_Appl) M_NameAppl = ALLTRIM(Name_Appl) EXIT ENDIF DBSKIP(1) ENDDO *** Проверки наличия и открытие БД *************************** DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения IF .NOT. FILE('Rasp_PROGNOZ.dbf') aMess := {} AADD(aMess, L('В приложении отсутствует база данных: "Rasp_PROGNOZ.dbf".')) AADD(aMess, L('Чтобы ее создать необходимо выполнить данный режим.')) AADD(aMess, L('Прочитайте описание метода, кликнув по кнопке: "Помощь".')) LB_Warning(aMess, 'Система "Эйдос"' ) RETURN NIL ENDIF DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы PRIVATE a23211[8] IF FILE("_23211.arx") // Параметры диалога F2_3_2_12() a23211 = DC_ARestore("_23211.arx") PUBLIC mNumMod := a23211[1] PUBLIC mRegim := a23211[2] PUBLIC mWindow := a23211[3] PUBLIC mXSize := a23211[4] PUBLIC mYSize := a23211[5] PUBLIC mLineWidth := a23211[6] PUBLIC mGamma := a23211[7] PUBLIC mAlfa := a23211[8] ELSE PUBLIC mNumMod := 1 PUBLIC mRegim := 2 PUBLIC mWindow := 7 PUBLIC mXSize := 1800 PUBLIC mYSize := 900 PUBLIC mLineWidth := 7 PUBLIC mGamma := 1 PUBLIC mAlfa := 1 a23211[1] = mNumMod a23211[2] = mRegim a23211[3] = mWindow a23211[4] = mXSize a23211[5] = mYSize a23211[6] = mLineWidth a23211[7] = mGamma a23211[8] = mAlfa DC_ASave(a23211, "_23211.arx") ENDIF IF mDialog PRIVATE aInput[6] aInput[1] = mWindow aInput[2] = mXSize aInput[3] = mYSize aInput[4] = mLineWidth aInput[5] = mGamma aInput[6] = mAlfa aOutput = SetIntSglag(aInput) // Задать значение интервала (окна) сглаживания, разрешения графической формы и параметры линии PUBLIC mNumMod := a23211 [1] PUBLIC mRegim := a23211 [2] PUBLIC mWindow := aOutput[1] PUBLIC mXSize := aOutput[2] PUBLIC mYSize := aOutput[3] PUBLIC mLineWidth := aOutput[4] PUBLIC mGamma := aOutput[5] PUBLIC mAlfa := aOutput[6] a23211[1] = mNumMod a23211[2] = mRegim a23211[3] = mWindow a23211[4] = mXSize a23211[5] = mYSize a23211[6] = mLineWidth a23211[7] = mGamma a23211[8] = mAlfa DC_ASave(a23211, "_23211.arx") ENDIF *** График в декартовой системе координат ********** DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения * PUBLIC X_MaxW := 1800, Y_MaxW := 900 // Размер графического окна для отображения когнитивных диаграмм в пикселях PUBLIC X_MaxW := mXSize, Y_MaxW := mYSize // Максимальный размер графического окна для отображения 4K. PUBLIC nXSize := X_MaxW PUBLIC nYSize := Y_MaxW // Create new bitmap with given size oPS := XBPPRESSPACE() :new() :Create() oBMP := XBPBITMAP() :New() :Create() oBMP:Make( nXSize, nYSize ) oBMP:presSpace( oPS ) // here your GRA* Code **** Закрасить фон прямоугольника *************** * GraSetColor( oPS, GRA_CLR_WHITE, GRA_CLR_WHITE ) GraSetColor( oPS, BD_LIGHTGREY, BD_LIGHTGREY ) GraBox( oPS, { 0, 0 }, { nXSize, nYSize }, GRA_FILL ) *######################################################################################################################### ChartEvents( oPS, mDialog ) // Графическая функция <<<===############################ * ChartEventsPolar( oPS, 'Events' ) *######################################################################################################################### *My image original, my image scaled ****** Запись полноразмерного графического файла в папку: M_PathAppl+"Events\" * DC_Impl(oScr) DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения IF FILEDATE("Events",16) = CTOD("//") // задача 2 DIRMAKE("Events") // задача 2 aMess := {} AADD(aMess, L('В папке текущего приложения: "'+UPPER(ALLTRIM(M_PathAppl))+'"')) AADD(aMess, L('не было директории "Events" для графических форм по прогнозам событий и она была создана!')) // <===####################### // задача 2 AADD(aMess, L('В эту папку записываются исходные изображения высокого качества (без масштабирования)')) LB_Warning(aMess, L('Прогноз событий в системе "Эйдос"')) // задача 2 ENDIF DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения DIRCHANGE(M_PathAppl+"Events\") // Перейти в папку Events // задача 2 cFileName = "EventsDescartes"+STRTRAN(STR(ADIR("*.*")+1,6)," ","0")+".jpg" ERASE(cFileName) oBMP:SaveFile(cFileName,XBPBMP_FORMAT_JPG) IF nWidth > 1800 FullView( cFileName, "по верху", 65 ) // Визуализация полноразмерного файла на мониторе высокого разрешения ELSE ****** Формирование с помощью bmp2bmp() и отображение масштабированного изображения aNewSize := {nWidth,nHeight-29} // Новый размер изображения (еще немного уменьшается, чтобы не рисовать по панели задач) oBMP:loadFile(cFileName) // Загрузка полноразмерного изображения oRet := BMP2BMP(oBMP,aNewSize) // Масштабирование изображения cFileNameScale = SUBSTR(cFileName,1,AT(".jpg",cFileName)-1)+"_scaled.jpg" ERASE(cFileNameScale) oRet:saveFile(cFileNameScale,XBPBMP_FORMAT_JPG) // Запись масштабированного графического файла в в папку приложения для визуализации FullView( cFileNameScale, "по верху", 0 ) // Визуализация масштабированного графического файла на мониторе ограниченного разрешения ENDIF DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения *** График в полярной системе координат ********** DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения PUBLIC X_MaxW := 2048, Y_MaxW := 2048 // Размер графического окна для отображения когнитивных диаграмм в пикселях PUBLIC X_MaxW := mXSize, Y_MaxW := mYSize // Максимальный размер графического окна для отображения 4K. PUBLIC nXSize := X_MaxW PUBLIC nYSize := Y_MaxW // Create new bitmap with given size oPS := XBPPRESSPACE() :new() :Create() oBMP := XBPBITMAP() :New() :Create() oBMP:Make( nXSize, nYSize ) oBMP:presSpace( oPS ) // here your GRA* Code **** Закрасить фон прямоугольника *************** * GraSetColor( oPS, GRA_CLR_WHITE, GRA_CLR_WHITE ) GraSetColor( oPS, BD_LIGHTGREY, BD_LIGHTGREY ) GraBox( oPS, { 0, 0 }, { nXSize, nYSize }, GRA_FILL ) *######################################################################################################################### * ChartEvents( oPS, mDialog ) // Графическая функция <<<===############################ ChartEventsPolar( oPS, 'Events' ) *######################################################################################################################### *My image original, my image scaled ****** Запись полноразмерного графического файла в папку: M_PathAppl+"Events\" * DC_Impl(oScr) DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения IF FILEDATE("Events",16) = CTOD("//") // задача 2 DIRMAKE("Events") // задача 2 aMess := {} AADD(aMess, L('В папке текущего приложения: "'+UPPER(ALLTRIM(M_PathAppl))+'"')) AADD(aMess, L('не было директории "Events" для графических форм по прогнозам событий и она была создана!')) // <===####################### // задача 2 AADD(aMess, L('В эту папку записываются исходные изображения высокого качества (без масштабирования)')) LB_Warning(aMess, L('Прогноз событий в системе "Эйдос"')) // задача 2 ENDIF DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения DIRCHANGE(M_PathAppl+"Events\") // Перейти в папку Events // задача 2 cFileName = "EventsPolar"+STRTRAN(STR(ADIR("*.*")+1,6)," ","0")+".jpg" ERASE(cFileName) oBMP:SaveFile(cFileName,XBPBMP_FORMAT_JPG) IF nWidth > 1800 FullView( cFileName, "по верху", 65 ) // Визуализация полноразмерного файла на мониторе высокого разрешения ELSE ****** Формирование с помощью bmp2bmp() и отображение масштабированного изображения aNewSize := {nWidth,nHeight-29} // Новый размер изображения (еще немного уменьшается, чтобы не рисовать по панели задач) oBMP:loadFile(cFileName) // Загрузка полноразмерного изображения oRet := BMP2BMP(oBMP,aNewSize) // Масштабирование изображения cFileNameScale = SUBSTR(cFileName,1,AT(".jpg",cFileName)-1)+"_scaled.jpg" ERASE(cFileNameScale) oRet:saveFile(cFileNameScale,XBPBMP_FORMAT_JPG) // Запись масштабированного графического файла в в папку приложения для визуализации FullView( cFileNameScale, "по верху", 0 ) // Визуализация масштабированного графического файла на мониторе ограниченного разрешения ENDIF DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения RETURN NIL ********************************************************************* ****** Визуализация графика ***************************************** ********************************************************************* STATIC FUNCTION ChartEvents( oPS ) DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы PRIVATE a23211[8] IF FILE("_23211.arx") // Параметры диалога F2_3_2_12() a23211 = DC_ARestore("_23211.arx") PUBLIC mNumMod := a23211[1] PUBLIC mRegim := a23211[2] PUBLIC mWindow := a23211[3] PUBLIC mXSize := a23211[4] PUBLIC mYSize := a23211[5] PUBLIC mLineWidth := a23211[6] PUBLIC mGamma := a23211[7] PUBLIC mAlfa := a23211[8] ELSE PUBLIC mNumMod := 1 PUBLIC mRegim := 2 PUBLIC mWindow := 7 PUBLIC mXSize := 1800 PUBLIC mYSize := 900 PUBLIC mLineWidth := 7 PUBLIC mGamma := 1 PUBLIC mAlfa := 1 a23211[1] = mNumMod a23211[2] = mRegim a23211[3] = mWindow a23211[4] = mXSize a23211[5] = mYSize a23211[6] = mLineWidth a23211[7] = mGamma a23211[8] = mAlfa DC_ASave(a23211, "_23211.arx") ENDIF X_MaxW = mXSize Y_MaxW = mYSize DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения aFakt := {} // Интенсивность фактических ЗМТ CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rasp_PROGNOZ EXCLUSIVE NEW SELECT Rasp_PROGNOZ DBGOTOP() DO WHILE .NOT. EOF() AADD(aFakt, ZMT_FAKT ) DBSKIP(1) ENDDO n = LEN(aFakt) *********************************************************************** * Экспоненциальное сглаживание линейно нормированного логарифма факта: * - логарифм для уменьшения влияния низкочастотных выбросов; * - линейное нормирование для отображения значений в область: 0 - 1; * - экспоненциальное сглаживание для удаления уменьшения влияния высокочастотных выбросов (сила сглаживания задается в диалоге от полного его отсутствия до максимального: до одной прямой линии). *********************************************************************** aLogFakt := {} // Логарифм факта (в лог.шкале выбросы играют меньшую роль) aLineNormLogFakt := {} // Линейное нормирование логарифма факта (отображение в область: 0-1) aExpSmLineNormLF := {} // Экспоненциальное сглаживание линейного нормирования логарифма факта // Логарифм факта (в лог.шкале выбросы играют меньшую роль) mMinFakt = +99999999 mMaxFakt = -99999999 FOR j=1 TO n mMinFakt = MIN(mMinFakt, aFakt[j]) mMaxFakt = MAX(mMaxFakt, aFakt[j]) NEXT FOR j=1 TO n AADD(aLogFakt, IF(aFakt[j]>0,LOG(aFakt[j]),LOG(mMinFakt))) NEXT // Линейное нормирование логарифма факта (отображение в область: 0-1) mMinLogFakt = +99999999 mMaxLogFakt = -99999999 FOR j=1 TO n mMinLogFakt = MIN(mMinLogFakt, aLogFakt[j]) mMaxLogFakt = MAX(mMaxLogFakt, aLogFakt[j]) NEXT FOR j=1 TO n AADD(aLineNormLogFakt, (aLogFakt[j] - mMinLogFakt) / (mMaxLogFakt - mMinLogFakt)) NEXT // Экспоненциальное сглаживание линейного нормирования логарифма факта ****** ЗАМЕНИТЬ НА ЦЕНТРИРОВАННОЕ ЛИНЕЙНОЕ СГЛАЖИВАНИЕ СКОЛЬЗЯЩИМ СРЕДНИМ <===########### * mAlfa = 0.8 * AADD(aExpSmLineNormLF, aLineNormLogFakt[1]) * FOR j=2 TO n * AADD(aExpSmLineNormLF, mAlfa * aLineNormLogFakt[j] + ( 1 - mAlfa ) * aExpSmLineNormLF[j-1] ) * NEXT // ЦЕНТРИРОВАННОЕ ЛИНЕЙНОЕ СГЛАЖИВАНИЕ СКОЛЬЗЯЩИМ СРЕДНИМ <===########### PRIVATE aAvrFakt[n] // Длина исходного массива AFILL(aAvrFakt, 0) * aAvr[1] = aVal[1] // Чтобы 1-й элемент сглаженного массива были точно равен 1-му элементу несглаженного массива <===###### Когда верификация * mWindow = 7 // Интервал (окно) сглаживания (месяц) (задается в диалоге) IF mAlfa > 1 aAvrFakt = aLineNormLogFakt // Чтобы 1-й элемент сглаженного массива были точно равен 1-му элементу несглаженного массива <===###### Когда верификация ENDIF hw = (mAlfa-1)/2 // Размах окна влево и вправо от текущей позиции FOR i=2 TO n // Организовываем цикл по числу элементов mSumY = 0 ** Определение начала и конца окна IF i<=hw // если индекс меньше половины окна, мы находимся в начале массива, нужно брать окно меньшего размера k1=1 // в качестве начала окна берем первый элемент k2=2*i-1 // конец окна z=k2 // текущий размер окна ELSEIF i+hw>n // если индекс+половина окна больше n - мы приближаемся к концу массива и размер окна также нужно уменьшать k1=i-n+i // начало окна k2=n // конец окна - последний элемент массива z=k2-k1 // размер окна ELSE // если первые два условия не выполняются, мы в середине массива k1=i-hw k2=i+hw z=mAlfa ENDIF FOR j = INT(k1) TO INT(k2) // организуем цикл от начала до конца окна mSumY = mSumY + aLineNormLogFakt[j] // <===######################## дает ошибку когда окно четное? NEXT aAvrFakt[i] = mSumY / z * aAvrFakt[i] = IF(aAvrFakt[i]Y_MaxF,Y_MaxF,aAvrFakt[i]) NEXT ****** Записать результаты сглаживания факта SELECT Rasp_PROGNOZ j = 0 DBGOTOP() DO WHILE .NOT. EOF() j++ REPLACE ZMTAvrFakt WITH aAvrFakt[j] DBSKIP(1) ENDDO aArgName := {} // Наименования градаций (даты в формате: ДД.ММ.ГГГГ) aArg := {} // Значение аргумента для нормирования графика по X aVal := {} // Полный прогноз (высокочастотный) aAvr := {} // Сглаженный прогноз aFakt := {} // Интенсивность фактических ЗМТ mSummaFakt = 0 DBGOTOP() DO WHILE .NOT. EOF() AADD(aArgName, ALLTRIM(FIELDGET(1))) // Дата AADD(aArg , RECNO() ) AADD(aVal , PROGN_POLN) AADD(aAvr , PROGN_AVR ) AADD(aFakt, ZMTAvrFakt) // Сглаженные и нормированные интенсивности фактических ЗМТ mSummaFakt = mSummaFakt + ZMT_FAKT // Если сумма интенсивностей фактических ЗМТ = 0, значит нет даных по фактическим ЗМТ DBSKIP(1) ENDDO *********************************************************************** *********************************************************************** ****** Поиск макс и мин значений аргумента ****** X_MinA = +99999999 // Минимальное значение X аргумента X_MaxA = -99999999 // Максимальное значение X аргумента FOR j=1 TO LEN(aArg) X_MinA = MIN(X_MinA, aArg[j]) X_MaxA = MAX(X_MaxA, aArg[j]) NEXT N_Arg = LEN(aArg) // Кол-во уникальных значений аргумента n = LEN(aArg) // Кол-во уникальных значений аргумента ****** Поиск макс и мин значений функции ******** Y_MinF = +99999999 // Минимальное значение Y отображаемой функции Y_MaxF = -99999999 // Максимальное значение Y отображаемой функции FOR j=1 TO LEN(aVal) Y_MinF = MIN(Y_MinF, aVal[j]) Y_MaxF = MAX(Y_MaxF, aVal[j]) Y_MinF = MIN(Y_MinF, aAvr[j]) Y_MaxF = MAX(Y_MaxF, aAvr[j]) IF mSummaFakt > 0 Y_MinF = MIN(Y_MinF, aFakt[j]) Y_MaxF = MAX(Y_MaxF, aFakt[j]) ENDIF NEXT ******************************************************************************************** *** Посчитать корреляцию факта с высокочастотным и сглаженным прогнозами и вывести в графике ******************************************************************************************** IF mSummaFakt > 0 *** Расчет сумм и средних mSumVal = 0 mSumAvr = 0 mSumFakt = 0 mN = 0 FOR j=1 TO n IF aFakt[j] > 0 // Корреляцию считать только для точек, по которым есть факт, а 0 пропускать mN++ mSumVal = mSumVal + aVal [j] mSumAvr = mSumAvr + aAvr [j] mSumFakt = mSumFakt + aFakt[j] ENDIF NEXT mSrVal = mSumVal /mN mSrAvr = mSumAvr /mN mSrFakt = mSumFakt/mN *** Расчет ср.кв.отклонений mDiVal = 0 mDiAvr = 0 mDiFakt = 0 FOR j=1 TO n IF aFakt[j] > 0 mDiVal = mDiVal + ( aVal [j] - mSrVal ) ^ 2 mDiAvr = mDiAvr + ( aAvr [j] - mSrAvr ) ^ 2 mDiFakt = mDiFakt + ( aFakt[j] - mSrFakt ) ^ 2 ENDIF NEXT mDiVal = SQRT(mDiVal /(mN-1)) mDiAvr = SQRT(mDiAvr /(mN-1)) mDiFakt = SQRT(mDiFakt/(mN-1)) *** Расчет ковариаций и ср.кв.отклонений mKovVal = 0 mKovAvr = 0 FOR j=1 TO n IF aFakt[j] > 0 mKovVal = mKovVal + (aVal[j] - mSrVal) * (aFakt[j] - mSrFakt) mKovAvr = mKovAvr + (aAvr[j] - mSrAvr) * (aFakt[j] - mSrFakt) ENDIF NEXT mKovVal = mKovVal / mN mKovAvr = mKovAvr / mN *** Расчет корреляций mKorVal = mKovVal / ( mDiVal * mDiFakt ) mKorAvr = mKovAvr / ( mDiAvr * mDiFakt ) ENDIF ******************************************************************************************** PRIVATE X0 := 75 PRIVATE Y0 := 165 // Начало координат по осям X и Y с учетом места для легенды PRIVATE W_Wind := X_MaxW - X0 - 25 // Ширина окна для самого графика PRIVATE H_Wind := Y_MaxW - Y0 - 70 // Высота окна для самого графика PRIVATE mNX := 100, mNY := 10 // Кол-во меток и надписей по осям X и Y PRIVATE Kx := W_Wind / ( X_MaxA-X_MinA ) // Коэффициент масштабирования по оси X: преобразует аргумент функции в номер пикселя по оси X PRIVATE Ky := H_Wind / ( Y_MaxF-Y_MinF ) // Коэффициент масштабирования по оси Y: преобразует значение функции в номер пикселя по оси Y PRIVATE Y0A := IF(Y_MinF > 0, Y0, Y0+ABS(Y_MinF)*Ky) // Позиция оси X на оси Y // <===################### **** Написать заголовок диаграммы aFonts := XbpFont():new():list() // Все доступные шрифты oFont := XbpFont():new():create("18.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты Ar_Model := {"Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } mTitle = 'ПРОГНОЗИРОВАНИЕ СОБЫТИЙ ПО АСТРОФАКТОРАМ МЕТОДОМ Н.А.ЧЕРЕДНИЧЕНКО' // Задача 2 aTxtPar = DC_GraQueryTextbox(mTitle, oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox("Длина текста в пикселях="+ALLTRIM(STR(aTxtPar[1]))+". Высота текста в пикселях="+ALLTRIM(STR(aTxtPar[2]))) GraStringAt( oPS, { X_MaxW/2, Y_MaxW-25 }, mTitle) oFont := XbpFont():new():create("14.Arial Bold") GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты IF LEN(ALLTRIM(M_NameAppl)) < 70 GraStringAt( oPS, { X_MaxW/2, Y_MaxW-52 }, "Приложение: "+'"'+ALLTRIM(M_NameAppl)+'"' ) ELSE GraStringAt( oPS, { X_MaxW/2, Y_MaxW-52 }, '"'+ALLTRIM(M_NameAppl)+'"' ) ENDIF oFont := XbpFont():new():create("10.Arial") GraSetFont( oPS ,oFont ) aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты ***** Закрасить фон прямоугольника *************** GraSetColor( oPS, aColor[98] , aColor[98] ) GraBox( oPS, { X0, Y0 }, { X0+W_Wind, Y0+H_Wind }, GRA_FILL ) GraSetColor( oPS, aColor[222] , aColor[222] ) ***** Нарисовать оси координат ******************* aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 2 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты GraLine( oPS, {X0 , Y0A }, {X0+W_Wind, Y0A } ) // Нарисовать ось X GraLine( oPS, {X0 , Y0 }, {X0 , Y0+H_Wind} ) // Нарисовать границу рамки изображения слева это и есть ось Y GraLine( oPS, {X0 , Y0 }, {X0+W_Wind, Y0 } ) // Нарисовать границу рамки изображения внизу параллельно оси X GraLine( oPS, {X0 , Y0+H_Wind}, {X0+W_Wind, Y0+H_Wind} ) // Нарисовать границу рамки изображения вверху параллельно оси X GraLine( oPS, {X0+W_Wind, Y0 }, {X0+W_Wind, Y0+H_Wind} ) // Нарисовать границу рамки изображения справа параллельно оси Y aAttr := ARRAY( GRA_AM_COUNT ) // Массив для атрибутов маркеров aAttr [ GRA_AM_SYMBOL ] := GRA_MARKSYM_PLUS GraSetAttrMarker( oPS, aAttr ) aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DOT aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты *** Закрасить области между метками на оси X ***** DX = ( X_MaxA-X_MinA ) / mNX // Диапазон значений x, через которое ставить метку GraSetColor( oPS, aColor[99], aColor[99] ) j = 0 FOR X=X_MinA TO X_MaxA STEP 2*DX j = j + 2 X1 = X0 + ( j - 1 ) * DX * Kx X2 = X0 + ( j ) * DX * Kx GraBox( oPS, { X1, Y0 }, { X2, Y0 + H_Wind }, GRA_FILL ) NEXT GraSetColor( oPS, aColor[222], aColor[222] ) *** Сделать сетку и надписать метки на оси X ********************* // <===########### DO CASE CASE 1800 <= X_MaxW .AND. X_MaxW <= 3600 mNNadp = IF(LEN(aArgName) <= 182, LEN(aArgName), 182) // Количество надписей по оси X (больше 182 не помещается) oFont := XbpFont():new():create("8.Arial Bold") CASE 3600 <= X_MaxW .AND. X_MaxW <= 4096 mNNadp = IF(LEN(aArgName) <= 364, LEN(aArgName), 364) // Количество надписей по оси X (больше 364 не помещается) oFont := XbpFont():new():create("6.Arial Bold") ENDCASE GraSetFont( oPS ,oFont ) aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты mNumbLabels = INT(LEN(aArgName) / mNNadp) // Рисовать каждую 1-ю, 2-ю, 3-ю, 4-ю,..., mNumbLabels надпись на оси X aMonth = {'Январь','Февраль','Март','Апрель','Май','Июнь','Июль','Август','Сентябрь','Октябрь','Ноябрь','Декабрь'} mMGold = -1 mGold = -1 FOR j=1 TO LEN(aArgName) X1 = X0 + ( j - 1 ) * Kx GraMarker ( oPS, { X1, Y0 } ) IF j = mNumbLabels * INT(j / mNumbLabels) // Если номер надписи нацело делится на mNumbLabels, то рисовать ее X1 = X0 + ( j - 1 ) * Kx - 5 GraMarker ( oPS, { X1, Y0 } ) GraLine ( oPS, { X1, Y0 }, {X1, Y0+H_Wind} ) // Нарисовать пунктирную линию уровня x ****** Написать наименование месяца и год ****** IF LEN(aArgName) <= 365 mMGnew = VAL(SUBSTR(aArgName[j],4,7)) // Делать надпись при смене месяца и года IF mMGold <> mMGnew mMGold = mMGnew GraStringAt( oPS, { X1, Y0-72 }, aMonth[mMGnew]+','+SUBSTR(aArgName[j],7,4)) ENDIF ELSE mGnew = VAL(SUBSTR(aArgName[j],7,4)) // Делать надпись при смене года IF mGold <> MGnew mGold = MGnew GraStringAt( oPS, { X1, Y0-72 }, SUBSTR(aArgName[j],7,4)) ENDIF ENDIF ENDIF NEXT oFont := XbpFont():new():create("6.Arial") GraSetFont( oPS ,oFont ) aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты FOR j=1 TO LEN(aArgName) IF j = mNumbLabels * INT(j / mNumbLabels) // Если номер надписи нацело делится на mNumbLabels, то рисовать ее X1 = X0 + ( j - 1 ) * Kx aTxtPar = DC_GraQueryTextbox(ALLTRIM(STR(X,15,1)), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox(STR(aTxtPar[1])+" "+STR(aTxtPar[2])) mArgName = aArgName[j] aTxtPar = DC_GraQueryTextbox(mArgName, oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox("Длина текста в пикселях="+ALLTRIM(STR(aTxtPar[1]))+". Высота текста в пикселях="+ALLTRIM(STR(aTxtPar[2]))) aMatrix := GraInitMatrix() // <<<########## GraRotate( oPS, aMatrix, 90, { X1, Y0 }, GRA_TRANSFORM_ADD ) oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) // <<<########## mMM = VAL(SUBSTR(mArgName,4,2)) aAttrF [ GRA_AS_COLOR ] := IF(mMM=2*INT(mMM/2),aColor[12],aColor[190]) GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraStringAt( oPS, { X1-57, Y0 }, mArgName ) // Написать даты (aArgName[j]) вертикально <===############# ENDIF NEXT ****** Не получается отключить режим вращения изображения ****** Вместо отключения можно докрутить до 360 градусов aMatrix := GraInitMatrix() // <<<########## GraRotate( oPS, aMatrix, 0, {900, 425}, GRA_TRANSFORM_REPLACE ) // <<<########## oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) // <<<########## oFont := XbpFont():new():create("10.Arial") GraSetFont( oPS ,oFont ) aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты *** Сделать сетку и надписать метки на оси Y ********************* DY = ( Y_MaxF-Y_MinF ) / mNY // Диапазон значений Y, через которое ставить метку j = 0 FOR Y=Y_MinF TO Y_MaxF STEP DY ++j Y1 = Y0 + ( j - 1 ) * DY * Ky GraMarker ( oPS, { X0 , Y1 } ) aTxtPar = DC_GraQueryTextbox(ALLTRIM(STR(Y,15,1)), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox(STR(aTxtPar[1])+" "+STR(aTxtPar[2])) GraStringAt( oPS, { X0-35, Y1-aTxtPar[2]/2 }, ALLTRIM(STR(Y,15,1)) ) GraLine ( oPS, { X0 , Y1 }, {X0+W_Wind, Y1} ) // Нарисовать пунктирную линию уровня Y NEXT j = mNY Y1 = Y0 + j * DY * Ky GraMarker ( oPS, { X0 , Y1 } ) aTxtPar = DC_GraQueryTextbox(ALLTRIM(STR(Y_MaxF,15,1)), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox(STR(aTxtPar[1])+" "+STR(aTxtPar[2])) GraStringAt( oPS, { X0-35, Y1-aTxtPar[2]/2 }, ALLTRIM(STR(Y_MaxF,15,1)) ) GraLine ( oPS, { X0 , Y1 }, {X0+W_Wind, Y1} ) // Нарисовать пунктирную линию уровня Y ***** Рисование маркеров и отрезков прямых основной линии ************************************ aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT * aAttr [ GRA_AL_COLOR ] := aColor[123] // Задать цвет основной линии (темно-фиолетовый) DO CASE CASE mGamma = 1 // Теплая гамма aAttr [ GRA_AL_COLOR ] := GraMakeRGBColor({040,040,255}) // Задать цвет основной линии (яркий синий) CASE mGamma = 2 // Холодная гамма * aAttr [ GRA_AL_COLOR ] := GraMakeRGBColor({255,040,040}) // Задать цвет основной линии (яркий красный) aAttr [ GRA_AL_COLOR ] := GraMakeRGBColor({000,000,000}) // Задать цвет основной линии (черный) ENDCASE aAttr [ GRA_AL_WIDTH ] := 2 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aVal[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aVal[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT ***** ЭТО СДЕЛАТЬ НА СГЛАЖЕННОЙ КРИВОЙ, А ЗДЕСЬ ТОНКОЙ ЛИНИЕЙ, ЦВЕТА СИНЕЙ ГАММЫ, ЧТОБЫ ЗМТ ОТОБРАЖАТЬ КРАСНЫМ ***** Сделать рисование линий двух цветов, внутри посветлее, а снаружи потемнее (эффект объема) ***** для этого рисовать от внешних частей линии к внутренним уменьшающейся толщиной линии и более светлым цветом ПОВЕРХ РАНЕЕ НАРИСОВАННОГО IF mWindow > 0 DO CASE CASE mGamma = 1 // Теплая гамма DO CASE CASE mLineWidth = 5 aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := aColor[190] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 5 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[156] // Задать цвет внутри линии (темный синий) aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[169] // Задать цвет внутри линии (голубой) aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT CASE mLineWidth = 7 aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := aColor[192] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 7 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[190] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 5 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[156] // Задать цвет внутри линии (темный синий) aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[169] // Задать цвет внутри линии (голубой) aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT CASE mLineWidth = 9 aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := BD_BLACK // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 9 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[192] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 7 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[190] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 5 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[156] // Задать цвет внутри линии (темный синий) aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[169] // Задать цвет внутри линии (голубой) aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT ENDCASE CASE mGamma = 2 // Холодная гамма DO CASE CASE mLineWidth = 5 aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := aColor[14] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 5 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[12] // Задать цвет внутри линии (темный синий) aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[34] // Задать цвет внутри линии (голубой) aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT CASE mLineWidth = 7 aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := aColor[15] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 7 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[14] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 5 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[12] // Задать цвет внутри линии (темный синий) aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[34] // Задать цвет внутри линии (голубой) aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT CASE mLineWidth = 9 aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := BD_BLACK // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 9 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[15] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 7 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[14] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 5 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[12] // Задать цвет внутри линии (темный синий) aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[34] // Задать цвет внутри линии (голубой) aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT ENDCASE ENDCASE ** Отобразить фактически произошедшие ЗМТ, если они были IF mSummaFakt > 0 aAttr := ARRAY( GRA_AM_COUNT ) // Массив для атрибутов маркеров FOR j=1 TO n IF aFakt[j] > 0 // Проверка, чтобы не отображать фактические ЗМТ с 0 интенсивностью X := X0 + (aArg [j]-X_MinA) * Kx Y := Y0A + (aFakt[j]-Y_MinF) * Ky FOR r = ROUND(mLineWidth * 2.0,0) TO 1 STEP -1 c = INT(r*5) * DO CASE * CASE mGamma = 1 // Теплая гамма * aAttr[ GRA_AL_COLOR ] := GraMakeRGBColor({0,0,255-c}) // Задать цвет маркера (синий разной яркости) * CASE mGamma = 2 // Холодная гамма * aAttr[ GRA_AL_COLOR ] := GraMakeRGBColor({255-c,0,0}) // Задать цвет маркера (красный разной яркости) * ENDCASE aAttr[ GRA_AL_COLOR ] := GraMakeRGBColor({255-c,0,0}) // Задать цвет маркера (красный разной яркости) aAttr[ GRA_AM_BOX ] := { r, r } // Размер маркера по X и по Y aAttr[ GRA_AM_SYMBOL ] := GRA_MARKSYM_SIXPOINTSTAR GraSetAttrMarker( oPS, aAttr ) GraMarker( oPS, { X, Y } ) // Отобразить маркер NEXT ENDIF NEXT ENDIF ***** Рисование маркеров на линии IF n <= 64 aAttr := ARRAY( GRA_AM_COUNT ) // Массив для атрибутов маркеров aAttr[ GRA_AM_SYMBOL ] := GRA_MARKSYM_DOT GraSetAttrMarker( oPS, aAttr ) FOR j=1 TO LEN(aArg) X := X0 + (aArg[j]-X_MinA) * Kx Y := Y0A + (aAvr[j]-Y_MinF) * Ky IF LEN(aArg) <= 32 aAttr[ GRA_AM_SYMBOL ] := GRA_MARKSYM_SMALLCIRCLE GraSetAttrMarker( oPS, aAttr ) GraMarker( oPS, { X, Y } ) // отобразить маркер ENDIF aAttr[ GRA_AM_SYMBOL ] := GRA_MARKSYM_DOT GraSetAttrMarker( oPS, aAttr ) GraMarker( oPS, { X, Y } ) // отобразить маркер * GraStringAt( oPS, { X, Y }, '('+ALLTRIM(STR(aAvr[j],15,1))+','+ALLTRIM(STR(aVal[j],15,1))+')') NEXT ENDIF ENDIF ***** Нарисовать оси координат ********************************** aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 2 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты графической линии GraLine( oPS, {X0 , Y0A }, {X0+W_Wind, Y0A } ) // Нарисовать ось X GraLine( oPS, {X0 , Y0 }, {X0 , Y0+H_Wind} ) // Нарисовать границу рамки изображения слева это и есть ось Y GraLine( oPS, {X0 , Y0 }, {X0+W_Wind, Y0 } ) // Нарисовать границу рамки изображения внизу параллельно оси X GraLine( oPS, {X0 , Y0+H_Wind}, {X0+W_Wind, Y0+H_Wind} ) // Нарисовать границу рамки изображения вверху параллельно оси X GraLine( oPS, {X0+W_Wind, Y0 }, {X0+W_Wind, Y0+H_Wind} ) // Нарисовать границу рамки изображения справа параллельно оси Y ****** Легенда *************************************************** Offset = -97 // Смещение вниз относительно нуля Y0 для позиции легенды Interval = 17 ***** Нарисовать рамку легенды aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты графической линии X1 := X0 Y1 := Y0 + Offset X2 := X0 + W_Wind Y2 := Y0 + Offset - 2 * Interval - 22 ***** Закрасить фон прямоугольника *************** GraSetColor( oPS, aColor[129] , aColor[129] ) GraBox( oPS, { X1, Y1 }, { X2, Y2 }, GRA_FILL) GraSetColor( oPS, aColor[222] , aColor[222] ) GraBox( oPS, { X1, Y1 }, { X2, Y2 } ) * GraLine( oPS, { 1300, Y1 }, { 1270, Y2 } ) // Нарисовать вертикальную линию, отделяющую левый комментарий от правого ***** Сделать надписи в легенде aAttr[ GRA_AL_COLOR ] := aColor[17] // Задать цвет линии aAttr[ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK GraSetAttrString( oPS, aAttrF ) * MsgBox(M_PathAppl) DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения IF FILEDATE("Events",16) = CTOD("//") DIRMAKE("Events") aMess := {} AADD(aMess, L('В папке текущего приложения: "'+UPPER(ALLTRIM(M_PathAppl))+'"')) AADD(aMess, L('не было директории "Events" для графических форм по прогнозам событий и она была создана!')) // <===####################### AADD(aMess, L('В эту папку записываются исходные изображения высокого качества (без масштабирования)')) LB_Warning(aMess, L('Прогноз событий в системе "Эйдос"')) ENDIF DIRCHANGE(M_PathAppl+"Events\") // Перейти в папку Events cFileName = "Events"+STRTRAN(STR(ADIR("*.*")+1,6)," ","0")+".jpg" X1 := X0 + 20 Y1 := Y0 + Offset - Interval X2 := X1 + 190 Y2 := Y0 + Offset - 1 * Interval **** Передача параметров расчета для графика DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения * ar := {} * AADD(ar, mNumMod) * AADD(ar, M_Interval) * AADD(ar, K_GradNClSc) * AADD(ar, K_GradNOpSc) * AADD(ar, mNObj) * DC_ASave(ar, "_23211chart.arx") ar = DC_ARestore("_23211chart.arx") **** Надпись в легенде слева *********** oFont := XbpFont():new():create("12.Arial") GraSetFont( oPS ,oFont ) Y2 := Y0 + Offset - 1 * Interval;GraStringAt( oPS, { X1, Y2-0 }, L('Модель: "') +UPPER(ALLTRIM(Ar_Model[ar[1]]))+'". '+; L('Число интервалов в класс.и опис.шкалах:')+' '+ALLTRIM(STR(ar[3]))+', '+ALLTRIM(STR(ar[4]))+'. '+; L('Тип интервалов:') +' '+IF(ar[2]=1,L('"РАВНЫЕ"'),L('"АДАПТИВНЫЕ"'))+'. '+; L('Число наблюдений в обучающей выборке:') +' '+ALLTRIM(STR(ar[5])) +'. '+; L('Размер интервала сглаживания =') +' '+ALLTRIM(STR(mWindow)) +'. '+; L('Форма создана:')+' '+DTOC(DATE())+"-"+TIME()) IF mSummaFakt > 0 Y2 := Y0 + Offset - 2 * Interval;GraStringAt( oPS, { X1, Y2-5 }, L('Разрешение изображения: X=')+ALLTRIM(STR(mXSize))+', Y='+ALLTRIM(STR(mYSize))+' '+L('пикселей.')+' '+; L('Корр.прогн.полн-факт=')+ALLTRIM(STR(mKorVal,15,3))+'. '+L('Корр.прогн.сглаж-факт=')+ALLTRIM(STR(mKorAvr,15,3))+'. '+; L('Путь на файл изображения:')+' '+M_PathAppl+"Events\"+cFileName) ELSE Y2 := Y0 + Offset - 2 * Interval;GraStringAt( oPS, { X1, Y2-5 }, L('Разрешение изображения: X=')+ALLTRIM(STR(mXSize))+', Y='+ALLTRIM(STR(mYSize))+' '+L('пикселей.')+'. '+; L('Путь на файл изображения:')+' '+M_PathAppl+"Events\"+cFileName) ENDIF ****** Надписи координатных осей ********************************* oFont := XbpFont():new():create("13.ArialBold") GraSetFont( oPS ,oFont ) * AxName = "Дата (день, месяц, год)" * GraStringAt( oPS, { X0+W_Wind/2-8*LEN(AxName)/2, Y0-45 }, AxName ) // Надпись оси Х (СДЕЛАНА ВЫШЕ) AyName = "Суммарная сила факторов, способствующих возникновению события (норм.знач.)" aMatrix := GraInitMatrix() GraRotate( oPS, aMatrix, 90, { X0-53, Y0+H_Wind/2-8*LEN(AyName)/2 }, GRA_TRANSFORM_ADD ) oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) GraStringAt( oPS, { X0-53, Y0+H_Wind/2-8*LEN(AyName)/2 }, AyName ) // Надпись оси Y ****** Не получается отключить режим вращения изображения ****** Вместо отключения можно докрутить до 360 градусов X_Max := 1800 Y_Max := 850 // Размер графического окна для самого графика в пикселях aMatrix := GraInitMatrix() // <<<########## GraRotate( oPS, aMatrix, 0, {900, 425}, GRA_TRANSFORM_REPLACE ) // <<<########## oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) // <<<########## RETURN NIL **************************************************************************************************************************** FUNCTION DelColMinExp1() oScr := DC_WaitOn(L('Сброс колонки: MIN-эксперт. Немного подождите!'),,,,,,,,,,,.F.) SELECT PrognReson DBGOTOP() DO WHILE .NOT. EOF() REPLACE PrognReson->PRAVKA_MIN WITH '' DBSKIP(1) ENDDO DBGOTOP() DC_Impl(oScr) RETURN NIL ************************* FUNCTION CopyMinProgExp1() oScr := DC_WaitOn(L('Копирование: MIN-программа ===>>> MIN-эксперт. Немного подождите!'),,,,,,,,,,,.F.) SELECT PrognReson DBGOTOP() DO WHILE .NOT. EOF() REPLACE PrognReson->PRAVKA_MIN WITH PrognReson->ProgAvrMin DBSKIP(1) ENDDO DBGOTOP() DC_Impl(oScr) RETURN NIL ************************* FUNCTION ForeCalcMinExp1() oScr := DC_WaitOn(L('Идет расчет прогноза по исправленным минимумам. Немного подождите!'),,,,,,,,,,,.F.) * Мое поле PRAVKA_PROGN_NI - я посчитала вручную нарастающий итог по прогнозу в соответствии с поправленными минимумами. mPrognNI = 0 mIntZmtNI = 0 SELECT PrognReson DBGOTOP() DO WHILE .NOT. EOF() IF LEN(ALLTRIM(PrognReson->PRAVKA_MIN)) > 0 // Чтобы можно было вводить не MIN, а любой символ REPLACE PrognReson->PRAVKA_MIN WITH 'MIN' mPrognNI = 0 mIntZmtNI = 0 ENDIF mPrognNI = mPrognNI + PROGN_N mIntZmtNI = mIntZmtNI + SUMINT_ZMT REPLACE PR_PROGNNI WITH mPrognNI REPLACE P_INTZMTNI WITH mIntZmtNI DBSKIP(1) ENDDO DBGOTOP() DC_Impl(oScr) RETURN NIL **************************************************************************************************************************** FUNCTION EditMinProgn1() // Исправление расположения минимумов в прогнозе LOCAL GetList := {}, aPres, oBrowse, oToolBar, aColors, bColor, GetOptions, oEventsKO, bItems, n:=0, lExit *** Проверить наличие БД PrognReson.dbf ************************* IF ApplChange("") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF IF .NOT. FILE('PrognReson.dbf') LB_Warning(L("Сначала надо сделать прогноз ЗМТ, а потом его корректировать !!! ")) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW Running(.F.) RETURN nil ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE PrognReson EXCLUSIVE NEW SELECT PrognReson DBGOTOP() ****************************************** aColors := { {GRA_CLR_WHITE,GRA_CLR_DARKRED },; {GRA_CLR_WHITE,GRA_CLR_DARKBLUE },; {GRA_CLR_BLACK,GRA_CLR_DARKGREEN} } aPres := ; { { XBP_PP_COL_HA_FGCLR, GRA_CLR_WHITE },; // Header FG Color { XBP_PP_COL_HA_BGCLR, GRA_CLR_DARKGRAY },; // Header BG Color { XBP_PP_COL_FA_FGCLR, GRA_CLR_YELLOW },; // Footer FG Color { XBP_PP_COL_FA_BGCLR, GRA_CLR_DARKGRAY },; // Footer BG Color { XBP_PP_COL_DA_ROWSEPARATOR, XBPCOL_SEP_DOTTED },; // Row Sep { XBP_PP_COL_DA_COLSEPARATOR, XBPCOL_SEP_DOTTED },; // Col Sep { XBP_PP_COL_HA_ALIGNMENT, XBPALIGN_LEFT },; // Header alignment { XBP_PP_COL_DA_ROWHEIGHT, 20 },; // Row Height { XBP_PP_COL_DA_CELLHEIGHT, 20 } } // Cell Height ****** Отображение таблицы *************** d = 4 @ 41, 0 DCGROUP oGroup1 CAPTION L(' ') SIZE 163, 3.0 @ 1, 1 DCPUSHBUTTON CAPTION 'Сброс колонки MIN-эксперт' SIZE LEN('Сброс колонки MIN-эксперт') -0, 1.5 ACTION {||DelColMinExp1() , DC_GetRefresh(GetList)} PARENT oGroup1 @ 1, DCGUI_COL+d DCPUSHBUTTON CAPTION 'Копирование: MIN-программа => MIN-эксперт' SIZE LEN('Копирование: MIN-программа => MIN-эксперт')-5, 1.5 ACTION {||CopyMinProgExp1() , DC_GetRefresh(GetList)} PARENT oGroup1 @ 1, DCGUI_COL+d DCPUSHBUTTON CAPTION 'Перерасчет прогноза на основе MIN-эксперт' SIZE LEN('Перерасчет прогноза на основе MIN-эксперт')-5, 1.5 ACTION {||ForeCalcMinExp1() , DC_GetRefresh(GetList)} PARENT oGroup1 @ 1, DCGUI_COL+d DCPUSHBUTTON CAPTION 'График: резонансные ЗМТ-программа' SIZE LEN('График: резонансные ЗМТ-программа') -1, 1.5 ACTION {||Chart23211r('Prog'), DC_GetRefresh(GetList)} PARENT oGroup1 @ 1, DCGUI_COL+d DCPUSHBUTTON CAPTION 'График: резонансные ЗМТ-эксперт' SIZE LEN('График: резонансные ЗМТ-программа') -4, 1.5 ACTION {||Chart23211r('Hand'), DC_GetRefresh(GetList)} PARENT oGroup1 PRIVATE bColorBlock:={||IIF(L2_mera=M_MaxValL2, {nil,aColor[153]},IIF(L1_mera=M_MaxValL1,{nil,aColor[107]},IIF(F_mera=M_MaxValF,{nil,aColor[33]},{nil,GRA_CLR_WHITE}))) } // Клиффорд DCSETPARENT TO @ 1, 0 DCBROWSE oBrowse ALIAS 'PrognReson' SIZE 163,40 ; EDIT xbeBRW_ItemSelected MODE DCGUI_BROWSE_EDITDOWN ; PRESENTATION aPres ; FREEZELEFT {1,1} ; // При горизонтальной прокрутке не прокручивать первую 1 колонку COLOR {||IIF(LEN(ALLTRIM(PrognReson->PRAVKA_MIN))>0, {nil,aColor[153]}, IIF(LEN(ALLTRIM(PrognReson->PROGAVRMIN))>0, {nil,aColor[39]}, {nil,GRA_CLR_WHITE}))} DCGETOPTIONS SAYFONT '10.Helv Bold' TABSTOP AUTORESIZE *DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE d1 = 4 d2 = 6 DCBROWSECOL FIELD PrognReson->N1 HEADER 'Дата ' PARENT oBrowse WIDTH 7 COLOR {||{nil,aColor[33]}} PROTECT {|| .T. } * DCBROWSECOL FIELD PrognReson->MO_SUN HEADER 'MO_SUN ' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } * DCBROWSECOL FIELD PrognReson->MO_MA HEADER 'MO_MA ' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } * DCBROWSECOL FIELD PrognReson->MO_JUP HEADER 'MO_JUP ' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } * DCBROWSECOL FIELD PrognReson->MO_SAT HEADER 'MO_SAT ' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } * DCBROWSECOL FIELD PrognReson->MO_UR HEADER 'MO_UR ' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } * DCBROWSECOL FIELD PrognReson->MO_NEP HEADER 'MO_NEP ' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } * DCBROWSECOL FIELD PrognReson->MO_RAHU HEADER 'MO_RAHU ' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } * DCBROWSECOL FIELD PrognReson->MO_APOG HEADER 'MO_APOG ' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } * DCBROWSECOL FIELD PrognReson->MO_MER HEADER 'MO_MER ' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } * DCBROWSECOL FIELD PrognReson->MO_VEN HEADER 'MO_VEN ' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } * DCBROWSECOL FIELD PrognReson->_MO_SUN HEADER '_MO_SUN ' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } * DCBROWSECOL FIELD PrognReson->_MO_MA HEADER '_MO_MA ' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } * DCBROWSECOL FIELD PrognReson->_MO_JUP HEADER '_MO_JUP ' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } * DCBROWSECOL FIELD PrognReson->_MO_SAT HEADER '_MO_SAT ' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } * DCBROWSECOL FIELD PrognReson->_MO_UR HEADER '_MO_UR ' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } * DCBROWSECOL FIELD PrognReson->_MO_NEP HEADER '_MO_NEP ' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } * DCBROWSECOL FIELD PrognReson->_MO_RAHU HEADER '_MO_RAHU ' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } * DCBROWSECOL FIELD PrognReson->_MO_APOG HEADER '_MO_APOG ' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } * DCBROWSECOL FIELD PrognReson->_MO_MER HEADER '_MO_MER ' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } * DCBROWSECOL FIELD PrognReson->_MO_VEN HEADER '_MO_VEN ' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } DCBROWSECOL FIELD PrognReson->PROGN_POLN HEADER 'PROGN_POLN' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } DCBROWSECOL FIELD PrognReson->PROGN_AVR HEADER 'PROGN_AVR ' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } DCBROWSECOL FIELD PrognReson->ZMT_FAKT HEADER 'ZMT_FAKT ' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } DCBROWSECOL FIELD PrognReson->ZMTAVRFAKT HEADER 'ZMTAVRFAKT' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } DCBROWSECOL FIELD PrognReson->PROGNNNORM HEADER 'PROGNNNORM' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } DCBROWSECOL FIELD PrognReson->PROGN_N HEADER 'PROGN_N ' PARENT oBrowse WIDTH d2 PROTECT {|| .T. } DCBROWSECOL FIELD PrognReson->PROGN_NI HEADER 'PROGN_NI ' PARENT oBrowse WIDTH d2 PROTECT {|| .T. } DCBROWSECOL FIELD PrognReson->SUMINT_ZMT HEADER 'SUMINT_ZMT' PARENT oBrowse WIDTH d2 PROTECT {|| .T. } DCBROWSECOL FIELD PrognReson->INT_ZMT_NI HEADER 'INT_ZMT_NI' PARENT oBrowse WIDTH d2 PROTECT {|| .T. } DCBROWSECOL FIELD PrognReson->PROGAVRMIN HEADER 'PROGAVRMIN' PARENT oBrowse WIDTH d2 PROTECT {|| .T. } DCBROWSECOL FIELD PrognReson->PRAVKA_MIN HEADER 'PRAVKA_MIN' PARENT oBrowse WIDTH 3 COLOR {||{nil,aColor[33]}} DCBROWSECOL FIELD PrognReson->PR_PROGNNI HEADER 'PR_PROGNNI' PARENT oBrowse WIDTH d2 PROTECT {|| .T. } DCBROWSECOL FIELD PrognReson->P_INTZMTNI HEADER 'P_INTZMTNI' PARENT oBrowse WIDTH d2 PROTECT {|| .T. } DCREAD GUI ; FIT ; OPTIONS GetOptions ; MODAL ; TITLE L('2.3.2.12. Исправление положения минимумов прогноза ЗМТ') ************************************************************************************************************************** **** Алгоритм расчета колонок ******** * В файле PrognRezon.dbf, который посчитан программой на данных реализации ЗМТ по региону Калифорнии за 2019 год, я добавила следующие 3 поля: PRAVKA_MIN, PRAVKA_PROGN_NI, PRAVKA_INT_ZMT_NI * PROGN_N - это нормированные данные, которые соответствуют данным в графике-прогнозе на 2019 год по Калифорнии. Это поле для поиска минимумов, на графике-прогнозе этим минимумам соответствуют окончания сейсмических циклов. * SUMINT_ZMT - это поле, содержащее реальные данные суточных суммарных показателей интенсивности ЗМТ по региону Калифорнии за 2019 год, которые я беру ежемесячно, делаю сводную таблицу, вставляю в файл Inp_fakt для расчетов в режиме 2.3.2.12, эти данные копируются и в поле SUMINT_ZMT. * PROGAVRMIN - так программа нашла минимумы * Мое поле PRAVKA_MIN - это я поправила минимумы вручную * PROGN_NI - так программа посчитала прогнозные данные с нарастающим итогом из поля PROGN_N (от одного минимума - до последующего минимума) * Мое поле PRAVKA_PROGN_NI - я посчитала вручную нарастающий итог по прогнозу в соответствии с поправленными минимумами. * INT_ZMT_NI - так программа посчитала с нарастающим итогом данные суточных суммарных показателей интенсивности ЗМТ (из поля SUMINT_ZMT) * Мое поле PRAVKA_INT_ZMT_NI - я пересчитала эти данные по поправленным минимумам. ForeCalcMinExp1() // Расчет прогноза по исправленным минимумам LB_Warning(L("Перерасчет прогноза резонансов по минимумам, исправленным вручную, успешно завершен!")) * Chart23211r() // Рисует 2 графика ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ***************************************************************************************************************************** ***************************************************************************************************************************** FUNCTION Chart23211r(mPar) // Рисование графиков резонансов, полученного автоматически и по минимумам, исправленным вручную *** Проверить наличие БД PrognReson.dbf ************************* IF ApplChange("") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF IF .NOT. FILE('PrognReson.dbf') LB_Warning(L("Сначала надо сделать прогноз ЗМТ, а потом его корректировать !!! ")) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW Running(.F.) RETURN nil ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE PrognReson EXCLUSIVE NEW SELECT PrognReson DBGOTOP() ***************************************************************** ******** Рисуем график ****************************************** ***************************************************************** * oScr := DC_WaitOn('Немного подождите! Идет формирование изображения в памяти и его масштабирование',,,,,,,,,,,.F.) DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы PRIVATE a23211[8] IF FILE("_23211.arx") // Параметры диалога F2_3_2_12() a23211 = DC_ARestore("_23211.arx") PUBLIC mNumMod := a23211[1] PUBLIC mRegim := a23211[2] PUBLIC mWindow := a23211[3] PUBLIC mXSize := a23211[4] PUBLIC mYSize := a23211[5] PUBLIC mLineWidth := a23211[6] PUBLIC mGamma := a23211[7] PUBLIC mAlfa := a23211[8] ELSE PUBLIC mNumMod := 1 PUBLIC mRegim := 2 PUBLIC mWindow := 7 PUBLIC mXSize := 1800 PUBLIC mYSize := 900 PUBLIC mLineWidth := 7 PUBLIC mGamma := 1 PUBLIC mAlfa := 1 a23211[1] = mNumMod a23211[2] = mRegim a23211[3] = mWindow a23211[4] = mXSize a23211[5] = mYSize a23211[6] = mLineWidth a23211[7] = mGamma a23211[8] = mAlfa DC_ASave(a23211, "_23211.arx") ENDIF DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения * PUBLIC X_MaxW := 1800, Y_MaxW := 900 // Размер графического окна для отображения когнитивных диаграмм в пикселях PUBLIC X_MaxW := mXSize, Y_MaxW := mYSize // Максимальный размер графического окна для отображения 4K. PUBLIC nXSize := X_MaxW PUBLIC nYSize := Y_MaxW ***** 1-й график PROG **************************************************************************************************** IF mPar = 'Prog' // Create new bitmap with given size oPS := XBPPRESSPACE() :new() :Create() oBMP := XBPBITMAP() :New() :Create() oBMP:Make( nXSize, nYSize ) oBMP:presSpace( oPS ) // here your GRA* Code **** Закрасить фон прямоугольника *************** * GraSetColor( oPS, GRA_CLR_WHITE, GRA_CLR_WHITE ) GraSetColor( oPS, BD_LIGHTGREY, BD_LIGHTGREY ) GraBox( oPS, { 0, 0 }, { nXSize, nYSize }, GRA_FILL ) *######################################################################################################################### Chart23211res( oPS, 'Prog' ) // Графическая функция <<<===####################### *######################################################################################################################### *My image original, my image scaled ****** Запись полноразмерного графического файла в папку: M_PathAppl+"Events\" * DC_Impl(oScr) DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения IF FILEDATE("Events",16) = CTOD("//") DIRMAKE("Events") aMess := {} AADD(aMess, L('В папке текущего приложения: "'+UPPER(ALLTRIM(M_PathAppl))+'"')) AADD(aMess, L('не было директории "Events" для графических форм по прогнозам событий и она была создана!')) // <===####################### AADD(aMess, L('В эту папку записываются исходные изображения высокого качества (без масштабирования)')) LB_Warning(aMess, L('Прогноз событий в системе "Эйдос"')) ENDIF DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения DIRCHANGE(M_PathAppl+"Events\") // Перейти в папку Events cFileName = "EventsResonProg"+STRTRAN(STR(ADIR("*.*")+1,6)," ","0")+".jpg" ERASE(cFileName) oBMP:SaveFile(cFileName,XBPBMP_FORMAT_JPG) IF nWidth > 1800 FullView( cFileName, "по верху", 65 ) // Визуализация полноразмерного файла на мониторе высокого разрешения ELSE ****** Формирование с помощью bmp2bmp() и отображение масштабированного изображения aNewSize := {nWidth,nHeight-29} // Новый размер изображения (еще немного уменьшается, чтобы не рисовать по панели задач) oBMP:loadFile(cFileName) // Загрузка полноразмерного изображения oRet := BMP2BMP(oBMP,aNewSize) // Масштабирование изображения cFileNameScale = SUBSTR(cFileName,1,AT(".jpg",cFileName)-1)+"_scaled.jpg" ERASE(cFileNameScale) oRet:saveFile(cFileNameScale,XBPBMP_FORMAT_JPG) // Запись масштабированного графического файла в в папку приложения для визуализации FullView( cFileNameScale, "по верху", 0 ) // Визуализация масштабированного графического файла на мониторе ограниченного разрешения ENDIF ENDIF ***** 2-й график HAND **************************************************************************************************** ***** Проверка на наличие исправленных минимумов ***** IF mPar = 'Hand' mSumMinHand = 0 DO WHILE .NOT. EOF() IF LEN(ALLTRIM(PrognReson->PRAVKA_MIN)) > 0 // Чтобы можно было вводить не MIN, а любой символ mSumMinHand++ ENDIF DBSKIP(1) ENDDO IF mSumMinHand = 0 aMess := {} AADD(aMess, L('Расчет и визуализация графика прогноза резонансов по минимумам,' )) AADD(aMess, L('исправленным вручную, НЕВОЗМОЖЕН, так как они не проставлены !!!')) LB_Warning(aMess) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW Running(.F.) RETURN nil ENDIF // Create new bitmap with given size oPS := XBPPRESSPACE() :new() :Create() oBMP := XBPBITMAP() :New() :Create() oBMP:Make( nXSize, nYSize ) oBMP:presSpace( oPS ) // here your GRA* Code **** Закрасить фон прямоугольника *************** * GraSetColor( oPS, GRA_CLR_WHITE, GRA_CLR_WHITE ) GraSetColor( oPS, BD_LIGHTGREY, BD_LIGHTGREY ) GraBox( oPS, { 0, 0 }, { nXSize, nYSize }, GRA_FILL ) *######################################################################################################################### Chart23211res( oPS, 'Hand' ) // Графическая функция <<<===####################### *######################################################################################################################### *My image original, my image scaled ****** Запись полноразмерного графического файла в папку: M_PathAppl+"Events\" * DC_Impl(oScr) DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения IF FILEDATE("Events",16) = CTOD("//") DIRMAKE("Events") aMess := {} AADD(aMess, L('В папке текущего приложения: "'+UPPER(ALLTRIM(M_PathAppl))+'"')) AADD(aMess, L('не было директории "Events" для графических форм по прогнозам событий и она была создана!')) // <===####################### AADD(aMess, L('В эту папку записываются исходные изображения высокого качества (без масштабирования)')) LB_Warning(aMess, L('Прогноз событий в системе "Эйдос"')) ENDIF DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения DIRCHANGE(M_PathAppl+"Events\") // Перейти в папку Events cFileName = "EventsResonHand"+STRTRAN(STR(ADIR("*.*")+1,6)," ","0")+".jpg" ERASE(cFileName) oBMP:SaveFile(cFileName,XBPBMP_FORMAT_JPG) IF nWidth > 1800 FullView( cFileName, "по верху", 65 ) // Визуализация полноразмерного файла на мониторе высокого разрешения ELSE ****** Формирование с помощью bmp2bmp() и отображение масштабированного изображения aNewSize := {nWidth,nHeight-29} // Новый размер изображения (еще немного уменьшается, чтобы не рисовать по панели задач) oBMP:loadFile(cFileName) // Загрузка полноразмерного изображения oRet := BMP2BMP(oBMP,aNewSize) // Масштабирование изображения cFileNameScale = SUBSTR(cFileName,1,AT(".jpg",cFileName)-1)+"_scaled.jpg" ERASE(cFileNameScale) oRet:saveFile(cFileNameScale,XBPBMP_FORMAT_JPG) // Запись масштабированного графического файла в в папку приложения для визуализации FullView( cFileNameScale, "по верху", 0 ) // Визуализация масштабированного графического файла на мониторе ограниченного разрешения ENDIF ENDIF DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE PrognReson EXCLUSIVE NEW SELECT PrognReson DBGOTOP() RETURN nil ***************************************************************************************************************************** ********************************************************************* ****** Визуализация графика ***************************************** ********************************************************************* STATIC FUNCTION Chart23211res( oPS, mPar ) DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы PRIVATE a23211[8] IF FILE("_23211.arx") // Параметры диалога F2_3_2_12() a23211 = DC_ARestore("_23211.arx") PUBLIC mNumMod := a23211[1] PUBLIC mRegim := a23211[2] PUBLIC mWindow := a23211[3] PUBLIC mXSize := a23211[4] PUBLIC mYSize := a23211[5] PUBLIC mLineWidth := a23211[6] PUBLIC mGamma := a23211[7] PUBLIC mAlfa := a23211[8] ELSE PUBLIC mNumMod := 1 PUBLIC mRegim := 2 PUBLIC mWindow := 7 PUBLIC mXSize := 1800 PUBLIC mYSize := 900 PUBLIC mLineWidth := 7 PUBLIC mGamma := 1 PUBLIC mAlfa := 1 a23211[1] = mNumMod a23211[2] = mRegim a23211[3] = mWindow a23211[4] = mXSize a23211[5] = mYSize a23211[6] = mLineWidth a23211[7] = mGamma a23211[8] = mAlfa DC_ASave(a23211, "_23211.arx") ENDIF X_MaxW = mXSize Y_MaxW = mYSize DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения *** Брать данные из разных колонок, а так все остальное одинаково * Графики: * в 1 графике Правка MIN_1, рассчитанном программой, по оси X - Даты, по оси Y - данные из полей PROGN_NI и INT_ZMT_NI * в 2 графике Правка MIN_2,- по моим данным, так должно получаться, , по оси X - Даты, там по оси Y - данные из полей PR_PROGNNI и P_INTZMTNI. aArgName := {} // Наименования градаций (даты в формате: ДД.ММ.ГГГГ) aArg := {} // Значение аргумента для нормирования графика по X aVal := {} // PROGN_NI или PR_PROGNNI aInt := {} // INT_ZMT_NI или P_INTZMTNI CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE PrognReson EXCLUSIVE NEW SELECT PrognReson DBGOTOP() DO CASE CASE mPar = 'Prog' DO WHILE .NOT. EOF() AADD(aArgName, ALLTRIM(FIELDGET(1))) // Дата AADD(aArg , RECNO() ) AADD(aVal , PROGN_NI ) AADD(aInt , INT_ZMT_NI ) DBSKIP(1) ENDDO CASE mPar = 'Hand' // Не рисовать график, если нет ни одного MIN, выдать в этом случае сообщение <<<===###### DO WHILE .NOT. EOF() IF LEN(ALLTRIM(PrognReson->PRAVKA_MIN)) > 0 // Чтобы можно было вводить не MIN, а любой символ mSumMinHand++ ENDIF AADD(aArgName, ALLTRIM(FIELDGET(1))) // Дата AADD(aArg , RECNO() ) AADD(aVal , PR_PROGNNI ) AADD(aInt , P_INTZMTNI ) DBSKIP(1) ENDDO ENDCASE *********************************************************************** *********************************************************************** ****** Поиск макс и мин значений аргумента ****** X_MinA = +99999999 // Минимальное значение X аргумента X_MaxA = -99999999 // Максимальное значение X аргумента FOR j=1 TO LEN(aArg) X_MinA = MIN(X_MinA, aArg[j]) X_MaxA = MAX(X_MaxA, aArg[j]) NEXT N_Arg = LEN(aArg) // Кол-во уникальных значений аргумента n = LEN(aArg) // Кол-во уникальных значений аргумента ****** Поиск макс и мин значений функции ******** Y_MinF = +99999999 // Минимальное значение Y отображаемой функции Y_MaxF = -99999999 // Максимальное значение Y отображаемой функции FOR j=1 TO LEN(aVal) Y_MinF = MIN(Y_MinF, aVal[j]) Y_MaxF = MAX(Y_MaxF, aVal[j]) Y_MinF = MIN(Y_MinF, aInt[j]) Y_MaxF = MAX(Y_MaxF, aInt[j]) NEXT ******************************************************************************************** PRIVATE X0 := 75 PRIVATE Y0 := 165 // Начало координат по осям X и Y с учетом места для легенды PRIVATE W_Wind := X_MaxW - X0 - 25 // Ширина окна для самого графика PRIVATE H_Wind := Y_MaxW - Y0 - 70 // Высота окна для самого графика PRIVATE mNX := 100, mNY := 10 // Кол-во меток и надписей по осям X и Y PRIVATE Kx := W_Wind / ( X_MaxA-X_MinA ) // Коэффициент масштабирования по оси X: преобразует аргумент функции в номер пикселя по оси X PRIVATE Ky := H_Wind / ( Y_MaxF-Y_MinF ) // Коэффициент масштабирования по оси Y: преобразует значение функции в номер пикселя по оси Y PRIVATE Y0A := IF(Y_MinF > 0, Y0, Y0+ABS(Y_MinF)*Ky) // Позиция оси X на оси Y // <===################### **** Написать заголовок диаграммы aFonts := XbpFont():new():list() // Все доступные шрифты oFont := XbpFont():new():create("18.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты Ar_Model := {"Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } DO CASE CASE mPar = 'Prog' mTitle = 'ПРОГНОЗ СОБЫТИЙ МЕТОДОМ Н.А.ЧЕРЕДНИЧЕНКО'+' (минимумы расчитаны программно)' CASE mPar = 'Hand' mTitle = 'ПРОГНОЗ СОБЫТИЙ МЕТОДОМ Н.А.ЧЕРЕДНИЧЕНКО'+' (минимумы исправлены экспертом)' ENDCASE aTxtPar = DC_GraQueryTextbox(mTitle, oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox("Длина текста в пикселях="+ALLTRIM(STR(aTxtPar[1]))+". Высота текста в пикселях="+ALLTRIM(STR(aTxtPar[2]))) GraStringAt( oPS, { X_MaxW/2, Y_MaxW-25 }, mTitle) oFont := XbpFont():new():create("14.Arial Bold") GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты IF LEN(ALLTRIM(M_NameAppl)) < 70 GraStringAt( oPS, { X_MaxW/2, Y_MaxW-52 }, "Приложение: "+'"'+ALLTRIM(M_NameAppl)+'"' ) ELSE GraStringAt( oPS, { X_MaxW/2, Y_MaxW-52 }, '"'+ALLTRIM(M_NameAppl)+'"' ) ENDIF oFont := XbpFont():new():create("10.Arial") GraSetFont( oPS ,oFont ) aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты ***** Закрасить фон прямоугольника *************** GraSetColor( oPS, aColor[98] , aColor[98] ) GraBox( oPS, { X0, Y0 }, { X0+W_Wind, Y0+H_Wind }, GRA_FILL ) GraSetColor( oPS, aColor[222] , aColor[222] ) ***** Нарисовать оси координат ******************* aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 2 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты GraLine( oPS, {X0 , Y0A }, {X0+W_Wind, Y0A } ) // Нарисовать ось X GraLine( oPS, {X0 , Y0 }, {X0 , Y0+H_Wind} ) // Нарисовать границу рамки изображения слева это и есть ось Y GraLine( oPS, {X0 , Y0 }, {X0+W_Wind, Y0 } ) // Нарисовать границу рамки изображения внизу параллельно оси X GraLine( oPS, {X0 , Y0+H_Wind}, {X0+W_Wind, Y0+H_Wind} ) // Нарисовать границу рамки изображения вверху параллельно оси X GraLine( oPS, {X0+W_Wind, Y0 }, {X0+W_Wind, Y0+H_Wind} ) // Нарисовать границу рамки изображения справа параллельно оси Y aAttr := ARRAY( GRA_AM_COUNT ) // Массив для атрибутов маркеров aAttr [ GRA_AM_SYMBOL ] := GRA_MARKSYM_PLUS GraSetAttrMarker( oPS, aAttr ) aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DOT aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты *** Закрасить области между метками на оси X ***** DX = ( X_MaxA-X_MinA ) / mNX // Диапазон значений x, через которое ставить метку GraSetColor( oPS, aColor[99], aColor[99] ) j = 0 FOR X=X_MinA TO X_MaxA STEP 2*DX j = j + 2 X1 = X0 + ( j - 1 ) * DX * Kx X2 = X0 + ( j ) * DX * Kx GraBox( oPS, { X1, Y0 }, { X2, Y0 + H_Wind }, GRA_FILL ) NEXT GraSetColor( oPS, aColor[222], aColor[222] ) *** Сделать сетку и надписать метки на оси X ********************* // <===########### DO CASE CASE 1800 <= X_MaxW .AND. X_MaxW <= 3600 mNNadp = IF(LEN(aArgName) <= 182, LEN(aArgName), 182) // Количество надписей по оси X (больше 182 не помещается) oFont := XbpFont():new():create("8.Arial Bold") CASE 3600 <= X_MaxW .AND. X_MaxW <= 4096 mNNadp = IF(LEN(aArgName) <= 364, LEN(aArgName), 364) // Количество надписей по оси X (больше 364 не помещается) oFont := XbpFont():new():create("6.Arial Bold") ENDCASE GraSetFont( oPS ,oFont ) aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты mNumbLabels = INT(LEN(aArgName) / mNNadp) // Рисовать каждую 1-ю, 2-ю, 3-ю, 4-ю,..., mNumbLabels надпись на оси X aMonth = {'Январь','Февраль','Март','Апрель','Май','Июнь','Июль','Август','Сентябрь','Октябрь','Ноябрь','Декабрь'} mMGold = -1 mGold = -1 FOR j=1 TO LEN(aArgName) X1 = X0 + ( j - 1 ) * Kx GraMarker ( oPS, { X1, Y0 } ) IF j = mNumbLabels * INT(j / mNumbLabels) // Если номер надписи нацело делится на mNumbLabels, то рисовать ее X1 = X0 + ( j - 1 ) * Kx - 5 GraMarker ( oPS, { X1, Y0 } ) GraLine ( oPS, { X1, Y0 }, {X1, Y0+H_Wind} ) // Нарисовать пунктирную линию уровня x ****** Написать наименование месяца и год ****** IF LEN(aArgName) <= 365 mMGnew = VAL(SUBSTR(aArgName[j],4,7)) // Делать надпись при смене месяца и года IF mMGold <> mMGnew mMGold = mMGnew GraStringAt( oPS, { X1, Y0-72 }, aMonth[mMGnew]+','+SUBSTR(aArgName[j],7,4)) ENDIF ELSE mGnew = VAL(SUBSTR(aArgName[j],7,4)) // Делать надпись при смене года IF mGold <> MGnew mGold = MGnew GraStringAt( oPS, { X1, Y0-72 }, SUBSTR(aArgName[j],7,4)) ENDIF ENDIF ENDIF NEXT oFont := XbpFont():new():create("6.Arial") GraSetFont( oPS ,oFont ) aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты FOR j=1 TO LEN(aArgName) IF j = mNumbLabels * INT(j / mNumbLabels) // Если номер надписи нацело делится на mNumbLabels, то рисовать ее X1 = X0 + ( j - 1 ) * Kx aTxtPar = DC_GraQueryTextbox(ALLTRIM(STR(X,15,1)), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox(STR(aTxtPar[1])+" "+STR(aTxtPar[2])) mArgName = aArgName[j] aTxtPar = DC_GraQueryTextbox(mArgName, oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox("Длина текста в пикселях="+ALLTRIM(STR(aTxtPar[1]))+". Высота текста в пикселях="+ALLTRIM(STR(aTxtPar[2]))) aMatrix := GraInitMatrix() // <<<########## GraRotate( oPS, aMatrix, 90, { X1, Y0 }, GRA_TRANSFORM_ADD ) oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) // <<<########## mMM = VAL(SUBSTR(mArgName,4,2)) aAttrF [ GRA_AS_COLOR ] := IF(mMM=2*INT(mMM/2),aColor[12],aColor[190]) GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraStringAt( oPS, { X1-57, Y0 }, mArgName ) // Написать даты (aArgName[j]) вертикально <===############# ENDIF NEXT ****** Не получается отключить режим вращения изображения ****** Вместо отключения можно докрутить до 360 градусов aMatrix := GraInitMatrix() // <<<########## GraRotate( oPS, aMatrix, 0, {900, 425}, GRA_TRANSFORM_REPLACE ) // <<<########## oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) // <<<########## oFont := XbpFont():new():create("10.Arial") GraSetFont( oPS ,oFont ) aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты *** Сделать сетку и надписать метки на оси Y ********************* DY = ( Y_MaxF-Y_MinF ) / mNY // Диапазон значений Y, через которое ставить метку j = 0 FOR Y=Y_MinF TO Y_MaxF STEP DY ++j Y1 = Y0 + ( j - 1 ) * DY * Ky GraMarker ( oPS, { X0 , Y1 } ) aTxtPar = DC_GraQueryTextbox(ALLTRIM(STR(Y,15,1)), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox(STR(aTxtPar[1])+" "+STR(aTxtPar[2])) GraStringAt( oPS, { X0-35, Y1-aTxtPar[2]/2 }, ALLTRIM(STR(Y,15,1)) ) GraLine ( oPS, { X0 , Y1 }, {X0+W_Wind, Y1} ) // Нарисовать пунктирную линию уровня Y NEXT j = mNY Y1 = Y0 + j * DY * Ky GraMarker ( oPS, { X0 , Y1 } ) aTxtPar = DC_GraQueryTextbox(ALLTRIM(STR(Y_MaxF,15,1)), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox(STR(aTxtPar[1])+" "+STR(aTxtPar[2])) GraStringAt( oPS, { X0-35, Y1-aTxtPar[2]/2 }, ALLTRIM(STR(Y_MaxF,15,1)) ) GraLine ( oPS, { X0 , Y1 }, {X0+W_Wind, Y1} ) // Нарисовать пунктирную линию уровня Y ***** Рисование маркеров и отрезков прямых основной линии ************************************ aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT * aAttr [ GRA_AL_COLOR ] := aColor[123] // Задать цвет основной линии (темно-фиолетовый) <<<===################# DO CASE CASE mGamma = 1 // Теплая гамма aAttr [ GRA_AL_COLOR ] := GraMakeRGBColor({040,040,255}) // Задать цвет основной линии (яркий синий) CASE mGamma = 2 // Холодная гамма * aAttr [ GRA_AL_COLOR ] := GraMakeRGBColor({255,040,040}) // Задать цвет основной линии (яркий красный) aAttr [ GRA_AL_COLOR ] := GraMakeRGBColor({000,000,000}) // Задать цвет основной линии (черный) ENDCASE aAttr [ GRA_AL_WIDTH ] := 2 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aVal[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aVal[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT ***** ЭТО СДЕЛАТЬ НА СГЛАЖЕННОЙ КРИВОЙ, А ЗДЕСЬ ТОНКОЙ ЛИНИЕЙ, ЦВЕТА СИНЕЙ ГАММЫ, ЧТОБЫ ЗМТ ОТОБРАЖАТЬ КРАСНЫМ ***** Сделать рисование линий двух цветов, внутри посветлее, а снаружи потемнее (эффект объема) ***** для этого рисовать от внешних частей линии к внутренним уменьшающейся толщиной линии и более светлым цветом ПОВЕРХ РАНЕЕ НАРИСОВАННОГО IF mWindow > 0 DO CASE CASE mGamma = 1 // Теплая гамма DO CASE CASE mLineWidth = 5 aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := aColor[190] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 5 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[156] // Задать цвет внутри линии (темный синий) aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[169] // Задать цвет внутри линии (голубой) aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT CASE mLineWidth = 7 aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := aColor[192] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 7 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[190] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 5 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[156] // Задать цвет внутри линии (темный синий) aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[169] // Задать цвет внутри линии (голубой) aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT CASE mLineWidth = 9 aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := BD_BLACK // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 9 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[192] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 7 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[190] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 5 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[156] // Задать цвет внутри линии (темный синий) aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[169] // Задать цвет внутри линии (голубой) aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT ENDCASE CASE mGamma = 2 // Холодная гамма DO CASE CASE mLineWidth = 5 aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := aColor[14] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 5 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[12] // Задать цвет внутри линии (темный синий) aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[34] // Задать цвет внутри линии (голубой) aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT CASE mLineWidth = 7 aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := aColor[15] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 7 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[14] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 5 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[12] // Задать цвет внутри линии (темный синий) aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[34] // Задать цвет внутри линии (голубой) aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT CASE mLineWidth = 9 aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := BD_BLACK // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 9 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[15] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 7 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[14] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 5 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[12] // Задать цвет внутри линии (темный синий) aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[34] // Задать цвет внутри линии (голубой) aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT ENDCASE ENDCASE ***** Рисование маркеров на линии IF n <= 64 aAttr := ARRAY( GRA_AM_COUNT ) // Массив для атрибутов маркеров aAttr[ GRA_AM_SYMBOL ] := GRA_MARKSYM_DOT GraSetAttrMarker( oPS, aAttr ) FOR j=1 TO LEN(aArg) X := X0 + (aArg[j]-X_MinA) * Kx Y := Y0A + (aAvr[j]-Y_MinF) * Ky IF LEN(aArg) <= 32 aAttr[ GRA_AM_SYMBOL ] := GRA_MARKSYM_SMALLCIRCLE GraSetAttrMarker( oPS, aAttr ) GraMarker( oPS, { X, Y } ) // отобразить маркер ENDIF aAttr[ GRA_AM_SYMBOL ] := GRA_MARKSYM_DOT GraSetAttrMarker( oPS, aAttr ) GraMarker( oPS, { X, Y } ) // отобразить маркер * GraStringAt( oPS, { X, Y }, '('+ALLTRIM(STR(aAvr[j],15,1))+','+ALLTRIM(STR(aVal[j],15,1))+')') NEXT ENDIF ENDIF ***** Нарисовать оси координат ********************************** aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 2 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты графической линии GraLine( oPS, {X0 , Y0A }, {X0+W_Wind, Y0A } ) // Нарисовать ось X GraLine( oPS, {X0 , Y0 }, {X0 , Y0+H_Wind} ) // Нарисовать границу рамки изображения слева это и есть ось Y GraLine( oPS, {X0 , Y0 }, {X0+W_Wind, Y0 } ) // Нарисовать границу рамки изображения внизу параллельно оси X GraLine( oPS, {X0 , Y0+H_Wind}, {X0+W_Wind, Y0+H_Wind} ) // Нарисовать границу рамки изображения вверху параллельно оси X GraLine( oPS, {X0+W_Wind, Y0 }, {X0+W_Wind, Y0+H_Wind} ) // Нарисовать границу рамки изображения справа параллельно оси Y ****** Легенда *************************************************** Offset = -97 // Смещение вниз относительно нуля Y0 для позиции легенды Interval = 17 ***** Нарисовать рамку легенды aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты графической линии X1 := X0 Y1 := Y0 + Offset X2 := X0 + W_Wind Y2 := Y0 + Offset - 2 * Interval - 22 ***** Закрасить фон прямоугольника *************** GraSetColor( oPS, aColor[129] , aColor[129] ) GraBox( oPS, { X1, Y1 }, { X2, Y2 }, GRA_FILL) GraSetColor( oPS, aColor[222] , aColor[222] ) GraBox( oPS, { X1, Y1 }, { X2, Y2 } ) * GraLine( oPS, { 1300, Y1 }, { 1270, Y2 } ) // Нарисовать вертикальную линию, отделяющую левый комментарий от правого ***** Сделать надписи в легенде aAttr[ GRA_AL_COLOR ] := aColor[17] // Задать цвет линии aAttr[ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK GraSetAttrString( oPS, aAttrF ) * MsgBox(M_PathAppl) DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения IF FILEDATE("Events",16) = CTOD("//") DIRMAKE("Events") aMess := {} AADD(aMess, L('В папке текущего приложения: "'+UPPER(ALLTRIM(M_PathAppl))+'"')) AADD(aMess, L('не было директории "Events" для графических форм по прогнозам событий и она была создана!')) // <===####################### AADD(aMess, L('В эту папку записываются исходные изображения высокого качества (без масштабирования)')) LB_Warning(aMess, L('Прогноз событий в системе "Эйдос"')) ENDIF DIRCHANGE(M_PathAppl+"EarthqQuakes\") // Перейти в папку Events cFileName = "Events"+STRTRAN(STR(ADIR("*.*")+1,6)," ","0")+".jpg" X1 := X0 + 20 Y1 := Y0 + Offset - Interval X2 := X1 + 190 Y2 := Y0 + Offset - 1 * Interval **** Передача параметров расчета для графика DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения * ar := {} * AADD(ar, mNumMod) * AADD(ar, M_Interval) * AADD(ar, K_GradNClSc) * AADD(ar, K_GradNOpSc) * AADD(ar, mNObj) * DC_ASave(ar, "_23211chart.arx") ar = DC_ARestore("_23211chart.arx") **** Надпись в легенде слева *********** oFont := XbpFont():new():create("12.Arial") GraSetFont( oPS ,oFont ) Y2 := Y0 + Offset - 1 * Interval;GraStringAt( oPS, { X1, Y2-0 }, L('Модель: "') +UPPER(ALLTRIM(Ar_Model[ar[1]]))+'". '+; L('Число интервалов в класс.и опис.шкалах:')+' '+ALLTRIM(STR(ar[3]))+', '+ALLTRIM(STR(ar[4]))+'. '+; L('Тип интервалов:') +' '+IF(ar[2]=1,L('"РАВНЫЕ"'),L('"АДАПТИВНЫЕ"'))+'. '+; L('Число наблюдений в обучающей выборке:') +' '+ALLTRIM(STR(ar[5])) +'. '+; L('Размер интервала сглаживания =') +' '+ALLTRIM(STR(mWindow)) +'. '+; L('Форма создана:')+' '+DTOC(DATE())+"-"+TIME()) ****** Надписи координатных осей ********************************* oFont := XbpFont():new():create("13.ArialBold") GraSetFont( oPS ,oFont ) * AxName = "Дата (день, месяц, год)" * GraStringAt( oPS, { X0+W_Wind/2-8*LEN(AxName)/2, Y0-45 }, AxName ) // Надпись оси Х (СДЕЛАНА ВЫШЕ) AyName = "Суммарная сила факторов, способствующих возникновению землетрясения (норм.знач.)" aMatrix := GraInitMatrix() GraRotate( oPS, aMatrix, 90, { X0-53, Y0+H_Wind/2-8*LEN(AyName)/2 }, GRA_TRANSFORM_ADD ) oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) GraStringAt( oPS, { X0-53, Y0+H_Wind/2-8*LEN(AyName)/2 }, AyName ) // Надпись оси Y ****** Не получается отключить режим вращения изображения ****** Вместо отключения можно докрутить до 360 градусов X_Max := 1800 Y_Max := 850 // Размер графического окна для самого графика в пикселях aMatrix := GraInitMatrix() // <<<########## GraRotate( oPS, aMatrix, 0, {900, 425}, GRA_TRANSFORM_REPLACE ) // <<<########## oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) // <<<########## RETURN NIL **************************************************************************************************************************** ********************************************************************* ****** Визуализация графика в полярной системе координат ************ ********************************************************************* *STATIC FUNCTION ChartEventsPolar( oPS ) FUNCTION ChartEventsPolar( oPS, mPar ) DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы PRIVATE a23211[8] IF mPar = 'Events' IF FILE("_23211.arx") // Параметры диалога F2_3_2_11() a23211 = DC_ARestore("_23211.arx") PUBLIC mNumMod := a23211[1] PUBLIC mRegim := a23211[2] PUBLIC mWindow := a23211[3] PUBLIC mXSize := a23211[4] PUBLIC mYSize := a23211[5] PUBLIC mLineWidth := a23211[6] PUBLIC mGamma := a23211[7] PUBLIC mAlfa := a23211[8] ELSE PUBLIC mNumMod := 1 PUBLIC mRegim := 2 PUBLIC mWindow := 7 PUBLIC mXSize := 1800 PUBLIC mYSize := 1800 PUBLIC mLineWidth := 7 PUBLIC mGamma := 1 PUBLIC mAlfa := 1 a23211[1] = mNumMod a23211[2] = mRegim a23211[3] = mWindow a23211[4] = mXSize a23211[5] = mYSize a23211[6] = mLineWidth a23211[7] = mGamma a23211[8] = mAlfa DC_ASave(a23211, "_23211.arx") ENDIF ENDIF IF mPar = 'Earthquakes' IF FILE("_23212.arx") // Параметры диалога F2_3_2_12() a23212 = DC_ARestore("_23212.arx") PUBLIC mNumMod := a23212[1] PUBLIC mRegim := a23212[2] PUBLIC mWindow := a23212[3] PUBLIC mXSize := a23212[4] PUBLIC mYSize := a23212[5] PUBLIC mLineWidth := a23212[6] PUBLIC mGamma := a23212[7] PUBLIC mAlfa := a23212[8] ELSE PUBLIC mNumMod := 1 PUBLIC mRegim := 2 PUBLIC mWindow := 7 PUBLIC mXSize := 1800 PUBLIC mYSize := 1800 PUBLIC mLineWidth := 7 PUBLIC mGamma := 1 PUBLIC mAlfa := 1 a23212[1] = mNumMod a23212[2] = mRegim a23212[3] = mWindow a23212[4] = mXSize a23212[5] = mYSize a23212[6] = mLineWidth a23212[7] = mGamma a23212[8] = mAlfa DC_ASave(a23212, "_23212.arx") ENDIF ENDIF X_MaxW = mXSize Y_MaxW = mYSize DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения aFakt := {} // Интенсивность фактических ЗМТ CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rasp_PROGNOZ EXCLUSIVE NEW SELECT Rasp_PROGNOZ DBGOTOP() DO WHILE .NOT. EOF() AADD(aFakt, ZMT_FAKT ) DBSKIP(1) ENDDO n = LEN(aFakt) *********************************************************************** * Экспоненциальное сглаживание линейно нормированного логарифма факта: * - логарифм для уменьшения влияния низкочастотных выбросов; * - линейное нормирование для отображения значений в область: 0 - 1; * - экспоненциальное сглаживание для удаления уменьшения влияния высокочастотных выбросов (сила сглаживания задается в диалоге от полного его отсутствия до максимального: до одной прямой линии). *********************************************************************** aLogFakt := {} // Логарифм факта (в лог.шкале выбросы играют меньшую роль) aLineNormLogFakt := {} // Линейное нормирование логарифма факта (отображение в область: 0-1) aExpSmLineNormLF := {} // Экспоненциальное сглаживание линейного нормирования логарифма факта // Логарифм факта (в лог.шкале выбросы играют меньшую роль) mMinFakt = +99999999 mMaxFakt = -99999999 FOR j=1 TO n mMinFakt = MIN(mMinFakt, aFakt[j]) mMaxFakt = MAX(mMaxFakt, aFakt[j]) NEXT FOR j=1 TO n AADD(aLogFakt, IF(aFakt[j]>0,LOG(aFakt[j]),LOG(mMinFakt))) NEXT // Линейное нормирование логарифма факта (отображение в область: 0-1) mMinLogFakt = +99999999 mMaxLogFakt = -99999999 FOR j=1 TO n mMinLogFakt = MIN(mMinLogFakt, aLogFakt[j]) mMaxLogFakt = MAX(mMaxLogFakt, aLogFakt[j]) NEXT FOR j=1 TO n AADD(aLineNormLogFakt, (aLogFakt[j] - mMinLogFakt) / (mMaxLogFakt - mMinLogFakt)) NEXT // Экспоненциальное сглаживание линейного нормирования логарифма факта ****** ЗАМЕНИТЬ НА ЦЕНТРИРОВАННОЕ ЛИНЕЙНОЕ СГЛАЖИВАНИЕ СКОЛЬЗЯЩИМ СРЕДНИМ <===########### * mAlfa = 0.8 * AADD(aExpSmLineNormLF, aLineNormLogFakt[1]) * FOR j=2 TO n * AADD(aExpSmLineNormLF, mAlfa * aLineNormLogFakt[j] + ( 1 - mAlfa ) * aExpSmLineNormLF[j-1] ) * NEXT // ЦЕНТРИРОВАННОЕ ЛИНЕЙНОЕ СГЛАЖИВАНИЕ СКОЛЬЗЯЩИМ СРЕДНИМ <===########### PRIVATE aAvrFakt[n] // Длина исходного массива AFILL(aAvrFakt, 0) * aAvr[1] = aVal[1] // Чтобы 1-й элемент сглаженного массива были точно равен 1-му элементу несглаженного массива <===###### Когда верификация * mWindow = 7 // Интервал (окно) сглаживания (месяц) (задается в диалоге) IF mAlfa > 1 aAvrFakt = aLineNormLogFakt // Чтобы 1-й элемент сглаженного массива были точно равен 1-му элементу несглаженного массива <===###### Когда верификация ENDIF hw = (mAlfa-1)/2 // Размах окна влево и вправо от текущей позиции FOR i=2 TO n // Организовываем цикл по числу элементов mSumY = 0 ** Определение начала и конца окна IF i<=hw // если индекс меньше половины окна, мы находимся в начале массива, нужно брать окно меньшего размера k1=1 // в качестве начала окна берем первый элемент k2=2*i-1 // конец окна z=k2 // текущий размер окна ELSEIF i+hw>n // если индекс+половина окна больше n - мы приближаемся к концу массива и размер окна также нужно уменьшать k1=i-n+i // начало окна k2=n // конец окна - последний элемент массива z=k2-k1 // размер окна ELSE // если первые два условия не выполняются, мы в середине массива k1=i-hw k2=i+hw z=mAlfa ENDIF FOR j = INT(k1) TO INT(k2) // организуем цикл от начала до конца окна mSumY = mSumY + aLineNormLogFakt[j] // <===######################## дает ошибку когда окно четное? NEXT aAvrFakt[i] = mSumY / z * aAvrFakt[i] = IF(aAvrFakt[i]Y_MaxF,Y_MaxF,aAvrFakt[i]) NEXT ****** Записать результаты сглаживания факта SELECT Rasp_PROGNOZ j = 0 DBGOTOP() DO WHILE .NOT. EOF() j++ REPLACE ZMTAvrFakt WITH aAvrFakt[j] DBSKIP(1) ENDDO aArgName := {} // Наименования градаций (даты в формате: ДД.ММ.ГГГГ) aArg := {} // Значение аргумента для нормирования графика по X aVal := {} // Полный прогноз (высокочастотный) aAvr := {} // Сглаженный прогноз aFakt := {} // Интенсивность фактических ЗМТ mSummaFakt = 0 DBGOTOP() DO WHILE .NOT. EOF() AADD(aArgName, ALLTRIM(FIELDGET(1))) // Дата AADD(aArg , RECNO() ) AADD(aVal , PROGN_POLN) AADD(aAvr , PROGN_AVR ) AADD(aFakt, ZMTAvrFakt) // Сглаженные и нормированные интенсивности фактических ЗМТ mSummaFakt = mSummaFakt + ZMT_FAKT // Если сумма интенсивностей фактических ЗМТ = 0, значит нет даных по фактическим ЗМТ DBSKIP(1) ENDDO *********************************************************************** *********************************************************************** ****** Поиск макс и мин значений аргумента ****** X_MinA = +99999999 // Минимальное значение X аргумента X_MaxA = -99999999 // Максимальное значение X аргумента FOR j=1 TO LEN(aArg) X_MinA = MIN(X_MinA, aArg[j]) X_MaxA = MAX(X_MaxA, aArg[j]) NEXT N_Arg = LEN(aArg) // Кол-во уникальных значений аргумента n = LEN(aArg) // Кол-во уникальных значений аргумента ****** Поиск макс и мин значений функции ******** Y_MinF = +99999999 // Минимальное значение Y отображаемой функции Y_MaxF = -99999999 // Максимальное значение Y отображаемой функции FOR j=1 TO LEN(aVal) Y_MinF = MIN(Y_MinF, aVal[j]) Y_MaxF = MAX(Y_MaxF, aVal[j]) Y_MinF = MIN(Y_MinF, aAvr[j]) Y_MaxF = MAX(Y_MaxF, aAvr[j]) IF mSummaFakt > 0 Y_MinF = MIN(Y_MinF, aFakt[j]) Y_MaxF = MAX(Y_MaxF, aFakt[j]) ENDIF NEXT ******************************************************************************************** *** Посчитать корреляцию факта с высокочастотным и сглаженным прогнозами и вывести в графике ******************************************************************************************** IF mSummaFakt > 0 *** Расчет сумм и средних mSumVal = 0 mSumAvr = 0 mSumFakt = 0 mN = 0 FOR j=1 TO n IF aFakt[j] > 0 // Корреляцию считать только для точек, по которым есть факт, а 0 пропускать mN++ mSumVal = mSumVal + aVal [j] mSumAvr = mSumAvr + aAvr [j] mSumFakt = mSumFakt + aFakt[j] ENDIF NEXT mSrVal = mSumVal /mN mSrAvr = mSumAvr /mN mSrFakt = mSumFakt/mN *** Расчет ср.кв.отклонений mDiVal = 0 mDiAvr = 0 mDiFakt = 0 FOR j=1 TO n IF aFakt[j] > 0 mDiVal = mDiVal + ( aVal [j] - mSrVal ) ^ 2 mDiAvr = mDiAvr + ( aAvr [j] - mSrAvr ) ^ 2 mDiFakt = mDiFakt + ( aFakt[j] - mSrFakt ) ^ 2 ENDIF NEXT mDiVal = SQRT(mDiVal /(mN-1)) mDiAvr = SQRT(mDiAvr /(mN-1)) mDiFakt = SQRT(mDiFakt/(mN-1)) *** Расчет ковариаций и ср.кв.отклонений mKovVal = 0 mKovAvr = 0 FOR j=1 TO n IF aFakt[j] > 0 mKovVal = mKovVal + (aVal[j] - mSrVal) * (aFakt[j] - mSrFakt) mKovAvr = mKovAvr + (aAvr[j] - mSrAvr) * (aFakt[j] - mSrFakt) ENDIF NEXT mKovVal = mKovVal / mN mKovAvr = mKovAvr / mN *** Расчет корреляций mKorVal = mKovVal / ( mDiVal * mDiFakt ) mKorAvr = mKovAvr / ( mDiAvr * mDiFakt ) ENDIF ******************************************************************************************** ******* Для декартовй системы координат **** PRIVATE X0 := 75 PRIVATE Y0 := 165 // Начало координат по осям X и Y с учетом места для легенды PRIVATE W_Wind := X_MaxW - X0 - 25 // Ширина окна для самого графика PRIVATE H_Wind := Y_MaxW - Y0 - 70 // Высота окна для самого графика PRIVATE mNX := 100, mNY := 10 // Кол-во меток и надписей по осям X и Y PRIVATE Kx := W_Wind / ( X_MaxA-X_MinA ) // Коэффициент масштабирования по оси X: преобразует аргумент функции в номер пикселя по оси X PRIVATE Ky := H_Wind / ( Y_MaxF-Y_MinF ) // Коэффициент масштабирования по оси Y: преобразует значение функции в номер пикселя по оси Y PRIVATE Y0A := IF(Y_MinF > 0, Y0, Y0+ABS(Y_MinF)*Ky) // Позиция оси X на оси Y // <===################### ********* Для полярной системы координат ************************************************* PRIVATE X0 := 75 PRIVATE Y0 := 165 // Начало координат по осям X и Y с учетом места для легенды PRIVATE W_Wind := X_MaxW - X0 - 25 // Ширина окна для самого графика PRIVATE H_Wind := Y_MaxW - Y0 - 70 // Высота окна для самого графика PRIVATE X0pol := X0 + W_Wind / 2 PRIVATE Y0pol := Y0 + H_Wind / 2 // Начало координат по осям X и Y с учетом места для легенды PRIVATE R0X := W_Wind / 2 - 150 // Радиус графика в полярной системе координат по X PRIVATE R0Y := H_Wind / 2 - 150 // Радиус графика в полярной системе координат по Y mNGrad = LEN(aAvr) PRIVATE Kx := R0X / ( X_MaxA-X_MinA ) // Коэффициент масштабирования по оси X: преобразует аргумент функции в номер пикселя по оси X PRIVATE Ky := R0Y / ( Y_MaxF-Y_MinF ) // Коэффициент масштабирования по оси Y: преобразует значение функции в номер пикселя по оси Y PRIVATE mNX := 10, mNY := 10 // Кол-во меток и надписей по осям X и Y ****************************************************************************************** **** Написать заголовок диаграммы aFonts := XbpFont():new():list() // Все доступные шрифты oFont := XbpFont():new():create("18.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты Ar_Model := {"Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } IF mPar = 'Events' mTitle = 'ПРОГНОЗИРОВАНИЕ СОБЫТИЙ ПО АСТРОФАКТОРАМ МЕТОДОМ Н.А.ЧЕРЕДНИЧЕНКО' // Задача 2 ENDIF IF mPar = 'Earthquakes' mTitle = 'ПРОГНОЗ ЗЕМЛЕТРЯСЕНИЙ МЕТОДОМ Н.А.ЧЕРЕДНИЧЕНКО' // Задача 1 ENDIF aTxtPar = DC_GraQueryTextbox(mTitle, oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox("Длина текста в пикселях="+ALLTRIM(STR(aTxtPar[1]))+". Высота текста в пикселях="+ALLTRIM(STR(aTxtPar[2]))) GraStringAt( oPS, { X_MaxW/2, Y_MaxW-25 }, mTitle) oFont := XbpFont():new():create("14.Arial Bold") GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты IF LEN(ALLTRIM(M_NameAppl)) < 70 GraStringAt( oPS, { X_MaxW/2, Y_MaxW-52 }, "Приложение: "+'"'+ALLTRIM(M_NameAppl)+'"' ) ELSE GraStringAt( oPS, { X_MaxW/2, Y_MaxW-52 }, '"'+ALLTRIM(M_NameAppl)+'"' ) ENDIF oFont := XbpFont():new():create("10.Arial") GraSetFont( oPS ,oFont ) aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты ***** Закрасить фон прямоугольника для декартовой системы координат *************** GraSetColor( oPS, aColor[98] , aColor[98] ) GraBox( oPS, { X0, Y0 }, { X0+W_Wind, Y0+H_Wind }, GRA_FILL ) GraSetColor( oPS, aColor[222] , aColor[222] ) ***** Нарисовать оси координат для декартовой системы координат ******************* aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 2 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты GraLine( oPS, {X0 , Y0A }, {X0+W_Wind, Y0A } ) // Нарисовать ось X GraLine( oPS, {X0 , Y0 }, {X0 , Y0+H_Wind} ) // Нарисовать границу рамки изображения слева это и есть ось Y GraLine( oPS, {X0 , Y0 }, {X0+W_Wind, Y0 } ) // Нарисовать границу рамки изображения внизу параллельно оси X GraLine( oPS, {X0 , Y0+H_Wind}, {X0+W_Wind, Y0+H_Wind} ) // Нарисовать границу рамки изображения вверху параллельно оси X GraLine( oPS, {X0+W_Wind, Y0 }, {X0+W_Wind, Y0+H_Wind} ) // Нарисовать границу рамки изображения справа параллельно оси Y aAttr := ARRAY( GRA_AM_COUNT ) // Массив для атрибутов маркеров aAttr [ GRA_AM_SYMBOL ] := GRA_MARKSYM_PLUS GraSetAttrMarker( oPS, aAttr ) aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DOT aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты *** Сделать метки и надписи на осям X и Y для полярной системы координат ********************* // Коэффициент перевода аргументов тригонометрических функций из градусов в радианы и расчета числа градусов на день PUBLIC GradRad := 3.14159265358979323846 / 180 * 360 / LEN(aArg) Faza = 90 N_Point = 360 DX = ( Y_MaxF-Y_MinF ) / 10 // Диапазон значений функции, через которое ставить метку kx = R0X / ( Y_MaxF-Y_MinF ) // Коэффициент преобразования значений функции в пиксельные координаты по оси X DY = ( Y_MaxF-Y_MinF ) / 10 // Диапазон значений функции, через которое ставить метку ky = R0Y / ( Y_MaxF-Y_MinF ) // Коэффициент преобразования значений функции в пиксельные координаты по оси Y j = 0 FOR Y=Y_MinF TO Y_MaxF STEP DY X1 = X0pol + j * DX * kx X2 = X0pol - j * DX * kx Y1 = Y0pol + j * DY * ky Y2 = Y0pol - j * DY * ky ++j GraMarker ( oPS, { X0 , Y1 } ) GraMarker ( oPS, { X0 , Y2 } ) GraMarker ( oPS, { X1 , Y0 } ) GraMarker ( oPS, { X2 , Y0 } ) aTxtPar = DC_GraQueryTextbox(ALLTRIM(STR(Y,15,2)), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox(STR(aTxtPar[1])+" "+STR(aTxtPar[2])) GraStringAt( oPS, { X0-35, Y1-aTxtPar[2]/2 }, ALLTRIM(STR(Y,15,2)) ) GraStringAt( oPS, { X0-35, Y2-aTxtPar[2]/2 }, ALLTRIM(STR(Y,15,2)) ) GraStringAt( oPS, { X1-aTxtPar[1]/2, Y0-22 }, ALLTRIM(STR(Y,15,2)) ) GraStringAt( oPS, { X2-aTxtPar[1]/2, Y0-22 }, ALLTRIM(STR(Y,15,2)) ) NEXT ***** Рисование маркеров и отрезков прямых основной линии полярной систем координат ************************************ aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := aColor[70] // Задать цвет основной линии (темно-зеленый) aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты *** для полярной системы координат ***** GraArc( oPS, { X0pol, Y0pol }, 5, ,,, GRA_OUTLINEFILL ) // Начало координат <<<===####################################### j = 0 X1 := X0pol + R0X * COS(GradRad*(Faza-(j ))) Y1 := Y0pol - R0Y * SIN(GradRad*(Faza-(j ))) * FOR j=2 TO LEN(aArg) STEP INT(LEN(aArg) / N_Point) FOR j=1 TO LEN(aArg) X2 := X0pol + R0X * COS(GradRad*(Faza-(j ))) Y2 := Y0pol - R0Y * SIN(GradRad*(Faza-(j ))) GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии между 1-й и 2-й точками на окружности GraLine( oPS, { X0pol, Y0pol }, { X1, Y1 } ) // Нарисовать отрезок прямой линии: начало координат - точка окружности GraArc( oPS, { X1, Y1 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать точку окружности X1 = X2 Y1 = Y2 NEXT GraArc( oPS, { X0pol, Y0pol }, 5, ,,, GRA_OUTLINEFILL ) // Начало координат <<<===####################################### aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии <<<===####################################### aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := 3 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 2 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты * FOR j=2 TO 720 STEP 0.1 // Спираль Архимеда ОТЛАДКА <<<===####################################### * X1 := X0pol + j * COS(GradRad*(Faza-j-1)) * Y1 := Y0pol - j * SIN(GradRad*(Faza-j-1)) * X2 := X0pol + j * COS(GradRad*(Faza-j )) * Y2 := Y0pol - j * SIN(GradRad*(Faza-j )) * GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии между 1-й и 2-й точками на графика * GraArc( oPS, { X1, Y1 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 1-ю точку графика * GraArc( oPS, { X2, Y2 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 2-ю точку графика * NEXT * GraArc( oPS, { X0pol, Y0pol }, 5, ,,, GRA_OUTLINEFILL ) // Начало координат <<<===####################################### DO CASE CASE mGamma = 1 // Теплая гамма aAttr [ GRA_AL_COLOR ] := aColor[12] // Задать цвет основной линии (яркий синий) CASE mGamma = 2 // Холодная гамма aAttr [ GRA_AL_COLOR ] := aColor[190] // Задать цвет основной линии (яркий красный) ENDCASE graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO LEN(aArg) // Рисование графика функции X1 := X0pol + R0X * ( aVal[j-1] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) Y1 := Y0pol - R0Y * ( aVal[j-1] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) X2 := X0pol + R0X * ( aVal[j ] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) Y2 := Y0pol - R0Y * ( aVal[j ] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии между 1-й и 2-й точками на графика * GraArc( oPS, { X1, Y1 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 1-ю точку графика * GraArc( oPS, { X2, Y2 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 2-ю точку графика NEXT GraArc( oPS, { X0pol, Y0pol }, 5, ,,, GRA_OUTLINEFILL ) // Начало координат <<<===####################################### ****** Надписи координатных осей для полярной системы координат ********************************* oFont := XbpFont():new():create("10.Arial") GraSetFont( oPS ,oFont ) FOR j=1 TO LEN(aArgName) // Рисование надписей дней года вокруг графика функции X1 := X0pol + (R0X+10) * COS(GradRad*(Faza - ( aArg[j] - X_MinA ) )) Y1 := Y0pol - (R0Y+10) * SIN(GradRad*(Faza - ( aArg[j] - X_MinA ) )) mMM = VAL(SUBSTR(aArgName[j],4,2)) aAttrF [ GRA_AS_COLOR ] := IF(mMM=2*INT(mMM/2),aColor[12],aColor[190]) GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты aMatrix := GraInitMatrix() GraRotate( oPS, aMatrix, Faza+180+aArg[j]*360/LEN(aArg), { X1, Y1 }, GRA_TRANSFORM_ADD ) oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) GraStringAt( oPS, { X1, Y1 }, aArgName[j] ) // Надпись на радиус-векторе NEXT ****** Не получается отключить режим вращения изображения ****** Вместо отключения можно докрутить до 360 градусов aMatrix := GraInitMatrix() // <<<########## GraRotate( oPS, aMatrix, 0, {X0pol, Y0pol}, GRA_TRANSFORM_REPLACE ) // <<<########## oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) // <<<########## aMonth = {'Январь','Февраль','Март','Апрель','Май','Июнь','Июль','Август','Сентябрь','Октябрь','Ноябрь','Декабрь'} mMGold = -1 mGold = -1 oFont := XbpFont():new():create("14.Arial") GraSetFont( oPS ,oFont ) aAttrF [ GRA_AS_COLOR ] := 1 GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты * FOR j=1 TO LEN(aArgName) // Рисование надписей дней года вокруг графика функции целиком * mMGnew = VAL(SUBSTR(aArgName[j],4,7)) // Делать надпись при смене месяца или года * IF mMGold <> mMGnew * mMGold = mMGnew * X2 := X0pol + (R0X+117) * COS(GradRad*(Faza - ( aArg[j] - X_MinA ) )) * Y2 := Y0pol - (R0Y+117) * SIN(GradRad*(Faza - ( aArg[j] - X_MinA ) )) * aMatrix := GraInitMatrix() * GraRotate( oPS, aMatrix, 360-j-91, { X2, Y2 }, GRA_TRANSFORM_ADD ) * oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) * GraStringAt( oPS, { X2, Y2 }, aMonth[mMGnew]+', '+SUBSTR(aArgName[j],7,4)) * ENDIF * NEXT FOR j=1 TO LEN(aArgName) // Рисование надписей месяца и года вокруг графика функции посимвольно mMGnew = VAL(SUBSTR(aArgName[j],4,7)) // Делать надпись при смене месяца или года IF mMGold <> mMGnew mMGold = mMGnew mMG = aMonth[mMGnew]+', '+SUBSTR(aArgName[j],7,4) FOR b=1 TO LEN(mMG) X2 := X0pol + (R0X+117) * COS(GradRad*(Faza - ( aArg[j] - X_MinA ) - b+1 )) Y2 := Y0pol - (R0Y+117) * SIN(GradRad*(Faza - ( aArg[j] - X_MinA ) - b+1 )) aMatrix := GraInitMatrix() GraRotate( oPS, aMatrix, Faza+270+(aArg[j]+b-1)*360/LEN(aArg), { X2, Y2 }, GRA_TRANSFORM_ADD ) oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) GraStringAt( oPS, { X2, Y2 }, SUBSTR(mMG,b,1) ) NEXT ENDIF NEXT ****** Не получается отключить режим вращения изображения ****** Вместо отключения можно докрутить до 360 градусов aMatrix := GraInitMatrix() // <<<########## GraRotate( oPS, aMatrix, 0, {X0pol, Y0pol}, GRA_TRANSFORM_REPLACE ) // <<<########## oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) // <<<########## ***** ЭТО СДЕЛАТЬ НА СГЛАЖЕННОЙ КРИВОЙ, А ЗДЕСЬ ТОНКОЙ ЛИНИЕЙ, ЦВЕТА СИНЕЙ ГАММЫ, ЧТОБЫ ЗМТ ОТОБРАЖАТЬ КРАСНЫМ ***** Сделать рисование линий двух цветов, внутри посветлее, а снаружи потемнее (эффект объема) ***** для этого рисовать от внешних частей линии к внутренним уменьшающейся толщиной линии и более светлым цветом ПОВЕРХ РАНЕЕ НАРИСОВАННОГО IF mWindow > 0 DO CASE CASE mGamma = 1 // Теплая гамма DO CASE CASE mLineWidth = 5 aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := aColor[190] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 5 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO LEN(aArg) // Рисование графика функции X1 := X0pol + R0X * ( aAvr[j-1] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) Y1 := Y0pol - R0Y * ( aAvr[j-1] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) X2 := X0pol + R0X * ( aAvr[j ] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) Y2 := Y0pol - R0Y * ( aAvr[j ] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии между 1-й и 2-й точками на графика * GraArc( oPS, { X1, Y1 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 1-ю точку графика * GraArc( oPS, { X2, Y2 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 2-ю точку графика NEXT aAttr [ GRA_AL_COLOR ] := aColor[156] // Задать цвет внутри линии (темный синий) aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO LEN(aArg) // Рисование графика функции X1 := X0pol + R0X * ( aAvr[j-1] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) Y1 := Y0pol - R0Y * ( aAvr[j-1] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) X2 := X0pol + R0X * ( aAvr[j ] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) Y2 := Y0pol - R0Y * ( aAvr[j ] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии между 1-й и 2-й точками на графика * GraArc( oPS, { X1, Y1 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 1-ю точку графика * GraArc( oPS, { X2, Y2 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 2-ю точку графика NEXT aAttr [ GRA_AL_COLOR ] := aColor[169] // Задать цвет внутри линии (голубой) aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO LEN(aArg) // Рисование графика функции X1 := X0pol + R0X * ( aAvr[j-1] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) Y1 := Y0pol - R0Y * ( aAvr[j-1] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) X2 := X0pol + R0X * ( aAvr[j ] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) Y2 := Y0pol - R0Y * ( aAvr[j ] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии между 1-й и 2-й точками на графика * GraArc( oPS, { X1, Y1 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 1-ю точку графика * GraArc( oPS, { X2, Y2 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 2-ю точку графика NEXT CASE mLineWidth = 7 aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := aColor[192] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 7 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO LEN(aArg) // Рисование графика функции X1 := X0pol + R0X * ( aAvr[j-1] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) Y1 := Y0pol - R0Y * ( aAvr[j-1] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) X2 := X0pol + R0X * ( aAvr[j ] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) Y2 := Y0pol - R0Y * ( aAvr[j ] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии между 1-й и 2-й точками на графика * GraArc( oPS, { X1, Y1 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 1-ю точку графика * GraArc( oPS, { X2, Y2 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 2-ю точку графика NEXT aAttr [ GRA_AL_COLOR ] := aColor[190] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 5 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO LEN(aArg) // Рисование графика функции X1 := X0pol + R0X * ( aAvr[j-1] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) Y1 := Y0pol - R0Y * ( aAvr[j-1] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) X2 := X0pol + R0X * ( aAvr[j ] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) Y2 := Y0pol - R0Y * ( aAvr[j ] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии между 1-й и 2-й точками на графика * GraArc( oPS, { X1, Y1 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 1-ю точку графика * GraArc( oPS, { X2, Y2 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 2-ю точку графика NEXT aAttr [ GRA_AL_COLOR ] := aColor[156] // Задать цвет внутри линии (темный синий) aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO LEN(aArg) // Рисование графика функции X1 := X0pol + R0X * ( aAvr[j-1] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) Y1 := Y0pol - R0Y * ( aAvr[j-1] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) X2 := X0pol + R0X * ( aAvr[j ] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) Y2 := Y0pol - R0Y * ( aAvr[j ] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии между 1-й и 2-й точками на графика * GraArc( oPS, { X1, Y1 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 1-ю точку графика * GraArc( oPS, { X2, Y2 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 2-ю точку графика NEXT aAttr [ GRA_AL_COLOR ] := aColor[169] // Задать цвет внутри линии (голубой) aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO LEN(aArg) // Рисование графика функции X1 := X0pol + R0X * ( aAvr[j-1] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) Y1 := Y0pol - R0Y * ( aAvr[j-1] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) X2 := X0pol + R0X * ( aAvr[j ] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) Y2 := Y0pol - R0Y * ( aAvr[j ] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии между 1-й и 2-й точками на графика * GraArc( oPS, { X1, Y1 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 1-ю точку графика * GraArc( oPS, { X2, Y2 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 2-ю точку графика NEXT CASE mLineWidth = 9 aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := BD_BLACK // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 9 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO LEN(aArg) // Рисование графика функции X1 := X0pol + R0X * ( aAvr[j-1] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) Y1 := Y0pol - R0Y * ( aAvr[j-1] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) X2 := X0pol + R0X * ( aAvr[j ] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) Y2 := Y0pol - R0Y * ( aAvr[j ] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии между 1-й и 2-й точками на графика * GraArc( oPS, { X1, Y1 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 1-ю точку графика * GraArc( oPS, { X2, Y2 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 2-ю точку графика NEXT aAttr [ GRA_AL_COLOR ] := aColor[192] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 7 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO LEN(aArg) // Рисование графика функции X1 := X0pol + R0X * ( aAvr[j-1] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) Y1 := Y0pol - R0Y * ( aAvr[j-1] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) X2 := X0pol + R0X * ( aAvr[j ] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) Y2 := Y0pol - R0Y * ( aAvr[j ] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии между 1-й и 2-й точками на графика * GraArc( oPS, { X1, Y1 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 1-ю точку графика * GraArc( oPS, { X2, Y2 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 2-ю точку графика NEXT aAttr [ GRA_AL_COLOR ] := aColor[190] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 5 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO LEN(aArg) // Рисование графика функции X1 := X0pol + R0X * ( aAvr[j-1] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) Y1 := Y0pol - R0Y * ( aAvr[j-1] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) X2 := X0pol + R0X * ( aAvr[j ] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) Y2 := Y0pol - R0Y * ( aAvr[j ] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии между 1-й и 2-й точками на графика * GraArc( oPS, { X1, Y1 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 1-ю точку графика * GraArc( oPS, { X2, Y2 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 2-ю точку графика NEXT aAttr [ GRA_AL_COLOR ] := aColor[156] // Задать цвет внутри линии (темный синий) aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO LEN(aArg) // Рисование графика функции X1 := X0pol + R0X * ( aAvr[j-1] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) Y1 := Y0pol - R0Y * ( aAvr[j-1] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) X2 := X0pol + R0X * ( aAvr[j ] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) Y2 := Y0pol - R0Y * ( aAvr[j ] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии между 1-й и 2-й точками на графика * GraArc( oPS, { X1, Y1 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 1-ю точку графика * GraArc( oPS, { X2, Y2 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 2-ю точку графика NEXT aAttr [ GRA_AL_COLOR ] := aColor[169] // Задать цвет внутри линии (голубой) aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO LEN(aArg) // Рисование графика функции X1 := X0pol + R0X * ( aAvr[j-1] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) Y1 := Y0pol - R0Y * ( aAvr[j-1] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) X2 := X0pol + R0X * ( aAvr[j ] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) Y2 := Y0pol - R0Y * ( aAvr[j ] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии между 1-й и 2-й точками на графика * GraArc( oPS, { X1, Y1 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 1-ю точку графика * GraArc( oPS, { X2, Y2 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 2-ю точку графика NEXT ENDCASE CASE mGamma = 2 // Холодная гамма DO CASE CASE mLineWidth = 5 aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := aColor[14] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 5 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO LEN(aArg) // Рисование графика функции X1 := X0pol + R0X * ( aAvr[j-1] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) Y1 := Y0pol - R0Y * ( aAvr[j-1] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) X2 := X0pol + R0X * ( aAvr[j ] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) Y2 := Y0pol - R0Y * ( aAvr[j ] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии между 1-й и 2-й точками на графика * GraArc( oPS, { X1, Y1 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 1-ю точку графика * GraArc( oPS, { X2, Y2 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 2-ю точку графика NEXT aAttr [ GRA_AL_COLOR ] := aColor[12] // Задать цвет внутри линии (темный синий) aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO LEN(aArg) // Рисование графика функции X1 := X0pol + R0X * ( aAvr[j-1] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) Y1 := Y0pol - R0Y * ( aAvr[j-1] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) X2 := X0pol + R0X * ( aAvr[j ] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) Y2 := Y0pol - R0Y * ( aAvr[j ] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии между 1-й и 2-й точками на графика * GraArc( oPS, { X1, Y1 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 1-ю точку графика * GraArc( oPS, { X2, Y2 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 2-ю точку графика NEXT aAttr [ GRA_AL_COLOR ] := aColor[34] // Задать цвет внутри линии (голубой) aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO LEN(aArg) // Рисование графика функции X1 := X0pol + R0X * ( aAvr[j-1] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) Y1 := Y0pol - R0Y * ( aAvr[j-1] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) X2 := X0pol + R0X * ( aAvr[j ] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) Y2 := Y0pol - R0Y * ( aAvr[j ] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии между 1-й и 2-й точками на графика * GraArc( oPS, { X1, Y1 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 1-ю точку графика * GraArc( oPS, { X2, Y2 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 2-ю точку графика NEXT CASE mLineWidth = 7 aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := aColor[15] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 7 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO LEN(aArg) // Рисование графика функции X1 := X0pol + R0X * ( aAvr[j-1] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) Y1 := Y0pol - R0Y * ( aAvr[j-1] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) X2 := X0pol + R0X * ( aAvr[j ] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) Y2 := Y0pol - R0Y * ( aAvr[j ] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии между 1-й и 2-й точками на графика * GraArc( oPS, { X1, Y1 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 1-ю точку графика * GraArc( oPS, { X2, Y2 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 2-ю точку графика NEXT aAttr [ GRA_AL_COLOR ] := aColor[14] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 5 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO LEN(aArg) // Рисование графика функции X1 := X0pol + R0X * ( aAvr[j-1] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) Y1 := Y0pol - R0Y * ( aAvr[j-1] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) X2 := X0pol + R0X * ( aAvr[j ] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) Y2 := Y0pol - R0Y * ( aAvr[j ] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии между 1-й и 2-й точками на графика * GraArc( oPS, { X1, Y1 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 1-ю точку графика * GraArc( oPS, { X2, Y2 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 2-ю точку графика NEXT aAttr [ GRA_AL_COLOR ] := aColor[12] // Задать цвет внутри линии (темный синий) aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO LEN(aArg) // Рисование графика функции X1 := X0pol + R0X * ( aAvr[j-1] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) Y1 := Y0pol - R0Y * ( aAvr[j-1] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) X2 := X0pol + R0X * ( aAvr[j ] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) Y2 := Y0pol - R0Y * ( aAvr[j ] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии между 1-й и 2-й точками на графика * GraArc( oPS, { X1, Y1 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 1-ю точку графика * GraArc( oPS, { X2, Y2 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 2-ю точку графика NEXT aAttr [ GRA_AL_COLOR ] := aColor[34] // Задать цвет внутри линии (голубой) aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO LEN(aArg) // Рисование графика функции X1 := X0pol + R0X * ( aAvr[j-1] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) Y1 := Y0pol - R0Y * ( aAvr[j-1] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) X2 := X0pol + R0X * ( aAvr[j ] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) Y2 := Y0pol - R0Y * ( aAvr[j ] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии между 1-й и 2-й точками на графика * GraArc( oPS, { X1, Y1 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 1-ю точку графика * GraArc( oPS, { X2, Y2 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 2-ю точку графика NEXT CASE mLineWidth = 9 aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := BD_BLACK // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 9 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO LEN(aArg) // Рисование графика функции X1 := X0pol + R0X * ( aAvr[j-1] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) Y1 := Y0pol - R0Y * ( aAvr[j-1] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) X2 := X0pol + R0X * ( aAvr[j ] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) Y2 := Y0pol - R0Y * ( aAvr[j ] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии между 1-й и 2-й точками на графика * GraArc( oPS, { X1, Y1 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 1-ю точку графика * GraArc( oPS, { X2, Y2 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 2-ю точку графика NEXT aAttr [ GRA_AL_COLOR ] := aColor[15] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 7 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO LEN(aArg) // Рисование графика функции X1 := X0pol + R0X * ( aAvr[j-1] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) Y1 := Y0pol - R0Y * ( aAvr[j-1] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) X2 := X0pol + R0X * ( aAvr[j ] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) Y2 := Y0pol - R0Y * ( aAvr[j ] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии между 1-й и 2-й точками на графика * GraArc( oPS, { X1, Y1 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 1-ю точку графика * GraArc( oPS, { X2, Y2 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 2-ю точку графика NEXT aAttr [ GRA_AL_COLOR ] := aColor[14] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 5 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO LEN(aArg) // Рисование графика функции X1 := X0pol + R0X * ( aAvr[j-1] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) Y1 := Y0pol - R0Y * ( aAvr[j-1] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) X2 := X0pol + R0X * ( aAvr[j ] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) Y2 := Y0pol - R0Y * ( aAvr[j ] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии между 1-й и 2-й точками на графика * GraArc( oPS, { X1, Y1 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 1-ю точку графика * GraArc( oPS, { X2, Y2 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 2-ю точку графика NEXT aAttr [ GRA_AL_COLOR ] := aColor[12] // Задать цвет внутри линии (темный синий) aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO LEN(aArg) // Рисование графика функции X1 := X0pol + R0X * ( aAvr[j-1] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) Y1 := Y0pol - R0Y * ( aAvr[j-1] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) X2 := X0pol + R0X * ( aAvr[j ] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) Y2 := Y0pol - R0Y * ( aAvr[j ] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии между 1-й и 2-й точками на графика * GraArc( oPS, { X1, Y1 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 1-ю точку графика * GraArc( oPS, { X2, Y2 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 2-ю точку графика NEXT aAttr [ GRA_AL_COLOR ] := aColor[34] // Задать цвет внутри линии (голубой) aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO LEN(aArg) // Рисование графика функции X1 := X0pol + R0X * ( aAvr[j-1] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) Y1 := Y0pol - R0Y * ( aAvr[j-1] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j-1] - X_MinA ) )) X2 := X0pol + R0X * ( aAvr[j ] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) Y2 := Y0pol - R0Y * ( aAvr[j ] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j ] - X_MinA ) )) GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии между 1-й и 2-й точками на графика * GraArc( oPS, { X1, Y1 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 1-ю точку графика * GraArc( oPS, { X2, Y2 }, 3, ,,, GRA_OUTLINEFILL ) // Нарисовать 2-ю точку графика NEXT ENDCASE ENDCASE ** Отобразить фактически произошедшие ЗМТ, если они были, для декартовой и полярной систем координат IF mSummaFakt > 0 aAttr := ARRAY( GRA_AM_COUNT ) // Массив для атрибутов маркеров FOR j=1 TO n IF aFakt[j] > 0 // Проверка, чтобы не отображать фактические ЗМТ с 0 интенсивностью * X := X0 + (aArg [j]-X_MinA) * Kx // для декартовой системы координат * Y := Y0A + (aFakt[j]-Y_MinF) * Ky // для декартовой системы координат X := X0pol + R0X * ( aFakt[j] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j] - X_MinA ) )) // для полярной системы координат Y := Y0pol - R0Y * ( aFakt[j] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j] - X_MinA ) )) // для полярной системы координат FOR r = ROUND(mLineWidth * 2.0,0) TO 1 STEP -1 c = INT(r*5) DO CASE CASE mGamma = 1 // Теплая гамма aAttr[ GRA_AL_COLOR ] := GraMakeRGBColor({0,0,255-c}) // Задать цвет маркера (синий разной яркости) CASE mGamma = 2 // Холодная гамма aAttr[ GRA_AL_COLOR ] := GraMakeRGBColor({255-c,0,0}) // Задать цвет маркера (красный разной яркости) ENDCASE aAttr[ GRA_AL_COLOR ] := GraMakeRGBColor({255-c,0,0}) // Задать цвет маркера (красный разной яркости) aAttr[ GRA_AM_BOX ] := { r, r } // Размер маркера по X и по Y aAttr[ GRA_AM_SYMBOL ] := GRA_MARKSYM_SIXPOINTSTAR GraSetAttrMarker( oPS, aAttr ) GraMarker( oPS, { X, Y } ) // Отобразить маркер NEXT ENDIF NEXT ENDIF ***** Рисование маркеров на линии для декартовой и полярной систем координат IF n <= 64 aAttr := ARRAY( GRA_AM_COUNT ) // Массив для атрибутов маркеров aAttr[ GRA_AM_SYMBOL ] := GRA_MARKSYM_DOT GraSetAttrMarker( oPS, aAttr ) FOR j=1 TO LEN(aArg) * X := X0 + (aArg[j]-X_MinA) * Kx * Y := Y0A + (aAvr[j]-Y_MinF) * Ky X := X0pol + R0X * ( aAvr[j] - Y_MinF ) * COS(GradRad*(Faza - ( aArg[j] - X_MinA ) )) // для полярной системы координат Y := Y0pol - R0Y * ( aAvr[j] - Y_MinF ) * SIN(GradRad*(Faza - ( aArg[j] - X_MinA ) )) // для полярной системы координат IF LEN(aArg) <= 32 aAttr[ GRA_AM_SYMBOL ] := GRA_MARKSYM_SMALLCIRCLE GraSetAttrMarker( oPS, aAttr ) GraMarker( oPS, { X, Y } ) // отобразить маркер ENDIF aAttr[ GRA_AM_SYMBOL ] := GRA_MARKSYM_DOT GraSetAttrMarker( oPS, aAttr ) GraMarker( oPS, { X, Y } ) // отобразить маркер * GraStringAt( oPS, { X, Y }, '('+ALLTRIM(STR(aAvr[j],15,1))+','+ALLTRIM(STR(aVal[j],15,1))+')') NEXT ENDIF ENDIF ***** Нарисовать оси координат для декартовой системы координат ********************************** aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 2 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты графической линии GraLine( oPS, {X0 , Y0A }, {X0+W_Wind, Y0A } ) // Нарисовать ось X GraLine( oPS, {X0 , Y0 }, {X0 , Y0+H_Wind} ) // Нарисовать границу рамки изображения слева это и есть ось Y GraLine( oPS, {X0 , Y0 }, {X0+W_Wind, Y0 } ) // Нарисовать границу рамки изображения внизу параллельно оси X GraLine( oPS, {X0 , Y0+H_Wind}, {X0+W_Wind, Y0+H_Wind} ) // Нарисовать границу рамки изображения вверху параллельно оси X GraLine( oPS, {X0+W_Wind, Y0 }, {X0+W_Wind, Y0+H_Wind} ) // Нарисовать границу рамки изображения справа параллельно оси Y ****** Легенда *************************************************** Offset = -97 // Смещение вниз относительно нуля Y0 для позиции легенды Interval = 17 N_Line = 2 // N_Line Число строк в легенде ***** Нарисовать рамку легенды aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты графической линии X1 := X0 Y1 := Y0 + Offset X2 := X0 + W_Wind Y2 := Y0 + Offset - N_Line * Interval - 22 // N_Line Число строк в легенде ***** Закрасить фон прямоугольника для декартовой системы координат *************** GraSetColor( oPS, aColor[129] , aColor[129] ) GraBox( oPS, { X1, Y1 }, { X2, Y2 }, GRA_FILL) GraSetColor( oPS, aColor[222] , aColor[222] ) GraBox( oPS, { X1, Y1 }, { X2, Y2 } ) * GraLine( oPS, { 1300, Y1 }, { 1270, Y2 } ) // Нарисовать вертикальную линию, отделяющую левый комментарий от правого ***** Сделать надписи в легенде aAttr[ GRA_AL_COLOR ] := aColor[17] // Задать цвет линии aAttr[ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK GraSetAttrString( oPS, aAttrF ) * MsgBox(M_PathAppl) DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения IF FILEDATE(mPar,16) = CTOD("//") DIRMAKE(mPar) aMess := {} AADD(aMess, L('В папке текущего приложения: "'+UPPER(ALLTRIM(M_PathAppl))+'"')) AADD(aMess, L('не было директории "'+mPar+'" для графических форм по прогнозам событий и она была создана!')) // <===####################### AADD(aMess, L('В эту папку записываются исходные изображения высокого качества (без масштабирования)')) LB_Warning(aMess, L('Прогноз событий в системе "Эйдос"')) ENDIF DIRCHANGE(M_PathAppl+mPar+"\") // Перейти в папку Events cFileName = mPar+"Polar"+STRTRAN(STR(ADIR("*.*")+1,6)," ","0")+".jpg" X1 := X0 + 20 Y1 := Y0 + Offset - Interval X2 := X1 + 190 Y2 := Y0 + Offset - 1 * Interval **** Передача параметров расчета для графика DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения * ar := {} * AADD(ar, mNumMod) * AADD(ar, M_Interval) * AADD(ar, K_GradNClSc) * AADD(ar, K_GradNOpSc) * AADD(ar, mNObj) * DC_ASave(ar, "_23211chart.arx") IF mPar = 'Events' ar = DC_ARestore("_23211chart.arx") ENDIF IF mPar = 'EarthQuakes' ar = DC_ARestore("_23212chart.arx") ENDIF **** Надпись в легенде слева *********** oFont := XbpFont():new():create("12.Arial") GraSetFont( oPS ,oFont ) Y2 := Y0 + Offset - 1 * Interval;GraStringAt( oPS, { X1, Y2-0 }, L('Модель: "') +UPPER(ALLTRIM(Ar_Model[ar[1]]))+'". '+; L('Число интервалов в класс.и опис.шкалах:')+' '+ALLTRIM(STR(ar[3]))+', '+ALLTRIM(STR(ar[4]))+'. '+; L('Тип интервалов:') +' '+IF(ar[2]=1,L('"РАВНЫЕ"'),L('"АДАПТИВНЫЕ"'))+'. '+; L('Число наблюдений в обучающей выборке:') +' '+ALLTRIM(STR(ar[5])) +'. '+; L('Размер интервала сглаживания =') +' '+ALLTRIM(STR(mWindow)) +'. '+; L('Форма создана:')+' '+DTOC(DATE())+"-"+TIME()) IF mSummaFakt > 0 Y2 := Y0 + Offset - 2 * Interval;GraStringAt( oPS, { X1, Y2-5 }, L('Разрешение изображения: X=')+ALLTRIM(STR(mXSize))+', Y='+ALLTRIM(STR(mYSize))+' '+L('пикселей.')+' '+; L('Корр.прогн.полн-факт=')+ALLTRIM(STR(mKorVal,15,3))+'. '+L('Корр.прогн.сглаж-факт=')+ALLTRIM(STR(mKorAvr,15,3))+'. '+; L('Путь на файл изображения:')+' '+M_PathAppl+mPar+"\"+cFileName) ELSE Y2 := Y0 + Offset - 2 * Interval;GraStringAt( oPS, { X1, Y2-5 }, L('Разрешение изображения: X=')+ALLTRIM(STR(mXSize))+', Y='+ALLTRIM(STR(mYSize))+' '+L('пикселей.')+'. '+; L('Путь на файл изображения:')+' '+M_PathAppl+mPar+"\"+cFileName) ENDIF ****** Надписи координатных осей ********************************* oFont := XbpFont():new():create("13.ArialBold") GraSetFont( oPS ,oFont ) AxName = "Суммарная сила факторов, способствующих возникновению события (норм.знач.)" GraStringAt( oPS, { X0+W_Wind/2-8*LEN(AxName)/2, Y0-45 }, AxName ) // Надпись оси Х (СДЕЛАНА ВЫШЕ) AyName = "Суммарная сила факторов, способствующих возникновению события (норм.знач.)" aMatrix := GraInitMatrix() GraRotate( oPS, aMatrix, 90, { X0-53, Y0+H_Wind/2-8*LEN(AyName)/2 }, GRA_TRANSFORM_ADD ) oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) GraStringAt( oPS, { X0-53, Y0+H_Wind/2-8*LEN(AyName)/2 }, AyName ) // Надпись оси Y ****** Не получается отключить режим вращения изображения ****** Вместо отключения можно докрутить до 360 градусов * X_Max := 1800 * Y_Max := 850 // Размер графического окна для самого графика в пикселях aMatrix := GraInitMatrix() // <<<########## GraRotate( oPS, aMatrix, 0, {900, 425}, GRA_TRANSFORM_REPLACE ) // <<<########## oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) // <<<########## RETURN NIL **************************************************************************************************************************** ************************************************************************************************************************* ******** 2.3.2.12. Прогнозирование землетрясений методом Н.А.Чередниченко // (C) Универсальная когнитивная аналитическая система "ЭЙДОС-X++", beta-version, rel: 15:24 10.10.2021. // (C) д.э.н., к.т.н., профессор Луценко Евгений Вениаминович, Россия, Краснодар. *The Eidos-X++ system differs from other artificial intelligence systems in the following parameters: *- it was developed in a universal setting, independent of the subject area. Therefore, it is universal and can be applied in many subject areas (http://lc.kubagro.ru/aidos/index.htm); *- it is in full open free access (http://lc.kubagro.ru/aidos/_Aidos-X.htm) and has all the relevant source texts (http://lc.kubagro.ru/__AIDOS-X.txt); *- it is one of the first domestic systems of artificial intelligence of the personal level, i.e. it does not take special training in the field of technologies of artificial intelligence from the user (there is an act of introduction of system "Eidos" in 1987) (http://lc.kubagro.ru/aidos/aidos02/PR-4.htm); *- it provides stable identification in a comparable form of strength and direction of cause-effect relationships in incomplete noisy interdependent (nonlinear) data of very large dimension of numerical and non-numerical nature, measured in different types of scales (nominal, ordinal and numerical) and in different units of measurement (i.e. does not impose strict requirements to the data that cannot be performed, and processes the data that can); *- it contains a large number of local (supplied with the installation) and cloud educational and scientific applications (currently 31 and 347 (http://lc.kubagro.ru/Source_data_applications/WebAppls.htm), respectively) (http://lc.kubagro.ru/aidos/Presentation_Aidos-online.pdf); *- it supports on-line environment of knowledge accumulation and is widely used all over the world (http://lc.kubagro.ru/map5.php); *- it provides multilingual interface support in 51 languages. The language databases are included in the installation and can be replenished automatically; *- the most time-consuming, computationally, are the operations of the synthesis models and implements recognition using graphic processing unit (GPU) where some tasks can only support up to several thousand times; the solution of these tasks is intelligent processing of big data, big information and big knowledge; *- it provides transformation of the initial empirical data into information, and its knowledge and solution using this knowledge of classification problems, decision support and research of the subject area by studying its system-cognitive model, generating a very large number of tabular and graphical output forms (development of cognitive graphics), many of which have no analogues in other systems (examples of forms can be found in: http://lc.kubagro.ru/aidos/aidos18_LLS/aidos18_LLS.pdf); *- it well imitates the human style of thinking: gives the results of the analysis, understandable to experts according to their experience, intuition and professional competence. *- instead of making almost impossible demands on the source data (such as the normality of distribution, absolute accuracy and complete repetitions of all combinations of factor values and their complete independence and additivity), the automated system-cognitive analysis (ASC-analysis) offers to process this data without any preliminary processing and thereby transform it into information, and then transform this information into knowledge by applying it to achieve goals (i.e. for the management) and solving problems of classification, decision support, and meaningful empirical research of the domain being modeled. *What is the strength of the approach implemented in Eidos system? The strength is implementing an approach whose effectiveness does not depend on what we think about the subject area or whether we think at all. It generates models directly based on empirical data, rather than based on our understanding of the mechanisms for implementing patterns in this data. This is why Eidos models are effective, even if our understanding of the subject area is incorrect or totally absent. *And this as well is the weakness of this approach implemented in Eidos system. Models of the Eidos system are phenomenological models, i.e. they do not reflect the mechanisms of determination, but only the fact and nature of determination. *РЕФЕРАТ *Программа: Система когнитивного прогнозирования сейсмичности на основе астрономических данных "Aidos-Temblors" (System "Aidos-Temblors") *Аннотация: Программа предназначена для прогнозирования уровня сейсмичности на основе астрономических данных. *Программа может использоваться в государственных и негосударственных организациях всех правовых форм, заинтересованных в прогнозировании сейсмичности на Земле и в устранении последствий землетрясений (МЧС), а также гражданами. *Функциональные возможности программы: *- обеспечивает достоверное прогнозирование сейсмичности на планете и в регионах по методу Н.А.Чередниченко; *- формирует прогноз на любой заданный период с временным разрешением до суток, на основе когнитивного анализа ретроспективных данных по сейсмической активности за весь период научных наблюдений и выявления силы и направления причинно-следственных связей между космической средой и сейсмической активностью. *Программа позволяет осуществлять ежедневный мониторинг накопления сейсмической энергии в кластерах сейсмических очагов. *Язык: Alaska-2.0 (xBase++) *Объём программы: 22 МБ *Операционная система MS Windows XP, 7, 8, 10 и выше ************************************************************************************************************************* #include "inkey.ch" #include "dcdir.ch" #include "appevent.ch" #include "xbp.ch" #include "dll.ch" #include "dccursor.ch" #Include "thread.ch" #include "class.ch" #include "dmlb.ch" #include "fileio.ch" #include "dctree.ch" *#include "SystemMetrics.ch" *#include "axcdxcmx.ch" // Графика ActiveX #include "collat.ch" #include "common.ch" #include "dbedit.ch" #include "Dbfdbe.ch" #include "dcapp.ch" #include "dcbitmap.ch" #include "dccargo.ch" #include "dcdialog.ch" #include "dcdir.ch" #include "dcfiles.ch" #include "dcgra.ch" #include "dcgraph.ch" // графика #include "BdColors.Ch" // графика #include "dccolors.ch" // графика #include "dcprint.ch" // графика #include "Dcicon.ch" #include "dcmsg.ch" #include "dcpick.ch" #include "deldbe.ch" #include "directry.ch" #include "dmlb.ch" #include "express.ch" #include "fileio.ch" #include "font.ch" #include "gra.ch" #include "inkey.ch" #include "memvar.ch" #include "natmsg.ch" #include "prompt.ch" #include '_dcdbfil.ch' #include "set.ch" #include "std.ch" #include "xbp.ch" #include '_dcappe.ch' #include 'dcscope.ch' #include '_dcstru.ch' #include 'dcfields.ch' #include 'dccolor.ch' *#include "Fileio.ch" // Max_DB *#include "rmchart.ch" // Графика ActiveX #include "dcads.ch" #pragma Library( "ASINet10.lib" ) // 2.0 // Для альтернативного и неальтернативного выбора в просмотре таблиц *#define BMP_CHECKED "check1.bmp" *#define BMP_UNCHECKED "check2.bmp" *#define BMP_RACHECKED "radio1.bmp" *#define BMP_RAUNCHECKED "radio2.bmp" *#include "test.ch" #define BMP_CHECKED 10002 #define BMP_UNCHECKED 10003 #define BMP_RACHECKED 10004 #define BMP_RAUNCHECKED 10005 #pragma library( "ascom10.lib" ) #pragma library( "dclip1.lib" ) #pragma library( "dclip2.lib" ) #pragma library( "dclipx.lib" ) #pragma library( "xbtbase1.lib" ) #pragma library( "xbtbase2.lib" ) #pragma library( "xppui2.lib" ) #pragma library( "XPPRT0.LIB" ) #Pragma Library("Taskbar.lib") #xtranslate NTrim() => LTrim(Str()) #define USE_HTTPCLIENT // comment out to try Method2 //#include "Imgview.ch" /* * We use user defined events */ #define xbeDS_DirChanged xbeP_User + 100 #define xbeFS_FileMarked xbeP_User + 101 #define xbeFS_FileSelected xbeP_User + 102 #define DCAREAMSG_1 'Invalid Expression in Index Key:' /* * This directive calculates a centered position */ #xtrans CenterPos( , ) => ; { Int( (\[1] - \[1]) / 2 ) ; , Int( (\[2] - \[2]) / 2 ) } #define DC_RDDMSG_1 'Invalid RDD selection - '+cSuperRdd #define DC_RDDMSG_2 'DBE Name Description' #define DC_RDDMSG_3 'Select a Database Driver' *#define ADSDBE_MEMOFILE_EXT (DBE_USER+1) // RO *#define ADSDBE_INDEX_EXT (DBE_USER+2) // RW *#define ADSDBE_TBL_MODE (DBE_USER+3) // RW *#define ADSDBE_LOCK_MODE (DBE_USER+4) // RW *#define ADSDBE_RIGHTS_MODE (DBE_USER+5) // RW *#define ADSDBE_MEMOBLOCKSIZE (DBE_USER+6) // RW *#define ADSDBE_PASSWORD (DBE_USER+7) // RW // Return types of ADSDBE_TBL_MODE *#define ADSDBE_NTX 1 *#define ADSDBE_CDX 2 *#define ADSDBE_ADT 3 // Для опредедения разрешения монитора от Джимми #define DESKTOPVERTRES 117 #define DESKTOPHORZRES 118 // Excel Orientation #DEFINE xlLandscape 2 #DEFINE xlPortrait 1 #DEFINE xlWorkbookNormal -4143 #DEFINE xlCellTypeLastCell 11 #DEFINE SRCCOPY 0xCC0020 // Для быстрой графики Роджера #define KEYEVENTF_KEYUP 0x02 #define VK_MENU 0x12 #define VK_SNAPSHOT 0x2C #DEFINE VK_LBUTTON 0x01 #DEFINE VK_RBUTTON 0x02 * Для CSV=>DBF конвертера *#include "ot4xb.ch" // => ot4xb.dll => www.xbwin.com #ifndef CRLF #define CRLF chr(13)+chr(10) #endif * Klasse zum sequentiellen Einlesen groбer Dateien *#IF .t. // zum Einbinden in eigenes Projekt, .f. setzen ! STATIC snHdll *********************************************************************** *********************************************************************** FUNCTION F2_3_2_12() LOCAL GetList[0], GetOptions, nColor, oMessageBox, oMenuWords, oDlg, ; oMenuBar,oMenu1,oMenu2,oMenu3,oMenu4,oMenu5,oMenu6,oMenu7,; oMenu3_3, nKey := 0, oWebBrowser Running(.T.) DIRCHANGE(Disk_dir+"/AID_DATA/Inp_data/") cExcelFakt = '' IF File("Inp_fakt.xls") PUBLIC cExcelFakt := "Inp_fakt.xls" ELSE mMess = 'Отсутствует файл: "Inp_fakt.xls"' ENDIF IF File("Inp_fakt.xlsx") PUBLIC cExcelFakt := "Inp_fakt.xlsx" ELSE mMess = 'Отсутствует файл: "Inp_fakt.xlsx"' ENDIF * IF LEN(cExcelFakt) = 0 * DC_WinAlert( mMess ) * mFlag = .T. * ENDIF DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы PRIVATE a23212[8] IF FILE("_23212.arx") // Параметры диалога F2_3_2_12() a23212 = DC_ARestore("_23212.arx") PUBLIC mNumMod := a23212[1] PUBLIC mRegim := a23212[2] PUBLIC mWindow := a23212[3] PUBLIC mXSize := a23212[4] PUBLIC mYSize := a23212[5] PUBLIC mLineWidth := a23212[6] PUBLIC mGamma := a23212[7] PUBLIC mAlfa := a23212[8] ELSE PUBLIC mNumMod := 1 PUBLIC mRegim := 2 PUBLIC mWindow := 7 PUBLIC mXSize := 1800 PUBLIC mYSize := 900 PUBLIC mLineWidth := 7 PUBLIC mGamma := 1 PUBLIC mAlfa := 1 a23212[1] = mNumMod a23212[2] = mRegim a23212[3] = mWindow a23212[4] = mXSize a23212[5] = mYSize a23212[6] = mLineWidth a23212[7] = mGamma a23212[8] = mAlfa DC_ASave(a23212, "_23212.arx") ENDIF ******************************************************************************************* ****** 0. Задать текущую стат.модель или модель знаний ******************************************************************************************* ****** Задание текущей модели @ 0, 0 DCGROUP oGroup1 CAPTION L('Задайте текущую статистическую или системно-когнитивную модель') SIZE 90,13.5 @ 1, 1 DCSAY L('Статистические базы:' ) PARENT oGroup1 @ 2, 3 DCRADIO mNumMod VALUE 1 PROMPT L('1. ABS - частный критерий: количество встреч сочетаний: "класс-признак" у объектов обуч.выборки') PARENT oGroup1 @ 3, 3 DCRADIO mNumMod VALUE 2 PROMPT L('2. PRC1 - частный критерий: усл. вероятность i-го признака среди признаков объектов j-го класса ') PARENT oGroup1 @ 4, 3 DCRADIO mNumMod VALUE 3 PROMPT L('3. PRC2 - частный критерий: условная вероятность i-го признака у объектов j-го класса ') PARENT oGroup1 @ 5.2,1 DCSAY L('Системно-когнитивные модели (Базы знаний):' ) PARENT oGroup1 @ 6, 3 DCRADIO mNumMod VALUE 4 PROMPT L('4. INF1 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC1 ') PARENT oGroup1 @ 7, 3 DCRADIO mNumMod VALUE 5 PROMPT L('5. INF2 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC2 ') PARENT oGroup1 @ 8, 3 DCRADIO mNumMod VALUE 6 PROMPT L('6. INF3 - частный критерий: Xи-квадрат, разности между фактическими и ожидаемыми абс.частотами ') PARENT oGroup1 @ 9, 3 DCRADIO mNumMod VALUE 7 PROMPT L('7. INF4 - частный критерий: ROI (Return On Investment); вероятности из PRC1 ') PARENT oGroup1 @10, 3 DCRADIO mNumMod VALUE 8 PROMPT L('8. INF5 - частный критерий: ROI (Return On Investment); вероятности из PRC2 ') PARENT oGroup1 @11, 3 DCRADIO mNumMod VALUE 9 PROMPT L('9. INF6 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC1 ') PARENT oGroup1 @12, 3 DCRADIO mNumMod VALUE 10 PROMPT L('10.INF7 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC2 ') PARENT oGroup1 d1 = 45 @14, 0 DCGROUP oGroup2 CAPTION L('') SIZE 90.0, 2.7 @ 1, 3 DCRADIO mRegim VALUE 1 PROMPT L('1. Синтез и верификация модели ') PARENT oGroup2 @ 1,d1 DCRADIO mRegim VALUE 2 PROMPT L('2. Синтез модели и прогнозирование ') PARENT oGroup2 d2 = 25 @17, 0 DCGROUP oGroup3 CAPTION L('Задайте параметры линейного сглаживания кривой интенсивности прогнозируемых ЗМТ:') SIZE 90.0, 5.7 @ 1, 3 DCSAY L('Интервал сглаживания:') PARENT oGroup3; @ 1,d2 DCGET mWindow PICTURE "####" PARENT oGroup3 @ 2, 3 DCSAY L('Толщина линии:') PARENT oGroup3; @ 2,d2 DCGET mLineWidth PICTURE "####" PARENT oGroup3 @ 3, 3 DCRADIO mGamma VALUE 1 PROMPT L('1. Теплая гамма ') PARENT oGroup3 @ 4, 3 DCRADIO mGamma VALUE 2 PROMPT L('2. Холодная гамма ') PARENT oGroup3 @ 0.8,d1 DCPUSHBUTTON CAPTION L('Помощь') SIZE LEN(L('Перерисовать график с другими параметрами'))-3, 1.5 ACTION {||Help23212() , DC_GetRefresh(GetList)} PARENT oGroup3 @ 2.8,d1 DCPUSHBUTTON CAPTION L('Сравнить прогноз с фактом') SIZE LEN(L('Перерисовать график с другими параметрами'))-3, 1.5 ACTION {||CompForeFact() , DC_GetRefresh(GetList)} PARENT oGroup3 d3 = 23 IF LEN(cExcelFakt) > 0 @23, 0 DCGROUP oGroup4 CAPTION L('Задайте интервал сглаживания кривой фактических ЗМТ:') SIZE 90.0, 2.7 @ 1, 3 DCSAY L('Интервал сглаживания:') PARENT oGroup4;@ 1,d2 DCGET mAlfa PICTURE "####" PARENT oGroup4 d3 = 26 ENDIF @d3, 0 DCGROUP oGroup5 CAPTION L('Задайте размер изображения в пикселях (не более 4K):') SIZE 90.0, 3.5 @ 1, 3 DCSAY L("Размер по X:") PARENT oGroup5; @ 1,d2 DCGET mXSize PICTURE "####" PARENT oGroup5 @ 2, 3 DCSAY L("Размер по Y:") PARENT oGroup5; @ 2,d2 DCGET mYSize PICTURE "####" PARENT oGroup5 @ 1.2,d1 DCPUSHBUTTON CAPTION L('Перерисовать график с другими параметрами') SIZE LEN(L('Перерисовать график с другими параметрами'))-3, 1.5 ACTION {||Chart23212(.T.) , DC_GetRefresh(GetList)} PARENT oGroup5 d4 = d3 + 4 @d4 , 0 DCGROUP oGroup6 CAPTION L('Исправление расположения минимумов прогноза и рисование графиков прогнозов резонансных ЗМТ:') SIZE 90.0, 3.5 @ 1.2, 3 DCPUSHBUTTON CAPTION L('Исправить расположение минимумов') SIZE LEN(L('Перерисовать график с другими параметрами'))-3, 1.5 ACTION {||EditMinProgn() , DC_GetRefresh(GetList)} PARENT oGroup6 @ 1.2,d1 DCPUSHBUTTON CAPTION L('График ПРОГРАММА') SIZE LEN(L('График ПРОГРАММА'))+3, 1.5 ACTION {||Chart23212r('Prog'), DC_GetRefresh(GetList)} PARENT oGroup6 @ 1.2,d1+21 DCPUSHBUTTON CAPTION L('График ЭКСПЕРТ' ) SIZE LEN(L('График ЭКСПЕРТ' ))+3, 1.5 ACTION {||Chart23212r('Hand'), DC_GetRefresh(GetList)} PARENT oGroup6 DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; OPTIONS GetOptions ; ADDBUTTONS; MODAL ; TITLE L('2.3.2.12. Прогнозирование землетрясений методом Н.А.Чередниченко') ******************************************************************** IF lExit ** Button Ok ELSE ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ******************************************************************** Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } M_Inf = UPPER(Ar_Model[mNumMod]) mFlagErr = .F. IF 1 <= mNumMod .AND. mNumMod <= 10 ELSE LB_Warning(L("Необходимо задать одну из моделей для расчетов !!! ")) mFlagErr = .T. ENDIF IF mFlagErr ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF *************************************** DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы mWindow = IF(mWindow>0,mWindow, 7) // Окно может быть только больше нуля mWindow = IF(mWindow=2*INT(mWindow/2),mWindow++, mWindow) // Окно может быть только нечетным mXSize = IF(mXSize<1800,1800,mXSize ) mXSize = IF(mXSize>4096,4096,mXSize ) mYSize = IF(mYSize< 900, 900,mYSize ) mYSize = IF(mYSize>4096,4096,mYSize ) mLineWidth = IF(mLineWidth=2*INT(mLineWidth/2),mLineWidth++, mLineWidth) // Толщина сглаженной линии может быть только нечетным mLineWidth = IF(mLineWidth<5,5,mLineWidth) mLineWidth = IF(mLineWidth>9,9,mLineWidth) * mAlfa = IF(mAlfa>1,1,mAlfa ) * mAlfa = IF(mAlfa<0,0,mAlfa ) mAlfa = IF(mAlfa>0,mAlfa, 7) // Окно может быть только больше нуля (для сглаживания центрированным скользящим средним) mAlfa = IF(mAlfa=2*INT(mAlfa/2),mAlfa++, mAlfa) // Окно может быть только нечетным a23212[1] = mNumMod a23212[2] = mRegim a23212[3] = mWindow a23212[4] = mXSize a23212[5] = mYSize a23212[6] = mLineWidth a23212[7] = mGamma a23212[8] = mAlfa DC_ASave(a23212, "_23212.arx") ******************************************************************* *** Создание БД Inp_data.dbf из файлов: "Input1.xls" и "Input2.xls" ******************************************************************* CLoseAll() DIRCHANGE(Disk_dir+"/AID_DATA/Inp_data/") *IF mRegim = 1 // Синтез и верификация модели, т.е. вместо Inp_rasp.dbf использовать Inp_data.dbf, т.е. просто скопировать Inp_data.dbf ===> Inp_rasp.dbf * COPY FILE ('Inp_data.dbf') TO ('Inp_rasp.dbf') *ENDIF mFlag = .F. cExcelFile1 = '' IF File("Input1.xls") PUBLIC cExcelFile1 := "Input1.xls" ELSE mMess = 'Отсутствует файл: "Input1.xls"' ENDIF IF File("Input1.xlsx") PUBLIC cExcelFile1 := "Input1.xlsx" ELSE mMess = 'Отсутствует файл: "Input1.xlsx"' ENDIF IF LEN(cExcelFile1) = 0 DC_WinAlert( mMess ) mFlag = .T. ENDIF cExcelFile2 = '' IF File("Input2.xls") PUBLIC cExcelFile2 := "Input2.xls" ELSE mMess = 'Отсутствует файл: "Input2.xls"' ENDIF IF File("Input2.xlsx") PUBLIC cExcelFile2 := "Input2.xlsx" ELSE mMess = 'Отсутствует файл: "Input2.xlsx"' ENDIF IF LEN(cExcelFile2) = 0 DC_WinAlert( mMess ) mFlag = .T. ENDIF cExcelFakt = '' IF File("Inp_fakt.xls") PUBLIC cExcelFakt := "Inp_fakt.xls" ELSE mMess = 'Отсутствует файл: "Inp_fakt.xls"' ENDIF IF File("Inp_fakt.xlsx") PUBLIC cExcelFakt := "Inp_fakt.xlsx" ELSE mMess = 'Отсутствует файл: "Inp_fakt.xlsx"' ENDIF *IF LEN(cExcelFakt) = 0 * DC_WinAlert( mMess ) * mFlag = .T. *ENDIF // Синтез модели и прогнозирование, т.е. для синтеза использовать Inp_data, а для распознавания Inp_rasp (должен присутствовать, а при верифкации он создается просто копированием Inp_data) IF mRegim = 2 cExcelFile3 = '' IF File("Inp_rasp.xls") PUBLIC cExcelFile3 := "Inp_rasp.xls" ELSE mMess = 'Отсутствует файл: "Inp_rasp.xls"' ENDIF IF File("Inp_rasp.xlsx") PUBLIC cExcelFile3 := "Inp_rasp.xlsx" ELSE mMess = 'Отсутствует файл: "Inp_rasp.xlsx"' ENDIF IF LEN(cExcelFile3) = 0 DC_WinAlert( mMess ) mFlag = .T. ENDIF ENDIF IF mFlag ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW Running(.F.) RETURN nil ENDIF *PUBLIC mDbaseName1 := "Input1" *PUBLIC mDbaseName2 := "Input2" *PUBLIC mDbaseName3 := "Inp_temp" *PUBLIC cDbaseFile1 := "Input1.dbf" *PUBLIC cDbaseFile2 := "Input2.dbf" *PUBLIC cDbaseFile3 := "Inp_temp.dbf" // Конвертация XLS-файлов в DBF *DC_ASave(aStructure, "_Structure.arx") // Запись в LC_Excel2WorkArea() массива структуры создаваемого файла *DC_ASave(aFieldName, "_FieldName.arx") // Запись в LC_Excel2WorkArea() массива имен полей создаваемого файла LC_Excel2WorkArea( cExcelFile1 ) aStructure1 = DC_ARestore('_Structure.arx') aFields1 = DC_ARestore('_FieldName.arx') FOR j=1 TO LEN(aStructure1) aStructure1[j,1] = aFields1[j] NEXT LC_Excel2WorkArea( cExcelFile2 ) *** Максимально увеличить размер полей в aStructure2 <===############## aStructure2 = DC_ARestore('_Structure.arx') aFields2 = DC_ARestore('_FieldName.arx') FOR j=2 TO LEN(aStructure2) aStructure2[j,1] = aFields2[j] NEXT *LB_Warning(aStructure2) IF LEN(cExcelFakt) > 0 LC_Excel2WorkArea( cExcelFakt ) ENDIF **** Формирование текстовых файлов с именами полей для ввода Inp_data.dbf в систему в режиме 2.3.2.2. **** Наименования колонок с 1-й по последнюю aInp_name := aFields1 // Массив имен всех полей Inp_data.dbf FOR j=2 TO LEN(aFields2) // Без поля "Дата" AADD(aInp_name, aFields2[j] ) NEXT CrLf = CHR(13)+CHR(10) // Конец строки (абзаца) (CrLf) mCol_name = "" FOR j=1 TO LEN(aInp_name) // 1-ю колонку включаем в Inp_nameAll.txt, для других целей mNameJ = ALLTRIM(aInp_name[j]) mNameJ = UPPER(SUBSTR(mNameJ,1,1)) + SUBSTR(mNameJ,2) // Сделать первые символы заголовков колонок большими, а остальные оставить как есть mCol_name = mCol_name + mNameJ + CrLf NEXT StrFile(mCol_name, 'Inp_nameAll.txt') // Добавить путь на папку Inp_data **** Наименования колонок со 2-й по последнюю mCol_name = "" FOR j=2 TO LEN(aInp_name) // 1-ю колонку не включаем в Inp_name.txt, т.к. это инф.об источнике данных, а не шкала mNameJ = ALLTRIM(aInp_name[j]) mNameJ = UPPER(SUBSTR(mNameJ,1,1)) + SUBSTR(mNameJ,2) // Сделать первые символы заголовков колонок большими, а остальные оставить как есть mCol_name = mCol_name + mNameJ + CrLf NEXT StrFile(mCol_name, 'Inp_name.txt') // Создание объединенной базы данных с именами полей из исходных баз данных, но пропустив 1-е поле (Дата) во 2-м файле aStructure3 := aStructure1 FOR j=2 TO 11 // 11 = 10 астропараметров + 1 дата * AADD(aStructure3, { aStructure2[j,1], aStructure2[j,2], aStructure2[j,3], aStructure2[j,4] } ) // <===################ * имя поля тип данных поля размер поля число знаков после запятой AADD(aStructure3, { aStructure2[j,1], 'N', 19, 7 } ) // <===################ NEXT DbCreate('Inp_temp', aStructure3 ) // Создание объединенной БД DbCreate('Inp_data', aStructure3 ) // Создание объединенной БД DbCreate('Inp_rasp', aStructure3 ) // Создание объединенной БД для 1-го листа Bala и просто для распознавания стандартными средствами Эйдос *********** БД Bala ****** aStructure4 := aStructure2 FOR j=2 TO 11 // 11 = 10 астропараметров + 1 дата * AADD(aStructure4, { '_'+aStructure2[j,1], aStructure2[j,2], aStructure2[j,3], aStructure2[j,4] } ) // <===################ Имена полей не могут повторяться, поэтому '_' * имя поля размер поля тип данных поля число знаков после запятой AADD(aStructure4, { '_'+aStructure2[j,1], 'N', 19, 7 } ) // <===################ Имена полей не могут повторяться, поэтому '_' NEXT j=11 AADD(aStructure4, { 'Progn_Poln', 'N', 19, 7 } ) // Прогноз полный AADD(aStructure4, { 'Progn_Avr' , 'N', 19, 7 } ) // Прогноз полный сглаженный AADD(aStructure4, { 'ZMT_fakt' , 'N', 19, 7 } ) // Интенсивность фактически произошедших ЗМТ (если ЗМТ не было - 0) из файла Inp_fakt.xls AADD(aStructure4, { 'ZMTAvrFakt', 'N', 19, 7 } ) // Интенсивность фактически произошедших ЗМТ (если ЗМТ не было - 0), сглаженная AADD(aStructure4, { 'PrognNNorm', 'N', 19, 7 } ) // Прогноз полный, ненормированный DbCreate('Bala', aStructure4 ) // Создание результирующей БД Bala.dbf AADD(aStructure4, { 'Progn_N' , 'N', 19, 7 } ) AADD(aStructure4, { 'Progn_NI' , 'N', 19, 7 } ) AADD(aStructure4, { 'SumInt_ZMT', 'N', 19, 7 } ) AADD(aStructure4, { 'INT_ZMT_NI', 'N', 19, 7 } ) AADD(aStructure4, { 'ProgAvrMin', 'C', 3, 0 } ) AADD(aStructure4, { 'PRAVKA_MIN', 'C', 3, 0 } ) // Дополнительные поля для ручного исправления расположения минимумов прогноза и перерасчета резонансов AADD(aStructure4, { 'PR_PROGNNI', 'N', 19, 7 } ) AADD(aStructure4, { 'P_INTZMTNI', 'N', 19, 7 } ) DbCreate('PrognReson', aStructure4 ) // Создание результирующей БД PrognReson.dbf для прогнозирования резонансов CLoseAll() USE Input1 EXCLUSIVE NEW INDEX ON FIELDGET(1) TO Input1 CLoseAll() USE Input2 EXCLUSIVE NEW INDEX ON FIELDGET(1) TO Input2 IF FILE( cExcelFakt ) CLoseAll() USE Inp_fakt EXCLUSIVE NEW INDEX ON FIELDGET(1) TO Inp_fakt ENDIF CLoseAll() USE Input1 INDEX Input1 EXCLUSIVE NEW;N_Col1 = FCOUNT();N_Rec1=RECCOUNT() USE Input2 INDEX Input2 EXCLUSIVE NEW;N_Col2 = FCOUNT();N_Rec2=RECCOUNT() USE Inp_temp EXCLUSIVE NEW;N_Col3 = FCOUNT() ***** Отображение стадии исполнения в кратком варианте ***************************************** nMax = 4*N_Rec1 nTime = 0 @ 4,5 DCPROGRESS oProgressm SIZE 90,1.1 MAXCOUNT nMax COLOR GRA_CLR_BLUE PERCENT EVERY 100 mMess = 'Объединение файлов: "'+cExcelFile1+'" и "'+cExcelFile2+'" по 1-му полю в БД: "Inp_data.dbf"' DCREAD GUI TITLE mMess PARENT @oDialogm FIT EXIT oDialogm:show() DC_GetProgress(oProgressm,0,nMax) ************************************************************************************************ SELECT Input1 DBGOTOP() DO WHILE .NOT. EOF() FIELDPUT(7, 3+1.5*FIELDGET(6)-3.5*LOG(FIELDGET(5))/LOG(10)) // Расчет интенсивности ЗМТ DC_GetProgress(oProgressm, ++nTime, nMax) DBSKIP(1) ENDDO SELECT Input1 DBGOTOP() DO WHILE .NOT. EOF() ar := {} FOR j=1 TO N_Col1 AADD(ar, FIELDGET(j)) NEXT SELECT Input2;SET ORDER TO 1;T=DBSEEK(ar[1]) // Если запись с таким ключом найдена во 2-й БД, IF T // добавить ее и записать в 3-ю объединенную БД FOR j=2 TO N_Col2 AADD(ar, FIELDGET(j)) NEXT SELECT Inp_temp APPEND BLANK FOR j=1 TO N_Col3 FIELDPUT(j, ar[j]) NEXT ENDIF DC_GetProgress(oProgressm, ++nTime, nMax) SELECT Input1 DBSKIP(1) ENDDO ***** Сортировка Inp_temp => Inp_data ********* CLoseAll() USE Inp_temp EXCLUSIVE NEW INDEX ON SUBSTR(FIELDGET(1),7,4)+SUBSTR(FIELDGET(1),4,2)+SUBSTR(FIELDGET(1),1,2) TO Inp_temp // ГГГГММДД CLoseAll() USE Inp_temp INDEX Inp_temp EXCLUSIVE NEW USE Inp_data EXCLUSIVE NEW SELECT Inp_temp SET ORDER TO 1 DBGOTOP() DO WHILE .NOT. EOF() ar := {} FOR j=1 TO N_Col3 AADD(ar, FIELDGET(j)) NEXT SELECT Inp_data APPEND BLANK FOR j=1 TO LEN(ar) FIELDPUT(j, ar[j]) NEXT DC_GetProgress(oProgressm, ++nTime, nMax) SELECT Inp_temp DBSKIP(1) ENDDO mSummaINT100 = 0 // Для последующих расчетов SELECT Inp_data DBGOTOP() DO WHILE .NOT. EOF() mSummaINT100 = mSummaINT100 + INT_ZMT DC_GetProgress(oProgressm, ++nTime, nMax) DBSKIP(1) ENDDO StrFile(ALLTRIM(STR(RECCOUNT())), 'N_Obj.txt') DC_GetProgress(oProgressm,nMax,nMax) oDialogm:Destroy() CLoseAll() ERASE("Inp_temp.dbf") COPY FILE ('Inp_data.dbf') TO ('Inp_data.xls') COPY FILE ('Inp_data.dbf') TO ('Inp_data.xlsx') *aMess := {} *AADD(aMess, 'Файлы: "'+cExcelFile1+'" и "'+cExcelFile2+'" объединены по полю "Дата"') *AADD(aMess, 'в БД: "Inp_data.dbf". Этот файл открывается в MS Excel.') *LB_Warning(aMess, 'Система "Эйдос"' ) **************************************************** *** Формализация предметной области и синтез моделей **************************************************** DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы Эйдос * IF FILE("_2_3_2_2.arx") * aSoftInt = DC_ARestore("_2_3_2_2.arx") // Если параметры были заданы ранее, то использовать их * Regim = aSoftInt[ 1] * Flag_zer = aSoftInt[ 2] * M_ClSc1 = aSoftInt[ 3] * M_ClSc2 = aSoftInt[ 4] * M_OpSc1 = aSoftInt[ 5] * M_OpSc2 = aSoftInt[ 6] * N_SKGrCl = aSoftInt[ 7] * N_SKGrPr = aSoftInt[ 8] * K_N_ClSc = aSoftInt[ 9] * K_N_OpSc = aSoftInt[10] * K_N_GrClSc = aSoftInt[11] * K_N_GrOpSc = aSoftInt[12] * M_ObAnk = aSoftInt[13] * N_Chast = aSoftInt[14] * M_Interval = aSoftInt[15] * M_Scenario = aSoftInt[16] * K_GradNClSc = aSoftInt[17] // Количество градаций в числовой классификационной шкале * K_GradNOpSc = aSoftInt[18] // Количество градаций в числовой описательной шкале * mGorizMin = aSoftInt[19] * mGorizMax = aSoftInt[20] * mGlubMin = aSoftInt[21] * mGlubMax = aSoftInt[22] * M_ChastObi = aSoftInt[23] * M_ChastRso = aSoftInt[24] * N_ChastObi = aSoftInt[25] * N_ChastRso = aSoftInt[26] * M_XlsDbf = aSoftInt[27] * mTxtCSField = aSoftInt[28] // Способ интерпретации значений текстовых полей - классификационных шкал файла исходных данных * mTxtOSField = aSoftInt[29] // Способ интерпретации значений текстовых полей - описательных шкал файла исходных данных * mTxtCSSep = aSoftInt[30] * mTxtOSSep = aSoftInt[31] ** mScenario = aSoftInt[32] // mScenario=1 Не применять сценарный метод АСК-анализа и спец.интерпретацию TXT-полей (старый вариант) * mScenario = aSoftInt[32] // mScenario=1 Не применять сценарный метод АСК-анализа * mSpecInterprCls = aSoftInt[33] // .T. - Применить спец.интерпретацию текстовых полей классов, .F. - не применять * mSpecInterprAtr = aSoftInt[34] // .T. - Применить спец.интерпретацию текстовых полей признаков, .F. - не применять * mNameGrNumSc= aSoftInt[35] // Какие наименования ГРАДАЦИЙ числовых шкал использовать * mClsAvr = aSoftInt[36] // .F. - делать модель из Inp_data, .T. - делать модель из Inp_data_avr * mSortUnqCls = aSoftInt[37] // Выделять уникальные значения классов и сортировать, 1-да, 2-нет * mLemmatCls = IF(mSpecInterprCls,aSoftInt[38],2) // Проводить лемматизацию классов, 1-да, 2-нет * mSortUnqGos = aSoftInt[39] // Выделять уникальные значения признаков и сортировать, 1-да, 2-нет * mLemmatGos = IF(mSpecInterprAtr,aSoftInt[40],2) // Проводить лемматизацию классов, 1-да, 2-нет * ELSE Regim = 1 // Формализации ПО или ген.расп.выб. Flag_zer = 2 // Считать нули и пробелы отсутствием данных? [1]-да, [2]-нет N_Chast = 1 // На сколько частей N разбивать обучающую или распознаваемую выборку (в зависимости от Regim) M_ClSc1 = 7 // Номер начального столбца диапазона классификационных шкал M_ClSc2 = 7 // Номер конечного столбца диапазона классификационных шкал M_OpSc1 = 8 // Номер начального столбца диапазона описательных шкал M_OpSc2 = 17 // Номер конечного столбца диапазона описательных шкал M_ObAnk = 3 // Создавать анкеты исходной выборки по строкам Inp_data-[1], по классам-[2], и 1-е, и 2-е [3] M_Interval = 1 // 1-равные интервалы, 2-адаптивные интервалы (с примерно равным количеством наблюдений, по Котельникову) N_SKGrCl = 5 N_SKGrPr = 5 K_N_ClSc = 1 K_N_OpSc = 1 K_N_GrClSc = 12 // Количество градаций в числовой классификационной шкале K_N_GrOpSc = 72 // Количество градаций в числовой описательной шкале M_Scenario = .F. mGorizMin = 5 mGorizMax = 5 mGlubMin = 5 mGlubMax = 5 K_GradNClSc = 12 K_GradNOpSc = 72 M_ChastObi = .F. M_ChastRso = .F. N_ChastObi = 1 N_ChastRso = 1 M_XlsDbf = 3 mTxtCSField = 1 // Способ интерпретации значений текстовых полей - классификационных шкал файла исходных данных mTxtOSField = 1 // Способ интерпретации значений текстовых полей - описательных шкал файла исходных данных mTxtCSSep = " " // Разделитель элементов классификационных шкал, если mTxtCSField=3 mTxtOSSep = " " // Разделитель элементов описательных шкал, если mTxtOSField=3 * mScenario = 1 // mScenario=1 Не применять сценарный метод АСК-анализа и спец.интерпретацию TXT-полей (старый вариант) mScenario = 1 // Не применять сценарный метод АСК-анализа mSpecInterprCls = .F. // .T. - Применить спец.интерпретацию текстовых полей классов, .F. - не применять mSpecInterprAtr = .F. // .T. - Применить спец.интерпретацию текстовых полей признаков, .F. - не применять mNameGrNumSc= 1 // Какие наименования ГРАДАЦИЙ числовых шкал использовать mClsAvr = .F. // .F. - делать модель из Inp_data, .T. - делать модель из Inp_data_avr mSortUnqCls = 1 // Выделять уникальные значения классов и сортировать, 1-да, 2-нет mLemmatCls = 2 // Проводить лемматизацию классов, 1-да, 2-нет mSortUnqGos = 1 // Выделять уникальные значения признаков и сортировать, 1-да, 2-нет mLemmatGos = 2 // Проводить лемматизацию признаков, 1-да, 2-нет // Сохранить файл с информацией о заданых параметрах программного интерфейса в текущей директории системы PRIVATE aSoftInt[40] aSoftInt[ 1] = Regim aSoftInt[ 2] = Flag_zer aSoftInt[ 3] = M_ClSc1 aSoftInt[ 4] = M_ClSc2 aSoftInt[ 5] = M_OpSc1 aSoftInt[ 6] = M_OpSc2 aSoftInt[ 7] = N_SKGrCl aSoftInt[ 8] = N_SKGrPr aSoftInt[ 9] = K_N_ClSc aSoftInt[10] = K_N_OpSc aSoftInt[11] = K_N_GrClSc aSoftInt[12] = K_N_GrOpSc aSoftInt[13] = M_ObAnk aSoftInt[14] = N_Chast aSoftInt[15] = M_Interval aSoftInt[16] = M_Scenario aSoftInt[17] = K_GradNClSc // Количество градаций в числовой классификационной шкале aSoftInt[18] = K_GradNOpSc // Количество градаций в числовой описательной шкале aSoftInt[19] = mGorizMin aSoftInt[20] = mGorizMax aSoftInt[21] = mGlubMin aSoftInt[22] = mGlubMax aSoftInt[23] = M_ChastObi aSoftInt[24] = M_ChastRso aSoftInt[25] = N_ChastObi aSoftInt[26] = N_ChastRso aSoftInt[27] = M_XlsDbf aSoftInt[28] = mTxtCSField aSoftInt[29] = mTxtOSField aSoftInt[30] = mTxtCSSep aSoftInt[31] = mTxtOSSep * aSoftInt[32] = mScenario // mScenario=1 Не применять сценарный метод АСК-анализа и спец.интерпретацию TXT-полей (старый вариант) aSoftInt[32] = mScenario // mScenario=1 Не применять сценарный метод АСК-анализа aSoftInt[33] = mSpecInterprCls // Применить спец.интерпретацию текстовых полей классов aSoftInt[34] = mSpecInterprAtr // Применить спец.интерпретацию текстовых полей признаков aSoftInt[35] = mNameGrNumSc // Какие наименования ГРАДАЦИЙ числовых шкал использовать aSoftInt[36] = mClsAvr // .F. = модель без усреднения по классам aSoftInt[37] = mSortUnqCls // Выделять уникальные значения классов и сортировать, 1-да, 2-нет aSoftInt[38] = IF(mSpecInterprCls,mLemmatCls,2) // Проводить лемматизацию классов, 1-да, 2-нет aSoftInt[39] = mSortUnqGos // Выделять уникальные значения признаков и сортировать, 1-да, 2-нет aSoftInt[40] = IF(mSpecInterprAtr,mLemmatGos,2) // Проводить лемматизацию признаков, 1-да, 2-нет DC_ASave(aSoftInt , "_2_3_2_2.arx") * ENDIF *** Создать новое пустое приложение с заданным имененем ****************************************** * mApplName = L('Прогнозирование ЗМТ в модели: "')+ALLTRIM(Ar_Model[mNumMod])+'", '+; * IF(M_Interval=1,L('равн.'),L('адапт.'))+L('интервалы,')+' '+; // Эти параметры не могут в наименовании приложения, т.к. они задаются позже формирования имени приложения * ALLTRIM(STR(K_GradNClSc))+' '+L('град.в кл.шкалах,')+' '+; // Или надо менять имя приложения прямо в базе приложения после задания этих параметров * ALLTRIM(STR(K_GradNOpSc))+' '+L('град.в оп.шкалах') mApplName = L('Прогнозирование ЗМТ в модели: "')+ALLTRIM(Ar_Model[mNumMod])+'"' M_NewAppl = ADD_ZAPPL(mApplName) *** Передача параметров расчета для графика DIRCHANGE(M_NewAppl) // Перейти в папку с БД новой модели и создать БД формализации предметной области: GenDbfClSc(.F.) // Классификационные шкалы GenDbfGrClSc(.F.) // Градации классификационных шкал GenDbfClass(.F.) // Классификационные шкалы и градации GenDbfOpSc(.F.) // Описательные шкалы GenDbfGrOpSc(.F.) // Градации описательных шкал GenDbfAttr(.F.) // Описательные шкалы и градации GenDbfObiZag() // Заголовки объектов обучающей выборки GenDbfObiKcl() // Коды классов объектов обучающей выборки GenDbfObiKpr() // Коды признаков объектов обучающей выборки GenDbfRsoZag() // Заголовки объектов распознаваемой выборки GenDbfRsoKcl() // Коды классов объектов распознаваемой выборки GenDbfRsoKpr() // Коды признаков объектов распознаваемой выборки F2_3_2_2(mApplName,"") // Запуск универсального программного интерфейса с внешними базами данных DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы Эйдос DC_ASave(aSoftInt , "_2_3_2_2.arx") // Сохранить возможно измененные параметры Running(.F.) *** Передача заданных параметров расчета для графика DIRCHANGE(Disk_dir+"/AID_DATA/Inp_data/") * StrFile(ALLTRIM(STR(RECCOUNT())), 'N_Obj.txt') N_Obj = VAL(FileStr('N_Obj.txt')) DIRCHANGE(M_NewAppl) // Перейти в папку с БД новой модели и создать БД формализации предметной области: ar := {} AADD(ar, mNumMod) AADD(ar, M_Interval) AADD(ar, K_GradNClSc) AADD(ar, K_GradNOpSc) AADD(ar, N_Obj) DC_ASave(ar, "_23212chart.arx") * ar = DC_ARestore("_23212chart.arx") ********* Поменять имя приложения прямо в базе приложения после задания этих параметров ********** mApplName = L('Прогнозирование ЗМТ в модели: "')+ALLTRIM(Ar_Model[mNumMod])+'", '+; IF(M_Interval=1,L('равн.'),L('адапт.'))+L('интервалы,')+' '+; // Эти параметры не могут в наименовании приложения, т.к. они задаются позже формирования имени приложения ALLTRIM(STR(K_GradNClSc))+' '+L('град.в кл.шкалах,')+' '+; // Или надо менять имя приложения прямо в базе приложения после задания этих параметров ALLTRIM(STR(K_GradNOpSc))+' '+L('град.в оп.шкалах') DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы Эйдос CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Appls EXCLUSIVE NEW SELECT Appls DBGOTOP() DO WHILE .NOT. EOF() IF LEN(ALLTRIM(BY_DEFAULT)) > 0 REPLACE NAME_APPL WITH mApplName EXIT ENDIF DBSKIP(1) ENDDO DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций ****** Формирование и запись txt-файла параметров модуля синтеза моделей ************************* cFile = "Model_sint_settings.txt" // <===######################################################## aPar := {} AADD(aPar,'Show_progress *') AADD(aPar,'Show_statistics_(milliseconds) 3000') AADD(aPar,'_') DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы Эйдос ERASE(cFile) CrLf = CHR(13)+CHR(10) // Конец строки (записи) mPar = '';FOR j=1 TO LEN(aPar);mPar=mPar+aPar[j]+CrLf;NEXT StrFile(mPar,cFile) LC_RunShell("Model_sint.exe", 89882657) // Модуль синтеза моделей *########################################################################################## *** ИСПРАВИТЬ МОДЕЛЬ PRC2, посчитанную на GPU: КАК В F3_2CPU (НА СТР.14011) *** <<<===##### *########################################################################################## * oScr := DC_WaitOn(L('Дорасчет модели PRC2. Немного подождите'),,,,,,,,,,,.F.) DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Attributes EXCLUSIVE NEW USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() // №1, N_Cls ################################ USE Gr_OpSc EXCLUSIVE NEW;N_Gos = RECCOUNT() // №2, N_Gos ################################ USE Opis_Sc EXCLUSIVE NEW * ###########################################################################* mLenNameMax = CreateStructAll() // Создание файлов структур баз данных всех моделей // Открытие текстовых баз данных ******************************************** *DC_ASave(aInfStruct, "_PrcStruct.arx") // Когда БД создается - записывать структуру, когда открывается - считывать aInfStruct = DC_ARestore("_PrcStruct.arx") ************************************************* ***** Формирование пустой записи N_Col = N_Cls+6 // Число полей CrLf = CHR(13)+CHR(10) // Конец строки (записи) Lc_buf = "" FOR j=1 TO N_Col * S = IF(j=2*INT(j/2),"#","X") // Для отладки S = " " // Для работы Lc_buf = Lc_buf + REPLICATE(S, aInfStruct[j,3]) NEXT Lc_buf = Lc_buf + CrLf Len_LcBuf = LEN(Lc_buf) ****** Создаем стат.базы и базы знаний (7 по частным критериям знаний) Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } PRIVATE nHandle[LEN(Ar_Model)] FOR z=1 TO 3 nHandle[z] := FOpen( Ar_Model[z]+".txt", FO_READWRITE ) // Открыть все текстовые базы данных ######################################## NEXT **** Рассчет массива начальных позиций полей в строке PRIVATE aPos[N_Col] aPos[1] = 1 FOR j=2 TO N_Col aPos[j] = aPos[j-1] + aInfStruct[j-1,3] NEXT * ########################################################################### * N = VAL(LC_FieldGet( Ar_Model[1]+".txt", nHandle[1], N_Gos+1, N_Cls+3 )) // Сумма числа признаков из Abs.txt NObj = VAL(LC_FieldGet( Ar_Model[1]+".txt", nHandle[1], N_Gos+4, N_Cls+3 )) // Сумма числа объектов из Abs.txt *** Prc2.txt ****************************** *** Запись столбца "Безусловная вероятность" IF NObj > 0 *** Запись столбца "Безусловная вероятность" FOR i=1 TO N_Gos // №9, N_Gos ################################ Ni = VAL(LC_FieldGet( Ar_Model[1]+".txt", nHandle[1], i, N_Cls+3 )) // Сумма Ni из Abs.txt IF Ni <> 0 String = STR(Ni/NObj*100, aInfStruct[N_Cls+3,3], aInfStruct[N_Cls+3,4] ) LC_FieldPut( Ar_Model[3]+".txt", nHandle[3], i, N_Cls+3, String ) ENDIF NEXT ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций FOR z=1 TO 3 FClose( nHandle[z] ) // Закрытие dbf и txt баз данных ###################################### NEXT * DC_Impl(oScr) *########################################################################################## ************************************************************************************************** F5_5(.F.) // Преобразовать в txt = > dbf Running(.F.) oScr := DC_WaitOn(L('Расчет баз данных: "ABS_Syla_Planet", "Grint"'),,,,,,,,,,,.F.) *** Расчет Силы Планет в файле: ABS_Syla_Planet ************************************************* *** В этом файле - 720 строк - (по числу градаций описательных шкал) и 29 столбцов. *** Первые 15 столбцов - копирую и переношу данные из полученного в режиме 3.1 файла ABS. *** В столбцах 16-27 - автоматически идет расчет силы планет по количеству и Интенсивности ЗМТ в каждой из 12 Градаций классификационных шкал. *** Столбец 28 (Summa_INT) - суммируются результаты столбцов 16-27. *** Столбец 29 (Syla_Planet)- Получаем искомый суммарный результат. Расчет в этом столбце - по формуле: *** =AB2*O2*1000/718,18, где 718,18 - это суммарная интенсивность ЗМТ из файла , это - сумма по столбцу 7 - (Int_ZMT) DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } M_Inf = UPPER(Ar_Model[mNumMod]) * MsgBox(STR(mNumMod)+' '+M_Inf) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Attributes EXCLUSIVE NEW;N_Atr = RECCOUNT() USE (M_Inf) EXCLUSIVE NEW *** Создать БД: ABS_Syla_Planet ************* mFN = -999 SELECT Attributes DBGOTOP() DO WHILE .NOT. EOF() mFN = MAX(mFN, LEN(ALLTRIM(Name_atr))) DBSKIP(1) ENDDO aStructure := { { "Kod_pr", "N", 15, 0 },; { "Name" , "C", mFN, 0 } } FOR j=1 TO N_Cls FieldName = "CLS"+ALLTRIM(STR(j,15)) AADD(aStructure, { FieldName, "N", 19, 1 }) NEXT AADD(aStructure, { "SUMMA", "N" , 19, 1 } ) FOR j=1 TO N_Cls FieldName = "SumINT_"+ALLTRIM(STR(j,15)) AADD(aStructure, { FieldName, "N", 19, 7 }) NEXT AADD(aStructure, { "Summa_INT" , "N", 19, 7 } ) AADD(aStructure, { "SylaPlanet", "N", 19, 7 } ) DbCreate( 'ABS_Syla_Planet', aStructure ) *** Перенос информации из Abs в БД: ABS_Syla_Planet ************* CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Attributes EXCLUSIVE NEW;N_Atr = RECCOUNT() USE (M_Inf) EXCLUSIVE NEW USE ABS_Syla_Planet EXCLUSIVE NEW SELECT (M_Inf) FOR r=1 TO N_Atr DBGOTO(r) ar := {} FOR j=1 TO FCOUNT()-2 AADD(ar, FIELDGET(j)) NEXT SELECT ABS_Syla_Planet APPEND BLANK FOR j=1 TO LEN(ar) FIELDPUT(j, ar[j]) NEXT SELECT (M_Inf) NEXT *** Расчет в БД: ABS_Syla_Planet ******************************** SELECT ABS_Syla_Planet DBGOTOP() DO WHILE .NOT. EOF() mSumma_INT = 0 FOR j=1 TO N_Cls mNij = FIELDGET(2+j) FIELDPUT(3+N_Cls+j, mNij*j) mSumma_INT = mSumma_INT + mNij*j NEXT REPLACE Summa_INT WITH mSumma_INT DBSKIP(1) ENDDO SELECT ABS_Syla_Planet DBGOTOP() DO WHILE .NOT. EOF() REPLACE SylaPlanet WITH Summa_INT * Summa * 1000 / mSummaINT100 DBSKIP(1) ENDDO *** Делаем файл: Bala.dbf *************************************** *** 1-й лист файла Bala. С файлом A_base ничего делать не надо. Но мы его переименовали в Inp_rasp и сделали по структуре таким же, как Inp_data.dbf *** Это сделано для того, чтобы можно было: 1) использовать для создания модели стандартные средства системы Эйдос, 2) использовать Inp_data вместо Inp_rasp при верификации модели *** На 2-м листе - Grint - переносим скопированные из файла Attributes , полученному после расчетов в режиме 3.1 - 3 столбца: *** NAME_ATR, MIN_GRINT, MAX_GRINT. А в 4-й столбец - Syla_Planet - копируем полученные нами данные из последнего столбца Файла . *** При этом переношу я эти данные, так как в последнем столбце есть формула, через промежуточный файл Excel, иначе будет появляться ошибка (ссылка). aStructure := { { "Kod_atr" , "N", 15, 0 },; { "Name_atr" , "C", mFN, 0 },; { "Min_grint" , "N", 19, 7 },; { "Max_grint" , "N", 19, 7 },; { "SylaPlanet", "N", 19, 7 } } DbCreate( 'Grint', aStructure ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Attributes EXCLUSIVE NEW;N_Atr = RECCOUNT() USE (M_Inf) EXCLUSIVE NEW USE ABS_Syla_Planet EXCLUSIVE NEW USE Grint EXCLUSIVE NEW SELECT Attributes DBGOTOP() DO WHILE .NOT. EOF() mRecno = RECNO() mKodAtr = Kod_atr mNameAtr = Name_atr mMinGrInt = Min_grint mMaxGrInt = Max_grint SELECT ABS_Syla_Planet DBGOTO(mRecno) mSylaPlanet = SylaPlanet SELECT Grint APPEND BLANK REPLACE Kod_atr WITH mKodAtr REPLACE Name_atr WITH mNameAtr REPLACE Min_grint WITH mMinGrInt REPLACE Max_grint WITH mMaxGrInt REPLACE SylaPlanet WITH mSylaPlanet SELECT Attributes DBSKIP(1) ENDDO DC_Impl(oScr) *** На третьем листе файла , который называется так же, строк - столько же, как и на первом листе: Inp_rasp.xls (A_Base), по числу дней года, и первые 11 столбцов *** - тоже с первого листа. Я не знаю, может быть, их можно удалить, эти столбцы, но вот я сделала так, и уже не решаюсь что-то менять. *** В следующих столбцах 12-21 - По формуле: =ВПР(B2;Grint!$B$2:$D$73;3;1) будет идти расчет на каждый прогнозный день, в зависимости от того, в какой интервал из 72 градаций *** описательных шкал попадает тот или иной астропараметр из будущего. Таким образом, на 3 листе Bala в столбцах 12-21 (они выделены голубым цветом) мы получаем прогноз (силу планет) *** на каждый прогнозный день 2019 гг. DIRCHANGE(Disk_dir+"/AID_DATA/Inp_data/") IF mRegim = 1 // Синтез и верификация модели, т.е. вместо Inp_rasp.dbf использовать Inp_data.dbf, т.е. просто скопировать Inp_data.dbf ===> Inp_rasp.dbf COPY FILE ('Inp_data.dbf') TO ('Inp_rasp.dbf') ENDIF IF mRegim = 2 // Это нужно делать только если задано прогнозирование, а не верификация. Дальше все одинаково LC_Excel2WorkArea( cExcelFile3 ) // Inp_rasp.xls(x) ===>Inp_rasp.dbf ENDIF oScr := DC_WaitOn(L('Расчет баз данных: "Bala", "Rasp_PROGNOZ"'),,,,,,,,,,,.F.) ********** Перенос информации из БД Inp_rasp.dbf в БД: Bala.dbf ************* CLoseAll() USE Bala EXCLUSIVE NEW INDEX ON FIELDGET(1) TO Bala // Для занесения информации о фактически произошедших ЗМТ CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Inp_rasp EXCLUSIVE NEW USE Bala INDEX Bala EXCLUSIVE NEW SELECT Inp_rasp DBGOTOP() DO WHILE .NOT. EOF() ar := {} AADD(ar, FIELDGET(1)) FOR j=8 TO 17 AADD(ar, FIELDGET(j)) // <===############################################################# NEXT * LB_Warning(ar) SELECT Bala;SET ORDER TO 1 APPEND BLANK FOR j=1 TO LEN(ar) FIELDPUT(j, ar[j]) // Дает ошибку на большой обучающей выборке (около 100 тыс.объектов) <===##################### NEXT REPLACE ZMT_fakt WITH 0 SELECT Inp_rasp DBSKIP(1) ENDDO ********** Перенос информации из БД Inp_fakt.dbf в БД: Bala.dbf и нормировка к прогнозируемым ********** IF FILE( cExcelFakt ) USE Inp_fakt INDEX Inp_fakt EXCLUSIVE NEW mSumIntFaktZMT = 0 SELECT Inp_fakt DBGOTOP() DO WHILE .NOT. EOF() mDate = FIELDGET(1) mIntZMT = FIELDGET(7) SELECT Bala;SET ORDER TO 1;T=DBSEEK(mDate) IF T REPLACE ZMT_fakt WITH mIntZMT mSumIntFaktZMT = mSumIntFaktZMT + mIntZMT ENDIF SELECT Inp_fakt DBSKIP(1) ENDDO ENDIF *** Скопировать БД Bala.dbf из папки Inp_data в папку текущего приложения *** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций COPY FILE ("Bala.dbf") TO (M_PathAppl+"Bala.dbf") DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Grint EXCLUSIVE NEW USE Bala EXCLUSIVE NEW USE Opis_Sc EXCLUSIVE NEW // Перенести значения полей (NAME_ATR, MIN_GRINT, MAX_GRINT, Syla_Planet) из Grint.dbf в массивы aNAME_ATR := {} aMIN_GRINT := {} aMAX_GRINT := {} aSyla_Planet := {} SELECT Grint DBGOTOP() DO WHILE .NOT. EOF() AADD(aNAME_ATR , ALLTRIM(NAME_ATR)) AADD(aMIN_GRINT , MIN_GRINT ) AADD(aMAX_GRINT , MAX_GRINT ) AADD(aSyla_Planet, SYLAPLANET) DBSKIP(1) ENDDO // Создать массивы диапазонов градаций шкал (NAME_OPSC, KODGR_MIN, KODGR_MAX) aNAME_OPSC := {} aKODGR_MIN := {} aKODGR_MAX := {} SELECT Opis_Sc DBGOTOP() DO WHILE .NOT. EOF() AADD(aNAME_OPSC, ALLTRIM(NAME_OPSC)) AADD(aKODGR_MIN, KODGR_MIN ) AADD(aKODGR_MAX, KODGR_MAX ) DBSKIP(1) ENDDO *** В следующих столбцах 12-21 - По формуле: =ВПР(B2;Grint!$B$2:$D$73;3;1) будет идти расчет на каждый прогнозный день, в зависимости от того, в какой интервал из 72 градаций *** описательных шкал попадает тот или иной астропараметр из будущего. Таким образом, на 3 листе Bala в столбцах 12-21 (они выделены голубым цветом) мы получаем прогноз (силу планет) *** на каждый прогнозный день 2019 гг. mNOpSc = LEN(aNAME_OPSC) // Число описательных шкал SELECT Bala DBGOTOP() DO WHILE .NOT. EOF() FOR ap = 1 TO mNOpSc // Код астропараметра mValAP = FIELDGET(1+ap) // Знач.астропараметра из БД FOR j=aKODGR_MIN[ap] TO aKODGR_MAX[ap] // Поиск в нужном диапазоне IF aMIN_GRINT[j] <= mValAP .AND. mValAP <= aMAX_GRINT[j] FIELDPUT(1+mNOpSc+ap, aSyla_Planet[j]) EXIT ENDIF NEXT NEXT DBSKIP(1) ENDDO *** Делаем файл: Rasp_PROGNOZ *********************************** ***** Последний прогнозный файл - . В нем столько же строк - по числу дней 2019 г, столбцы 1-21 - перенесены с листа файла , ***** тоже через промежуточный файл Excel, и пока с теми же ошибками, здесь я их исправляю вручную, и получаю уже такой файл: CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций COPY FILE ("Bala.dbf") TO ("Rasp_PROGNOZ.dbf") ****** Исправление непосчитанных ячеек CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rasp_PROGNOZ EXCLUSIVE NEW SELECT Rasp_PROGNOZ FOR ap = 1 TO mNOpSc // Код астропараметра DBGOTOP() DO WHILE .NOT. EOF() mValAPold = FIELDGET(1+mNOpSc+ap) // Знач.астропараметра из БД за текущий день DBSKIP(1) mValAPnew = FIELDGET(1+mNOpSc+ap) // Знач.астропараметра из БД за следующий день IF mValAPnew = 0 FIELDPUT(1+mNOpSc+ap, mValAPold) ENDIF ENDDO NEXT **** Расчет итогового столбца *********************************** SELECT Rasp_PROGNOZ DBGOTOP() DO WHILE .NOT. EOF() mPROGN_POLN = 0 FOR ap = 1 TO mNOpSc // Код астропараметра mPROGN_POLN = mPROGN_POLN + FIELDGET(1+mNOpSc+ap) NEXT REPLACE PROGN_POLN WITH mPROGN_POLN REPLACE PrognNNorm WITH mPROGN_POLN DBSKIP(1) ENDDO ******************************************************************************************** ****** НОРМИРОВАНИЕ ПРОГНОЗА И ФАКТА ******************************************************* ******************************************************************************************** DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения aVal := {} // Полный прогноз (высокочастотный) aFakt := {} // Факт CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rasp_PROGNOZ EXCLUSIVE NEW SELECT Rasp_PROGNOZ DBGOTOP() DO WHILE .NOT. EOF() AADD(aVal , PROGN_POLN) AADD(aFakt, ZMT_FAKT) DBSKIP(1) ENDDO n = LEN(aFakt) *********************************************************************** * Экспоненциальное сглаживание линейно нормированного логарифма факта: * - логарифм для уменьшения влияния низкочастотных выбросов; * - линейное нормирование для отображения значений в область: 0 - 1; * - экспоненциальное сглаживание для удаления уменьшения влияния высокочастотных выбросов (сила сглаживания задается в диалоге от полного его отсутствия до максимального: до одной прямой линии). *********************************************************************** aLogFakt := {} // Логарифм факта (в лог.шкале выбросы играют меньшую роль) aLineNormLogFakt := {} // Линейное нормирование логарифма факта (отображение в область: 0-1) aExpSmLineNormLF := {} // Экспоненциальное сглаживание линейного нормирования логарифма факта (ЗАМЕНИТЬ СГЛАЖИВАНИЕМ ЦЕНТРИРОВАННЫМ СКОЛЬЗЯЩИМ СРЕДНИМ) <===######### // Логарифм факта (в лог.шкале выбросы играют меньшую роль) mMinFakt = +99999999 mMaxFakt = -99999999 FOR j=1 TO n mMinFakt = MIN(mMinFakt, aFakt[j]) mMaxFakt = MAX(mMaxFakt, aFakt[j]) NEXT * FOR j=1 TO n * AADD(aLogFakt, IF(aFakt[j]>0,LOG(aFakt[j]),LOG(mMinFakt))) * NEXT aLogFakt = aFakt // Линейное нормирование логарифма факта (отображение в область: 0-1) mMinLogFakt = +99999999 mMaxLogFakt = -99999999 FOR j=1 TO n mMinLogFakt = MIN(mMinLogFakt, aLogFakt[j]) mMaxLogFakt = MAX(mMaxLogFakt, aLogFakt[j]) NEXT FOR j=1 TO n AADD(aLineNormLogFakt, (aLogFakt[j] - mMinLogFakt) / (mMaxLogFakt - mMinLogFakt)) NEXT // Экспоненциальное сглаживание линейного нормирования логарифма факта ****** ЗАМЕНИТЬ НА ЦЕНТРИРОВАННОЕ ЛИНЕЙНОЕ СГЛАЖИВАНИЕ СКОЛЬЗЯЩИМ СРЕДНИМ <===########### * mAlfa = 0.8 * AADD(aExpSmLineNormLF, aLineNormLogFakt[1]) * FOR j=2 TO n * AADD(aExpSmLineNormLF, mAlfa * aLineNormLogFakt[j] + ( 1 - mAlfa ) * aExpSmLineNormLF[j-1] ) * NEXT // ЦЕНТРИРОВАННОЕ ЛИНЕЙНОЕ СГЛАЖИВАНИЕ СКОЛЬЗЯЩИМ СРЕДНИМ <===########### PRIVATE aAvrFakt[n] // Длина исходного массива AFILL(aAvrFakt, 0) * aAvr[1] = aVal[1] // Чтобы 1-й элемент сглаженного массива были точно равен 1-му элементу несглаженного массива <===###### Когда верификация * mWindow = 7 // Интервал (окно) сглаживания (месяц) (задается в диалоге) IF mAlfa > 1 aAvrFakt = aLineNormLogFakt // Чтобы 1-й элемент сглаженного массива были точно равен 1-му элементу несглаженного массива <===###### Когда верификация ENDIF hw = (mAlfa-1)/2 // Размах окна влево и вправо от текущей позиции FOR i=2 TO n // Организовываем цикл по числу элементов mSumY = 0 ** Определение начала и конца окна IF i<=hw // если индекс меньше половины окна, мы находимся в начале массива, нужно брать окно меньшего размера k1=1 // в качестве начала окна берем первый элемент k2=2*i-1 // конец окна z=k2 // текущий размер окна ELSEIF i+hw>n // если индекс+половина окна больше n - мы приближаемся к концу массива и размер окна также нужно уменьшать k1=i-n+i // начало окна k2=n // конец окна - последний элемент массива z=k2-k1 // размер окна ELSE // если первые два условия не выполняются, мы в середине массива k1=i-hw k2=i+hw z=mAlfa ENDIF FOR j = INT(k1) TO INT(k2) // организуем цикл от начала до конца окна mSumY = mSumY + aLineNormLogFakt[j] // <===######################## дает ошибку когда окно четное? NEXT aAvrFakt[i] = mSumY / z * aAvrFakt[i] = IF(aAvrFakt[i]Y_MaxF,Y_MaxF,aAvrFakt[i]) NEXT ************* Нормирование значений: ValNorm = (Val-Min)/(Max-Min) mMinVal = +99999999 mMaxVal = -99999999 mMinFakt = +99999999 mMaxFakt = -99999999 mMinAvrFakt = +99999999 mMaxAvrFakt = -99999999 FOR j=1 TO n mMinVal = MIN(mMinVal , aVal [j]) mMaxVal = MAX(mMaxVal , aVal [j]) mMinFakt = MIN(mMinFakt , aFakt [j]) mMaxFakt = MAX(mMaxFakt , aFakt [j]) mMinAvrFakt = MIN(mMinAvrFakt, aAvrFakt[j]) mMaxAvrFakt = MAX(mMaxAvrFakt, aAvrFakt[j]) NEXT FOR j=1 TO n aVal [j] = (aVal [j] - mMinVal ) / (mMaxVal - mMinVal ) aFakt[j] = (aFakt [j] - mMinFakt ) / (mMaxFakt - mMinFakt ) aAvrFakt[j] = (aAvrFakt[j] - mMinAvrFakt) / (mMaxAvrFakt - mMinAvrFakt) NEXT ****** Записать результаты нормирования прогноза и сглаживания факта в БД SELECT Rasp_PROGNOZ j = 0 DBGOTOP() DO WHILE .NOT. EOF() j++ REPLACE Progn_poln WITH aVal [j] REPLACE ZMT_fakt WITH aFakt [j] REPLACE ZMTAvrFakt WITH aAvrFakt[j] DBSKIP(1) ENDDO ******************************************************************************************** ****** СГЛАЖИВАНИЕ ПРОГНОЗА **************************************************************** ******************************************************************************************** Y_MinF = +99999999 // Минимальное значение Y отображаемой функции Y_MaxF = -99999999 // Максимальное значение Y отображаемой функции FOR j=1 TO n Y_MinF = MIN(Y_MinF, aVal [j]) Y_MaxF = MAX(Y_MaxF, aVal [j]) Y_MinF = MIN(Y_MinF, aFakt[j]) Y_MaxF = MAX(Y_MaxF, aFakt[j]) NEXT n = LEN(aVal) mWindow = INT(IF(mWindow < n, mWindow, n/2)) // окно сглаживания не может быть больше половины длины массива значений IF mWindow > 0 ******* Расчет сглаженной кривой aAvr *** (http://habr.com/post/134375/) ********** * %в случае, если размер окна четный, увеличиваем его на 1 для симметрии; * window = 5; * if(mod(window,2)==0) * window=window+1; * end * hw=(window-1)/2; %размах окна влево и вправо от текущей позиции * n=length(Signal); * result=zeros(n,1); * result(1)=SN(1); %первый элемент берем из исходного массива SN как есть * for i=2:n %организовываем цикл по числу элементов * init_sum = 0; * if(i<=hw) %если индекс меньше половины окна, мы находимся в начале массива, * %нужно брать окно меньшего размера * k1=1; %в качестве начала окна берем первый элемент * k2=2*i-1; %конец окна * z=k2; %текущий размер окна * elseif (i+hw>n) %если индекс+половина окна больше n - мы приближаемся к концу массива и размер окна * %также нужно уменьшать * k1=i-n+i; %начало окна * k2=n; %конец окна - последний элемент массива * z=k2-k1; %размер окна * else %если первые два условия не выполняются, мы в середине массива * k1=i-hw; * k2=i+hw; * z=window; * end * for j=k1:k2 %организуем цикл от начала до конца окна * init_sum=init_sum+SN(j); %складываем все элементы * end * result(i)=init_sum/(z); %и делим на текущий размер окна * end PRIVATE aAvr[n] // Длина исходного массива * aAvr[1] = aVal[1] // Чтобы 1-й элемент сглаженного массива были точно равен 1-му элементу несглаженного массива <===###### Когда верификация * mWindow = 7 // Интервал (окно) сглаживания (месяц) (задается в диалоге) aAvr = aVal // Чтобы 1-й элемент сглаженного массива были точно равен 1-му элементу несглаженного массива <===###### Когда верификация hw = (mWindow-1)/2 // Размах окна влево и вправо от текущей позиции FOR i=2 TO n // Организовываем цикл по числу элементов mSumY = 0 ** Определение начала и конца окна IF i<=hw // если индекс меньше половины окна, мы находимся в начале массива, нужно брать окно меньшего размера k1=1 // в качестве начала окна берем первый элемент k2=2*i-1 // конец окна z=k2 // текущий размер окна ELSEIF i+hw>n // если индекс+половина окна больше n - мы приближаемся к концу массива и размер окна также нужно уменьшать k1=i-n+i // начало окна k2=n // конец окна - последний элемент массива z=k2-k1 // размер окна ELSE // если первые два условия не выполняются, мы в середине массива k1=i-hw k2=i+hw z=mWindow ENDIF FOR j = INT(k1) TO INT(k2) // организуем цикл от начала до конца окна mSumY = mSumY + aVal[j] // <===######################## дает ошибку когда окно четное? NEXT aAvr[i] = mSumY / z aAvr[i] = IF(aAvr[i]Y_MaxF,Y_MaxF,aAvr[i]) NEXT ENDIF ******************************************************************************************** ****** Записать сглаженный прогноз в БД SELECT Rasp_PROGNOZ j = 0 DBGOTOP() DO WHILE .NOT. EOF() j++ REPLACE Progn_avr WITH aAvr[j] DBSKIP(1) ENDDO ******************************************************************************************** ******************************************************************************************** *** РАСЧЕТ PrognReson.dbf ******************************************************************************************** ***** Подготовка данных для расчета ****************** DIRCHANGE(Disk_dir+"/AID_DATA/Inp_data/") CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций COPY FILE ("PrognReson.dbf") TO (M_PathAppl+"PrognReson.dbf") ERASE("PrognReson.dbf") CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций aFakt := {} IF FILE('Inp_fakt.dbf') USE Inp_fakt EXCLUSIVE NEW // <<<===##################################### SELECT Inp_fakt DBGOTOP() DO WHILE .NOT. EOF() AADD(aFakt, FIELDGET(7)) DBSKIP(1) ENDDO ENDIF DIRCHANGE(M_PathAppl) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rasp_PROGNOZ EXCLUSIVE NEW USE PrognReson EXCLUSIVE NEW;ZAP SELECT Rasp_PROGNOZ r = 0 DBGOTOP() DO WHILE .NOT. EOF() ar := {} FOR j=1 TO FCOUNT() AADD(ar, FIELDGET(j)) NEXT SELECT PrognReson APPEND BLANK FOR j=1 TO LEN(ar) FIELDPUT(j, ar[j]) NEXT IF LEN(aFakt) > 0 REPLACE SumINT_ZMT WITH aFakt[++r] // <<<===##################################### ENDIF SELECT Rasp_PROGNOZ DBSKIP(1) ENDDO ***** Расчет ***************************************** aPrognAvr := {} aPrognMin := {} SELECT PrognReson DBGOTOP() DO WHILE .NOT. EOF() REPLACE PROGN_N WITH PROGNNNORM / 10000 AADD(aPrognAvr, PROGN_AVR) AADD(aPrognMin, '') DBSKIP(1) ENDDO ***** Поиск минимумов: ***** Если среднее N значений aPrognAvr раньше текущего И среднее N значений aPrognAvr раньше позже текущего больше него, то это минимум n = 2 FOR j=n+1 TO LEN(aPrognAvr)-n mAvrNdo = 0 FOR i=j-n TO j-1 mAvrNdo = mAvrNdo + aPrognAvr[i] NEXT mAvrNdo = mAvrNdo / n mAvrNpo = 0 FOR i=j+1 TO j+n mAvrNpo = mAvrNpo + aPrognAvr[i] NEXT mAvrNpo = mAvrNpo / n IF mAvrNdo > aPrognAvr[j] .AND. aPrognAvr[j] < mAvrNpo aPrognMin[j] = 'MIN' ENDIF NEXT r = 0 SELECT PrognReson DBGOTOP() DO WHILE .NOT. EOF() REPLACE ProgAvrMin WITH aPrognMin[++r] DBSKIP(1) ENDDO mPrognNI = 0 mIntZmtNI = 0 SELECT PrognReson DBGOTOP() DO WHILE .NOT. EOF() IF ProgAvrMin = 'MIN' mPrognNI = 0 mIntZmtNI = 0 ENDIF mPrognNI = mPrognNI + PROGN_N mIntZmtNI = mIntZmtNI + SUMINT_ZMT REPLACE PROGN_NI WITH mPrognNI REPLACE INT_ZMT_NI WITH mIntZmtNI DBSKIP(1) ENDDO DC_Impl(oScr) ******************************************* Chart23212(.F.) // Рисуем график ******************************************* aMess := {} AADD(aMess, L('РАСЧЕТ УСПЕШНО ЗАВЕРШЕН! Созданы следующие базы данных (все БД открываются в MS Excel):')) AADD(aMess, L('- файлы: "'+cExcelFile1+'" и "')+cExcelFile2+L('" объединены по полю "Дата" в БД: "')+Disk_dir+'"\AID_DATA\Inp_data\Inp_data.dbf".') AADD(aMess, L('- в папке текущего приложения:')+' '+M_PathAppl+' '+'находятся базы данных:') AADD(aMess, L('- "ABS_Syla_Planet.DBF", "Grint.dbf", "Bala.dbf" и "Rasp_PROGNOZ.dbf".')) AADD(aMess, L('- графическая форма записана в папке:')+' '+M_PathAppl+L('Earthquakes.')) LB_Warning(aMess, 'Система "Эйдос"' ) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW Running(.F.) RETURN nil **************************************************************************************** FUNCTION Help23212() DCSETFONT TO '9.Helv' s=1 D=0.8 @ s, 1 DCSAY L('Помощь по режиму "2.3.2.12". Прогноз землетрясений методом Н.А.Чередниченко') FONT '10.HelvBold' SAYSIZE 0;s=s+D s=s+D @ s, 1 DCSAY L('Методика прогнозирования общей сейсмичности основана на зависимости сейсмических процессов на Земле - от влияния небесных тел. Гравитационное взаимодействие планет и ') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('регулярные возмущения силы передаются в годовом движении планет посредством их проекций на определенные регионы Земли и способны вызывать вполне ощутимые результаты в ') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('виде накопления потенциальной энергии в сейсмических очагах-резонаторах, а также разрядки этих очагов с выбросом сейсмической энергии. В спектре планетарного волнового ') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('воздействия на сейсмичность Земли Нептуну принадлежит основная низкочастотная гармоника, а все более быстро двигающиеся объекты, которые обращаются по своим орбитам между ') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('Солнцем и Нептуном, вносят дополнительные гармоники. Медленно движущиеся планеты насыщают сейсмические очаги низкочастотной энергией, движение быстрых планет, динамика ') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('их проекций на поверхность Земли, - вызывают разрядку сейсмических очагов-резонаторов по всей Земле. Луна является самым быстро движущимся небесным объектом, ей ') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('принадлежит роль основного катализатора разрядки сейсмических очагов. ') SAYSIZE 0;s=s+D s=s+D @ s, 1 DCSAY L('Каждому землетрясению из статистической базы соответствует определенное положение планет на эклиптике, а также их взаимное расположения, что может быть выражено в разнице ') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('эклиптикальных долгот Луны и 10 астропараметров: Солнца, планет от Меркурия - до Нептуна, а также лунного узла и апогея. Чем обширнее статистическая база сейсмособытий, тем ') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('разнообразнее будет набор лунно-планетарных взаимоотношений при реализации землетрясений. Исходные данные землетрясений из мировой или региональных статистических баз ') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('можно исследовать методом АСК-анализа. В качестве исследуемого класса в данной методике используется показатель Интенсивности землетрясений, который является более важным,') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('чем показатель магнитуды, так как включает в себя, кроме магнитуды, еще и глубины гипоцентров. Данные по Интенсивности землетрясений можно распределить на градации, при этом') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('опытным путем выбраны 12 градаций класса. Если в зависимость им поставить в качестве признаков показатели лунно-планетарных взаимоотношений (также разделенные на ') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('подобранные опытным путем 72 градации), то в результате исследования в системе "Aidos-X" весь спектр градаций класса неравномерно распределится по градациям признаков таким') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('образом, что при одних строго определенных лунно-планетарных взаимоотношениях землетрясений не происходит вообще, а при других - они происходят в большом числе случаев. ') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('Такое распределение сейсмособытий послужило основанием для определения Силы планет по комбинациям градаций признаков от не способных вызвать землетрясение - до вызывающих ') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('массовую разрядку сейсмических очагов в исследуемом регионе или мире. ') SAYSIZE 0;s=s+D s=s+D @ s, 1 DCSAY L('Каждый из 10 астропараметров (или показателей Лунно-планетарных взаимоотношений) динамично изменяется вследствие годового обращения Земли вокруг Солнца, движения планет и ') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('Луны, поэтому при наступлении в прогностическом периоде такой комбинации градаций признаков, при которой не происходило землетрясений в прошлом, можно ожидать, что ') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('землетрясений не будет, а при возникновении в прогнозируемом временном периоде такой комбинации градаций признаков, которая соответствует максимальной Силе планет в ') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('ретроспективном периоде, можно ожидать возникновения соответствующих сейсмособытий. ') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('Прогнозная форма в режиме 2.3.2.12 выдается в виде графика-прогноза для исследуемого региона или мира, на котором представлены сейсмические циклы повышения и снижения ') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('уровня общей сейсмичности, эти циклы появляются вследствие наложения низкочастотных и высокочастотных гармоник, создаваемых динамически изменяющимися лунно-планетарными ') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('взаимоотношениями. Высокочастотные пики в сейсмических циклах означают вероятные всплески сейсмичности, разрядку сейсмических очагов с высокой Интенсивностью землетрясений. ') SAYSIZE 0;s=s+D s=s+D @ s, 1 DCSAY L('Непосредственно работе режима 2.3.2.12 посвящены публикации:') SAYSIZE 0;s=s+D s=s+D @ s, 1 DCSAY L('Lutsenko E.V., Trounev A.P. AI SYSTEM FOR COGNITIVE PREDICTION. CHAPTER I. SEISMIC MODELS, December 2020, DOI: 10.13140/RG.2.2.34745.39524, License: CC BY-SA 4.0, ') SAYSIZE 0;s=s+D @ s,42 DCSAY L('https://www.researchgate.net/publication/347881661_AI_SYSTEM_FOR_COGNITIVE_PREDICTION_CHAPTER_I_SEISMIC_MODELS') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'https://www.researchgate.net/publication/347881661_AI_SYSTEM_FOR_COGNITIVE_PREDICTION_CHAPTER_I_SEISMIC_MODELS', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)};s=s+D s=s+D @ s, 1 DCSAY L('Луценко Е. В. Методология системно-когнитивного прогнозирования сейсмичности : монография / Е. В. Луценко, А. П. Трунев, Н. А. Чередниченко; под общ. ред. В. И. Лойко. ') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('- Краснодар : КубГАУ, 2020. - 532 с., ISBN 978-5-907294-89-9, DOI 10.13140/RG.2.2.29617.33122 - Режим доступа:') SAYSIZE 0 @ s,42 DCSAY L('https://www.researchgate.net/publication/340116509_METHODOLOGY_OF_SYSTEM-COGNITIVE_FORECASTING_OF_SEISMICITY') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'https://www.researchgate.net/publication/340116509_METHODOLOGY_OF_SYSTEM-COGNITIVE_FORECASTING_OF_SEISMICITY', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)};s=s+D s=s+D @ s, 1 DCSAY L('Луценко Е.В. Резонансный сейсмогенез и системно-когнитивное прогнозирование сейсмичности : монография /Е.В.Луценко, А.П.Трунев, Н.А.Чередниченко; под общ.ред. В.И.Лойко. ') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('- Краснодар : КубГАУ, 2019. - 256 с. - Режим доступа:') SAYSIZE 0 @ s,42 DCSAY L('https://www.researchgate.net/publication/335992085_RESONANT_SEISMOGENIC_AND_SYSTEMIC-COGNITIVE_PREDICTION_OF_SEISMICITY') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'https://www.researchgate.net/publication/335992085_RESONANT_SEISMOGENIC_AND_SYSTEMIC-COGNITIVE_PREDICTION_OF_SEISMICITY', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)};s=s+D s=s+D @ s, 1 DCSAY L('Луценко Е. В. Методика системно-когнитивного прогнозирования сейсмичности (на примере региона Италии) / Е. В. Луценко, А. П. Трунев, Н. А. Чередниченко - Краснодар : ') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('КубГАУ, 2019. - 33 с. - Режим доступа:') SAYSIZE 0 @ s,42 DCSAY L('https://www.researchgate.net/publication/336580243_METHOD_of_SYSTEM-COGNITIVE_PREDICTION_of_SEISMICITY_on_the_example_of_the_region_of_Italy') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'https://www.researchgate.net/publication/336580243_METHOD_of_SYSTEM-COGNITIVE_PREDICTION_of_SEISMICITY_on_the_example_of_the_region_of_Italy', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)};s=s+D s=s+D @ s, 1 DCSAY L('а также облачное Эйдос-приложение № 156, которое можно установить в режиме 1.3. "Скачать приложение из облака"') SAYSIZE 0;s=s+D DCREAD GUI FIT MODAL TITLE L('Помощь по режиму "2.3.2.12". Прогноз землетрясений методом Н.А.Чередниченко') RETURN NIL **************************************************************************************** ******** Сравнение прогноза ЗМТ с фактом стандартными средствами системы "Эйдос" **************************************************************************************** FUNCTION CompForeFact() Running(.F.) *** Проверка наличия приложения и файла: Rasp_PROGNOZ.dbf в папке текущего приложения, выдача сообщения, если чего-нибудь не хватает *** Проверка наличия модели DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы Эйдос CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Appls EXCLUSIVE NEW IF RECCOUNT() = 0 LB_Warning('Нет файла: "Rasp_PROGNOZ.dbf". Необходимо сначала создать модель!') RETURN nil ENDIF SELECT Appls DBGOTOP() DO WHILE .NOT. EOF() IF LEN(ALLTRIM(BY_DEFAULT)) > 0 M_PathAppl = ALLTRIM(Path_Appl) // Путь на текущее приложение EXIT ENDIF DBSKIP(1) ENDDO DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения IF .NOT. FILE('Rasp_PROGNOZ.dbf') LB_Warning('Нет файла: "Rasp_PROGNOZ.dbf". Необходимо сначала создать модель!') RETURN nil ENDIF *** Копирование файла Rasp_PROGNOZ.dbf из папки текущего приложения в папку Inp_data с именем Inp_data.dbf и создание файлов наименований полей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций COPY FILE ("Rasp_PROGNOZ.dbf") TO (Disk_dir+"/AID_DATA/Inp_data/"+"Inp_data.dbf") CrLf = CHR(13)+CHR(10) // Конец строки (записи) * 'DATE' // 01 mInpName = 'MO_SUN' + CrLf +; // 02 'MO_MA' + CrLf +; // 03 'MO_JUP' + CrLf +; // 04 'MO_SAT' + CrLf +; // 05 'MO_UR' + CrLf +; // 06 'MO_NEP' + CrLf +; // 07 'MO_RAHU' + CrLf +; // 08 'MO_APOG' + CrLf +; // 09 'MO_MER' + CrLf +; // 10 'MO_VEN' + CrLf +; // 11 '_MO_SUN' + CrLf +; // 12 Дальше описательные шкалы '_MO_MA' + CrLf +; // 13 '_MO_JUP' + CrLf +; // 14 '_MO_SAT' + CrLf +; // 15 '_MO_UR' + CrLf +; // 16 '_MO_NEP' + CrLf +; // 17 '_MO_RAHU' + CrLf +; // 18 '_MO_APOG' + CrLf +; // 19 '_MO_MER' + CrLf +; // 20 '_MO_VEN' + CrLf +; // 21 'PROGN_POLN' + CrLf +; // 22 Дальше классификационные шкалы 'PROGN_AVR' + CrLf +; // 23 'ZMT_FAKT' + CrLf +; // 24 'ZMTAVRFAKT' + CrLf +; // 25 'PROGNNNORM' // 26 DIRCHANGE(Disk_dir+"\AID_DATA\Inp_data\") // Перейти в папку Inp_data StrFile(mInpName , "Inp_name.txt") // Запись текстового файла "Inp_name.txt" mInpNameAll = 'Date' + CrLf + mInpName StrFile(mInpNameAll, "Inp_nameAll.txt") // Запись текстового файла "Inp_name.txt" *** Подготовка параметров режима 2.3.2.2. Regim = 1 // Формализации ПО или ген.расп.выб. Flag_zer = 2 // Считать нули и пробелы отсутствием данных? [1]-да, [2]-нет N_Chast = 1 // На сколько частей N разбивать обучающую или распознаваемую выборку (в зависимости от Regim) M_ClSc1 = 22 // Номер начального столбца диапазона классификационных шкал M_ClSc2 = 26 // Номер конечного столбца диапазона классификационных шкал M_OpSc1 = 12 // Номер начального столбца диапазона описательных шкал M_OpSc2 = 21 // Номер конечного столбца диапазона описательных шкал M_ObAnk = 3 // Создавать анкеты исходной выборки по строкам Inp_data-[1], по классам-[2], и 1-е, и 2-е [3] M_Interval = 1 // 1-равные интервалы, 2-адаптивные интервалы (с примерно равным количеством наблюдений, по Котельникову) N_SKGrCl = 5 N_SKGrPr = 5 K_N_ClSc = 1 K_N_OpSc = 1 K_N_GrClSc = 12 // Количество градаций в числовой классификационной шкале K_N_GrOpSc = 72 // Количество градаций в числовой описательной шкале M_Scenario = .F. mGorizMin = 5 mGorizMax = 5 mGlubMin = 5 mGlubMax = 5 K_GradNClSc = 12 K_GradNOpSc = 72 M_ChastObi = .F. M_ChastRso = .F. N_ChastObi = 1 N_ChastRso = 1 M_XlsDbf = 3 mTxtCSField = 1 // Способ интерпретации значений текстовых полей - классификационных шкал файла исходных данных mTxtOSField = 1 // Способ интерпретации значений текстовых полей - описательных шкал файла исходных данных mTxtCSSep = " " // Разделитель элементов классификационных шкал, если mTxtCSField=3 mTxtOSSep = " " // Разделитель элементов описательных шкал, если mTxtOSField=3 * mScenario = 1 // mScenario=1 Не применять сценарный метод АСК-анализа и спец.интерпретацию TXT-полей (старый вариант) mScenario = 1 // Не применять сценарный метод АСК-анализа mSpecInterprCls = .F. // .T. - Применить спец.интерпретацию текстовых полей классов, .F. - не применять mSpecInterprAtr = .F. // .T. - Применить спец.интерпретацию текстовых полей признаков, .F. - не применять mNameGrNumSc= 1 // Какие наименования ГРАДАЦИЙ числовых шкал использовать mClsAvr = .F. // .F. - делать модель из Inp_data, .T. - делать модель из Inp_data_avr mSortUnqCls = 1 // Выделять уникальные значения классов и сортировать, 1-да, 2-нет mLemmatCls = 2 // Проводить лемматизацию классов, 1-да, 2-нет mSortUnqGos = 1 // Выделять уникальные значения признаков и сортировать, 1-да, 2-нет mLemmatGos = 2 // Проводить лемматизацию признаков, 1-да, 2-нет // Сохранить файл с информацией о заданых параметрах программного интерфейса в текущей директории системы PRIVATE aSoftInt[40] aSoftInt[ 1] = Regim aSoftInt[ 2] = Flag_zer aSoftInt[ 3] = M_ClSc1 aSoftInt[ 4] = M_ClSc2 aSoftInt[ 5] = M_OpSc1 aSoftInt[ 6] = M_OpSc2 aSoftInt[ 7] = N_SKGrCl aSoftInt[ 8] = N_SKGrPr aSoftInt[ 9] = K_N_ClSc aSoftInt[10] = K_N_OpSc aSoftInt[11] = K_N_GrClSc aSoftInt[12] = K_N_GrOpSc aSoftInt[13] = M_ObAnk aSoftInt[14] = N_Chast aSoftInt[15] = M_Interval aSoftInt[16] = M_Scenario aSoftInt[17] = K_GradNClSc // Количество градаций в числовой классификационной шкале aSoftInt[18] = K_GradNOpSc // Количество градаций в числовой описательной шкале aSoftInt[19] = mGorizMin aSoftInt[20] = mGorizMax aSoftInt[21] = mGlubMin aSoftInt[22] = mGlubMax aSoftInt[23] = M_ChastObi aSoftInt[24] = M_ChastRso aSoftInt[25] = N_ChastObi aSoftInt[26] = N_ChastRso aSoftInt[27] = M_XlsDbf aSoftInt[28] = mTxtCSField aSoftInt[29] = mTxtOSField aSoftInt[30] = mTxtCSSep aSoftInt[31] = mTxtOSSep * aSoftInt[32] = mScenario // mScenario=1 Не применять сценарный метод АСК-анализа и спец.интерпретацию TXT-полей (старый вариант) aSoftInt[32] = mScenario // mScenario=1 Не применять сценарный метод АСК-анализа aSoftInt[33] = mSpecInterprCls // Применить спец.интерпретацию текстовых полей классов aSoftInt[34] = mSpecInterprAtr // Применить спец.интерпретацию текстовых полей признаков aSoftInt[35] = mNameGrNumSc // Какие наименования ГРАДАЦИЙ числовых шкал использовать aSoftInt[36] = mClsAvr // .F. = модель без усреднения по классам aSoftInt[37] = mSortUnqCls // Выделять уникальные значения классов и сортировать, 1-да, 2-нет aSoftInt[38] = IF(mSpecInterprCls,mLemmatCls,2) // Проводить лемматизацию классов, 1-да, 2-нет aSoftInt[39] = mSortUnqGos // Выделять уникальные значения признаков и сортировать, 1-да, 2-нет aSoftInt[40] = IF(mSpecInterprAtr,mLemmatGos,2) // Проводить лемматизацию признаков, 1-да, 2-нет DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы DC_ASave(aSoftInt , "_2_3_2_2.arx") *** Создать новое пустое приложение с заданным имененем ****************************************** mApplName = L('Сравнение прогноза ЗМТ методом Чередниченко Н.А. с фактом') M_NewAppl = ADD_ZAPPL(mApplName) DIRCHANGE(M_NewAppl) // Перейти в папку с БД новой модели и создать БД формализации предметной области: GenDbfClSc(.F.) // Классификационные шкалы GenDbfGrClSc(.F.) // Градации классификационных шкал GenDbfClass(.F.) // Классификационные шкалы и градации GenDbfOpSc(.F.) // Описательные шкалы GenDbfGrOpSc(.F.) // Градации описательных шкал GenDbfAttr(.F.) // Описательные шкалы и градации GenDbfObiZag() // Заголовки объектов обучающей выборки GenDbfObiKcl() // Коды классов объектов обучающей выборки GenDbfObiKpr() // Коды признаков объектов обучающей выборки GenDbfRsoZag() // Заголовки объектов распознаваемой выборки GenDbfRsoKcl() // Коды классов объектов распознаваемой выборки GenDbfRsoKpr() // Коды признаков объектов распознаваемой выборки DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы Эйдос DC_ASave(aSoftInt , "_2_3_2_2.arx") F2_3_2_2(mApplName,"") // Запуск универсального программного интерфейса с внешними базами данных DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций F3_5('GPU','SintRec','3.3') // Синтез всех моделей F4_2_2_1() // Расчет матрицы сходства классов F4_2_2_2() // Визуализация когн.диаграммы сходства классов F4_2_2_3() // Расчет и визуализация дендрограммы агломеративной когнитивной кластеризации классов aMess := {} AADD(aMess, 'Еще можно исследовать модель в режимах:') AADD(aMess, '4.4.8, 4.4.9, 4.4.10, 4.4.11, 4.5 и других') LB_Warning(aMess,'(C) Система "Эйдос"') Running(.F.) RETURN nil ***************************************************************** ******** Рисуем график ****************************************** ***************************************************************** FUNCTION Chart23212(mDialog) * oScr := DC_WaitOn('Немного подождите! Идет формирование изображения в памяти и его масштабирование',,,,,,,,,,,.F.) *** Проверки наличия приложения ****************************** DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE PathGrAp EXCLUSIVE NEW;N_GrAp = RECCOUNT() USE Appls EXCLUSIVE NEW;N_Appls = RECCOUNT() USE Users EXCLUSIVE NEW;N_Users = RECCOUNT() IF N_GrAp = 0 // Если нет групп приложений - ничего не делать LB_Warning(L("В режиме 1.5 нет ни одной группы приложений !!!")) Running(.F.) RETURN(.T.) ENDIF IF N_Users = 0 // Если нет пользователей - ничего не делать LB_Warning(L("В режиме 1.2 не задано ни одного пользователя !!!")) Running(.F.) RETURN(.T.) ENDIF IF N_Appls = 0 // Если нет приложений - ничего не делать LB_Warning(L("В диспетчере приложений 1.3 нет ни одного приложения !!!")) Running(.F.) RETURN(.T.) ENDIF ****** Если приложение есть, то перейти в него *************** SELECT Appls PUBLIC M_PathAppl := "" PUBLIC M_NameAppl := "" DBGOTOP() DO WHILE .NOT. EOF() IF LEN(ALLTRIM(By_default)) > 0 REPLACE By_default WITH "W" M_PathAppl = ALLTRIM(Path_Appl) M_NameAppl = ALLTRIM(Name_Appl) EXIT ENDIF DBSKIP(1) ENDDO *** Проверки наличия и открытие БД *************************** DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения IF .NOT. FILE('Rasp_PROGNOZ.dbf') aMess := {} AADD(aMess, L('В приложении отсутствует база данных: "Rasp_PROGNOZ.dbf".')) AADD(aMess, L('Чтобы ее создать необходимо выполнить данный режим.')) AADD(aMess, L('Прочитайте описание метода, кликнув по кнопке: "Помощь".')) LB_Warning(aMess, 'Система "Эйдос"' ) RETURN NIL ENDIF DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы PRIVATE a23212[8] IF FILE("_23212.arx") // Параметры диалога F2_3_2_12() a23212 = DC_ARestore("_23212.arx") PUBLIC mNumMod := a23212[1] PUBLIC mRegim := a23212[2] PUBLIC mWindow := a23212[3] PUBLIC mXSize := a23212[4] PUBLIC mYSize := a23212[5] PUBLIC mLineWidth := a23212[6] PUBLIC mGamma := a23212[7] PUBLIC mAlfa := a23212[8] ELSE PUBLIC mNumMod := 1 PUBLIC mRegim := 2 PUBLIC mWindow := 7 PUBLIC mXSize := 1800 PUBLIC mYSize := 900 PUBLIC mLineWidth := 7 PUBLIC mGamma := 1 PUBLIC mAlfa := 1 a23212[1] = mNumMod a23212[2] = mRegim a23212[3] = mWindow a23212[4] = mXSize a23212[5] = mYSize a23212[6] = mLineWidth a23212[7] = mGamma a23212[8] = mAlfa DC_ASave(a23212, "_23212.arx") ENDIF IF mDialog PRIVATE aInput[6] aInput[1] = mWindow aInput[2] = mXSize aInput[3] = mYSize aInput[4] = mLineWidth aInput[5] = mGamma aInput[6] = mAlfa aOutput = SetIntSglag(aInput) // Задать значение интервала (окна) сглаживания, разрешения графической формы и параметры линии PUBLIC mNumMod := a23212 [1] PUBLIC mRegim := a23212 [2] PUBLIC mWindow := aOutput[1] PUBLIC mXSize := aOutput[2] PUBLIC mYSize := aOutput[3] PUBLIC mLineWidth := aOutput[4] PUBLIC mGamma := aOutput[5] PUBLIC mAlfa := aOutput[6] a23212[1] = mNumMod a23212[2] = mRegim a23212[3] = mWindow a23212[4] = mXSize a23212[5] = mYSize a23212[6] = mLineWidth a23212[7] = mGamma a23212[8] = mAlfa DC_ASave(a23212, "_23212.arx") ENDIF DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения * PUBLIC X_MaxW := 1800, Y_MaxW := 900 // Размер графического окна для отображения когнитивных диаграмм в пикселях PUBLIC X_MaxW := mXSize, Y_MaxW := mYSize // Максимальный размер графического окна для отображения 4K. PUBLIC nXSize := X_MaxW PUBLIC nYSize := Y_MaxW // Create new bitmap with given size oPS := XBPPRESSPACE() :new() :Create() oBMP := XBPBITMAP() :New() :Create() oBMP:Make( nXSize, nYSize ) oBMP:presSpace( oPS ) // here your GRA* Code **** Закрасить фон прямоугольника *************** * GraSetColor( oPS, GRA_CLR_WHITE, GRA_CLR_WHITE ) GraSetColor( oPS, BD_LIGHTGREY, BD_LIGHTGREY ) GraBox( oPS, { 0, 0 }, { nXSize, nYSize }, GRA_FILL ) *######################################################################################################################### ChartEarthquakes( oPS, mDialog ) // Графическая функция <<<===############################ * ChartEventsPolar( oPS, 'Earthquakes' ) *######################################################################################################################### *My image original, my image scaled ****** Запись полноразмерного графического файла в папку: M_PathAppl+"Earthquakes\" * DC_Impl(oScr) DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения IF FILEDATE("Earthquakes",16) = CTOD("//") DIRMAKE("Earthquakes") aMess := {} AADD(aMess, L('В папке текущего приложения: "'+UPPER(ALLTRIM(M_PathAppl))+'"')) AADD(aMess, L('не было директории "Earthquakes" для графических форм по прогнозам ЗМТ она была создана!')) // <===####################### AADD(aMess, L('В эту папку записываются исходные изображения высокого качества (без масштабирования)')) LB_Warning(aMess, L('Прогноз землетрясений в системе "Эйдос"')) ENDIF DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения DIRCHANGE(M_PathAppl+"Earthquakes\") // Перейти в папку Earthquakes cFileName = "EarthquakesDescartes"+STRTRAN(STR(ADIR("*.*")+1,6)," ","0")+".jpg" ERASE(cFileName) oBMP:SaveFile(cFileName,XBPBMP_FORMAT_JPG) IF nWidth > 1800 FullView( cFileName, "по верху", 65 ) // Визуализация полноразмерного файла на мониторе высокого разрешения ELSE ****** Формирование с помощью bmp2bmp() и отображение масштабированного изображения aNewSize := {nWidth,nHeight-29} // Новый размер изображения (еще немного уменьшается, чтобы не рисовать по панели задач) oBMP:loadFile(cFileName) // Загрузка полноразмерного изображения oRet := BMP2BMP(oBMP,aNewSize) // Масштабирование изображения cFileNameScale = SUBSTR(cFileName,1,AT(".jpg",cFileName)-1)+"_scaled.jpg" ERASE(cFileNameScale) oRet:saveFile(cFileNameScale,XBPBMP_FORMAT_JPG) // Запись масштабированного графического файла в в папку приложения для визуализации FullView( cFileNameScale, "по верху", 0 ) // Визуализация масштабированного графического файла на мониторе ограниченного разрешения ENDIF DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения *** График в полярной системе координат ********** DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения PUBLIC X_MaxW := 2048, Y_MaxW := 2048 // Размер графического окна для отображения когнитивных диаграмм в пикселях PUBLIC X_MaxW := mXSize, Y_MaxW := mYSize // Максимальный размер графического окна для отображения 4K. PUBLIC nXSize := X_MaxW PUBLIC nYSize := Y_MaxW // Create new bitmap with given size oPS := XBPPRESSPACE() :new() :Create() oBMP := XBPBITMAP() :New() :Create() oBMP:Make( nXSize, nYSize ) oBMP:presSpace( oPS ) // here your GRA* Code **** Закрасить фон прямоугольника *************** * GraSetColor( oPS, GRA_CLR_WHITE, GRA_CLR_WHITE ) GraSetColor( oPS, BD_LIGHTGREY, BD_LIGHTGREY ) GraBox( oPS, { 0, 0 }, { nXSize, nYSize }, GRA_FILL ) *######################################################################################################################### * ChartEarthquakes( oPS, mDialog ) // Графическая функция <<<===############################ ChartEventsPolar( oPS, 'Earthquakes' ) *######################################################################################################################### *My image original, my image scaled ****** Запись полноразмерного графического файла в папку: M_PathAppl+"Earthquakes\" * DC_Impl(oScr) DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения IF FILEDATE("Earthquakes",16) = CTOD("//") DIRMAKE("Earthquakes") aMess := {} AADD(aMess, L('В папке текущего приложения: "'+UPPER(ALLTRIM(M_PathAppl))+'"')) AADD(aMess, L('не было директории "Earthquakes" для графических форм по прогнозам ЗМТ она была создана!')) // <===####################### AADD(aMess, L('В эту папку записываются исходные изображения высокого качества (без масштабирования)')) LB_Warning(aMess, L('Прогноз землетрясений в системе "Эйдос"')) ENDIF DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения DIRCHANGE(M_PathAppl+"Earthquakes\") // Перейти в папку Earthquakes cFileName = "EarthquakesPolar"+STRTRAN(STR(ADIR("*.*")+1,6)," ","0")+".jpg" ERASE(cFileName) oBMP:SaveFile(cFileName,XBPBMP_FORMAT_JPG) IF nWidth > 1800 FullView( cFileName, "по верху", 65 ) // Визуализация полноразмерного файла на мониторе высокого разрешения ELSE ****** Формирование с помощью bmp2bmp() и отображение масштабированного изображения aNewSize := {nWidth,nHeight-29} // Новый размер изображения (еще немного уменьшается, чтобы не рисовать по панели задач) oBMP:loadFile(cFileName) // Загрузка полноразмерного изображения oRet := BMP2BMP(oBMP,aNewSize) // Масштабирование изображения cFileNameScale = SUBSTR(cFileName,1,AT(".jpg",cFileName)-1)+"_scaled.jpg" ERASE(cFileNameScale) oRet:saveFile(cFileNameScale,XBPBMP_FORMAT_JPG) // Запись масштабированного графического файла в в папку приложения для визуализации FullView( cFileNameScale, "по верху", 0 ) // Визуализация масштабированного графического файла на мониторе ограниченного разрешения ENDIF DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения *** График в полярной системе координат ********** DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения RETURN NIL ********************************************************************* ****** Визуализация графика ***************************************** ********************************************************************* STATIC FUNCTION ChartEarthQuakes( oPS ) DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы PRIVATE a23212[8] IF FILE("_23212.arx") // Параметры диалога F2_3_2_12() a23212 = DC_ARestore("_23212.arx") PUBLIC mNumMod := a23212[1] PUBLIC mRegim := a23212[2] PUBLIC mWindow := a23212[3] PUBLIC mXSize := a23212[4] PUBLIC mYSize := a23212[5] PUBLIC mLineWidth := a23212[6] PUBLIC mGamma := a23212[7] PUBLIC mAlfa := a23212[8] ELSE PUBLIC mNumMod := 1 PUBLIC mRegim := 2 PUBLIC mWindow := 7 PUBLIC mXSize := 1800 PUBLIC mYSize := 900 PUBLIC mLineWidth := 7 PUBLIC mGamma := 1 PUBLIC mAlfa := 1 a23212[1] = mNumMod a23212[2] = mRegim a23212[3] = mWindow a23212[4] = mXSize a23212[5] = mYSize a23212[6] = mLineWidth a23212[7] = mGamma a23212[8] = mAlfa DC_ASave(a23212, "_23212.arx") ENDIF X_MaxW = mXSize Y_MaxW = mYSize DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения aFakt := {} // Интенсивность фактических ЗМТ CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rasp_PROGNOZ EXCLUSIVE NEW SELECT Rasp_PROGNOZ DBGOTOP() DO WHILE .NOT. EOF() AADD(aFakt, ZMT_FAKT ) DBSKIP(1) ENDDO n = LEN(aFakt) *********************************************************************** * Экспоненциальное сглаживание линейно нормированного логарифма факта: * - логарифм для уменьшения влияния низкочастотных выбросов; * - линейное нормирование для отображения значений в область: 0 - 1; * - экспоненциальное сглаживание для удаления уменьшения влияния высокочастотных выбросов (сила сглаживания задается в диалоге от полного его отсутствия до максимального: до одной прямой линии). *********************************************************************** aLogFakt := {} // Логарифм факта (в лог.шкале выбросы играют меньшую роль) aLineNormLogFakt := {} // Линейное нормирование логарифма факта (отображение в область: 0-1) aExpSmLineNormLF := {} // Экспоненциальное сглаживание линейного нормирования логарифма факта // Логарифм факта (в лог.шкале выбросы играют меньшую роль) mMinFakt = +99999999 mMaxFakt = -99999999 FOR j=1 TO n mMinFakt = MIN(mMinFakt, aFakt[j]) mMaxFakt = MAX(mMaxFakt, aFakt[j]) NEXT FOR j=1 TO n AADD(aLogFakt, IF(aFakt[j]>0,LOG(aFakt[j]),LOG(mMinFakt))) NEXT // Линейное нормирование логарифма факта (отображение в область: 0-1) mMinLogFakt = +99999999 mMaxLogFakt = -99999999 FOR j=1 TO n mMinLogFakt = MIN(mMinLogFakt, aLogFakt[j]) mMaxLogFakt = MAX(mMaxLogFakt, aLogFakt[j]) NEXT FOR j=1 TO n AADD(aLineNormLogFakt, (aLogFakt[j] - mMinLogFakt) / (mMaxLogFakt - mMinLogFakt)) NEXT // Экспоненциальное сглаживание линейного нормирования логарифма факта ****** ЗАМЕНИТЬ НА ЦЕНТРИРОВАННОЕ ЛИНЕЙНОЕ СГЛАЖИВАНИЕ СКОЛЬЗЯЩИМ СРЕДНИМ <===########### * mAlfa = 0.8 * AADD(aExpSmLineNormLF, aLineNormLogFakt[1]) * FOR j=2 TO n * AADD(aExpSmLineNormLF, mAlfa * aLineNormLogFakt[j] + ( 1 - mAlfa ) * aExpSmLineNormLF[j-1] ) * NEXT // ЦЕНТРИРОВАННОЕ ЛИНЕЙНОЕ СГЛАЖИВАНИЕ СКОЛЬЗЯЩИМ СРЕДНИМ <===########### PRIVATE aAvrFakt[n] // Длина исходного массива AFILL(aAvrFakt, 0) * aAvr[1] = aVal[1] // Чтобы 1-й элемент сглаженного массива были точно равен 1-му элементу несглаженного массива <===###### Когда верификация * mWindow = 7 // Интервал (окно) сглаживания (месяц) (задается в диалоге) IF mAlfa > 1 aAvrFakt = aLineNormLogFakt // Чтобы 1-й элемент сглаженного массива были точно равен 1-му элементу несглаженного массива <===###### Когда верификация ENDIF hw = (mAlfa-1)/2 // Размах окна влево и вправо от текущей позиции FOR i=2 TO n // Организовываем цикл по числу элементов mSumY = 0 ** Определение начала и конца окна IF i<=hw // если индекс меньше половины окна, мы находимся в начале массива, нужно брать окно меньшего размера k1=1 // в качестве начала окна берем первый элемент k2=2*i-1 // конец окна z=k2 // текущий размер окна ELSEIF i+hw>n // если индекс+половина окна больше n - мы приближаемся к концу массива и размер окна также нужно уменьшать k1=i-n+i // начало окна k2=n // конец окна - последний элемент массива z=k2-k1 // размер окна ELSE // если первые два условия не выполняются, мы в середине массива k1=i-hw k2=i+hw z=mAlfa ENDIF FOR j = INT(k1) TO INT(k2) // организуем цикл от начала до конца окна mSumY = mSumY + aLineNormLogFakt[j] // <===######################## дает ошибку когда окно четное? NEXT aAvrFakt[i] = mSumY / z * aAvrFakt[i] = IF(aAvrFakt[i]Y_MaxF,Y_MaxF,aAvrFakt[i]) NEXT ****** Записать результаты сглаживания факта SELECT Rasp_PROGNOZ j = 0 DBGOTOP() DO WHILE .NOT. EOF() j++ REPLACE ZMTAvrFakt WITH aAvrFakt[j] DBSKIP(1) ENDDO aArgName := {} // Наименования градаций (даты в формате: ДД.ММ.ГГГГ) aArg := {} // Значение аргумента для нормирования графика по X aVal := {} // Полный прогноз (высокочастотный) aAvr := {} // Сглаженный прогноз aFakt := {} // Интенсивность фактических ЗМТ mSummaFakt = 0 DBGOTOP() DO WHILE .NOT. EOF() AADD(aArgName, ALLTRIM(FIELDGET(1))) // Дата AADD(aArg , RECNO() ) AADD(aVal , PROGN_POLN) AADD(aAvr , PROGN_AVR ) AADD(aFakt, ZMTAvrFakt) // Сглаженные и нормированные интенсивности фактических ЗМТ mSummaFakt = mSummaFakt + ZMT_FAKT // Если сумма интенсивностей фактических ЗМТ = 0, значит нет даных по фактическим ЗМТ DBSKIP(1) ENDDO *********************************************************************** *********************************************************************** ****** Поиск макс и мин значений аргумента ****** X_MinA = +99999999 // Минимальное значение X аргумента X_MaxA = -99999999 // Максимальное значение X аргумента FOR j=1 TO LEN(aArg) X_MinA = MIN(X_MinA, aArg[j]) X_MaxA = MAX(X_MaxA, aArg[j]) NEXT N_Arg = LEN(aArg) // Кол-во уникальных значений аргумента n = LEN(aArg) // Кол-во уникальных значений аргумента ****** Поиск макс и мин значений функции ******** Y_MinF = +99999999 // Минимальное значение Y отображаемой функции Y_MaxF = -99999999 // Максимальное значение Y отображаемой функции FOR j=1 TO LEN(aVal) Y_MinF = MIN(Y_MinF, aVal[j]) Y_MaxF = MAX(Y_MaxF, aVal[j]) Y_MinF = MIN(Y_MinF, aAvr[j]) Y_MaxF = MAX(Y_MaxF, aAvr[j]) IF mSummaFakt > 0 Y_MinF = MIN(Y_MinF, aFakt[j]) Y_MaxF = MAX(Y_MaxF, aFakt[j]) ENDIF NEXT ******************************************************************************************** *** Посчитать корреляцию факта с высокочастотным и сглаженным прогнозами и вывести в графике ******************************************************************************************** IF mSummaFakt > 0 *** Расчет сумм и средних mSumVal = 0 mSumAvr = 0 mSumFakt = 0 mN = 0 FOR j=1 TO n IF aFakt[j] > 0 // Корреляцию считать только для точек, по которым есть факт, а 0 пропускать mN++ mSumVal = mSumVal + aVal [j] mSumAvr = mSumAvr + aAvr [j] mSumFakt = mSumFakt + aFakt[j] ENDIF NEXT mSrVal = mSumVal /mN mSrAvr = mSumAvr /mN mSrFakt = mSumFakt/mN *** Расчет ср.кв.отклонений mDiVal = 0 mDiAvr = 0 mDiFakt = 0 FOR j=1 TO n IF aFakt[j] > 0 mDiVal = mDiVal + ( aVal [j] - mSrVal ) ^ 2 mDiAvr = mDiAvr + ( aAvr [j] - mSrAvr ) ^ 2 mDiFakt = mDiFakt + ( aFakt[j] - mSrFakt ) ^ 2 ENDIF NEXT mDiVal = SQRT(mDiVal /(mN-1)) mDiAvr = SQRT(mDiAvr /(mN-1)) mDiFakt = SQRT(mDiFakt/(mN-1)) *** Расчет ковариаций и ср.кв.отклонений mKovVal = 0 mKovAvr = 0 FOR j=1 TO n IF aFakt[j] > 0 mKovVal = mKovVal + (aVal[j] - mSrVal) * (aFakt[j] - mSrFakt) mKovAvr = mKovAvr + (aAvr[j] - mSrAvr) * (aFakt[j] - mSrFakt) ENDIF NEXT mKovVal = mKovVal / mN mKovAvr = mKovAvr / mN *** Расчет корреляций mKorVal = mKovVal / ( mDiVal * mDiFakt ) mKorAvr = mKovAvr / ( mDiAvr * mDiFakt ) ENDIF ******************************************************************************************** PRIVATE X0 := 75 PRIVATE Y0 := 165 // Начало координат по осям X и Y с учетом места для легенды PRIVATE W_Wind := X_MaxW - X0 - 25 // Ширина окна для самого графика PRIVATE H_Wind := Y_MaxW - Y0 - 70 // Высота окна для самого графика PRIVATE mNX := 100, mNY := 10 // Кол-во меток и надписей по осям X и Y PRIVATE Kx := W_Wind / ( X_MaxA-X_MinA ) // Коэффициент масштабирования по оси X: преобразует аргумент функции в номер пикселя по оси X PRIVATE Ky := H_Wind / ( Y_MaxF-Y_MinF ) // Коэффициент масштабирования по оси Y: преобразует значение функции в номер пикселя по оси Y PRIVATE Y0A := IF(Y_MinF > 0, Y0, Y0+ABS(Y_MinF)*Ky) // Позиция оси X на оси Y // <===################### **** Написать заголовок диаграммы aFonts := XbpFont():new():list() // Все доступные шрифты oFont := XbpFont():new():create("18.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты Ar_Model := {"Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } mTitle = 'ПРОГНОЗ ЗЕМЛЕТРЯСЕНИЙ МЕТОДОМ Н.А.ЧЕРЕДНИЧЕНКО' aTxtPar = DC_GraQueryTextbox(mTitle, oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox("Длина текста в пикселях="+ALLTRIM(STR(aTxtPar[1]))+". Высота текста в пикселях="+ALLTRIM(STR(aTxtPar[2]))) GraStringAt( oPS, { X_MaxW/2, Y_MaxW-25 }, mTitle) oFont := XbpFont():new():create("14.Arial Bold") GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты IF LEN(ALLTRIM(M_NameAppl)) < 70 GraStringAt( oPS, { X_MaxW/2, Y_MaxW-52 }, "Приложение: "+'"'+ALLTRIM(M_NameAppl)+'"' ) ELSE GraStringAt( oPS, { X_MaxW/2, Y_MaxW-52 }, '"'+ALLTRIM(M_NameAppl)+'"' ) ENDIF oFont := XbpFont():new():create("10.Arial") GraSetFont( oPS ,oFont ) aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты ***** Закрасить фон прямоугольника *************** GraSetColor( oPS, aColor[98] , aColor[98] ) GraBox( oPS, { X0, Y0 }, { X0+W_Wind, Y0+H_Wind }, GRA_FILL ) GraSetColor( oPS, aColor[222] , aColor[222] ) ***** Нарисовать оси координат ******************* aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 2 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты GraLine( oPS, {X0 , Y0A }, {X0+W_Wind, Y0A } ) // Нарисовать ось X GraLine( oPS, {X0 , Y0 }, {X0 , Y0+H_Wind} ) // Нарисовать границу рамки изображения слева это и есть ось Y GraLine( oPS, {X0 , Y0 }, {X0+W_Wind, Y0 } ) // Нарисовать границу рамки изображения внизу параллельно оси X GraLine( oPS, {X0 , Y0+H_Wind}, {X0+W_Wind, Y0+H_Wind} ) // Нарисовать границу рамки изображения вверху параллельно оси X GraLine( oPS, {X0+W_Wind, Y0 }, {X0+W_Wind, Y0+H_Wind} ) // Нарисовать границу рамки изображения справа параллельно оси Y aAttr := ARRAY( GRA_AM_COUNT ) // Массив для атрибутов маркеров aAttr [ GRA_AM_SYMBOL ] := GRA_MARKSYM_PLUS GraSetAttrMarker( oPS, aAttr ) aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DOT aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты *** Закрасить области между метками на оси X ***** DX = ( X_MaxA-X_MinA ) / mNX // Диапазон значений x, через которое ставить метку GraSetColor( oPS, aColor[99], aColor[99] ) j = 0 FOR X=X_MinA TO X_MaxA STEP 2*DX j = j + 2 X1 = X0 + ( j - 1 ) * DX * Kx X2 = X0 + ( j ) * DX * Kx GraBox( oPS, { X1, Y0 }, { X2, Y0 + H_Wind }, GRA_FILL ) NEXT GraSetColor( oPS, aColor[222], aColor[222] ) *** Сделать сетку и надписать метки на оси X ********************* // <===########### DO CASE CASE 1800 <= X_MaxW .AND. X_MaxW <= 3600 mNNadp = IF(LEN(aArgName) <= 182, LEN(aArgName), 182) // Количество надписей по оси X (больше 182 не помещается) oFont := XbpFont():new():create("8.Arial Bold") CASE 3600 <= X_MaxW .AND. X_MaxW <= 4096 mNNadp = IF(LEN(aArgName) <= 364, LEN(aArgName), 364) // Количество надписей по оси X (больше 364 не помещается) oFont := XbpFont():new():create("6.Arial Bold") ENDCASE GraSetFont( oPS ,oFont ) aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты mNumbLabels = INT(LEN(aArgName) / mNNadp) // Рисовать каждую 1-ю, 2-ю, 3-ю, 4-ю,..., mNumbLabels надпись на оси X aMonth = {'Январь','Февраль','Март','Апрель','Май','Июнь','Июль','Август','Сентябрь','Октябрь','Ноябрь','Декабрь'} mMGold = -1 mGold = -1 FOR j=1 TO LEN(aArgName) X1 = X0 + ( j - 1 ) * Kx GraMarker ( oPS, { X1, Y0 } ) IF j = mNumbLabels * INT(j / mNumbLabels) // Если номер надписи нацело делится на mNumbLabels, то рисовать ее X1 = X0 + ( j - 1 ) * Kx - 5 GraMarker ( oPS, { X1, Y0 } ) GraLine ( oPS, { X1, Y0 }, {X1, Y0+H_Wind} ) // Нарисовать пунктирную линию уровня x ****** Написать наименование месяца и год ****** IF LEN(aArgName) <= 365 mMGnew = VAL(SUBSTR(aArgName[j],4,7)) // Делать надпись при смене месяца и года IF mMGold <> mMGnew mMGold = mMGnew GraStringAt( oPS, { X1, Y0-72 }, aMonth[mMGnew]+','+SUBSTR(aArgName[j],7,4)) ENDIF ELSE mGnew = VAL(SUBSTR(aArgName[j],7,4)) // Делать надпись при смене года IF mGold <> MGnew mGold = MGnew GraStringAt( oPS, { X1, Y0-72 }, SUBSTR(aArgName[j],7,4)) ENDIF ENDIF ENDIF NEXT oFont := XbpFont():new():create("6.Arial") GraSetFont( oPS ,oFont ) aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты FOR j=1 TO LEN(aArgName) IF j = mNumbLabels * INT(j / mNumbLabels) // Если номер надписи нацело делится на mNumbLabels, то рисовать ее X1 = X0 + ( j - 1 ) * Kx aTxtPar = DC_GraQueryTextbox(ALLTRIM(STR(X,15,1)), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox(STR(aTxtPar[1])+" "+STR(aTxtPar[2])) mArgName = aArgName[j] aTxtPar = DC_GraQueryTextbox(mArgName, oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox("Длина текста в пикселях="+ALLTRIM(STR(aTxtPar[1]))+". Высота текста в пикселях="+ALLTRIM(STR(aTxtPar[2]))) aMatrix := GraInitMatrix() // <<<########## GraRotate( oPS, aMatrix, 90, { X1, Y0 }, GRA_TRANSFORM_ADD ) oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) // <<<########## mMM = VAL(SUBSTR(mArgName,4,2)) aAttrF [ GRA_AS_COLOR ] := IF(mMM=2*INT(mMM/2),aColor[12],aColor[190]) GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraStringAt( oPS, { X1-57, Y0 }, mArgName ) // Написать даты (aArgName[j]) вертикально <===############# ENDIF NEXT ****** Не получается отключить режим вращения изображения ****** Вместо отключения можно докрутить до 360 градусов aMatrix := GraInitMatrix() // <<<########## GraRotate( oPS, aMatrix, 0, {900, 425}, GRA_TRANSFORM_REPLACE ) // <<<########## oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) // <<<########## oFont := XbpFont():new():create("10.Arial") GraSetFont( oPS ,oFont ) aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты *** Сделать сетку и надписать метки на оси Y ********************* DY = ( Y_MaxF-Y_MinF ) / mNY // Диапазон значений Y, через которое ставить метку j = 0 FOR Y=Y_MinF TO Y_MaxF STEP DY ++j Y1 = Y0 + ( j - 1 ) * DY * Ky GraMarker ( oPS, { X0 , Y1 } ) aTxtPar = DC_GraQueryTextbox(ALLTRIM(STR(Y,15,1)), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox(STR(aTxtPar[1])+" "+STR(aTxtPar[2])) GraStringAt( oPS, { X0-35, Y1-aTxtPar[2]/2 }, ALLTRIM(STR(Y,15,1)) ) GraLine ( oPS, { X0 , Y1 }, {X0+W_Wind, Y1} ) // Нарисовать пунктирную линию уровня Y NEXT j = mNY Y1 = Y0 + j * DY * Ky GraMarker ( oPS, { X0 , Y1 } ) aTxtPar = DC_GraQueryTextbox(ALLTRIM(STR(Y_MaxF,15,1)), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox(STR(aTxtPar[1])+" "+STR(aTxtPar[2])) GraStringAt( oPS, { X0-35, Y1-aTxtPar[2]/2 }, ALLTRIM(STR(Y_MaxF,15,1)) ) GraLine ( oPS, { X0 , Y1 }, {X0+W_Wind, Y1} ) // Нарисовать пунктирную линию уровня Y ***** Рисование маркеров и отрезков прямых основной линии ************************************ aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT * aAttr [ GRA_AL_COLOR ] := aColor[123] // Задать цвет основной линии (темно-фиолетовый) DO CASE CASE mGamma = 1 // Теплая гамма aAttr [ GRA_AL_COLOR ] := GraMakeRGBColor({040,040,255}) // Задать цвет основной линии (яркий синий) CASE mGamma = 2 // Холодная гамма * aAttr [ GRA_AL_COLOR ] := GraMakeRGBColor({255,040,040}) // Задать цвет основной линии (яркий красный) aAttr [ GRA_AL_COLOR ] := GraMakeRGBColor({000,000,000}) // Задать цвет основной линии (черный) ENDCASE aAttr [ GRA_AL_WIDTH ] := 2 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aVal[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aVal[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT ***** ЭТО СДЕЛАТЬ НА СГЛАЖЕННОЙ КРИВОЙ, А ЗДЕСЬ ТОНКОЙ ЛИНИЕЙ, ЦВЕТА СИНЕЙ ГАММЫ, ЧТОБЫ ЗМТ ОТОБРАЖАТЬ КРАСНЫМ ***** Сделать рисование линий двух цветов, внутри посветлее, а снаружи потемнее (эффект объема) ***** для этого рисовать от внешних частей линии к внутренним уменьшающейся толщиной линии и более светлым цветом ПОВЕРХ РАНЕЕ НАРИСОВАННОГО IF mWindow > 0 DO CASE CASE mGamma = 1 // Теплая гамма DO CASE CASE mLineWidth = 5 aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := aColor[190] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 5 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[156] // Задать цвет внутри линии (темный синий) aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[169] // Задать цвет внутри линии (голубой) aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT CASE mLineWidth = 7 aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := aColor[192] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 7 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[190] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 5 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[156] // Задать цвет внутри линии (темный синий) aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[169] // Задать цвет внутри линии (голубой) aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT CASE mLineWidth = 9 aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := BD_BLACK // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 9 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[192] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 7 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[190] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 5 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[156] // Задать цвет внутри линии (темный синий) aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[169] // Задать цвет внутри линии (голубой) aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT ENDCASE CASE mGamma = 2 // Холодная гамма DO CASE CASE mLineWidth = 5 aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := aColor[14] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 5 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[12] // Задать цвет внутри линии (темный синий) aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[34] // Задать цвет внутри линии (голубой) aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT CASE mLineWidth = 7 aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := aColor[15] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 7 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[14] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 5 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[12] // Задать цвет внутри линии (темный синий) aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[34] // Задать цвет внутри линии (голубой) aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT CASE mLineWidth = 9 aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := BD_BLACK // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 9 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[15] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 7 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[14] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 5 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[12] // Задать цвет внутри линии (темный синий) aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[34] // Задать цвет внутри линии (голубой) aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aAvr[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aAvr[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT ENDCASE ENDCASE ** Отобразить фактически произошедшие ЗМТ, если они были IF mSummaFakt > 0 aAttr := ARRAY( GRA_AM_COUNT ) // Массив для атрибутов маркеров FOR j=1 TO n IF aFakt[j] > 0 // Проверка, чтобы не отображать фактические ЗМТ с 0 интенсивностью X := X0 + (aArg [j]-X_MinA) * Kx Y := Y0A + (aFakt[j]-Y_MinF) * Ky FOR r = ROUND(mLineWidth * 2.0,0) TO 1 STEP -1 c = INT(r*5) * DO CASE * CASE mGamma = 1 // Теплая гамма * aAttr[ GRA_AL_COLOR ] := GraMakeRGBColor({0,0,255-c}) // Задать цвет маркера (синий разной яркости) * CASE mGamma = 2 // Холодная гамма * aAttr[ GRA_AL_COLOR ] := GraMakeRGBColor({255-c,0,0}) // Задать цвет маркера (красный разной яркости) * ENDCASE aAttr[ GRA_AL_COLOR ] := GraMakeRGBColor({255-c,0,0}) // Задать цвет маркера (красный разной яркости) aAttr[ GRA_AM_BOX ] := { r, r } // Размер маркера по X и по Y aAttr[ GRA_AM_SYMBOL ] := GRA_MARKSYM_SIXPOINTSTAR GraSetAttrMarker( oPS, aAttr ) GraMarker( oPS, { X, Y } ) // Отобразить маркер NEXT ENDIF NEXT ENDIF ***** Рисование маркеров на линии IF n <= 64 aAttr := ARRAY( GRA_AM_COUNT ) // Массив для атрибутов маркеров aAttr[ GRA_AM_SYMBOL ] := GRA_MARKSYM_DOT GraSetAttrMarker( oPS, aAttr ) FOR j=1 TO LEN(aArg) X := X0 + (aArg[j]-X_MinA) * Kx Y := Y0A + (aAvr[j]-Y_MinF) * Ky IF LEN(aArg) <= 32 aAttr[ GRA_AM_SYMBOL ] := GRA_MARKSYM_SMALLCIRCLE GraSetAttrMarker( oPS, aAttr ) GraMarker( oPS, { X, Y } ) // отобразить маркер ENDIF aAttr[ GRA_AM_SYMBOL ] := GRA_MARKSYM_DOT GraSetAttrMarker( oPS, aAttr ) GraMarker( oPS, { X, Y } ) // отобразить маркер * GraStringAt( oPS, { X, Y }, '('+ALLTRIM(STR(aAvr[j],15,1))+','+ALLTRIM(STR(aVal[j],15,1))+')') NEXT ENDIF ENDIF ***** Нарисовать оси координат ********************************** aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 2 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты графической линии GraLine( oPS, {X0 , Y0A }, {X0+W_Wind, Y0A } ) // Нарисовать ось X GraLine( oPS, {X0 , Y0 }, {X0 , Y0+H_Wind} ) // Нарисовать границу рамки изображения слева это и есть ось Y GraLine( oPS, {X0 , Y0 }, {X0+W_Wind, Y0 } ) // Нарисовать границу рамки изображения внизу параллельно оси X GraLine( oPS, {X0 , Y0+H_Wind}, {X0+W_Wind, Y0+H_Wind} ) // Нарисовать границу рамки изображения вверху параллельно оси X GraLine( oPS, {X0+W_Wind, Y0 }, {X0+W_Wind, Y0+H_Wind} ) // Нарисовать границу рамки изображения справа параллельно оси Y ****** Легенда *************************************************** Offset = -97 // Смещение вниз относительно нуля Y0 для позиции легенды Interval = 17 ***** Нарисовать рамку легенды aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты графической линии X1 := X0 Y1 := Y0 + Offset X2 := X0 + W_Wind Y2 := Y0 + Offset - 2 * Interval - 22 ***** Закрасить фон прямоугольника *************** GraSetColor( oPS, aColor[129] , aColor[129] ) GraBox( oPS, { X1, Y1 }, { X2, Y2 }, GRA_FILL) GraSetColor( oPS, aColor[222] , aColor[222] ) GraBox( oPS, { X1, Y1 }, { X2, Y2 } ) * GraLine( oPS, { 1300, Y1 }, { 1270, Y2 } ) // Нарисовать вертикальную линию, отделяющую левый комментарий от правого ***** Сделать надписи в легенде aAttr[ GRA_AL_COLOR ] := aColor[17] // Задать цвет линии aAttr[ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK GraSetAttrString( oPS, aAttrF ) * MsgBox(M_PathAppl) DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения IF FILEDATE("Earthquakes",16) = CTOD("//") DIRMAKE("Earthquakes") aMess := {} AADD(aMess, L('В папке текущего приложения: "'+UPPER(ALLTRIM(M_PathAppl))+'"')) AADD(aMess, L('не было директории "Earthquakes" для графических форм по прогнозам ЗМТ она была создана!')) // <===####################### AADD(aMess, L('В эту папку записываются исходные изображения высокого качества (без масштабирования)')) LB_Warning(aMess, L('Прогноз землетрясений в системе "Эйдос"')) ENDIF DIRCHANGE(M_PathAppl+"Earthquakes\") // Перейти в папку Earthquakes cFileName = "Earthquakes"+STRTRAN(STR(ADIR("*.*")+1,6)," ","0")+".jpg" X1 := X0 + 20 Y1 := Y0 + Offset - Interval X2 := X1 + 190 Y2 := Y0 + Offset - 1 * Interval **** Передача параметров расчета для графика DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения * ar := {} * AADD(ar, mNumMod) * AADD(ar, M_Interval) * AADD(ar, K_GradNClSc) * AADD(ar, K_GradNOpSc) * AADD(ar, mNObj) * DC_ASave(ar, "_23212chart.arx") ar = DC_ARestore("_23212chart.arx") **** Надпись в легенде слева *********** oFont := XbpFont():new():create("12.Arial") GraSetFont( oPS ,oFont ) Y2 := Y0 + Offset - 1 * Interval;GraStringAt( oPS, { X1, Y2-0 }, L('Модель: "') +UPPER(ALLTRIM(Ar_Model[ar[1]]))+'". '+; L('Число интервалов в класс.и опис.шкалах:')+' '+ALLTRIM(STR(ar[3]))+', '+ALLTRIM(STR(ar[4]))+'. '+; L('Тип интервалов:') +' '+IF(ar[2]=1,L('"РАВНЫЕ"'),L('"АДАПТИВНЫЕ"'))+'. '+; L('Число наблюдений в обучающей выборке:') +' '+ALLTRIM(STR(ar[5])) +'. '+; L('Размер интервала сглаживания =') +' '+ALLTRIM(STR(mWindow)) +'. '+; L('Форма создана:')+' '+DTOC(DATE())+"-"+TIME()) IF mSummaFakt > 0 Y2 := Y0 + Offset - 2 * Interval;GraStringAt( oPS, { X1, Y2-5 }, L('Разрешение изображения: X=')+ALLTRIM(STR(mXSize))+', Y='+ALLTRIM(STR(mYSize))+' '+L('пикселей.')+' '+; L('Корр.прогн.полн-факт=')+ALLTRIM(STR(mKorVal,15,3))+'. '+L('Корр.прогн.сглаж-факт=')+ALLTRIM(STR(mKorAvr,15,3))+'. '+; L('Путь на файл изображения:')+' '+M_PathAppl+"Earthquakes\"+cFileName) ELSE Y2 := Y0 + Offset - 2 * Interval;GraStringAt( oPS, { X1, Y2-5 }, L('Разрешение изображения: X=')+ALLTRIM(STR(mXSize))+', Y='+ALLTRIM(STR(mYSize))+' '+L('пикселей.')+'. '+; L('Путь на файл изображения:')+' '+M_PathAppl+"Earthquakes\"+cFileName) ENDIF ****** Надписи координатных осей ********************************* oFont := XbpFont():new():create("13.ArialBold") GraSetFont( oPS ,oFont ) * AxName = "Дата (день, месяц, год)" * GraStringAt( oPS, { X0+W_Wind/2-8*LEN(AxName)/2, Y0-45 }, AxName ) // Надпись оси Х (СДЕЛАНА ВЫШЕ) AyName = "Суммарная сила факторов, способствующих возникновению землетрясения (норм.знач.)" aMatrix := GraInitMatrix() GraRotate( oPS, aMatrix, 90, { X0-53, Y0+H_Wind/2-8*LEN(AyName)/2 }, GRA_TRANSFORM_ADD ) oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) GraStringAt( oPS, { X0-53, Y0+H_Wind/2-8*LEN(AyName)/2 }, AyName ) // Надпись оси Y ****** Не получается отключить режим вращения изображения ****** Вместо отключения можно докрутить до 360 градусов X_Max := 1800 Y_Max := 850 // Размер графического окна для самого графика в пикселях aMatrix := GraInitMatrix() // <<<########## GraRotate( oPS, aMatrix, 0, {900, 425}, GRA_TRANSFORM_REPLACE ) // <<<########## oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) // <<<########## RETURN NIL **************************************************************************************************************************** FUNCTION DelColMinExp() oScr := DC_WaitOn(L('Сброс колонки: MIN-эксперт. Немного подождите!'),,,,,,,,,,,.F.) SELECT PrognReson DBGOTOP() DO WHILE .NOT. EOF() REPLACE PrognReson->PRAVKA_MIN WITH '' DBSKIP(1) ENDDO DBGOTOP() DC_Impl(oScr) RETURN NIL ************************* FUNCTION CopyMinProgExp() oScr := DC_WaitOn(L('Копирование: MIN-программа ===>>> MIN-эксперт. Немного подождите!'),,,,,,,,,,,.F.) SELECT PrognReson DBGOTOP() DO WHILE .NOT. EOF() REPLACE PrognReson->PRAVKA_MIN WITH PrognReson->ProgAvrMin DBSKIP(1) ENDDO DBGOTOP() DC_Impl(oScr) RETURN NIL ************************* FUNCTION ForeCalcMinExp() oScr := DC_WaitOn(L('Идет расчет прогноза по исправленным минимумам. Немного подождите!'),,,,,,,,,,,.F.) * Мое поле PRAVKA_PROGN_NI - я посчитала вручную нарастающий итог по прогнозу в соответствии с поправленными минимумами. mPrognNI = 0 mIntZmtNI = 0 SELECT PrognReson DBGOTOP() DO WHILE .NOT. EOF() IF LEN(ALLTRIM(PrognReson->PRAVKA_MIN)) > 0 // Чтобы можно было вводить не MIN, а любой символ REPLACE PrognReson->PRAVKA_MIN WITH 'MIN' mPrognNI = 0 mIntZmtNI = 0 ENDIF mPrognNI = mPrognNI + PROGN_N mIntZmtNI = mIntZmtNI + SUMINT_ZMT REPLACE PR_PROGNNI WITH mPrognNI REPLACE P_INTZMTNI WITH mIntZmtNI DBSKIP(1) ENDDO DBGOTOP() DC_Impl(oScr) RETURN NIL **************************************************************************************************************************** FUNCTION EditMinProgn() // Исправление расположения минимумов в прогнозе LOCAL GetList := {}, aPres, oBrowse, oToolBar, aColors, bColor, GetOptions, oEventsKO, bItems, n:=0, lExit *** Проверить наличие БД PrognReson.dbf ************************* IF ApplChange("") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF IF .NOT. FILE('PrognReson.dbf') LB_Warning(L("Сначала надо сделать прогноз ЗМТ, а потом его корректировать !!! ")) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW Running(.F.) RETURN nil ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE PrognReson EXCLUSIVE NEW SELECT PrognReson DBGOTOP() ****************************************** aColors := { {GRA_CLR_WHITE,GRA_CLR_DARKRED },; {GRA_CLR_WHITE,GRA_CLR_DARKBLUE },; {GRA_CLR_BLACK,GRA_CLR_DARKGREEN} } aPres := ; { { XBP_PP_COL_HA_FGCLR, GRA_CLR_WHITE },; // Header FG Color { XBP_PP_COL_HA_BGCLR, GRA_CLR_DARKGRAY },; // Header BG Color { XBP_PP_COL_FA_FGCLR, GRA_CLR_YELLOW },; // Footer FG Color { XBP_PP_COL_FA_BGCLR, GRA_CLR_DARKGRAY },; // Footer BG Color { XBP_PP_COL_DA_ROWSEPARATOR, XBPCOL_SEP_DOTTED },; // Row Sep { XBP_PP_COL_DA_COLSEPARATOR, XBPCOL_SEP_DOTTED },; // Col Sep { XBP_PP_COL_HA_ALIGNMENT, XBPALIGN_LEFT },; // Header alignment { XBP_PP_COL_DA_ROWHEIGHT, 20 },; // Row Height { XBP_PP_COL_DA_CELLHEIGHT, 20 } } // Cell Height ****** Отображение таблицы *************** d = 4 @ 41, 0 DCGROUP oGroup1 CAPTION L(' ') SIZE 163, 3.0 @ 1, 1 DCPUSHBUTTON CAPTION 'Сброс колонки MIN-эксперт' SIZE LEN('Сброс колонки MIN-эксперт') -0, 1.5 ACTION {||DelColMinExp() , DC_GetRefresh(GetList)} PARENT oGroup1 @ 1, DCGUI_COL+d DCPUSHBUTTON CAPTION 'Копирование: MIN-программа => MIN-эксперт' SIZE LEN('Копирование: MIN-программа => MIN-эксперт')-5, 1.5 ACTION {||CopyMinProgExp() , DC_GetRefresh(GetList)} PARENT oGroup1 @ 1, DCGUI_COL+d DCPUSHBUTTON CAPTION 'Перерасчет прогноза на основе MIN-эксперт' SIZE LEN('Перерасчет прогноза на основе MIN-эксперт')-5, 1.5 ACTION {||ForeCalcMinExp() , DC_GetRefresh(GetList)} PARENT oGroup1 @ 1, DCGUI_COL+d DCPUSHBUTTON CAPTION 'График: резонансные ЗМТ-программа' SIZE LEN('График: резонансные ЗМТ-программа') -1, 1.5 ACTION {||Chart23212r('Prog'), DC_GetRefresh(GetList)} PARENT oGroup1 @ 1, DCGUI_COL+d DCPUSHBUTTON CAPTION 'График: резонансные ЗМТ-эксперт' SIZE LEN('График: резонансные ЗМТ-программа') -4, 1.5 ACTION {||Chart23212r('Hand'), DC_GetRefresh(GetList)} PARENT oGroup1 PRIVATE bColorBlock:={||IIF(L2_mera=M_MaxValL2, {nil,aColor[153]},IIF(L1_mera=M_MaxValL1,{nil,aColor[107]},IIF(F_mera=M_MaxValF,{nil,aColor[33]},{nil,GRA_CLR_WHITE}))) } // Клиффорд DCSETPARENT TO @ 1, 0 DCBROWSE oBrowse ALIAS 'PrognReson' SIZE 163,40 ; EDIT xbeBRW_ItemSelected MODE DCGUI_BROWSE_EDITDOWN ; PRESENTATION aPres ; FREEZELEFT {1,1} ; // При горизонтальной прокрутке не прокручивать первую 1 колонку COLOR {||IIF(LEN(ALLTRIM(PrognReson->PRAVKA_MIN))>0, {nil,aColor[153]}, IIF(LEN(ALLTRIM(PrognReson->PROGAVRMIN))>0, {nil,aColor[39]}, {nil,GRA_CLR_WHITE}))} DCGETOPTIONS SAYFONT '10.Helv Bold' TABSTOP AUTORESIZE *DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE d1 = 4 d2 = 6 DCBROWSECOL FIELD PrognReson->N1 HEADER 'Дата ' PARENT oBrowse WIDTH 7 COLOR {||{nil,aColor[33]}} PROTECT {|| .T. } * DCBROWSECOL FIELD PrognReson->MO_SUN HEADER 'MO_SUN ' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } * DCBROWSECOL FIELD PrognReson->MO_MA HEADER 'MO_MA ' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } * DCBROWSECOL FIELD PrognReson->MO_JUP HEADER 'MO_JUP ' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } * DCBROWSECOL FIELD PrognReson->MO_SAT HEADER 'MO_SAT ' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } * DCBROWSECOL FIELD PrognReson->MO_UR HEADER 'MO_UR ' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } * DCBROWSECOL FIELD PrognReson->MO_NEP HEADER 'MO_NEP ' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } * DCBROWSECOL FIELD PrognReson->MO_RAHU HEADER 'MO_RAHU ' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } * DCBROWSECOL FIELD PrognReson->MO_APOG HEADER 'MO_APOG ' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } * DCBROWSECOL FIELD PrognReson->MO_MER HEADER 'MO_MER ' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } * DCBROWSECOL FIELD PrognReson->MO_VEN HEADER 'MO_VEN ' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } * DCBROWSECOL FIELD PrognReson->_MO_SUN HEADER '_MO_SUN ' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } * DCBROWSECOL FIELD PrognReson->_MO_MA HEADER '_MO_MA ' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } * DCBROWSECOL FIELD PrognReson->_MO_JUP HEADER '_MO_JUP ' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } * DCBROWSECOL FIELD PrognReson->_MO_SAT HEADER '_MO_SAT ' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } * DCBROWSECOL FIELD PrognReson->_MO_UR HEADER '_MO_UR ' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } * DCBROWSECOL FIELD PrognReson->_MO_NEP HEADER '_MO_NEP ' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } * DCBROWSECOL FIELD PrognReson->_MO_RAHU HEADER '_MO_RAHU ' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } * DCBROWSECOL FIELD PrognReson->_MO_APOG HEADER '_MO_APOG ' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } * DCBROWSECOL FIELD PrognReson->_MO_MER HEADER '_MO_MER ' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } * DCBROWSECOL FIELD PrognReson->_MO_VEN HEADER '_MO_VEN ' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } DCBROWSECOL FIELD PrognReson->PROGN_POLN HEADER 'PROGN_POLN' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } DCBROWSECOL FIELD PrognReson->PROGN_AVR HEADER 'PROGN_AVR ' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } DCBROWSECOL FIELD PrognReson->ZMT_FAKT HEADER 'ZMT_FAKT ' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } DCBROWSECOL FIELD PrognReson->ZMTAVRFAKT HEADER 'ZMTAVRFAKT' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } DCBROWSECOL FIELD PrognReson->PROGNNNORM HEADER 'PROGNNNORM' PARENT oBrowse WIDTH d1 PROTECT {|| .T. } DCBROWSECOL FIELD PrognReson->PROGN_N HEADER 'PROGN_N ' PARENT oBrowse WIDTH d2 PROTECT {|| .T. } DCBROWSECOL FIELD PrognReson->PROGN_NI HEADER 'PROGN_NI ' PARENT oBrowse WIDTH d2 PROTECT {|| .T. } DCBROWSECOL FIELD PrognReson->SUMINT_ZMT HEADER 'SUMINT_ZMT' PARENT oBrowse WIDTH d2 PROTECT {|| .T. } DCBROWSECOL FIELD PrognReson->INT_ZMT_NI HEADER 'INT_ZMT_NI' PARENT oBrowse WIDTH d2 PROTECT {|| .T. } DCBROWSECOL FIELD PrognReson->PROGAVRMIN HEADER 'PROGAVRMIN' PARENT oBrowse WIDTH d2 PROTECT {|| .T. } DCBROWSECOL FIELD PrognReson->PRAVKA_MIN HEADER 'PRAVKA_MIN' PARENT oBrowse WIDTH 3 COLOR {||{nil,aColor[33]}} DCBROWSECOL FIELD PrognReson->PR_PROGNNI HEADER 'PR_PROGNNI' PARENT oBrowse WIDTH d2 PROTECT {|| .T. } DCBROWSECOL FIELD PrognReson->P_INTZMTNI HEADER 'P_INTZMTNI' PARENT oBrowse WIDTH d2 PROTECT {|| .T. } DCREAD GUI ; FIT ; OPTIONS GetOptions ; MODAL ; TITLE L('2.3.2.12. Исправление положения минимумов прогноза ЗМТ') ************************************************************************************************************************** **** Алгоритм расчета колонок ******** * В файле PrognRezon.dbf, который посчитан программой на данных реализации ЗМТ по региону Калифорнии за 2019 год, я добавила следующие 3 поля: PRAVKA_MIN, PRAVKA_PROGN_NI, PRAVKA_INT_ZMT_NI * PROGN_N - это нормированные данные, которые соответствуют данным в графике-прогнозе на 2019 год по Калифорнии. Это поле для поиска минимумов, на графике-прогнозе этим минимумам соответствуют окончания сейсмических циклов. * SUMINT_ZMT - это поле, содержащее реальные данные суточных суммарных показателей интенсивности ЗМТ по региону Калифорнии за 2019 год, которые я беру ежемесячно, делаю сводную таблицу, вставляю в файл Inp_fakt для расчетов в режиме 2.3.2.12, эти данные копируются и в поле SUMINT_ZMT. * PROGAVRMIN - так программа нашла минимумы * Мое поле PRAVKA_MIN - это я поправила минимумы вручную * PROGN_NI - так программа посчитала прогнозные данные с нарастающим итогом из поля PROGN_N (от одного минимума - до последующего минимума) * Мое поле PRAVKA_PROGN_NI - я посчитала вручную нарастающий итог по прогнозу в соответствии с поправленными минимумами. * INT_ZMT_NI - так программа посчитала с нарастающим итогом данные суточных суммарных показателей интенсивности ЗМТ (из поля SUMINT_ZMT) * Мое поле PRAVKA_INT_ZMT_NI - я пересчитала эти данные по поправленным минимумам. ForeCalcMinExp() // Расчет прогноза по исправленным минимумам LB_Warning(L("Перерасчет прогноза резонансов по минимумам, исправленным вручную, успешно завершен!")) * Chart23212r() // Рисует 2 графика ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ***************************************************************************************************************************** ***************************************************************************************************************************** FUNCTION Chart23212r(mPar) // Рисование графиков резонансов, полученного автоматически и по минимумам, исправленным вручную *** Проверить наличие БД PrognReson.dbf ************************* IF ApplChange("") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF IF .NOT. FILE('PrognReson.dbf') LB_Warning(L("Сначала надо сделать прогноз ЗМТ, а потом его корректировать !!! ")) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW Running(.F.) RETURN nil ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE PrognReson EXCLUSIVE NEW SELECT PrognReson DBGOTOP() ***************************************************************** ******** Рисуем график ****************************************** ***************************************************************** * oScr := DC_WaitOn('Немного подождите! Идет формирование изображения в памяти и его масштабирование',,,,,,,,,,,.F.) DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы PRIVATE a23212[8] IF FILE("_23212.arx") // Параметры диалога F2_3_2_12() a23212 = DC_ARestore("_23212.arx") PUBLIC mNumMod := a23212[1] PUBLIC mRegim := a23212[2] PUBLIC mWindow := a23212[3] PUBLIC mXSize := a23212[4] PUBLIC mYSize := a23212[5] PUBLIC mLineWidth := a23212[6] PUBLIC mGamma := a23212[7] PUBLIC mAlfa := a23212[8] ELSE PUBLIC mNumMod := 1 PUBLIC mRegim := 2 PUBLIC mWindow := 7 PUBLIC mXSize := 1800 PUBLIC mYSize := 900 PUBLIC mLineWidth := 7 PUBLIC mGamma := 1 PUBLIC mAlfa := 1 a23212[1] = mNumMod a23212[2] = mRegim a23212[3] = mWindow a23212[4] = mXSize a23212[5] = mYSize a23212[6] = mLineWidth a23212[7] = mGamma a23212[8] = mAlfa DC_ASave(a23212, "_23212.arx") ENDIF DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения * PUBLIC X_MaxW := 1800, Y_MaxW := 900 // Размер графического окна для отображения когнитивных диаграмм в пикселях PUBLIC X_MaxW := mXSize, Y_MaxW := mYSize // Максимальный размер графического окна для отображения 4K. PUBLIC nXSize := X_MaxW PUBLIC nYSize := Y_MaxW ***** 1-й график PROG **************************************************************************************************** IF mPar = 'Prog' // Create new bitmap with given size oPS := XBPPRESSPACE() :new() :Create() oBMP := XBPBITMAP() :New() :Create() oBMP:Make( nXSize, nYSize ) oBMP:presSpace( oPS ) // here your GRA* Code **** Закрасить фон прямоугольника *************** * GraSetColor( oPS, GRA_CLR_WHITE, GRA_CLR_WHITE ) GraSetColor( oPS, BD_LIGHTGREY, BD_LIGHTGREY ) GraBox( oPS, { 0, 0 }, { nXSize, nYSize }, GRA_FILL ) *######################################################################################################################### Chart23212res( oPS, 'Prog' ) // Графическая функция <<<===####################### *######################################################################################################################### *My image original, my image scaled ****** Запись полноразмерного графического файла в папку: M_PathAppl+"Earthquakes\" * DC_Impl(oScr) DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения IF FILEDATE("Earthquakes",16) = CTOD("//") DIRMAKE("Earthquakes") aMess := {} AADD(aMess, L('В папке текущего приложения: "'+UPPER(ALLTRIM(M_PathAppl))+'"')) AADD(aMess, L('не было директории "Earthquakes" для графических форм по прогнозам ЗМТ она была создана!')) // <===####################### AADD(aMess, L('В эту папку записываются исходные изображения высокого качества (без масштабирования)')) LB_Warning(aMess, L('Прогноз землетрясений в системе "Эйдос"')) ENDIF DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения DIRCHANGE(M_PathAppl+"Earthquakes\") // Перейти в папку Earthquakes cFileName = "EarthQuakesResonProg"+STRTRAN(STR(ADIR("*.*")+1,6)," ","0")+".jpg" ERASE(cFileName) oBMP:SaveFile(cFileName,XBPBMP_FORMAT_JPG) IF nWidth > 1800 FullView( cFileName, "по верху", 65 ) // Визуализация полноразмерного файла на мониторе высокого разрешения ELSE ****** Формирование с помощью bmp2bmp() и отображение масштабированного изображения aNewSize := {nWidth,nHeight-29} // Новый размер изображения (еще немного уменьшается, чтобы не рисовать по панели задач) oBMP:loadFile(cFileName) // Загрузка полноразмерного изображения oRet := BMP2BMP(oBMP,aNewSize) // Масштабирование изображения cFileNameScale = SUBSTR(cFileName,1,AT(".jpg",cFileName)-1)+"_scaled.jpg" ERASE(cFileNameScale) oRet:saveFile(cFileNameScale,XBPBMP_FORMAT_JPG) // Запись масштабированного графического файла в в папку приложения для визуализации FullView( cFileNameScale, "по верху", 0 ) // Визуализация масштабированного графического файла на мониторе ограниченного разрешения ENDIF ENDIF ***** 2-й график HAND **************************************************************************************************** ***** Проверка на наличие исправленных минимумов ***** IF mPar = 'Hand' mSumMinHand = 0 DO WHILE .NOT. EOF() IF LEN(ALLTRIM(PrognReson->PRAVKA_MIN)) > 0 // Чтобы можно было вводить не MIN, а любой символ mSumMinHand++ ENDIF DBSKIP(1) ENDDO IF mSumMinHand = 0 aMess := {} AADD(aMess, L('Расчет и визуализация графика прогноза резонансов по минимумам,' )) AADD(aMess, L('исправленным вручную, НЕВОЗМОЖЕН, так как они не проставлены !!!')) LB_Warning(aMess) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW Running(.F.) RETURN nil ENDIF // Create new bitmap with given size oPS := XBPPRESSPACE() :new() :Create() oBMP := XBPBITMAP() :New() :Create() oBMP:Make( nXSize, nYSize ) oBMP:presSpace( oPS ) // here your GRA* Code **** Закрасить фон прямоугольника *************** * GraSetColor( oPS, GRA_CLR_WHITE, GRA_CLR_WHITE ) GraSetColor( oPS, BD_LIGHTGREY, BD_LIGHTGREY ) GraBox( oPS, { 0, 0 }, { nXSize, nYSize }, GRA_FILL ) *######################################################################################################################### Chart23212res( oPS, 'Hand' ) // Графическая функция <<<===####################### *######################################################################################################################### *My image original, my image scaled ****** Запись полноразмерного графического файла в папку: M_PathAppl+"Earthquakes\" * DC_Impl(oScr) DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения IF FILEDATE("Earthquakes",16) = CTOD("//") DIRMAKE("Earthquakes") aMess := {} AADD(aMess, L('В папке текущего приложения: "'+UPPER(ALLTRIM(M_PathAppl))+'"')) AADD(aMess, L('не было директории "Earthquakes" для графических форм по прогнозам ЗМТ она была создана!')) // <===####################### AADD(aMess, L('В эту папку записываются исходные изображения высокого качества (без масштабирования)')) LB_Warning(aMess, L('Прогноз землетрясений в системе "Эйдос"')) ENDIF DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения DIRCHANGE(M_PathAppl+"Earthquakes\") // Перейти в папку Earthquakes cFileName = "EarthQuakesResonHand"+STRTRAN(STR(ADIR("*.*")+1,6)," ","0")+".jpg" ERASE(cFileName) oBMP:SaveFile(cFileName,XBPBMP_FORMAT_JPG) IF nWidth > 1800 FullView( cFileName, "по верху", 65 ) // Визуализация полноразмерного файла на мониторе высокого разрешения ELSE ****** Формирование с помощью bmp2bmp() и отображение масштабированного изображения aNewSize := {nWidth,nHeight-29} // Новый размер изображения (еще немного уменьшается, чтобы не рисовать по панели задач) oBMP:loadFile(cFileName) // Загрузка полноразмерного изображения oRet := BMP2BMP(oBMP,aNewSize) // Масштабирование изображения cFileNameScale = SUBSTR(cFileName,1,AT(".jpg",cFileName)-1)+"_scaled.jpg" ERASE(cFileNameScale) oRet:saveFile(cFileNameScale,XBPBMP_FORMAT_JPG) // Запись масштабированного графического файла в в папку приложения для визуализации FullView( cFileNameScale, "по верху", 0 ) // Визуализация масштабированного графического файла на мониторе ограниченного разрешения ENDIF ENDIF DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE PrognReson EXCLUSIVE NEW SELECT PrognReson DBGOTOP() RETURN nil ***************************************************************************************************************************** ********************************************************************* ****** Визуализация графика ***************************************** ********************************************************************* STATIC FUNCTION Chart23212res( oPS, mPar ) DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы PRIVATE a23212[8] IF FILE("_23212.arx") // Параметры диалога F2_3_2_12() a23212 = DC_ARestore("_23212.arx") PUBLIC mNumMod := a23212[1] PUBLIC mRegim := a23212[2] PUBLIC mWindow := a23212[3] PUBLIC mXSize := a23212[4] PUBLIC mYSize := a23212[5] PUBLIC mLineWidth := a23212[6] PUBLIC mGamma := a23212[7] PUBLIC mAlfa := a23212[8] ELSE PUBLIC mNumMod := 1 PUBLIC mRegim := 2 PUBLIC mWindow := 7 PUBLIC mXSize := 1800 PUBLIC mYSize := 900 PUBLIC mLineWidth := 7 PUBLIC mGamma := 1 PUBLIC mAlfa := 1 a23212[1] = mNumMod a23212[2] = mRegim a23212[3] = mWindow a23212[4] = mXSize a23212[5] = mYSize a23212[6] = mLineWidth a23212[7] = mGamma a23212[8] = mAlfa DC_ASave(a23212, "_23212.arx") ENDIF X_MaxW = mXSize Y_MaxW = mYSize DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения *** Брать данные из разных колонок, а так все остальное одинаково * Графики: * в 1 графике Правка MIN_1, рассчитанном программой, по оси X - Даты, по оси Y - данные из полей PROGN_NI и INT_ZMT_NI * в 2 графике Правка MIN_2,- по моим данным, так должно получаться, , по оси X - Даты, там по оси Y - данные из полей PR_PROGNNI и P_INTZMTNI. aArgName := {} // Наименования градаций (даты в формате: ДД.ММ.ГГГГ) aArg := {} // Значение аргумента для нормирования графика по X aVal := {} // PROGN_NI или PR_PROGNNI aInt := {} // INT_ZMT_NI или P_INTZMTNI CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE PrognReson EXCLUSIVE NEW SELECT PrognReson DBGOTOP() DO CASE CASE mPar = 'Prog' DO WHILE .NOT. EOF() AADD(aArgName, ALLTRIM(FIELDGET(1))) // Дата AADD(aArg , RECNO() ) AADD(aVal , PROGN_NI ) AADD(aInt , INT_ZMT_NI ) DBSKIP(1) ENDDO CASE mPar = 'Hand' // Не рисовать график, если нет ни одного MIN, выдать в этом случае сообщение <<<===###### DO WHILE .NOT. EOF() IF LEN(ALLTRIM(PrognReson->PRAVKA_MIN)) > 0 // Чтобы можно было вводить не MIN, а любой символ mSumMinHand++ ENDIF AADD(aArgName, ALLTRIM(FIELDGET(1))) // Дата AADD(aArg , RECNO() ) AADD(aVal , PR_PROGNNI ) AADD(aInt , P_INTZMTNI ) DBSKIP(1) ENDDO ENDCASE *********************************************************************** *********************************************************************** ****** Поиск макс и мин значений аргумента ****** X_MinA = +99999999 // Минимальное значение X аргумента X_MaxA = -99999999 // Максимальное значение X аргумента FOR j=1 TO LEN(aArg) X_MinA = MIN(X_MinA, aArg[j]) X_MaxA = MAX(X_MaxA, aArg[j]) NEXT N_Arg = LEN(aArg) // Кол-во уникальных значений аргумента n = LEN(aArg) // Кол-во уникальных значений аргумента ****** Поиск макс и мин значений функции ******** Y_MinF = +99999999 // Минимальное значение Y отображаемой функции Y_MaxF = -99999999 // Максимальное значение Y отображаемой функции FOR j=1 TO LEN(aVal) Y_MinF = MIN(Y_MinF, aVal[j]) Y_MaxF = MAX(Y_MaxF, aVal[j]) Y_MinF = MIN(Y_MinF, aInt[j]) Y_MaxF = MAX(Y_MaxF, aInt[j]) NEXT ******************************************************************************************** PRIVATE X0 := 75 PRIVATE Y0 := 165 // Начало координат по осям X и Y с учетом места для легенды PRIVATE W_Wind := X_MaxW - X0 - 25 // Ширина окна для самого графика PRIVATE H_Wind := Y_MaxW - Y0 - 70 // Высота окна для самого графика PRIVATE mNX := 100, mNY := 10 // Кол-во меток и надписей по осям X и Y PRIVATE Kx := W_Wind / ( X_MaxA-X_MinA ) // Коэффициент масштабирования по оси X: преобразует аргумент функции в номер пикселя по оси X PRIVATE Ky := H_Wind / ( Y_MaxF-Y_MinF ) // Коэффициент масштабирования по оси Y: преобразует значение функции в номер пикселя по оси Y PRIVATE Y0A := IF(Y_MinF > 0, Y0, Y0+ABS(Y_MinF)*Ky) // Позиция оси X на оси Y // <===################### **** Написать заголовок диаграммы aFonts := XbpFont():new():list() // Все доступные шрифты oFont := XbpFont():new():create("18.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты Ar_Model := {"Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } DO CASE CASE mPar = 'Prog' mTitle = 'ПРОГНОЗ РЕЗОНАНСНЫХ ЗЕМЛЕТРЯСЕНИЙ МЕТОДОМ Н.А.ЧЕРЕДНИЧЕНКО'+' (минимумы расчитаны программно)' CASE mPar = 'Hand' mTitle = 'ПРОГНОЗ РЕЗОНАНСНЫХ ЗЕМЛЕТРЯСЕНИЙ МЕТОДОМ Н.А.ЧЕРЕДНИЧЕНКО'+' (минимумы исправлены экспертом)' ENDCASE aTxtPar = DC_GraQueryTextbox(mTitle, oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox("Длина текста в пикселях="+ALLTRIM(STR(aTxtPar[1]))+". Высота текста в пикселях="+ALLTRIM(STR(aTxtPar[2]))) GraStringAt( oPS, { X_MaxW/2, Y_MaxW-25 }, mTitle) oFont := XbpFont():new():create("14.Arial Bold") GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты IF LEN(ALLTRIM(M_NameAppl)) < 70 GraStringAt( oPS, { X_MaxW/2, Y_MaxW-52 }, "Приложение: "+'"'+ALLTRIM(M_NameAppl)+'"' ) ELSE GraStringAt( oPS, { X_MaxW/2, Y_MaxW-52 }, '"'+ALLTRIM(M_NameAppl)+'"' ) ENDIF oFont := XbpFont():new():create("10.Arial") GraSetFont( oPS ,oFont ) aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты ***** Закрасить фон прямоугольника *************** GraSetColor( oPS, aColor[98] , aColor[98] ) GraBox( oPS, { X0, Y0 }, { X0+W_Wind, Y0+H_Wind }, GRA_FILL ) GraSetColor( oPS, aColor[222] , aColor[222] ) ***** Нарисовать оси координат ******************* aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 2 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты GraLine( oPS, {X0 , Y0A }, {X0+W_Wind, Y0A } ) // Нарисовать ось X GraLine( oPS, {X0 , Y0 }, {X0 , Y0+H_Wind} ) // Нарисовать границу рамки изображения слева это и есть ось Y GraLine( oPS, {X0 , Y0 }, {X0+W_Wind, Y0 } ) // Нарисовать границу рамки изображения внизу параллельно оси X GraLine( oPS, {X0 , Y0+H_Wind}, {X0+W_Wind, Y0+H_Wind} ) // Нарисовать границу рамки изображения вверху параллельно оси X GraLine( oPS, {X0+W_Wind, Y0 }, {X0+W_Wind, Y0+H_Wind} ) // Нарисовать границу рамки изображения справа параллельно оси Y aAttr := ARRAY( GRA_AM_COUNT ) // Массив для атрибутов маркеров aAttr [ GRA_AM_SYMBOL ] := GRA_MARKSYM_PLUS GraSetAttrMarker( oPS, aAttr ) aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DOT aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты *** Закрасить области между метками на оси X ***** DX = ( X_MaxA-X_MinA ) / mNX // Диапазон значений x, через которое ставить метку GraSetColor( oPS, aColor[99], aColor[99] ) j = 0 FOR X=X_MinA TO X_MaxA STEP 2*DX j = j + 2 X1 = X0 + ( j - 1 ) * DX * Kx X2 = X0 + ( j ) * DX * Kx GraBox( oPS, { X1, Y0 }, { X2, Y0 + H_Wind }, GRA_FILL ) NEXT GraSetColor( oPS, aColor[222], aColor[222] ) *** Сделать сетку и надписать метки на оси X ********************* // <===########### DO CASE CASE 1800 <= X_MaxW .AND. X_MaxW <= 3600 mNNadp = IF(LEN(aArgName) <= 182, LEN(aArgName), 182) // Количество надписей по оси X (больше 182 не помещается) oFont := XbpFont():new():create("8.Arial Bold") CASE 3600 <= X_MaxW .AND. X_MaxW <= 4096 mNNadp = IF(LEN(aArgName) <= 364, LEN(aArgName), 364) // Количество надписей по оси X (больше 364 не помещается) oFont := XbpFont():new():create("6.Arial Bold") ENDCASE GraSetFont( oPS ,oFont ) aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты mNumbLabels = INT(LEN(aArgName) / mNNadp) // Рисовать каждую 1-ю, 2-ю, 3-ю, 4-ю,..., mNumbLabels надпись на оси X aMonth = {'Январь','Февраль','Март','Апрель','Май','Июнь','Июль','Август','Сентябрь','Октябрь','Ноябрь','Декабрь'} mMGold = -1 mGold = -1 FOR j=1 TO LEN(aArgName) X1 = X0 + ( j - 1 ) * Kx GraMarker ( oPS, { X1, Y0 } ) IF j = mNumbLabels * INT(j / mNumbLabels) // Если номер надписи нацело делится на mNumbLabels, то рисовать ее X1 = X0 + ( j - 1 ) * Kx - 5 GraMarker ( oPS, { X1, Y0 } ) GraLine ( oPS, { X1, Y0 }, {X1, Y0+H_Wind} ) // Нарисовать пунктирную линию уровня x ****** Написать наименование месяца и год ****** IF LEN(aArgName) <= 365 mMGnew = VAL(SUBSTR(aArgName[j],4,7)) // Делать надпись при смене месяца и года IF mMGold <> mMGnew mMGold = mMGnew GraStringAt( oPS, { X1, Y0-72 }, aMonth[mMGnew]+','+SUBSTR(aArgName[j],7,4)) ENDIF ELSE mGnew = VAL(SUBSTR(aArgName[j],7,4)) // Делать надпись при смене года IF mGold <> MGnew mGold = MGnew GraStringAt( oPS, { X1, Y0-72 }, SUBSTR(aArgName[j],7,4)) ENDIF ENDIF ENDIF NEXT oFont := XbpFont():new():create("6.Arial") GraSetFont( oPS ,oFont ) aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты FOR j=1 TO LEN(aArgName) IF j = mNumbLabels * INT(j / mNumbLabels) // Если номер надписи нацело делится на mNumbLabels, то рисовать ее X1 = X0 + ( j - 1 ) * Kx aTxtPar = DC_GraQueryTextbox(ALLTRIM(STR(X,15,1)), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox(STR(aTxtPar[1])+" "+STR(aTxtPar[2])) mArgName = aArgName[j] aTxtPar = DC_GraQueryTextbox(mArgName, oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox("Длина текста в пикселях="+ALLTRIM(STR(aTxtPar[1]))+". Высота текста в пикселях="+ALLTRIM(STR(aTxtPar[2]))) aMatrix := GraInitMatrix() // <<<########## GraRotate( oPS, aMatrix, 90, { X1, Y0 }, GRA_TRANSFORM_ADD ) oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) // <<<########## mMM = VAL(SUBSTR(mArgName,4,2)) aAttrF [ GRA_AS_COLOR ] := IF(mMM=2*INT(mMM/2),aColor[12],aColor[190]) GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraStringAt( oPS, { X1-57, Y0 }, mArgName ) // Написать даты (aArgName[j]) вертикально <===############# ENDIF NEXT ****** Не получается отключить режим вращения изображения ****** Вместо отключения можно докрутить до 360 градусов aMatrix := GraInitMatrix() // <<<########## GraRotate( oPS, aMatrix, 0, {900, 425}, GRA_TRANSFORM_REPLACE ) // <<<########## oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) // <<<########## oFont := XbpFont():new():create("10.Arial") GraSetFont( oPS ,oFont ) aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты *** Сделать сетку и надписать метки на оси Y ********************* DY = ( Y_MaxF-Y_MinF ) / mNY // Диапазон значений Y, через которое ставить метку j = 0 FOR Y=Y_MinF TO Y_MaxF STEP DY ++j Y1 = Y0 + ( j - 1 ) * DY * Ky GraMarker ( oPS, { X0 , Y1 } ) aTxtPar = DC_GraQueryTextbox(ALLTRIM(STR(Y,15,1)), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox(STR(aTxtPar[1])+" "+STR(aTxtPar[2])) GraStringAt( oPS, { X0-35, Y1-aTxtPar[2]/2 }, ALLTRIM(STR(Y,15,1)) ) GraLine ( oPS, { X0 , Y1 }, {X0+W_Wind, Y1} ) // Нарисовать пунктирную линию уровня Y NEXT j = mNY Y1 = Y0 + j * DY * Ky GraMarker ( oPS, { X0 , Y1 } ) aTxtPar = DC_GraQueryTextbox(ALLTRIM(STR(Y_MaxF,15,1)), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox(STR(aTxtPar[1])+" "+STR(aTxtPar[2])) GraStringAt( oPS, { X0-35, Y1-aTxtPar[2]/2 }, ALLTRIM(STR(Y_MaxF,15,1)) ) GraLine ( oPS, { X0 , Y1 }, {X0+W_Wind, Y1} ) // Нарисовать пунктирную линию уровня Y ***** Рисование маркеров и отрезков прямых основной линии ************************************ aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT * aAttr [ GRA_AL_COLOR ] := aColor[123] // Задать цвет основной линии (темно-фиолетовый) <<<===################# DO CASE CASE mGamma = 1 // Теплая гамма aAttr [ GRA_AL_COLOR ] := GraMakeRGBColor({040,040,255}) // Задать цвет основной линии (яркий синий) CASE mGamma = 2 // Холодная гамма * aAttr [ GRA_AL_COLOR ] := GraMakeRGBColor({255,040,040}) // Задать цвет основной линии (яркий красный) aAttr [ GRA_AL_COLOR ] := GraMakeRGBColor({000,000,000}) // Задать цвет основной линии (черный) ENDCASE aAttr [ GRA_AL_WIDTH ] := 2 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aVal[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aVal[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT ***** ЭТО СДЕЛАТЬ НА СГЛАЖЕННОЙ КРИВОЙ, А ЗДЕСЬ ТОНКОЙ ЛИНИЕЙ, ЦВЕТА СИНЕЙ ГАММЫ, ЧТОБЫ ЗМТ ОТОБРАЖАТЬ КРАСНЫМ ***** Сделать рисование линий двух цветов, внутри посветлее, а снаружи потемнее (эффект объема) ***** для этого рисовать от внешних частей линии к внутренним уменьшающейся толщиной линии и более светлым цветом ПОВЕРХ РАНЕЕ НАРИСОВАННОГО IF mWindow > 0 DO CASE CASE mGamma = 1 // Теплая гамма DO CASE CASE mLineWidth = 5 aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := aColor[190] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 5 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[156] // Задать цвет внутри линии (темный синий) aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[169] // Задать цвет внутри линии (голубой) aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT CASE mLineWidth = 7 aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := aColor[192] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 7 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[190] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 5 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[156] // Задать цвет внутри линии (темный синий) aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[169] // Задать цвет внутри линии (голубой) aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT CASE mLineWidth = 9 aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := BD_BLACK // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 9 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[192] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 7 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[190] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 5 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[156] // Задать цвет внутри линии (темный синий) aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[169] // Задать цвет внутри линии (голубой) aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT ENDCASE CASE mGamma = 2 // Холодная гамма DO CASE CASE mLineWidth = 5 aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := aColor[14] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 5 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[12] // Задать цвет внутри линии (темный синий) aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[34] // Задать цвет внутри линии (голубой) aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT CASE mLineWidth = 7 aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := aColor[15] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 7 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[14] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 5 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[12] // Задать цвет внутри линии (темный синий) aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[34] // Задать цвет внутри линии (голубой) aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT CASE mLineWidth = 9 aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := BD_BLACK // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 9 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[15] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 7 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[14] // Задать цвет снаружи линии (очень темный синий) aAttr [ GRA_AL_WIDTH ] := 5 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky // <===########################### X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[12] // Задать цвет внутри линии (темный синий) aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[34] // Задать цвет внутри линии (голубой) aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO n X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aInt[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aInt[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT ENDCASE ENDCASE ***** Рисование маркеров на линии IF n <= 64 aAttr := ARRAY( GRA_AM_COUNT ) // Массив для атрибутов маркеров aAttr[ GRA_AM_SYMBOL ] := GRA_MARKSYM_DOT GraSetAttrMarker( oPS, aAttr ) FOR j=1 TO LEN(aArg) X := X0 + (aArg[j]-X_MinA) * Kx Y := Y0A + (aAvr[j]-Y_MinF) * Ky IF LEN(aArg) <= 32 aAttr[ GRA_AM_SYMBOL ] := GRA_MARKSYM_SMALLCIRCLE GraSetAttrMarker( oPS, aAttr ) GraMarker( oPS, { X, Y } ) // отобразить маркер ENDIF aAttr[ GRA_AM_SYMBOL ] := GRA_MARKSYM_DOT GraSetAttrMarker( oPS, aAttr ) GraMarker( oPS, { X, Y } ) // отобразить маркер * GraStringAt( oPS, { X, Y }, '('+ALLTRIM(STR(aAvr[j],15,1))+','+ALLTRIM(STR(aVal[j],15,1))+')') NEXT ENDIF ENDIF ***** Нарисовать оси координат ********************************** aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 2 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты графической линии GraLine( oPS, {X0 , Y0A }, {X0+W_Wind, Y0A } ) // Нарисовать ось X GraLine( oPS, {X0 , Y0 }, {X0 , Y0+H_Wind} ) // Нарисовать границу рамки изображения слева это и есть ось Y GraLine( oPS, {X0 , Y0 }, {X0+W_Wind, Y0 } ) // Нарисовать границу рамки изображения внизу параллельно оси X GraLine( oPS, {X0 , Y0+H_Wind}, {X0+W_Wind, Y0+H_Wind} ) // Нарисовать границу рамки изображения вверху параллельно оси X GraLine( oPS, {X0+W_Wind, Y0 }, {X0+W_Wind, Y0+H_Wind} ) // Нарисовать границу рамки изображения справа параллельно оси Y ****** Легенда *************************************************** Offset = -97 // Смещение вниз относительно нуля Y0 для позиции легенды Interval = 17 ***** Нарисовать рамку легенды aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты графической линии X1 := X0 Y1 := Y0 + Offset X2 := X0 + W_Wind Y2 := Y0 + Offset - 2 * Interval - 22 ***** Закрасить фон прямоугольника *************** GraSetColor( oPS, aColor[129] , aColor[129] ) GraBox( oPS, { X1, Y1 }, { X2, Y2 }, GRA_FILL) GraSetColor( oPS, aColor[222] , aColor[222] ) GraBox( oPS, { X1, Y1 }, { X2, Y2 } ) * GraLine( oPS, { 1300, Y1 }, { 1270, Y2 } ) // Нарисовать вертикальную линию, отделяющую левый комментарий от правого ***** Сделать надписи в легенде aAttr[ GRA_AL_COLOR ] := aColor[17] // Задать цвет линии aAttr[ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK GraSetAttrString( oPS, aAttrF ) * MsgBox(M_PathAppl) DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения IF FILEDATE("Earthquakes",16) = CTOD("//") DIRMAKE("Earthquakes") aMess := {} AADD(aMess, L('В папке текущего приложения: "'+UPPER(ALLTRIM(M_PathAppl))+'"')) AADD(aMess, L('не было директории "EarthQuakes" для графических форм по прогнозам ЗМТ она была создана!')) // <===####################### AADD(aMess, L('В эту папку записываются исходные изображения высокого качества (без масштабирования)')) LB_Warning(aMess, L('Прогноз землетрясений в системе "Эйдос"')) ENDIF DIRCHANGE(M_PathAppl+"EarthqQuakes\") // Перейти в папку EarthQuakes cFileName = "Earthquakes"+STRTRAN(STR(ADIR("*.*")+1,6)," ","0")+".jpg" X1 := X0 + 20 Y1 := Y0 + Offset - Interval X2 := X1 + 190 Y2 := Y0 + Offset - 1 * Interval **** Передача параметров расчета для графика DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения * ar := {} * AADD(ar, mNumMod) * AADD(ar, M_Interval) * AADD(ar, K_GradNClSc) * AADD(ar, K_GradNOpSc) * AADD(ar, mNObj) * DC_ASave(ar, "_23212chart.arx") ar = DC_ARestore("_23212chart.arx") **** Надпись в легенде слева *********** oFont := XbpFont():new():create("12.Arial") GraSetFont( oPS ,oFont ) Y2 := Y0 + Offset - 1 * Interval;GraStringAt( oPS, { X1, Y2-0 }, L('Модель: "') +UPPER(ALLTRIM(Ar_Model[ar[1]]))+'". '+; L('Число интервалов в класс.и опис.шкалах:')+' '+ALLTRIM(STR(ar[3]))+', '+ALLTRIM(STR(ar[4]))+'. '+; L('Тип интервалов:') +' '+IF(ar[2]=1,L('"РАВНЫЕ"'),L('"АДАПТИВНЫЕ"'))+'. '+; L('Число наблюдений в обучающей выборке:') +' '+ALLTRIM(STR(ar[5])) +'. '+; L('Размер интервала сглаживания =') +' '+ALLTRIM(STR(mWindow)) +'. '+; L('Форма создана:')+' '+DTOC(DATE())+"-"+TIME()) ****** Надписи координатных осей ********************************* oFont := XbpFont():new():create("13.ArialBold") GraSetFont( oPS ,oFont ) * AxName = "Дата (день, месяц, год)" * GraStringAt( oPS, { X0+W_Wind/2-8*LEN(AxName)/2, Y0-45 }, AxName ) // Надпись оси Х (СДЕЛАНА ВЫШЕ) AyName = "Суммарная сила факторов, способствующих возникновению землетрясения (норм.знач.)" aMatrix := GraInitMatrix() GraRotate( oPS, aMatrix, 90, { X0-53, Y0+H_Wind/2-8*LEN(AyName)/2 }, GRA_TRANSFORM_ADD ) oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) GraStringAt( oPS, { X0-53, Y0+H_Wind/2-8*LEN(AyName)/2 }, AyName ) // Надпись оси Y ****** Не получается отключить режим вращения изображения ****** Вместо отключения можно докрутить до 360 градусов X_Max := 1800 Y_Max := 850 // Размер графического окна для самого графика в пикселях aMatrix := GraInitMatrix() // <<<########## GraRotate( oPS, aMatrix, 0, {900, 425}, GRA_TRANSFORM_REPLACE ) // <<<########## oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) // <<<########## RETURN NIL **************************************************************************************************************************** ********************************************************** ******** Добавить учебные приложения (лабораторные работы) ********************************************************** #include "dcdialog.ch" #include "appevent.ch" FUNCTION AddsAppls() LOCAL GetList[0], lOk:=.t. LOCAL lCancelled := .F. LOCAL nResult, bError PUBLIC FlagAppl := .F. // Если .T. - новое приложение, если .F. - то уже имеющееся IF FILE("_InstLab.arx") // Файл с информацией о том, какие лаб.работы были установлены прошлый раз aInstLab = DC_ARestore("_InstLab.arx") ELSE AFILL(aInstLab, .F.) DC_ASave(aInstLab, "_InstLab.arx") ENDIF IF FILE("_CurrLab.arx") // Файл с информацией о том, какая лаб.работа прошлый раз была выбрана для установки M_CurrLab = DC_ARestore("_CurrLab.arx") ELSE M_CurrLab = 1 DC_ASave(M_CurrLab, "_CurrLab.arx") ENDIF IF .NOT. FILE("PathGrAp.dbf") GenDbfPaths() ENDIF IF .NOT. FILE("Appls.dbf") GenDbfAppls() ENDIF ****** Задание лабораторных работ для инсталляции nRadio = 1 @ 0, 0 DCGROUP oGroup1 CAPTION L('Задайте, каким путем устанавливать учебные приложения (лабораторные работы):') SIZE 119.0, 18.5 @ 1, 2 DCRADIO nRadio VALUE 1 PROMPT L('1. Лаб.работы 1-го типа, устанавливаемые путем КОПИРОВАНИЯ готовых баз данных учебного приложения:') PARENT oGroup1 @ 2, 2 DCRADIO nRadio VALUE 2 PROMPT L('2. Лаб.работы 2-го типа, устанавливаемые путем РАСЧЕТА исходных баз данных учебного приложения:' ) PARENT oGroup1 @ 3, 2 DCRADIO nRadio VALUE 3 PROMPT L('3. Лаб.работы 3-го типа, устанавливаемые путем ВВОДА из внешних баз исходных данных:' ) PARENT oGroup1 @ 4, 2 DCRADIO nRadio VALUE 4 PROMPT L('4. Лаб.работы 4-го типа, устанавливаемые путем СКАЧИВАНИЯ исходных данных из INTERNET:' ) PARENT oGroup1 @ 6, 1 DCGROUP oGroup2 CAPTION L('1. Лаб.работы 1-го типа, устанавливаемые путем КОПИРОВАНИЯ готовых баз данных учебного приложения:') SIZE 117.0, 11.5 PARENT oGroup1 HIDE {|| nRadio<>1 } @ 1, 2 DCCHECKBOX aInstLab[ 1] PROMPT L('Лаб.раб.№ 1.01: Прогноз пунктов назначения ж/д составов ') PARENT oGroup2 EDITPROTECT {|| nRadio<>1 } HIDE {|| nRadio<>1 } @ 2, 2 DCCHECKBOX aInstLab[ 2] PROMPT L('Лаб.раб.№ 1.02: Прогноз учебных достижений студентов на основе их имиджа ') PARENT oGroup2 EDITPROTECT {|| nRadio<>1 } HIDE {|| nRadio<>1 } @ 3, 2 DCCHECKBOX aInstLab[ 3] PROMPT L('Лаб.раб.№ 1.03: Прогноз учебных достижений студентов на основе их почерка ') PARENT oGroup2 EDITPROTECT {|| nRadio<>1 } HIDE {|| nRadio<>1 } @ 4, 2 DCCHECKBOX aInstLab[ 4] PROMPT L('Лаб.раб.№ 1.04: Прогноз учебн.дост.студ. на основе их социального статуса ') PARENT oGroup2 EDITPROTECT {|| nRadio<>1 } HIDE {|| nRadio<>1 } @ 5, 2 DCCHECKBOX aInstLab[ 5] PROMPT L('Лаб.раб.№ 1.05: Идентификация трехмерных тел по их проекциям ') PARENT oGroup2 EDITPROTECT {|| nRadio<>1 } HIDE {|| nRadio<>1 } @ 6, 2 DCCHECKBOX aInstLab[ 6] PROMPT L('Лаб.раб.№ 1.06: Идентификация правильных тел Платона по их признакам ') PARENT oGroup2 EDITPROTECT {|| nRadio<>1 } HIDE {|| nRadio<>1 } @ 7, 2 DCCHECKBOX aInstLab[ 7] PROMPT L('Лаб.раб.№ 1.07: Идентификация символов по их признакам ') PARENT oGroup2 EDITPROTECT {|| nRadio<>1 } HIDE {|| nRadio<>1 } @ 8, 2 DCCHECKBOX aInstLab[ 8] PROMPT L('Лаб.раб.№ 1.08: Прогнозирование и принятие решений в растениеводстве ') PARENT oGroup2 EDITPROTECT {|| nRadio<>1 } HIDE {|| nRadio<>1 } @ 9, 2 DCCHECKBOX aInstLab[ 9] PROMPT L('Лаб.раб.№ 1.09: Идентификация респондентов по астрономическим данным ') PARENT oGroup2 EDITPROTECT {|| nRadio<>1 } HIDE {|| nRadio<>1 } @10, 2 DCCHECKBOX aInstLab[10] PROMPT L('Лаб.раб.№ 1.10: Идентификация места по признакам (на примере остановок транспорта) ') PARENT oGroup2 EDITPROTECT {|| nRadio<>1 } HIDE {|| nRadio<>1 } // Репозитарий UCI // ЛР, устанавливаемые путем копирования БД *************************************************** @ 1,92 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 1.01') SIZE 22, 1 ACTION {||LC_RunUrl("http://lc.kubagro.ru/aidos/aidos06_lab/lab_01.htm")} PARENT oGroup2 EDITPROTECT {|| nRadio<>1 } HIDE {|| nRadio<>1 } @ 2,92 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 1.02') SIZE 22, 1 ACTION {||LC_RunUrl("http://lc.kubagro.ru/aidos/aidos06_lab/lab_02.htm")} PARENT oGroup2 EDITPROTECT {|| nRadio<>1 } HIDE {|| nRadio<>1 } @ 3,92 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 1.03') SIZE 22, 1 ACTION {||LC_RunUrl("http://lc.kubagro.ru/aidos/aidos06_lab/lab_03.htm")} PARENT oGroup2 EDITPROTECT {|| nRadio<>1 } HIDE {|| nRadio<>1 } @ 4,92 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 1.04') SIZE 22, 1 ACTION {||LC_RunUrl("http://lc.kubagro.ru/aidos/aidos06_lab/lab_04.htm")} PARENT oGroup2 EDITPROTECT {|| nRadio<>1 } HIDE {|| nRadio<>1 } @ 5,92 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 1.05') SIZE 22, 1 ACTION {||LC_RunUrl("http://lc.kubagro.ru/aidos/aidos06_lab/lab_08.htm")} PARENT oGroup2 EDITPROTECT {|| nRadio<>1 } HIDE {|| nRadio<>1 } @ 6,92 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 1.06') SIZE 22, 1 ACTION {||LC_RunUrl("http://lc.kubagro.ru/aidos/index.htm")} PARENT oGroup2 EDITPROTECT {|| nRadio<>1 } HIDE {|| nRadio<>1 } @ 7,92 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 1.07') SIZE 22, 1 ACTION {||TheoryLW1_07()} PARENT oGroup2 EDITPROTECT {|| nRadio<>1 } HIDE {|| nRadio<>1 } @ 8,92 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 1.08') SIZE 22, 1 ACTION {||TheoryLW1_08()} PARENT oGroup2 EDITPROTECT {|| nRadio<>1 } HIDE {|| nRadio<>1 } @ 9,92 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 1.09') SIZE 22, 1 ACTION {||TheoryLW1_09()} PARENT oGroup2 EDITPROTECT {|| nRadio<>1 } HIDE {|| nRadio<>1 } @10,92 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 1.10') SIZE 22, 1 ACTION {||Razrab() } PARENT oGroup2 EDITPROTECT {|| nRadio<>1 } HIDE {|| nRadio<>1 } @ 6, 1 DCGROUP oGroup3 CAPTION L('2. Лаб.работы 2-го типа, устанавливаемые путем РАСЧЕТА исходных баз данных учебного приложения:') SIZE 117.0, 11.5 PARENT oGroup1 HIDE {|| nRadio<>2 } @ 1, 2 DCRADIO M_CurrLab VALUE 11 PROMPT L('Лаб.раб.№ 2.01: Исследование RND-модели, аналогичной текущей ') PARENT oGroup3 EDITPROTECT {|| nRadio<>2 } HIDE {|| nRadio<>2 } @ 2, 2 DCRADIO M_CurrLab VALUE 12 PROMPT L('Лаб.раб.№ 2.02: Исследование свойств нат.чисел при разл.объемах выборки ') PARENT oGroup3 EDITPROTECT {|| nRadio<>2 } HIDE {|| nRadio<>2 } @ 3, 2 DCRADIO M_CurrLab VALUE 13 PROMPT L('Лаб.раб.№ 2.03: Исследование детерминации свойств системы ее структурой ') PARENT oGroup3 EDITPROTECT {|| nRadio<>2 } HIDE {|| nRadio<>2 } @ 4, 2 DCRADIO M_CurrLab VALUE 14 PROMPT L('Лаб.раб.№ 2.04: Исследование зашумленных когнитивных функций ') PARENT oGroup3 EDITPROTECT {|| nRadio<>2 } HIDE {|| nRadio<>2 } @ 5, 2 DCRADIO M_CurrLab VALUE 15 PROMPT L('Лаб.раб.№ 2.05: Исследование нормального распределения ') PARENT oGroup3 EDITPROTECT {|| nRadio<>2 } HIDE {|| nRadio<>2 } @ 6, 2 DCRADIO M_CurrLab VALUE 16 PROMPT L('Лаб.раб.№ 2.06: АСК-анализ изображений (на примере символов) ') PARENT oGroup3 EDITPROTECT {|| nRadio<>2 } HIDE {|| nRadio<>2 } @ 7, 2 DCRADIO M_CurrLab VALUE 17 PROMPT L('Лаб.раб.№ 2.07: Оценка стоимости квартир по параметрам квартиры, дома и района ') PARENT oGroup3 EDITPROTECT {|| nRadio<>2 } HIDE {|| nRadio<>2 } @ 8, 2 DCRADIO M_CurrLab VALUE 18 PROMPT L('Лаб.раб.№ 2.08: АСК-анализ числовых и символьных рядов, в т.ч. псевдослучаных чисел ') PARENT oGroup3 EDITPROTECT {|| nRadio<>2 } HIDE {|| nRadio<>2 } @ 9, 2 DCRADIO M_CurrLab VALUE 19 PROMPT L('Лаб.раб.№ 2.09: Исследование RND-модели при различных объемах выборки ') PARENT oGroup3 EDITPROTECT {|| nRadio<>2 } HIDE {|| nRadio<>2 } @10, 2 DCRADIO M_CurrLab VALUE 20 PROMPT L('Лаб.раб.№ 2.10: в процессе разработки ') PARENT oGroup3 EDITPROTECT {|| nRadio<>2 } HIDE {|| nRadio<>2 } // ЛР, устанавливаемые путем расчета БД ******************************************************* @ 1,92 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 2.01') SIZE 22, 1 ACTION {||LC_RunUrl("http://lc.kubagro.ru/aidos/aidos06_lab/lab_10.htm")} PARENT oGroup3 EDITPROTECT {|| nRadio<>2 } HIDE {|| nRadio<>2 } @ 2,92 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 2.02') SIZE 22, 1 ACTION {||TheoryLW2_02()} PARENT oGroup3 EDITPROTECT {|| nRadio<>2 } HIDE {|| nRadio<>2 } @ 3,92 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 2.03') SIZE 22, 1 ACTION {||TheoryLW2_03()} PARENT oGroup3 EDITPROTECT {|| nRadio<>2 } HIDE {|| nRadio<>2 } @ 4,92 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 2.04') SIZE 22, 1 ACTION {||TheoryLW2_04()} PARENT oGroup3 EDITPROTECT {|| nRadio<>2 } HIDE {|| nRadio<>2 } @ 5,92 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 2.05') SIZE 22, 1 ACTION {||Razrab() } PARENT oGroup3 EDITPROTECT {|| nRadio<>2 } HIDE {|| nRadio<>2 } @ 6,92 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 2.06') SIZE 22, 1 ACTION {||HelpASCAimages()} PARENT oGroup3 EDITPROTECT {|| nRadio<>2 } HIDE {|| nRadio<>2 } @ 7,92 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 2.07') SIZE 22, 1 ACTION {||Razrab() } PARENT oGroup3 EDITPROTECT {|| nRadio<>2 } HIDE {|| nRadio<>2 } @ 8,92 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 2.08') SIZE 22, 1 ACTION {||LC_RunUrl("http://ej.kubagro.ru/2014/05/pdf/22.pdf")} PARENT oGroup3 EDITPROTECT {|| nRadio<>2 } HIDE {|| nRadio<>2 } @ 9,92 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 2.09') SIZE 22, 1 ACTION {||LC_RunUrl("http://lc.kubagro.ru/aidos/aidos06_lab/lab_10.htm")} PARENT oGroup3 EDITPROTECT {|| nRadio<>2 } HIDE {|| nRadio<>2 } @10,92 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 2.10') SIZE 22, 1 ACTION {||Razrab() } PARENT oGroup3 EDITPROTECT {|| nRadio<>2 } HIDE {|| nRadio<>2 } @ 6, 1 DCGROUP oGroup4 CAPTION L('3. Лаб.работы 3-го типа, устанавливаемые путем ВВОДА из внешних баз исходных данных:') SIZE 117.0, 11.5 PARENT oGroup1 HIDE {|| nRadio<>3 } @ 1, 2 DCRADIO M_CurrLab VALUE 21 PROMPT L('Лаб.раб.№ 3.01: Идентификация слов по входящим в них буквам ') PARENT oGroup4 EDITPROTECT {|| nRadio<>3 } HIDE {|| nRadio<>3 } @ 2, 2 DCRADIO M_CurrLab VALUE 22 PROMPT L('Лаб.раб.№ 3.02: Атрибуция анонимных и псевдонимных текстов ') PARENT oGroup4 EDITPROTECT {|| nRadio<>3 } HIDE {|| nRadio<>3 } @ 3, 2 DCRADIO M_CurrLab VALUE 23 PROMPT L('Лаб.раб.№ 3.03: Идентификация предметов по их признакам ') PARENT oGroup4 EDITPROTECT {|| nRadio<>3 } HIDE {|| nRadio<>3 } @ 4, 2 DCRADIO M_CurrLab VALUE 24 PROMPT L('Лаб.раб.№ 3.04: Оценка автомобилей с пробегом по их характеристикам ') PARENT oGroup4 EDITPROTECT {|| nRadio<>3 } HIDE {|| nRadio<>3 } @ 5, 2 DCRADIO M_CurrLab VALUE 25 PROMPT L('Лаб.раб.№ 3.05: Оценка квартир по параметрам квартиры, дома и района ') PARENT oGroup4 EDITPROTECT {|| nRadio<>3 } HIDE {|| nRadio<>3 } @ 6, 2 DCRADIO M_CurrLab VALUE 26 PROMPT L('Лаб.раб.№ 3.06: Прогнозирование и принятие решений в зерновом производстве ') PARENT oGroup4 EDITPROTECT {|| nRadio<>3 } HIDE {|| nRadio<>3 } @ 7, 2 DCRADIO M_CurrLab VALUE 27 PROMPT L('Лаб.раб.№ 3.07: Принятие решений по конфигурированию системы безопасности MS Windows ') PARENT oGroup4 EDITPROTECT {|| nRadio<>3 } HIDE {|| nRadio<>3 } @ 8, 2 DCRADIO M_CurrLab VALUE 28 PROMPT L('Лаб.раб.№ 3.08: Управление номенклатурой и объемами реализации продукции (бенчмаркинг)') PARENT oGroup4 EDITPROTECT {|| nRadio<>3 } HIDE {|| nRadio<>3 } @ 9, 2 DCRADIO M_CurrLab VALUE 29 PROMPT L('Лаб.раб.№ 3.09: Автоматизированный SWOT-анализ и реинжиниринг бизнес процессов ') PARENT oGroup4 EDITPROTECT {|| nRadio<>3 } HIDE {|| nRadio<>3 } @10, 2 DCRADIO M_CurrLab VALUE 30 PROMPT L('Лаб.раб.№ 3.10: Прогноз рисков ДТП и страховых выплат в системе ОСАГО (андеррайтинг) ') PARENT oGroup4 EDITPROTECT {|| nRadio<>3 } HIDE {|| nRadio<>3 } // ЛР, устанавливаемые путем импорта данных из внешних БД ************************************* @ 1,92 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 3.01') SIZE 22, 1 ACTION {||LC_RunUrl("http://ej.kubagro.ru/2004/02/pdf/12.pdf")} PARENT oGroup4 EDITPROTECT {|| nRadio<>3 } HIDE {|| nRadio<>3 } @ 2,92 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 3.02') SIZE 22, 1 ACTION {||LC_RunUrl("http://lc.kubagro.ru/aidos/Works_on_ASK-analysis_of_texts.htm")} PARENT oGroup4 EDITPROTECT {|| nRadio<>3 } HIDE {|| nRadio<>3 } @ 3,92 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 3.03') SIZE 22, 1 ACTION {||Razrab()} PARENT oGroup4 EDITPROTECT {|| nRadio<>3 } HIDE {|| nRadio<>3 } @ 4,92 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 3.04') SIZE 22, 1 ACTION {||LC_RunUrl("http://ej.kubagro.ru/2013/10/pdf/36.pdf")} PARENT oGroup4 EDITPROTECT {|| nRadio<>3 } HIDE {|| nRadio<>3 } @ 5,92 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 3.05') SIZE 22, 1 ACTION {||Razrab()} PARENT oGroup4 EDITPROTECT {|| nRadio<>3 } HIDE {|| nRadio<>3 } @ 6,92 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 3.06') SIZE 22, 1 ACTION {||LC_RunUrl("http://ej.kubagro.ru/2010/05/pdf/07.pdf")} PARENT oGroup4 EDITPROTECT {|| nRadio<>3 } HIDE {|| nRadio<>3 } @ 7,92 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 3.07') SIZE 22, 1 ACTION {||LC_RunUrl("http://ej.kubagro.ru/2010/05/pdf/06.pdf")} PARENT oGroup4 EDITPROTECT {|| nRadio<>3 } HIDE {|| nRadio<>3 } @ 8,92 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 3.08') SIZE 22, 1 ACTION {||LC_RunUrl("http://ej.kubagro.ru/2010/05/pdf/08.pdf")} PARENT oGroup4 EDITPROTECT {|| nRadio<>3 } HIDE {|| nRadio<>3 } @ 9,92 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 3.09') SIZE 22, 1 ACTION {||TheoryLW3_09()} PARENT oGroup4 EDITPROTECT {|| nRadio<>3 } HIDE {|| nRadio<>3 } @10,92 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 3.10') SIZE 22, 1 ACTION {||LC_RunUrl("http://ej.kubagro.ru/2007/05/pdf/08.pdf")} PARENT oGroup4 EDITPROTECT {|| nRadio<>3 } HIDE {|| nRadio<>3 } @ 6, 1 DCGROUP oGroup5 CAPTION L('4. Лаб.работы 4-го типа, устанавливаемые путем СКАЧИВАНИЯ исходных данных из INTERNET:') SIZE 117.0, 11.5 PARENT oGroup1 HIDE {|| nRadio<>4 } @ 1, 2 DCRADIO M_CurrLab VALUE 31 PROMPT L('Лаб.раб.№ 4.01: АСК-анализ мирового времени по данным сайта: "ftp://tai.bipm.org" ') PARENT oGroup5 EDITPROTECT {|| nRadio<>4 } HIDE {|| nRadio<>4 } @ 2, 2 DCRADIO M_CurrLab VALUE 32 PROMPT L('Лаб.раб.№ 4.02: АСК-анализ текстового контента сайтов, найденных по запросам ') PARENT oGroup5 EDITPROTECT {|| nRadio<>4 } HIDE {|| nRadio<>4 } @ 3, 2 DCRADIO M_CurrLab VALUE 33 PROMPT L('Лаб.раб.№ 4.03: в процессе разработки ') PARENT oGroup5 EDITPROTECT {|| nRadio<>4 } HIDE {|| nRadio<>4 } @ 4, 2 DCRADIO M_CurrLab VALUE 34 PROMPT L('Лаб.раб.№ 4.04: в процессе разработки ') PARENT oGroup5 EDITPROTECT {|| nRadio<>4 } HIDE {|| nRadio<>4 } @ 5, 2 DCRADIO M_CurrLab VALUE 35 PROMPT L('Лаб.раб.№ 4.05: в процессе разработки ') PARENT oGroup5 EDITPROTECT {|| nRadio<>4 } HIDE {|| nRadio<>4 } @ 6, 2 DCRADIO M_CurrLab VALUE 36 PROMPT L('Лаб.раб.№ 4.06: в процессе разработки ') PARENT oGroup5 EDITPROTECT {|| nRadio<>4 } HIDE {|| nRadio<>4 } @ 7, 2 DCRADIO M_CurrLab VALUE 37 PROMPT L('Лаб.раб.№ 4.07: в процессе разработки ') PARENT oGroup5 EDITPROTECT {|| nRadio<>4 } HIDE {|| nRadio<>4 } @ 8, 2 DCRADIO M_CurrLab VALUE 38 PROMPT L('Лаб.раб.№ 4.08: в процессе разработки ') PARENT oGroup5 EDITPROTECT {|| nRadio<>4 } HIDE {|| nRadio<>4 } @ 9, 2 DCRADIO M_CurrLab VALUE 39 PROMPT L('Лаб.раб.№ 4.09: в процессе разработки ') PARENT oGroup5 EDITPROTECT {|| nRadio<>4 } HIDE {|| nRadio<>4 } @10, 2 DCRADIO M_CurrLab VALUE 40 PROMPT L('Лаб.раб.№ 4.10: в процессе разработки ') PARENT oGroup5 EDITPROTECT {|| nRadio<>4 } HIDE {|| nRadio<>4 } @ 1,92 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 4.01') SIZE 22, 1 ACTION {|| Razrab() } PARENT oGroup5 EDITPROTECT {|| nRadio<>4 } HIDE {|| nRadio<>4 } @ 2,92 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 4.02') SIZE 22, 1 ACTION {|| Razrab() } PARENT oGroup5 EDITPROTECT {|| nRadio<>4 } HIDE {|| nRadio<>4 } @ 3,92 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 4.03') SIZE 22, 1 ACTION {|| Razrab() } PARENT oGroup5 EDITPROTECT {|| nRadio<>4 } HIDE {|| nRadio<>4 } @ 4,92 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 4.04') SIZE 22, 1 ACTION {|| Razrab() } PARENT oGroup5 EDITPROTECT {|| nRadio<>4 } HIDE {|| nRadio<>4 } @ 5,92 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 4.05') SIZE 22, 1 ACTION {|| Razrab() } PARENT oGroup5 EDITPROTECT {|| nRadio<>4 } HIDE {|| nRadio<>4 } @ 6,92 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 4.06') SIZE 22, 1 ACTION {|| Razrab() } PARENT oGroup5 EDITPROTECT {|| nRadio<>4 } HIDE {|| nRadio<>4 } @ 7,92 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 4.07') SIZE 22, 1 ACTION {|| Razrab() } PARENT oGroup5 EDITPROTECT {|| nRadio<>4 } HIDE {|| nRadio<>4 } @ 8,92 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 4.08') SIZE 22, 1 ACTION {|| Razrab() } PARENT oGroup5 EDITPROTECT {|| nRadio<>4 } HIDE {|| nRadio<>4 } @ 9,92 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 4.09') SIZE 22, 1 ACTION {|| Razrab() } PARENT oGroup5 EDITPROTECT {|| nRadio<>4 } HIDE {|| nRadio<>4 } @10,92 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 4.10') SIZE 22, 1 ACTION {|| Razrab() } PARENT oGroup5 EDITPROTECT {|| nRadio<>4 } HIDE {|| nRadio<>4 } // Добавить новые лаб.работы: 1 расчетную и 9 основанных на исходных данных из Internet. @19, 0 DCGROUP oGroup6 CAPTION L('Как задавать лабораторные работы для изучения') SIZE 119.0, 5.5 @ 1, 2 DCSAY L('Задайте, какие лабораторные работы устанавливать. Для каждой лабораторной работы будет создана новая папка с числовым именем в папке с базовой ') PARENT oGroup6 @ 2, 2 DCSAY L('группой приложений AID_DATA, путь на которую задан в БД PathGrAp.DBF, а также новая запись в БД Appls.dbf с названием учебного приложения и путем ') PARENT oGroup6 @ 3, 2 DCSAY L('на него. После завершения установки лабораторных работ необходимо задать одну из них в качестве текущей и выполнить синтез моделей в 3-й подистеме.') PARENT oGroup6 @ 4, 2 DCSAY L('Описания лабораторных работ есть на сайте автора: http://lc.kubagro.ru/aidos/aidos06_lab/, а также по адресу: http://www.twirpx.com/file/38266/ ') PARENT oGroup6 DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; ADDBUTTONS; OPTIONS GetOptions ; MODAL ; TITLE L('1.3. Задание лабораторных работ для инсталляции') ******************************************************************** IF lExit ** Button Ok ELSE ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ******************************************************************** DC_ASave(aInstLab , "_InstLab.arx") // Файл с информацией о том, установка каких лаб.работ с копируемыми БД задана DC_ASave(M_CurrLab, "_CurrLab.arx") // Файл с информацией о выбранной лабораторной работе с формируемыми БД *LB_Warning(STR(M_CurrLab,19)) *DC_DebugQout( aInstLab, M_CurrLab) IF nRadio = 1 .AND. ASCAN(aInstLab, .T.) = 0 LB_Warning(L("Ни одной лабораторной работы не задано для установки!")) RETURN NIL ENDIF IF nRadio = 2 IF M_CurrLab < 11 .OR. M_CurrLab > 20 LB_Warning(L("Ни одной лабораторной работы не задано для установки!")) RETURN NIL ENDIF ENDIF IF nRadio = 3 IF M_CurrLab < 21 .OR. M_CurrLab > 30 LB_Warning(L("Ни одной лабораторной работы не задано для установки!")) RETURN NIL ENDIF aMess := {} AADD(aMess,L('Сейчас все файлы из папки: '+Disk_dir+'\AID_DATA\Inp_data\ будут удалены!')) AADD(aMess,L('Если какие-то из них нужны, скопируйте их в другое место и нажимите: "OK"')) LB_Warning(aMess) Zap_InpData() // Удалить все файлы из папки Inp_data ENDIF IF nRadio = 4 IF M_CurrLab < 31 .OR. M_CurrLab > 40 LB_Warning(L("Ни одной лабораторной работы не задано для установки!")) RETURN NIL ENDIF ENDIF ***************************************************************************************************** ***************************************************************************************************** // УСТАНОВКА ЛАБОРАТОРНЫХ РАБОТ ******************************** ***************************************************************************************************** ********* Наименования лабораторных работ // Номер ЛР aLabWName := {L('Лаб.раб.№ 1.01: Прогноз пунктов назначения ж/д составов' ),; // 01 // 1. Лаб.работы, устанавливаемые путем КОПИРОВАНИЯ готовых баз данных учебного приложения: L('Лаб.раб.№ 1.02: Прогноз учебных достижений студентов на основе их имиджа' ),; // 02 L('Лаб.раб.№ 1.03: Прогноз учебных достижений студентов на основе их почерка' ),; // 03 L('Лаб.раб.№ 1.04: Прогноз учебн.дост.студ. на основе их социального статуса' ),; // 04 L('Лаб.раб.№ 1.05: Идентификация трехмерных тел по их проекциям' ),; // 05 L('Лаб.раб.№ 1.06: Идентификация правильных тел Платона по их признакам' ),; // 06 L('Лаб.раб.№ 1.07: Идентификация символов по их признакам' ),; // 07 L('Лаб.раб.№ 1.08: Прогнозирование и принятие решений в растениеводстве' ),; // 08 L('Лаб.раб.№ 1.09: Идентификация респондентов по астрономическим данным' ),; // 09 L('Лаб.раб.№ 1.10: Идентификация места по признакам (на примере остановок)' ),; // 10 Новая L('Лаб.раб.№ 2.01: Исследование RND-модели, аналогичной текущей' ),; // 11 // 2. Лаб.работы, устанавливаемые путем РАСЧЕТА исходных баз данных учебного приложения: L('Лаб.раб.№ 2.02: Исследование свойств нат.чисел при разл.объемах выборки' ),; // 12 L('Лаб.раб.№ 2.03: Исследование детерминации свойств системы ее структурой' ),; // 13 L('Лаб.раб.№ 2.04: Исследование зашумленных когнитивных функций' ),; // 14 L('Лаб.раб.№ 2.05: Исследование нормального распределения' ),; // 15 L('Лаб.раб.№ 2.06: АСК-анализ изображений (на примере символов)' ),; // 16 Новая L('Лаб.раб.№ 2.07: В процессе разработки' ),; // 17 Новая L('Лаб.раб.№ 2.08: АСК-анализ числовых и символьных рядов, в т.ч. псевдослучаных чисел' ),; // 18 Новая L('Лаб.раб.№ 2.09: Исследование RND-модели при различных объемах выборки' ),; // 19 Новая L('Лаб.раб.№ 2.10: в процессе разработки' ),; // 20 Новая L('Лаб.раб.№ 3.01: Идентификация слов по входящим в них буквам' ),; // 21 // 3. Лаб.работы, устанавливаемые путем ВВОДА из внешних баз данных с помощью программного интерфейса: L('Лаб.раб.№ 3.02: Атрибуция анонимных и псевдонимных текстов' ),; // 22 L('Лаб.раб.№ 3.03: Идентификация предметов по их признакам' ),; // 23 L('Лаб.раб.№ 3.04: Оценка автомобилей с пробегом по их характеристикам' ),; // 24 L('Лаб.раб.№ 3.05: Оценка квартир по параметрам квартиры, дома и района' ),; // 25 L('Лаб.раб.№ 3.06: Прогнозирование и принятие решений в зерновом производстве' ),; // 26 Новая L('Лаб.раб.№ 3.07: Принятие решений по конфигурированию системы безопасности MS Windows' ),; // 27 Новая L('Лаб.раб.№ 3.08: Управление номенклатурой и объемами реализации продукции (бенчмаркинг)'),; // 28 Новая L('Лаб.раб.№ 3.09: Автоматизированный SWOT-анализ и реинжиниринг бизнес процессов' ),; // 29 Новая L('Лаб.раб.№ 3.10: Прогноз рисков ДТП и страховых выплат в системе ОСАГО (андеррайтинг)' ),; // 30 Новая L('Лаб.раб.№ 4.01: АСК-анализ мирового времени по данным сайта: "ftp://tai.bipm.org"' ),; // 31 Новая L('Лаб.раб.№ 4.02: АСК-анализ текстового контента сайтов, найденных по запросам' ),; // 32 Новая L('Лаб.раб.№ 4.03: в процессе разработки' ),; // 33 Новая L('Лаб.раб.№ 4.04: в процессе разработки' ),; // 34 Новая L('Лаб.раб.№ 4.05: в процессе разработки' ),; // 35 Новая L('Лаб.раб.№ 4.06: в процессе разработки' ),; // 36 Новая L('Лаб.раб.№ 4.07: в процессе разработки' ),; // 37 Новая L('Лаб.раб.№ 4.08: в процессе разработки' ),; // 38 Новая L('Лаб.раб.№ 4.09: в процессе разработки' ),; // 39 Новая L('Лаб.раб.№ 4.10: в процессе разработки' ) } // 40 Новая *@ 1, 2 DCRADIO nRadio VALUE 1 PROMPT L('1. Лаб.работы 1-го типа, устанавливаемые путем КОПИРОВАНИЯ готовых баз данных учебного приложения:') PARENT oGroup1 *@ 2, 2 DCRADIO nRadio VALUE 2 PROMPT L('2. Лаб.работы 2-го типа, устанавливаемые путем РАСЧЕТА исходных баз данных учебного приложения:' ) PARENT oGroup1 *@ 3, 2 DCRADIO nRadio VALUE 3 PROMPT L('3. Лаб.работы 3-го типа, устанавливаемые путем ВВОДА из внешних баз исходных данных:' ) PARENT oGroup1 *@ 4, 2 DCRADIO nRadio VALUE 4 PROMPT L('4. Лаб.работы 4-го типа, устанавливаемые путем СКАЧИВАНИЯ исходных данных из INTERNET:' ) PARENT oGroup1 DO CASE CASE nRadio=1 // 1. Лаб.работы 1-го типа, устанавливаемые путем КОПИРОВАНИЯ готовых баз данных учебного приложения // Подготовка данных для отображения графического прогресс-бар // Определить значение Wsego // Задание максимальной величины параметра Time Wsego = 0 FOR M_CurrLab=1 TO 10 // В этой версии 10 Лаб.работ устанавливается путем копирования БД IF aInstLab[M_CurrLab] // Путь на исходные БД лабораторной работы M_PathLabW = UPPER(ALLTRIM(M_ApplsPath)) + "\LabWorks\LabW"+STRTRAN(STR(M_CurrLab,4)," ","0")+"\" // Кол-во ВСЕХ файлов в папке Лаб.работы № M_CurrLab N_All = ADIR(M_PathLabW+"*.*") Wsego = Wsego + N_All ENDIF NEXT // Отображение стадии исполнения. Будет написано прямо в окне Progress-bar @ 0,0 DCGROUP oGroup1 CAPTION L('Стадии исполнения процесса') FONT "6.Helv" SIZE 105,11.5 ; PARENT oTabPage1 @13,0 DCGROUP oGroup2 CAPTION L('Прогноз времени исполнения') FONT "6.Helv" SIZE 105, 5.0 ; PARENT oTabPage2 s = 1 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 1] FONT "10.Helv" @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 2] FONT "10.Helv" @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 3] FONT "10.Helv" @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 4] FONT "10.Helv" @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 5] FONT "10.Helv" @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 6] FONT "10.Helv" @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 7] FONT "10.Helv" @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 8] FONT "10.Helv" @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 9] FONT "10.Helv" @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[10] FONT "10.Helv" s++ @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay97 FONT "10.HelvBold" s++ @0.2+s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay98 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @1.5+s ,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay99 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @s ,1 DCPROGRESS oProgress ; SIZE 95,1.5 ; PERCENT ; EVERY 1+INT(Wsego/nEvery) ; // Кол-во обновлений изображения MAXCOUNT Wsego ; COLOR GRA_CLR_CYAN // Цвет полосы @s++,97 DCPUSHBUTTON CAPTION L('&Cancel') ; ACTION {||lCancelled:=.T.} OBJECT oButton ; SIZE 7,1.5 DCREAD GUI ; TITLE L('1.3. Установка заданных из 30 учебных приложений (лабораторных работ)') ; PARENT @oDialog ; FIT ; EXIT ; MODAL oDialog:show() ********************************************************************************************************* // Начало отсчета времени для прогнозирования длительности исполнения Time_progress = 0 // Прошло секунд с начала процесса // Процесс может идти больше суток, поэтому для определения // во всех случаях вычисляется время, прошедшее с начала года T_Mess1 = L("Начало:")+" "+TIME() // Начало Sec_1 = (DOY(DATE())-1)*86400+SECONDS() PUBLIC T1 := (DOY(DATE())-1)*86400+SECONDS() // Время предыдущей индикации процесса исполнения PUBLIC T2 := (DOY(DATE())-1)*86400+SECONDS()+1 // Текущее время (1-й раз оно заметно больше T1 чтобы было отображение) PUBLIC T1tp := T1 PUBLIC T2tp := T2 // УСТАНОВКА ЛАБОРАТОРНЫХ РАБОТ ******************************** N_InsLPlan = 0 // Кол-во заданных на установку лабораторных работ (план) N_InsLFakt = 0 // Кол-во фактически установленных лабораторных работ (факт) aFlag := {} // Признак, что лаб.раб.установлена FOR j=1 TO 9 IF aInstLab[j] ++N_InsLPlan // Кол-во заданных на установку лабораторных работ (план) AADD(aFlag,.T.) ELSE AADD(aFlag,.F.) ENDIF NEXT ***************************************************************************************************** // Лаб.работы, устанавливаемые копированием готовых исходных БД: // Для лаб.работ №№1-10 // Исходные БД лаб.работы брать из папки: d:\ALASKA\AIDOS-X\AID_DATA\LabWorks\LabW####\, где: ####-номер лаб.работы // и копировать их в папку: d:\ALASKA\AIDOS-X\AID_DATA\########\, где: ########-номер приложения // Информацию о новом приложении вносить в БД Appls.dbf. Сделать массив имен копируемых файлов. // Файлы Лаб.работ уже должны быть в новом стандарте. Преобразовать их из старого стандарта // в новый и скопировать их в LabWorks\LabW#### надо самому (OldAppls, 5_1) * DIRCHANGE(M_ApplsPath) // Перейти в папку с БД приложений DIRCHANGE(Disk_dir+'\AID_DATA\') // Перейти в папку с БД с системой и баами данных ЛР IF FILEDATE("LabWorks",16) = CTOD("//") DIRMAKE("LabWorks") DIRCHANGE("LabWorks") // Перейти в папку с исходными БД лабораторных работ FOR j=1 TO 30 M_Name = "LabW"+STRTRAN(STR(j,4)," ","0") IF FILEDATE("M_Name",16) = CTOD("//") DIRMAKE(M_Name) ENDIF NEXT Mess = L('В папке с БД приложений "#" не было папки LabWorks для исходных БД лабораторных работ. Обратитесь за ними к разработчику!') Mess = STRTRAN(Mess, "#", UPPER(ALLTRIM(M_ApplsPath))) LB_Warning(Mess, L("1.3. Установка лабораторных работ" )) DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы RETURN NIL ENDIF // Операции, общие для установки первых 9 Лаб.работ, // устанавливаемых путем копирования исходных БД: aFileNameMin := {"Classes.dbf",; "Opis_Sc.dbf",; "Gr_OpSc.dbf",; "Obi_Zag.dbf",; "ObI_Kcl.dbf",; "Obi_Kpr.dbf",; "Rso_Zag.dbf",; "Rso_Kcl.dbf",; "Rso_Kpr.dbf" } // Копировать в папку приложения ВСЕ файлы из папки с исходными файлами Лаб.работы FOR M_CurrLab = 1 TO 9 // В этой версии 10 Лаб.работ устанавливается путем копирования БД (сделать 10 - остановки трамваев) DC_CompleteEvents() // Обработка события Cancel ************* Прерывание процесса по нажатию Cancel ############################################## IF lCancelled // Прерывание процесса по нажатию Cancel LB_Warning(L("Процесс установки учебных приложений был прерван пользователем !!!")) oButton:SetCaption(L('&Ok')) // Деструктурирование окна отображения графического Progress-bar oButton:activate := {||PostAppEvent(xbeP_Close,,,oDialog)} //<<<<<< Add This DC_AppEvent( @lOk ) oDialog:Destroy() * aSave_adds := DC_DataSave() // Сохранение вычислительной среды (открытые и текущие БД и индексы) DC_DataRest( aSave_adds ) // Восстановление вычислительной среды (открытые и текущие БД и индексы) DIRCHANGE(Disk_dir) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE USERS INDEX ON Kod_AdmApp TO USERS CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE APPLS NEW INDEX ON Kod_AdmApp TO APPLS USE USERS INDEX USERS EXCLUSIVE SELECT Users DO CASE CASE Flag_SysAdmin = .T. SET FILTER TO // Сисадмин видит все CASE Flag_AdmAppl = .T. SET FILTER TO Kod_AdmApp = M_KodAdmAppls // Адм.прил. и пользователь CASE Flag_User = .T. // Видят только свои приложения SET FILTER TO Kod_AdmApp = M_KodAdmAppls OTHERWISE LB_Warning(L("Этот режим доступен только после авторизации в режиме 1.1 !!!")) RETURN NIL ENDCASE *DBGOTOP();DBGOBOTTOM();DBGOTOP() USE APPLS INDEX APPLS EXCLUSIVE NEW SELECT Appls RETURN NIL ENDIF ************* Прерывание процесса по нажатию Cancel ############################################## IF aInstLab[M_CurrLab] aSay[M_CurrLab]:SetCaption(aLabWName[M_CurrLab]) // Путь на исходные БД лабораторной работы * M_PathLabW = UPPER(ALLTRIM(M_ApplsPath)) + "\LabWorks\LabW"+STRTRAN(STR(M_CurrLab,4)," ","0")+"\" M_PathLabW = UPPER(ALLTRIM(Disk_dir+'\AID_DATA')) + "\LabWorks\LabW"+STRTRAN(STR(M_CurrLab,4)," ","0")+"\" // Лаб.раб. в папке с системой N_All = ADIR(M_PathLabW+"*.*") PRIVATE aFileNameAll[N_All] ADIR(M_PathLabW+"*.*",aFileNameAll) // Имена ВСЕХ файлов в папке Лаб.работы ASORT(aFileNameAll) IF N_All > 0 // Проверка наличия всех исходных БД устанавливаемой лабораторной работы FOR j=1 TO LEN(aFileNameMin) Name_SS = M_PathLabW+aFileNameMin[j] IF .NOT. FILE(Name_SS) // Существует ли обязательная исходная БД aFlag[M_CurrLab] = .F. ENDIF NEXT // Если все обязательные исходные БД Лаб.работы существуют, то создание нового приложения // и копирование ВСЕХ ФАЙЛОВ Лаб.работы (а не только обязательных) в папку нового приложения IF .NOT. aFlag[M_CurrLab] aSay[M_CurrLab]:SetCaption(aSay[M_CurrLab]:caption+L(' - Нет исходных БД')) ELSE // Создать папку приложения - новой лабораторной работы // Путь на БД новой лабораторной работы в папке приложений M_NewAppl = ADD_ZAPPL(aLabWName[M_CurrLab]) FOR j=1 TO LEN(aFileNameAll) Name_SS = M_PathLabW+aFileNameAll[j] Name_DD = M_NewAppl +aFileNameAll[j] * LB_Warning(L("Источник: "+Name_SS+", приемник: "+Name_DD)) COPY FILE (Name_SS) TO (Name_DD) lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) NEXT // Добавить информацию о новом учебном приложении в БД Appls.dbf SELECT Appls ++N_InsLFakt aSay[M_CurrLab]:SetCaption(aSay[M_CurrLab]:caption+L(' - Готово ')) ENDIF ENDIF ENDIF NEXT CASE nRadio=3 // 3. Лаб.работы 3-го типа, устанавливаемые путем ВВОДА из внешних баз исходных данных с помощью программного интерфейса 2.3.2.2. DIRCHANGE(M_ApplsPath) // Перейти в папку с БД приложений IF FILEDATE("LabWorks",16) = CTOD("//") DIRMAKE("LabWorks") DIRCHANGE("LabWorks") // Перейти в папку с исходными БД лабораторных работ FOR j=21 TO 30 M_Name = "LabW"+STRTRAN(STR(j,4)," ","0") IF FILEDATE("M_Name",16) = CTOD("//") DIRMAKE(M_Name) ENDIF NEXT Mess = L('В папке с БД приложений "#" не было папки LabWorks для исходных БД лабораторных работ. Обратитесь за ними к разработчику!') Mess = STRTRAN(Mess, "#", UPPER(ALLTRIM(M_ApplsPath))) LB_Warning(Mess, L("1.3. Установка лабораторных работ") ) DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы RETURN NIL ENDIF aFileNameMin := {"Inp_data.xls",; // Файлы для копирования "_2_3_2_2.arx" } M_PathLabW = UPPER(ALLTRIM(M_ApplsPath)) + "\LabWorks\LabW"+STRTRAN(STR(M_CurrLab,4)," ","0")+"\" // Путь на исходные БД лабораторной работы // Если файлы для копирования существуют, то создание нового приложения // и копирование этих файлов в папку нового приложения и в папку системы Name_SS1 = M_PathLabW+"Inp_data.xls" Name_SS2 = M_PathLabW+"_2_3_2_2.arx" IF .NOT. FILE(Name_SS1) aMess := {} AADD(aMess, L('Файла: "'+Name_SS1+'" не существует!')) AADD(aMess, L('Варианты решения проблемы:')) AADD(aMess, L('1. Скачать лабораторную работу из облака в режиме 1.3, если она там есть.')) AADD(aMess, L('2. Скачать полную инсталляцию системы с сайта разработчика: http://lc.kubagro.ru/aidos/_Aidos-X.htm')) AADD(aMess, L('3. Обратиться к разработчику по электронной почте: prof.lutsenko@gmail.com')) AADD(aMess, L('4. Изучить другую лабораторную работу, например 2-го типа (в которых исх.данные рассчитываются).')) LB_Warning(aMess, L('(C) Универсальная когнитивная аналитическая система "Эйдос-Х++"')) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF IF .NOT. FILE(Name_SS2) aMess := {} AADD(aMess, L("Файла: "+Name_SS2+" не существует!")) AADD(aMess, L("Обращайтесь к разработчику или" )) AADD(aMess, L("скачивайте лаб.работу из облака!" )) LB_Warning(aMess, L('(C) Универсальная когнитивная аналитическая система "Эйдос-Х++"')) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF // Создать папку приложения - новой лабораторной работы *** Потом в 2.3.2.2 эта папка создается повторно, поэтому здесь ее создавать не надо, или наоборот здесь создавать, а в 2.3.2.2 не надо ########## M_NewAppl = ADD_ZAPPL(aLabWName[M_CurrLab]) // Путь на БД новой лабораторной работы в папке приложений и наименование ЛР в БД приложений // Создание пустых баз данных нового приложения DIRCHANGE(M_NewAppl) // Перейти в папку с новым приложением и создать БД формализации предметной области: GenDbfClSc(.F.) // Классификационные шкалы ######### GenDbfGrClSc(.F.) // Градации классификационных шкал ######### GenDbfClass(.F.) // Классификационные шкалы и градации GenDbfOpSc(.F.) // Описательные шкалы GenDbfGrOpSc(.F.) // Градации описательных шкал GenDbfAttr(.F.) // Описательные шкалы и градации ######### GenDbfObiZag() // Заголовки объектов обучающей выборки GenDbfObiKcl() // Коды классов объектов обучающей выборки GenDbfObiKpr() // Коды признаков объектов обучающей выборки GenDbfRsoZag() // Заголовки объектов распознаваемой выборки GenDbfRsoKcl() // Коды классов объектов распознаваемой выборки GenDbfRsoKpr() // Коды признаков объектов распознаваемой выборки ******** Копирование файлов из папки лаб.работы в папки для работы Name_SS1 = M_PathLabW+"Inp_data.xls" Name_SS2 = M_PathLabW+"_2_3_2_2.arx" Name_DD1 = M_NewAppl +"Inp_data.xls" Name_DD2 = Disk_dir +"\Aid_data\Inp_data\Inp_data.xls" IF FILE( Name_DD2 ) IF IsFileOpened( Name_DD2 ) aMess := {} AADD(aMess, L('Файл # используется внешней программой!' )) AADD(aMess, L('Пожалуйста, закройте его и повторите операцию!')) aMess[1] = STRTRAN(aMess[1], "#", ALLTRIM(Name_DD2) ) LB_Warning(aMess, L('(C) Универсальная когнитивная аналитическая система "Эйдос-Х++"')) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Del_Appl() // Удалить недосозданное приложение Running(.F.) RETURN NIL ENDIF ENDIF * LB_Warning(L("Источник: "+Name_SS1+", приемник: "+Name_DD1) * LB_Warning(L("Источник: "+Name_SS1+", приемник: "+Name_DD2) * COPY FILE (Name_SS1) TO (Name_DD1) COPY FILE (Name_SS1) TO (Name_DD2) Name_SS2 = M_PathLabW+"_2_3_2_2.arx" Name_DD3 = M_NewAppl +"_2_3_2_2.arx" // Папка приложений Name_DD4 = Disk_dir +"\_2_3_2_2.arx" // Папка системы * LB_Warning(L("Источник: "+Name_SS2+", приемник: "+Name_DD3) * LB_Warning(L("Источник: "+Name_SS2+", приемник: "+Name_DD4) COPY FILE (Name_SS2) TO (Name_DD3) COPY FILE (Name_SS2) TO (Name_DD4) F2_3_2_2(aLabWName[M_CurrLab],"1.3()") // Запуск универсального программного интерфейса с внешними базами данных aMess := {} mLW = ALLTRIM(aLabWName[M_CurrLab]) AADD(aMess, STRTRAN(L(mLW), ":", ': "')+L('" успешно установлена!')) AADD(aMess, L(" ")) AADD(aMess, L("Для дальнейшего ее изучения и выполнения необходимо:")) AADD(aMess, L(" ")) AADD(aMess, L("1. Открыть файл исходных данных:"+' '+Name_DD2+".")) AADD(aMess, L(" ")) AADD(aMess, L("2. Прочитать описание данной лабораторной работы в режиме 5.14.")) AADD(aMess, L(" ")) AADD(aMess, L("3. Выполнить режимы: 2.1, 2.2, 2.3.1, 3.5, 5.5, 3.4 и другие")) AADD(aMess, L(" в соответствии со схемой преобразования данных в информацию,")) AADD(aMess, L(" а ее в знания, приведенной в режиме 6.4.")) LB_Warning(aMess, L('(C) Универсальная когнитивная аналитическая система "Эйдос-Х++"')) N_InsLPlan = 1 N_InsLFakt = 1 CASE nRadio=2 // 2. Лаб.работы 2-го типа, устанавливаемые путем РАСЧЕТА исходных баз данных учебного приложения N_InsLPlan = 1 // Кол-во заданных на установку лабораторных работ (план) N_InsLFakt = 0 // Кол-во фактически установленных лабораторных работ (факт) DO CASE ***************************************************************************************************** // Лаб.работы, устанавливаемые путем расчета исходных БД: CASE M_CurrLab=11 // Лаб.раб.№ 11: Исследование RND-модели при различных объемах выборки <<<===################## // Перейти в папку выбранного приложения, если оно есть, узнать параметры модели, // а если его нет - задать параметры модели по умолчанию IF ApplChange("") nRadio1 := 2 // Нет текущего приложения, задавать параметры вручную N_Csc = 10 // Кол-во класс.шкал N_Gcs = 30 // Суммарное кол-во градаций клас.шкал (классов) N_Osc = 10 // Кол-во опис.шкал N_Gos = 30 // Суммарное кол-во градаций опис.шкал (признаков) N_Obj = 30 // Кол-во объектов обучающей выборки N_AvrGcs = 5 // Среднее кол-во классов в объекте обучающей выборки N_AvrGos = 20 // Среднее кол-во признаков в объекте обучающей выборки N_AvrGrCs = 3 // Среднее кол-во градаций в клас.шкале N_AvrGrOs = 3 // Среднее кол-во градаций в опис.шкале N_Cls = N_Gcs N_ObiKcl = N_AvrGcs*N_Obj/4 // Кол-во записей в БД кодов классов обучающей выборки N_ObiKpr = N_AvrGos*N_Obj/7 // Кол-во записей в БД кодов признаков обучающей выборки ELSE nRadio1 := 1 // Есть текущее приложение, определять параметры автоматически с возможностью последующей корректировки CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Class_Sc EXCLUSIVE NEW;N_Csc = RECCOUNT() USE Gr_ClSc EXCLUSIVE NEW;N_Gcs = RECCOUNT();N_Cls = N_Gcs USE Opis_Sc EXCLUSIVE NEW;N_Osc = RECCOUNT() USE Gr_OpSc EXCLUSIVE NEW;N_Gos = RECCOUNT() USE Obi_zag EXCLUSIVE NEW;N_Obj = RECCOUNT() USE Obi_Kcl EXCLUSIVE NEW;N_ObiKcl = RECCOUNT() // Кол-во записей в БД кодов классов обучающей выборки USE Obi_Kpr EXCLUSIVE NEW;N_ObiKpr = RECCOUNT() // Кол-во записей в БД кодов признаков обучающей выборки N_AvrGrCs = N_Gcs/N_Csc // Верно N_AvrGrOs = N_Gos/N_Osc // Верно N_AvrGcs = N_ObiKcl/N_Obj*4 // <<<===############## Определить непосредственно по БД N_AvrGos = N_ObiKpr/N_Obj*7 // <<<===############## Определить непосредственно по БД ENDIF @ 0,0 DCGROUP oGroup1 CAPTION L('Задание параметров RND-модели:') SIZE 98, 34 @ 1-0.2,2 DCRADIO nRadio1 VALUE 1 PROMPT L('Определить автоматически на основе текущего приложения') PARENT oGroup1 @ 2-0.2,2 DCRADIO nRadio1 VALUE 2 PROMPT L('Задать произвольные параметры RND-модели вручную' ) PARENT oGroup1 @ 4-0.7,1 DCGROUP oGroup2 CAPTION L('Автоматическое определение параметров RND-модели на основе текущего приложения') SIZE 96, 11.5 PARENT oGroup1 HIDE {|| .NOT.nRadio1=1 } Mess1 = L('<- Количество классификационных шкал в RND_модели' ) Mess2 = L('<- Количество классов (градаций классификационных шкал) в RND-модели' ) Mess3 = L('<- Количество описательных шкал в RND_модели' ) Mess4 = L('<- Количество признаков (градаций описательных шкал) в RND-модели' ) Mess5 = L('<- Количество объектов обучающей выборки в RND-модели' ) Mess6 = L('<- Оценка среднего количества классов, к которым относится объект обучающей выборки') Mess7 = L('<- Оценка среднего количества признаков у объекта обучающей выборки' ) Mess8 = L('<- Среднее количество градаций в классификационной шкале (округлено до целых)' ) Mess9 = L('<- Среднее количество градаций в описательной шкале (округлено до целых)' ) @ 1,1 DCSAY L("Наименование текущего приложения: ")+ALLTRIM(M_NameAppl) PARENT oGroup2 HIDE {|| .NOT.nRadio1=1 } @ 2,0.2 DCSAY N_Csc PARENT oGroup2 PICTURE "###############" EDITPROTECT {|| .NOT.nRadio1=1 } HIDE {|| .NOT.nRadio1=1 } @ 3,0.2 DCSAY N_Gcs PARENT oGroup2 PICTURE "###############" EDITPROTECT {|| .NOT.nRadio1=1 } HIDE {|| .NOT.nRadio1=1 } @ 4,0.2 DCSAY N_Osc PARENT oGroup2 PICTURE "###############" EDITPROTECT {|| .NOT.nRadio1=1 } HIDE {|| .NOT.nRadio1=1 } @ 5,0.2 DCSAY N_Gos PARENT oGroup2 PICTURE "###############" EDITPROTECT {|| .NOT.nRadio1=1 } HIDE {|| .NOT.nRadio1=1 } @ 6,0.2 DCSAY N_Obj PARENT oGroup2 PICTURE "###############" EDITPROTECT {|| .NOT.nRadio1=1 } HIDE {|| .NOT.nRadio1=1 } @ 7,0.2 DCSAY N_AvrGcs PARENT oGroup2 PICTURE "###############" EDITPROTECT {|| .NOT.nRadio1=1 } HIDE {|| .NOT.nRadio1=1 } @ 8,0.2 DCSAY N_AvrGos PARENT oGroup2 PICTURE "###############" EDITPROTECT {|| .NOT.nRadio1=1 } HIDE {|| .NOT.nRadio1=1 } @ 9,0.2 DCSAY N_AvrGrCs PARENT oGroup2 PICTURE "###############" EDITPROTECT {|| .NOT.nRadio1=1 } HIDE {|| .NOT.nRadio1=1 } @10,0.2 DCSAY N_AvrGrOs PARENT oGroup2 PICTURE "###############" EDITPROTECT {|| .NOT.nRadio1=1 } HIDE {|| .NOT.nRadio1=1 } @ 2,24 DCSAY Mess1 PARENT oGroup2 HIDE {|| .NOT.nRadio1=1 } @ 3,24 DCSAY Mess2 PARENT oGroup2 HIDE {|| .NOT.nRadio1=1 } @ 4,24 DCSAY Mess3 PARENT oGroup2 HIDE {|| .NOT.nRadio1=1 } @ 5,24 DCSAY Mess4 PARENT oGroup2 HIDE {|| .NOT.nRadio1=1 } @ 6,24 DCSAY Mess5 PARENT oGroup2 HIDE {|| .NOT.nRadio1=1 } @ 7,24 DCSAY Mess6 PARENT oGroup2 HIDE {|| .NOT.nRadio1=1 } @ 8,24 DCSAY Mess7 PARENT oGroup2 HIDE {|| .NOT.nRadio1=1 } @ 9,24 DCSAY Mess8 PARENT oGroup2 HIDE {|| .NOT.nRadio1=1 } @10,24 DCSAY Mess9 PARENT oGroup2 HIDE {|| .NOT.nRadio1=1 } @ 4-0.7,1 DCGROUP oGroup3 CAPTION L('Задание произвольных параметров RND-модели вручную') SIZE 96, 11.5 PARENT oGroup1 HIDE {|| .NOT.nRadio1=2 } Mess1 = L('<- Количество классификационных шкал в RND_модели' ) Mess2 = L('<- Количество классов (градаций классификационных шкал) в RND-модели') Mess3 = L('<- Количество описательных шкал в RND_модели' ) Mess4 = L('<- Количество признаков (градаций описательных шкал) в RND-модели' ) Mess5 = L('<- Количество объектов обучающей выборки в RND-модели' ) Mess6 = L('<- Количество классов, к которым относится объект обучающей выборки' ) Mess7 = L('<- Количество признаков у объекта обучающей выборки' ) Mess8 = L('<- Количество градаций в классификационной шкале' ) Mess9 = L('<- Количество градаций в описательной шкале' ) @ 1,1 DCSAY L("Наименование текущего приложения: ")+ALLTRIM(M_NameAppl) PARENT oGroup3 HIDE {|| .NOT.nRadio1=2 } @ 2,0.2 DCSAY L(" ") GET N_Csc PARENT oGroup3 PICTURE "###############" EDITPROTECT {|| .NOT.nRadio1=2 } HIDE {|| .NOT.nRadio1=2 } @ 3,0.2 DCSAY L(" ") GET N_Gcs PARENT oGroup3 PICTURE "###############" EDITPROTECT {|| .NOT.nRadio1=2 } HIDE {|| .NOT.nRadio1=2 } @ 4,0.2 DCSAY L(" ") GET N_Osc PARENT oGroup3 PICTURE "###############" EDITPROTECT {|| .NOT.nRadio1=2 } HIDE {|| .NOT.nRadio1=2 } @ 5,0.2 DCSAY L(" ") GET N_Gos PARENT oGroup3 PICTURE "###############" EDITPROTECT {|| .NOT.nRadio1=2 } HIDE {|| .NOT.nRadio1=2 } @ 6,0.2 DCSAY L(" ") GET N_Obj PARENT oGroup3 PICTURE "###############" EDITPROTECT {|| .NOT.nRadio1=2 } HIDE {|| .NOT.nRadio1=2 } @ 7,0.2 DCSAY L(" ") GET N_AvrGcs PARENT oGroup3 PICTURE "###############" EDITPROTECT {|| .NOT.nRadio1=2 } HIDE {|| .NOT.nRadio1=2 } @ 8,0.2 DCSAY L(" ") GET N_AvrGos PARENT oGroup3 PICTURE "###############" EDITPROTECT {|| .NOT.nRadio1=2 } HIDE {|| .NOT.nRadio1=2 } @ 9,0.2 DCSAY L(" ") GET N_AvrGrCs PARENT oGroup3 PICTURE "###############" EDITPROTECT {|| .NOT.nRadio1=2 } HIDE {|| .NOT.nRadio1=2 } @10,0.2 DCSAY L(" ") GET N_AvrGrOs PARENT oGroup3 PICTURE "###############" EDITPROTECT {|| .NOT.nRadio1=2 } HIDE {|| .NOT.nRadio1=2 } @ 2,24 DCSAY Mess1 PARENT oGroup3 HIDE {|| .NOT.nRadio1=2 } @ 3,24 DCSAY Mess2 PARENT oGroup3 HIDE {|| .NOT.nRadio1=2 } @ 4,24 DCSAY Mess3 PARENT oGroup3 HIDE {|| .NOT.nRadio1=2 } @ 5,24 DCSAY Mess4 PARENT oGroup3 HIDE {|| .NOT.nRadio1=2 } @ 6,24 DCSAY Mess5 PARENT oGroup3 HIDE {|| .NOT.nRadio1=2 } @ 7,24 DCSAY Mess6 PARENT oGroup3 HIDE {|| .NOT.nRadio1=2 } @ 8,24 DCSAY Mess7 PARENT oGroup3 HIDE {|| .NOT.nRadio1=2 } @ 9,24 DCSAY Mess8 PARENT oGroup3 HIDE {|| .NOT.nRadio1=2 } @10,24 DCSAY Mess9 PARENT oGroup3 HIDE {|| .NOT.nRadio1=2 } @15+0.2,1 DCGROUP oGroup4 CAPTION L('Что такое RND-модель?' ) SIZE 96, 7.5 PARENT oGroup1 @23+0.1,1 DCGROUP oGroup5 CAPTION L('Зачем создается и исследуется RND-модель?') SIZE 96, 10.2 PARENT oGroup1 @ 1,2 DCSAY L('RND-модель - это модель, в которой принадлежность объектов обучающей выборки к классам является случайной, ') PARENT oGroup4 @ 2,2 DCSAY L('как и признаки объектов. Для генерации случайных кодов классов и признаков используется числовой генератор ') PARENT oGroup4 @ 3,2 DCSAY L('равномерно распределенных случайных чисел. При автоматическом определении параметров RND-модели на основе ') PARENT oGroup4 @ 4,2 DCSAY L('текущей модели количество классов, признаков и объектов обучающей выборки в RND-модели будет таким же, как ') PARENT oGroup4 @ 5,2 DCSAY L('в текущей модели. Среднее количество классов, к которым относится объект обучающей выборки и среднее коли- ') PARENT oGroup4 @ 6,2 DCSAY L('чество признаков у него также будет совпадать с этими характеристиками объектов обуч.выборки текущей модели. ') PARENT oGroup4 @ 1,2 DCSAY L('Информацию об объектах обучающей выборки текущей модели можно считать суммой полезной информации о них ') PARENT oGroup5 @ 2,2 DCSAY L('(полезный сигнал) и шума. В RND-модели вся информация представляет собой шум. Поэтому сравнение этих моделей, ') PARENT oGroup5 @ 3,2 DCSAY L('не отличающихся перечисленными параметрами, позволяет оценить влияние значимой информации и шума на результаты,') PARENT oGroup5 @ 4,2 DCSAY L('в частности убедиться в наличии самой этой значимой информации, т.е. закономерностей в предметной области, а ') PARENT oGroup5 @ 5,2 DCSAY L('также оценить эффективность различных стат.моделей и моделей знаний и интегральных критериев для выявления и ') PARENT oGroup5 @ 6,2 DCSAY L('исследования этой значимой информации, знаний и закономерностей. При увеличении объема обучающей выборки в RND-') PARENT oGroup5 @ 7,2 DCSAY L('модели вероятность верной идентификации стремится к вероятности случайного угадывания, а в реальной модели к ') PARENT oGroup5 @ 8,2 DCSAY L('некоторому пределу, превосходящему вероятность случайного угадывания и характеризующему эффективность модели ') PARENT oGroup5 @ 9,2 DCSAY ('и целесообразность ее применения. ') PARENT oGroup5 DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; OPTIONS GetOptions ; ADDBUTTONS ; MODAL ; TITLE L('1.3. Задание параметров RND-модели') ************************************************************************************************** *************************************************** IF lExit ** Button Ok ELSE ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF *************************************************** IF N_Csc * N_Osc * N_Gos * N_Gcs * N_Obj * N_AvrGcs * N_AvrGos * N_AvrGrOs * N_AvrGrCs = 0 LB_Warning(L("Параметры модели равные нулю недопустимы !!!")) Running(.F.) RETURN NIL ENDIF // Начало отсчета времени для прогнозирования длительности исполнения Time_progress = 0 // Прошло секунд с начала процесса // Процесс может идти больше суток, поэтому для определения // во всех случаях вычисляется время, прошедшее с начала года T_Mess1 = L("Начало:")+" "+TIME() // Начало Sec_1 = (DOY(DATE())-1)*86400+SECONDS() PUBLIC T1 := (DOY(DATE())-1)*86400+SECONDS() // Время предыдущей индикации процесса исполнения PUBLIC T2 := (DOY(DATE())-1)*86400+SECONDS()+1 // Текущее время (1-й раз оно заметно больше T1 чтобы было отображение) PUBLIC T1tp := T1 PUBLIC T2tp := T2 // Определить значение Wsego // Задание максимальной величины параметра Time ################################################# Wsego = 1 + N_Csc + N_Osc + N_Obj + 1 IF nRadio1 = 1 Wsego = N_ObiKcl + N_ObiKpr + Wsego ENDIF ************************************************************************************************** // Подготовка данных для отображения графического прогресс-бар // Отображение стадии исполнения. Будет написано прямо в окне Progress-bar @ 0,0 DCGROUP oGroup1 CAPTION L('Стадии исполнения процесса') FONT "6.Helv" SIZE 105,8.5 ; PARENT oTabPage1 @10,0 DCGROUP oGroup2 CAPTION L('Прогноз времени исполнения') FONT "6.Helv" SIZE 105,5.0 ; PARENT oTabPage2 PRIVATE aSay[13] s = 1 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 1] FONT "10.Helv" @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 2] FONT "10.Helv" @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 3] FONT "10.Helv" @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 4] FONT "10.Helv" @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 5] FONT "10.Helv" @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 6] FONT "10.Helv" @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 7] FONT "10.Helv" s++ @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay97 FONT "10.HelvBold" s++ @0.2+s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay98 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @1.5+s ,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay99 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @s ,1 DCPROGRESS oProgress ; SIZE 95,1.5 ; PERCENT ; EVERY 1+INT(Wsego/nEvery) ; // Кол-во обновлений изображения MAXCOUNT Wsego ; COLOR GRA_CLR_CYAN // Цвет полосы @s++,97 DCPUSHBUTTON CAPTION L('&Cancel') ; ACTION {||lOk:=.T.} OBJECT oButton ; SIZE 7,1.5 DCREAD GUI ; TITLE L('1.3. Установка ')+L(ALLTRIM(aLabWName[M_CurrLab])) ; PARENT @oDialog ; FIT ; EXIT ; MODAL oDialog:show() ************************************************************************************************** M_OldNAppl = "" IF nRadio1 = 1 // Определить параметры RND-модели автоматически на основе текущей модели, // добавить RND-модель с этими параметрами и сделать ее текущей IF ApplChange("") // Перейти в папку выбранного приложения или выйти из системы LB_Warning(L("Необходимо задать (выбрать) хотя бы одно текущее приложение !!!")) Running(.F.) RETURN NIL ENDIF M_OldNAppl = UPPER(ALLTRIM(M_NameAppl)) // Наименование текущего приложения CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Class_Sc EXCLUSIVE NEW;N_Csc = RECCOUNT() USE Gr_ClSc EXCLUSIVE NEW;N_Gcs = RECCOUNT();N_Cls = N_Gcs USE Opis_Sc EXCLUSIVE NEW;N_Osc = RECCOUNT() USE Gr_OpSc EXCLUSIVE NEW;N_Gos = RECCOUNT() USE Obi_zag EXCLUSIVE NEW;N_Obj = RECCOUNT() USE Obi_Kcl EXCLUSIVE NEW;N_ObiKcl = RECCOUNT() // Кол-во записей в БД кодов классов обучающей выборки USE Obi_Kpr EXCLUSIVE NEW;N_ObiKpr = RECCOUNT() // Кол-во записей в БД кодов признаков обучающей выборки aSay[1]:SetCaption(L('Определение среднего количества классов у объекта обучающей выборки')) * aSay[2]:SetCaption(L('Определение среднего количества признаков у объекта обучающей выборки')) SELECT Obi_Kcl N_AvrGcs = 0 // Суммарное количество кодов классов в обучающей выборке DO WHILE .NOT. EOF() FOR j=2 TO 5 M_Kcl = FIELDGET(j) IF M_Kcl <> 0 // Проверка на корректность кода класса ++N_AvrGcs ENDIF NEXT lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) DBSKIP(1) ENDDO // Cреднее количество классов, к которым относится объект обучающей выборки N_AvrGcs = N_AvrGcs / N_Obj aSay[1]:SetCaption(aSay[1]:caption+'='+ALLTRIM(STR(ROUND(N_AvrGcs,3),15,3))+' '+L(' - Готово ')) // Определение среднего количества признаков у объекта обучающей выборки aSay[2]:SetCaption(L('Определение среднего количества признаков у объекта обучающей выборки')) SELECT Obi_Kpr N_AvrGos = 0 // Суммарное количество кодов признаков в обучающей выборке DO WHILE .NOT. EOF() FOR j=2 TO 8 M_Kpr = FIELDGET(j) IF 0 <> M_Kpr // Проверка на корректность кода признака ++N_AvrGos ENDIF NEXT lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) DBSKIP(1) ENDDO // Cреднее количество признаков у объекта обучающей выборки N_AvrGos = N_AvrGos / N_Obj aSay[2]:SetCaption(aSay[2]:caption+'='+ALLTRIM(STR(ROUND(N_AvrGos,3),15,3))+' '+L(' - Готово ')) N_AvrGrCs = N_Gcs/N_Csc N_AvrGrOs = N_Gos/N_Osc ENDIF // УСТАНОВКА ЛАБОРАТОРНОЙ РАБОТЫ ******************************** aSay[3]:SetCaption(L('Создание нового приложения с пустыми базами данных')) // Создание нового приложения DO CASE CASE nRadio1 = 1 // Определить параметры RND-модели автоматически на основе текущей модели M_NewNAppl = 'RND-модель на основе приложения: "'+M_OldNAppl+'"' CASE nRadio1 = 2 // Задавать параметры модели вручную M_NewNAppl = aLabWName[M_CurrLab] ENDCASE M_NewAppl = ADD_ZAPPL(M_NewNAppl) // Путь на БД новой лабораторной работы в папке приложений aSave_LW08 := DC_DataSave() // Сохранение вычислительной среды // Создание пустых баз данных нового приложения DIRCHANGE(M_NewAppl) // Перейти в папку с новым приложением и создать БД формализации предметной области: GenDbfClSc(.F.) // Классификационные шкалы ######### GenDbfGrClSc(.F.) // Градации классификационных шкал ######### GenDbfClass(.F.) // Классификационные шкалы и градации GenDbfOpSc(.F.) // Описательные шкалы GenDbfGrOpSc(.F.) // Градации описательных шкал GenDbfAttr(.F.) // Описательные шкалы и градации ######### GenDbfObiZag() // Заголовки объектов обучающей выборки GenDbfObiKcl() // Коды классов объектов обучающей выборки GenDbfObiKpr() // Коды признаков объектов обучающей выборки GenDbfRsoZag() // Заголовки объектов распознаваемой выборки GenDbfRsoKcl() // Коды классов объектов распознаваемой выборки GenDbfRsoKpr() // Коды признаков объектов распознаваемой выборки lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) aSay[3]:SetCaption(aSay[3]:caption+L(' - Готово ')) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW USE Class_Sc EXCLUSIVE NEW USE Gr_ClSc EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW USE Opis_Sc EXCLUSIVE NEW USE Gr_OpSc EXCLUSIVE NEW USE Obi_zag EXCLUSIVE NEW USE Obi_Kcl EXCLUSIVE NEW USE Obi_Kpr EXCLUSIVE NEW aSay[4]:SetCaption(L('Генерация случайных классификационных шкал и градаций')) M_KodGrCs = 0 FOR i=1 TO N_Csc SELECT Class_Sc APPEND BLANK REPLACE Kod_ClSc WITH i REPLACE Name_ClSc WITH "Классификационная шкала_"+ALLTRIM(STR(i,19))+"/"+ALLTRIM(STR(N_Csc,19)) FOR j=1 TO N_AvrGrCs SELECT Gr_ClSc APPEND BLANK REPLACE Kod_ClSc WITH i REPLACE Kod_GrCs WITH ++M_KodGrCs REPLACE Name_GrCs WITH ALLTRIM(STR(j,19))+"/"+ALLTRIM(STR(N_AvrGrCs,19))+"-Градация классификационной шкалы_"+ALLTRIM(STR(i,19))+"/"+ALLTRIM(STR(N_Csc,19)) SELECT Classes APPEND BLANK REPLACE Kod_Cls WITH M_KodGrCs REPLACE Name_Cls WITH "Классификационная шкала_"+ALLTRIM(STR(i,19))+"/"+ALLTRIM(STR(N_Csc,19))+"-Градация классификационной шкалы_"+ALLTRIM(STR(j,19))+"/"+ALLTRIM(STR(N_AvrGrCs,19)) REPLACE Kod_ClSc WITH i REPLACE N_CHRCLSC WITH LEN("Классификационная шкала_"+ALLTRIM(STR(i,19))+"/"+ALLTRIM(STR(N_Csc,19))) NEXT lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) NEXT aSay[4]:SetCaption(aSay[4]:caption+L(' - Готово ')) aSay[5]:SetCaption(L('Генерация случайных описательных шкал и градаций')) M_KodGrOs = 0 FOR i=1 TO N_Osc SELECT Opis_Sc APPEND BLANK REPLACE Kod_OpSc WITH i REPLACE Name_OpSc WITH "Описательная шкала_"+ALLTRIM(STR(i,19))+"/"+ALLTRIM(STR(N_Osc,19)) FOR j=1 TO N_AvrGrOs SELECT Gr_OpSc APPEND BLANK REPLACE Kod_OpSc WITH i REPLACE Kod_GrOs WITH ++M_KodGrOs REPLACE Name_GrOs WITH ALLTRIM(STR(j,19))+"/"+ALLTRIM(STR(N_AvrGrOs,19))+"-Градация описательной шкалы_"+ALLTRIM(STR(i,19))+"/"+ALLTRIM(STR(N_Osc,19)) SELECT Attributes APPEND BLANK REPLACE Kod_Atr WITH M_KodGrOs REPLACE Name_Atr WITH "Описательная шкала_"+ALLTRIM(STR(i,19))+"/"+ALLTRIM(STR(N_Osc,19))+"-Градация описательной шкалы_"+ALLTRIM(STR(j,19))+"/"+ALLTRIM(STR(N_AvrGrOs,19)) REPLACE Kod_OpSc WITH i REPLACE N_CHROPSC WITH LEN("Описательная шкала_"+ALLTRIM(STR(i,19))+"/"+ALLTRIM(STR(N_Osc,19))) NEXT lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) NEXT aSay[5]:SetCaption(aSay[5]:caption+L(' - Готово ')) aSay[6]:SetCaption(L('Генерация баз данных обучающей выборки')) FOR M_KodObj=1 TO N_Obj SELECT Obi_Zag APPEND BLANK REPLACE Kod_obj WITH M_KodObj REPLACE Name_obj WITH "Объект обучающей выборки_"+ALLTRIM(STR(M_KodObj,19))+"/"+ALLTRIM(STR(N_Obj,19)) ***** Генерация массива кодов классов для БД ObI_Kcl A_Kcl := {} DO WHILE LEN(A_Kcl) < N_AvrGcs M_KodCl = 1 + RANDOM()%N_Cls // Код класса IF ASCAN(A_Kcl, M_KodCl) = 0 // Если класс еще не встречался AADD (A_Kcl, M_KodCl) ENDIF ENDDO ASORT(A_Kcl) *** Занести массив кодов классов в БД ObI_Kcl SELECT Obi_Kcl APPEND BLANK REPLACE Kod_Obj WITH M_KodObj IF LEN(A_Kcl) > 0 k=1 FOR j=1 TO LEN(A_Kcl) IF k <= 4 FIELDPUT(1+k++,A_Kcl[j]) ELSE k=1 APPEND BLANK REPLACE Kod_Obj WITH M_KodObj FIELDPUT(1+k++,A_Kcl[j]) ENDIF NEXT ENDIF ***** Генерация массива кодов признаков для БД ObI_Kpr A_Kpr := {} DO WHILE LEN(A_Kpr) < N_AvrGos M_KodPr = 1 + RANDOM()%N_Gos // Код признака AADD (A_Kpr, M_KodPr) ENDDO ASORT(A_KPr) *** Занести массив кодов признаков в БД ObI_Kpr SELECT Obi_Kpr APPEND BLANK REPLACE Kod_Obj WITH M_KodObj IF LEN(A_Kpr) > 0 k=1 FOR j=1 TO LEN(A_Kpr) IF k <= 7 FIELDPUT(1+k++,A_Kpr[j]) ELSE k=1 APPEND BLANK REPLACE Kod_Obj WITH M_KodObj FIELDPUT(1+k++,A_Kpr[j]) ENDIF NEXT ENDIF lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) NEXT aSay[6]:SetCaption(aSay[6]:caption+L(' - Готово ')) aSay[7]:SetCaption(L('Переиндексация всех БД созданного приложения')) GenNtxClass() // Классификационные шкалы и градации GenNtxOpSc() // Описательные шкалы GenNtxGrOpSc() // Градации описательных шкал GenNtxObiZag() // Заголовки объектов обучающей выборки GenNtxObiKcl() // Коды классов объектов обучающей выборки GenNtxObiKpr() // Коды признаков объектов обучающей выборки GenNtxRsoZag() // Заголовки объектов распознаваемой выборки GenNtxRsoKcl() // Коды классов объектов распознаваемой выборки GenNtxRsoKpr() // Коды признаков объектов распознаваемой выборки lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) aSay[7]:SetCaption(aSay[7]:caption+L(' - Готово ')) N_InsLFakt = 1 // Кол-во фактически установленных лабораторных работ (факт) DC_DataRest( aSave_LW08 ) // Восстановление вычислительной среды (открытые и текущие БД и индексы) Running(.T.) // Чтобы не могли запустить какой-нибудь режим пока висит окно окончания работы oSay97:SetCaption(oSay97:caption) oButton:SetCaption(L('&Ok')) // Деструктурирование окна отображения графического Progress-bar oButton:activate := {||PostAppEvent(xbeP_Close,,,oDialog)} //<<<<<< Add This DC_AppEvent( @lOk ) oDialog:Destroy() ***************************************************************************************************** CASE M_CurrLab=12 // Лаб.раб.№ 2.02: Исследование свойств нат.чисел при разл.объемах выборки Chislo1 = 1 Chislo2 = 30 @0,0 DCSAY L('ЗАДАЙТЕ ГРАНИЦЫ ДИАПАЗОНА ЧИСЕЛ:') SAYSIZE 0 FONT '10.Arial Bold' @2,0 DCSAY L("- минимальное число: ") @3,0 DCSAY L("- максимальное число: ") @2,18 DCGET Chislo1 PICTURE "#####" @3,18 DCGET Chislo2 PICTURE "#####" DCREAD GUI FIT ADDBUTTONS TITLE L('1.3. Установка ')+L(ALLTRIM(aLabWName[M_CurrLab])) IF Chislo2 <= Chislo1 LB_Warning(L("Максимальное число должно быть больше минимального")) RETURN NIL ENDIF IF Chislo2 - Chislo1 + 1 > 1200 LB_Warning(L("Заданный дипазон не должен включать больше 1200 чисел")) RETURN NIL ENDIF ************************************************************************************************** // Подготовка данных для отображения графического прогресс-бар // Определить значение Wsego // Определяются параметры модели, необходимые для прогнозирования длительности исполнения и формирования кл.и оп.шкал и градаций oScr := DC_WaitOn(L('Установка Лаб.раб.№ 2.02: Исследование свойств нат.чисел при разл.объемах выборки'),,,,,,,,,,,.F.) A_ClSc := {} AADD(A_ClSc, "Число: ") // 1, числа от Chislo2 до Chislo2 A_GrCS := {} FOR ss=Chislo1 TO Chislo2 AADD(A_GrCS , ALLTRIM(UPPER(A_ClSc[1]))+"-"+STRTRAN(STR(ss,4),' ','0')) // Код градации описательной шкалы NEXT A_OpSc := {} AADD(A_OpSc, "Делители: ") // 1, числа от 1 до Chislo2, являющиеся делителями чисел от Chislo1 до Chislo2 AADD(A_OpSc, "Количество делителей: ") // 2, количество делителей чисел от Chislo1 до Chislo2 AADD(A_OpSc, "Основание степени: ") // 3, числа от 1 до Chislo2, степенями которых являются числа от Chislo1 до Chislo2 AADD(A_OpSc, "Показатель степени: ") // 4, количество степеней от 1 до mStepMax, такой, что: 2^mStepMax < Chislo2 AADD(A_OpSc, "Простые множители: ") // 5, массив простых множителей чисел от Chislo1 до Chislo2 AADD(A_OpSc, "Количество простых множителей:") // 6, количество простых от 1 до mPrMnMax множителей чисел от Chislo1 до Chislo2 ***** Определить числа от 1 до Chislo2, являющиеся делителями чисел от Chislo1 до Chislo2 A_Div := {} // Массив делителей FOR ss = Chislo1 TO Chislo2 // Числа FOR j=2 TO Chislo2-1 // Делители (включая 1 и самого себя) * IF j <> ss .AND. j <> ss-1 IF ss=j*INT(ss/j) // ss нацело делится на j IF ASCAN(A_Div, j) = 0 AADD(A_Div, j) ENDIF ENDIF * ENDIF NEXT NEXT ASORT(A_Div) A_KodOS := {} A_GrOs := {} FOR j=1 TO LEN(A_Div) AADD(A_KodOS, 1) // Код описательной шкалы AADD(A_GrOs , ALLTRIM(UPPER(A_OpSc[1]))+"-"+STRTRAN(STR(A_Div[j],4),' ','0')) // j - код градации описательной шкалы NEXT ****** Определить количество делителей для чисел от Chislo1 до Chislo2 и использовать его далее A_NDiv := {} // Массив количеств делителей чисел от Chislo1 до Chislo2 FOR ss=Chislo1 TO Chislo2 N_Div=0 // Кол-во делителей для числа ss (за исключением 1 и самого себя) *** Проверка делимости FOR j=2 TO Chislo2-1 * IF j <> ss .AND. j <> ss-1 IF ss=j*INT(ss/j) ++N_Div ENDIF * ENDIF NEXT IF ASCAN(A_NDiv, N_Div) = 0 AADD(A_NDiv, N_Div) ENDIF NEXT ASORT(A_NDiv) FOR j=1 TO LEN(A_NDiv) AADD(A_KodOS, 2) // Код описательной шкалы AADD(A_GrOs , ALLTRIM(UPPER(A_OpSc[2]))+"-"+STRTRAN(STR(A_NDiv[j],4),' ','0')) // Код градации описательной шкалы NEXT ******* Определить числа от 1 до Chislo2 (основания степеней), степенями которых являются числа от Chislo1 до Chislo2 ******* Массив чисел от Chislo1 до Chislo2 A_Chislo := {} FOR ss = Chislo1 TO Chislo2 AADD(A_Chislo, ss) NEXT N_Obj = LEN(A_Chislo) A_OsnSt := {} // Массив оснований степеней, которыми являются числа от Chislo1 до Chislo2 A_PokSt := {} // Массив показателей степеней, которыми являются числа от Chislo1 до Chislo2 ErrI = 0 ErrJ = 0 FOR ss = Chislo1 TO Chislo2 FOR i=2 TO Chislo2 // Основания степени FOR j=2 TO Chislo2 // Показатели степени (за исключением 1) * // Определить, возможно ли посчитать такое число bError := ErrorBlock( {|e| Break(e)} ) // установить новый кодовый блок обработки ошибок BEGIN SEQUENCE IF ss = i ^ j // нормальный программный код IF ASCAN(A_OsnSt, i) = 0 AADD (A_OsnSt, i) ENDIF IF ASCAN(A_PokSt, j) = 0 AADD (A_PokSt, j) ENDIF ENDIF RECOVER * EXIT // код обработки ошибок ENDSEQUENCE ErrorBlock( bError ) // переустановить старый кодовый NEXT NEXT NEXT ASORT(A_OsnSt) ASORT(A_PokSt) * DC_DebugQout( A_OsnSt ) * DC_DebugQout( A_PokSt ) FOR j=1 TO LEN(A_OsnSt) mGrOS = ALLTRIM(UPPER(A_OpSc[3]))+"-"+STRTRAN(STR(A_OsnSt[j],4),' ','0') * IF ASCAN(A_GrOs, mGrOS) = 0 AADD (A_KodOS, 3) // Код описательной шкалы AADD (A_GrOs, mGrOS) // Код градации описательной шкалы * ENDIF NEXT FOR j=1 TO LEN(A_PokSt) mGrOS = ALLTRIM(UPPER(A_OpSc[4]))+"-"+STRTRAN(STR(A_PokSt[j],4),' ','0') * IF ASCAN(A_GrOs, mGrOS) = 0 AADD (A_KodOS, 4) // Код описательной шкалы AADD (A_GrOs, mGrOS) // Код градации описательной шкалы * ENDIF NEXT * DC_DebugQout( A_GrOs ) ******* Найти ВСЕ простые числа на которые делятся числа от 2 до Chislo2 Ar_prch := {} // Массив простых чисел FOR ss = 2 TO Chislo2 **** Проверка, является ли ss простым числом Flag = .T. FOR i=2 TO ss-1 IF ss = i*INT(ss/i) // Делится ли ss на i Flag = .F. EXIT ENDIF NEXT IF Flag AADD(Ar_prch,ss) ENDIF NEXT * DC_DebugQout( Ar_prch ) *** Оставить только те из Ar_prch, на которые реально нацело делятся числа от Chislo1 до Chislo2 A_PrCh := {} FOR ss = Chislo1 TO Chislo2 FOR j=1 TO LEN(Ar_prch) IF ss = Ar_prch[j]*INT(ss/Ar_prch[j]) // Делится ли ss на j IF ASCAN(A_PrCh, Ar_prch[j]) = 0 AADD(A_PrCh, Ar_prch[j]) ENDIF ENDIF NEXT NEXT ASORT(A_PrCh) FOR j=1 TO LEN(A_PrCh) AADD(A_KodOS, 5) // Код описательной шкалы AADD(A_GrOs , ALLTRIM(UPPER(A_OpSc[5]))+"-"+STRTRAN(STR(A_PrCh[j],4),' ','0')) // Код градации описательной шкалы NEXT ******* Определить количество простых множителей в числах от Chislo1 до Chislo2 ******* с повторами одинаковых простых множителей, чтобы их произведение давало число A_NPrMn := {} FOR ss = Chislo1 TO Chislo2 Ar_prmn := {} // Массив простых множителей числа ss Chislo = ss FOR j=1 TO LEN(A_PrCh) **** Проверка, делится ли Chislo на простое число из массива Ar_prch DO WHILE Chislo = A_PrCh[j] * INT(Chislo/A_PrCh[j]) AADD(Ar_prmn,A_PrCh[j]) Chislo = Chislo/A_PrCh[j] ENDDO NEXT IF ASCAN(A_NPrMn, LEN(Ar_prmn)) = 0 IF LEN(Ar_prmn) > 0 AADD(A_NPrMn, LEN(Ar_prmn)) ENDIF ENDIF NEXT ASORT(A_NPrMn) FOR j=1 TO LEN(A_NPrMn) AADD(A_KodOS, 6) // Код описательной шкалы AADD(A_GrOs , ALLTRIM(UPPER(A_OpSc[6]))+"-"+STRTRAN(STR(A_NPrMn[j],4),' ','0')) // Код градации описательной шкалы NEXT // Создание нового приложения с пустыми базами данных M_NewAppl = ADD_ZAPPL(ALLTRIM(aLabWName[M_CurrLab])+' (чисел: '+ALLTRIM(STR(Chislo2 - Chislo1 + 1))+')'+', расч.исх.данные') // Путь на БД новой лабораторной работы в папке приложений aSave_LW09 := DC_DataSave() // Сохранение вычислительной среды // Создание пустых баз данных нового приложения DIRCHANGE(M_NewAppl) // Перейти в папку с БД новой модели и создать БД формализации предметной области: GenDbfClSc(.F.) // Классификационные шкалы ######### GenDbfGrClSc(.F.) // Градации классификационных шкал ######### GenDbfClass(.F.) // Классификационные шкалы и градации GenDbfOpSc(.F.) // Описательные шкалы GenDbfGrOpSc(.F.) // Градации описательных шкал GenDbfAttr(.F.) // Описательные шкалы и градации ######### GenDbfObiZag() // Заголовки объектов обучающей выборки GenDbfObiKcl() // Коды классов объектов обучающей выборки GenDbfObiKpr() // Коды признаков объектов обучающей выборки GenDbfRsoZag() // Заголовки объектов распознаваемой выборки GenDbfRsoKcl() // Коды классов объектов распознаваемой выборки GenDbfRsoKpr() // Коды признаков объектов распознаваемой выборки ********* Создать БД Inp_data.dbf DIRCHANGE(Disk_dir+"\AID_DATA\Inp_data\") // Перейти в папку Inp_data aStructure := { { "Object" , "N", 8, 0 }, ; // 1. Число { "Number ", "C", 19, 0 }, ; // 2. Число { "Dividers ", "C", 250, 0 }, ; // 3. Делители - числа от 1 до Chislo2, являющиеся делителями чисел от Chislo1 до Chislo2 { "N_divisors", "C", 250, 0 }, ; // 4. Количество делителей - количество делителей чисел от Chislo1 до Chislo2 { "BasDegree" , "C", 250, 0 }, ; // 5. Основание степени - числа от 1 до Chislo2, степенями которых являются числа от Chislo1 до Chislo2 { "Exponent" , "C", 250, 0 }, ; // 6. Показатель степени - количество степеней от 1 до mStepMax, такой, что: 2^mStepMax < Chislo2 { "SimMultipl", "C", 250, 0 }, ; // 7. Простой множитель - массив простых множителей чисел от Chislo1 до Chislo2 { "NSimMultip", "C", 250, 0 } } // 8. Количество простых множителей - количество простых от 1 до mPrMnMax множителей чисел от Chislo1 до Chislo2 DbCreate( 'Inp_data.dbf', aStructure ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir+"\AID_DATA\Inp_data\") // Перейти в папку Inp_data USE Inp_data EXCLUSIVE NEW DIRCHANGE(M_NewAppl) // Перейти в папку с БД новой модели и создать БД формализации предметной области: USE Classes EXCLUSIVE NEW USE Class_Sc EXCLUSIVE NEW USE Gr_ClSc EXCLUSIVE NEW USE Opis_Sc EXCLUSIVE NEW USE Gr_OpSc EXCLUSIVE NEW USE Obi_zag EXCLUSIVE NEW USE Obi_Kcl EXCLUSIVE NEW USE Obi_Kpr EXCLUSIVE NEW // ########################################### // Генерация классификационных шкал и градаций SELECT Classes;ZAP FOR ss=1 TO LEN(A_GrCS) APPEND BLANK REPLACE Kod_cls WITH ss REPLACE Name_cls WITH A_GrCS[ss] REPLACE Kod_ClSc WITH 1 NEXT SELECT Class_Sc;ZAP APPEND BLANK REPLACE Kod_ClSc WITH 1 REPLACE Name_ClSc WITH UPPER(ALLTRIM(A_ClSc[1])) REPLACE KodGr_Min WITH Chislo1 REPLACE KodGr_Max WITH Chislo2 SELECT Gr_ClSc;ZAP FOR ss=1 TO LEN(A_GrCS) APPEND BLANK REPLACE Kod_ClSc WITH 1 REPLACE Kod_GrCS WITH ss * REPLACE Name_GrCS WITH A_GrCS[ss] // ################################ mPos = AT(":", A_GrCs[ss]) mLen = LEN(A_GrCs[ss]) REPLACE Name_GrCs WITH SUBSTR(A_GrCs[ss], mPos+2, mLen-mPos-1) NEXT // Генерация описательных шкал SELECT Opis_sc;ZAP FOR ss=1 TO LEN(A_OpSc) APPEND BLANK REPLACE Kod_OpSc WITH ss REPLACE Name_OpSc WITH UPPER(ALLTRIM(A_OpSc[ss])) NEXT // Генерация градаций описательных шкал SELECT Gr_OpSc;ZAP FOR ss=1 TO LEN(A_GrOs) APPEND BLANK REPLACE Kod_OpSc WITH A_KodOS[ss] REPLACE Kod_GrOs WITH ss mPos = AT(":", A_GrOs[ss]) mLen = LEN(A_GrOs[ss]) REPLACE Name_GrOs WITH SUBSTR(A_GrOs[ss], mPos+2, mLen-mPos-1) NEXT // Формирование обучающей выборки SELECT Obi_zag;ZAP SELECT Obi_Kcl;ZAP SELECT Obi_Kpr;ZAP mNumObj := 0 FOR ss=Chislo1 TO Chislo2 SELECT Obi_zag APPEND BLANK REPLACE Kod_obj WITH ++mNumObj REPLACE Name_obj WITH "Число: "+ALLTRIM(STR(ss)) SELECT Inp_data APPEND BLANK REPLACE Object WITH mNumObj REPLACE Number WITH ALLTRIM(STR(ss)) SELECT Obi_Kcl APPEND BLANK REPLACE Kod_obj WITH mNumObj * REPLACE CLS1 WITH ss // ####################################### Kod = ASCAN(A_GrCS , ALLTRIM(UPPER(A_ClSc[1]))+"-"+STRTRAN(STR(ss,4),' ','0')) // Код градации классификационной шкалы IF Kod > 0 REPLACE CLS1 WITH Kod ENDIF SELECT Obi_Kpr APPEND BLANK REPLACE Kod_obj WITH mNumObj p=0 // Позиция для записи в БД N_Div=0 // Кол-во делителей *** Проверка делимости FOR j=1 TO LEN(A_Div) * IF j <> ss IF ss=A_Div[j]*INT(ss/A_Div[j]) // Если число ss нацело делится на делитель A_Div[j] Kod = ASCAN(A_GrOs , ALLTRIM(UPPER(A_OpSc[1]))+"-"+STRTRAN(STR(A_Div[j],4),' ','0')) // Код градации описательной шкалы // <<<===######################## IF Kod > 0 ++N_Div SELECT Inp_data REPLACE Dividers WITH ALLTRIM(Dividers)+IF(LEN(ALLTRIM(Dividers))>0,' ','') + STRTRAN(STR(A_Div[j],4),' ','0') // <<<===######################## SELECT Obi_Kpr IF p+1 <= 7 FIELDPUT(++p+1, Kod) ELSE APPEND BLANK REPLACE Kod_obj WITH mNumObj p=0 FIELDPUT(++p+1, Kod) ENDIF ENDIF ENDIF * ENDIF NEXT *** Занесение количества делителей Kod = ASCAN(A_GrOs , ALLTRIM(UPPER(A_OpSc[2]))+"-"+STRTRAN(STR(N_Div,4),' ','0')) // Код градации описательной шкалы IF Kod > 0 IF p+1 <= 7 FIELDPUT(++p+1, Kod) ELSE APPEND BLANK REPLACE Kod_obj WITH mNumObj p=0 FIELDPUT(++p+1, Kod) ENDIF SELECT Inp_data REPLACE N_DIVISORS WITH STRTRAN(STR(N_Div,4),' ','0') SELECT Obi_Kpr ENDIF *** Проверка, является ли данное число ss *** целой степенью j некоторого натурального числа i SELECT Obi_Kpr * MsgBox(STR(LEN(A_GrOs))) * LB_Warning(A_GrOs) // ################## FOR i=1 TO LEN(A_OsnSt) // Основания степени FOR j=1 TO LEN(A_PokSt) // Показатели степени IF ss = A_OsnSt[i]^A_PokSt[j] // ss является целой степенью A_PokSt[j] натурального числа A_OsnSt[i] mGrOS = ALLTRIM(UPPER(A_OpSc[3]))+"-"+STRTRAN(STR(A_OsnSt[i],4),' ','0') Kod = ASCAN(A_GrOs , mGrOS ) // Код градации описательной шкалы IF Kod > 0 IF p+1 <= 7 FIELDPUT(++p+1, Kod) ELSE APPEND BLANK REPLACE Kod_obj WITH mNumObj p=0 FIELDPUT(++p+1, Kod) ENDIF SELECT Inp_data REPLACE BasDegree WITH ALLTRIM(BasDegree)+IF(LEN(ALLTRIM(BasDegree))>0,' ','') + STRTRAN(STR(A_OsnSt[i],4),' ','0') SELECT Obi_Kpr ENDIF mGrOS = ALLTRIM(UPPER(A_OpSc[4]))+"-"+STRTRAN(STR(A_PokSt[j],4),' ','0') Kod = ASCAN(A_GrOs , mGrOS ) // Код градации описательной шкалы IF Kod > 0 IF p+1 <= 7 FIELDPUT(++p+1, Kod) ELSE APPEND BLANK REPLACE Kod_obj WITH mNumObj p=0 FIELDPUT(++p+1, Kod) ENDIF SELECT Inp_data REPLACE Exponent WITH ALLTRIM(Exponent)+IF(LEN(ALLTRIM(Exponent))>0,' ','') + STRTRAN(STR(A_PokSt[j],4),' ','0') SELECT Obi_Kpr ENDIF ENDIF NEXT NEXT ******* 2. Разложить составное число на простые множители Ar_prmn := {} // Массив всех простых множителей числа ss с повторами множителей, // чтобы число получалось путем перемножения простых множителей Chislo = ss FOR j=1 TO LEN(A_PrCh) **** Проверка, делится ли Chislo на простое число из массива Ar_prch DO WHILE Chislo = A_PrCh[j] * INT(Chislo/A_PrCh[j]) AADD(Ar_prmn,A_PrCh[j]) Chislo = Chislo/A_PrCh[j] ENDDO NEXT *** Занести коды простых множителей в БД ObInfKPr.dbf и сами простые множители в Inp_data.dbf FOR j=1 TO LEN(Ar_prmn) Kod = ASCAN(A_GrOs , ALLTRIM(UPPER(A_OpSc[5]))+"-"+STRTRAN(STR(Ar_prmn[j],4),' ','0')) // Код градации описательной шкалы IF Kod > 0 IF p+1 <= 7 FIELDPUT(++p+1, Kod) ELSE APPEND BLANK REPLACE Kod_obj WITH mNumObj p=0 FIELDPUT(++p+1, Kod) ENDIF SELECT Inp_data REPLACE SIMMULTIPL WITH ALLTRIM(SIMMULTIPL)+IF(LEN(ALLTRIM(SIMMULTIPL))>0,' ','') + STRTRAN(STR(Ar_prmn[j],4),' ','0') // <<<===################ SELECT Obi_Kpr ENDIF NEXT Kod = ASCAN(A_GrOs , ALLTRIM(UPPER(A_OpSc[6]))+"-"+STRTRAN(STR(LEN(Ar_prmn),4),' ','0')) // Код градации описательной шкалы IF Kod > 0 IF p+1 <= 7 FIELDPUT(++p+1, Kod) ELSE APPEND BLANK REPLACE Kod_obj WITH mNumObj p=0 FIELDPUT(++p+1, Kod) ENDIF SELECT Inp_data REPLACE NSIMMULTIP WITH STRTRAN(STR(LEN(Ar_prmn),4),' ','0') SELECT Obi_Kpr ENDIF NEXT // Переиндексация всех БД созданного приложения GenDbfAttr(.F.) // Описательные шкалы и градации ######### GenNtxClass() // Классификационные шкалы и градации GenNtxClSc() // Классификационные шкалы GenNtxGrClSc() // Градации Классификационные шкал GenNtxOpSc() // Описательные шкалы GenNtxGrOpSc() // Градации описательных шкал GenNtxObiZag() // Заголовки объектов обучающей выборки GenNtxObiKcl() // Коды классов объектов обучающей выборки GenNtxObiKpr() // Коды признаков объектов обучающей выборки GenNtxRsoZag() // Заголовки объектов распознаваемой выборки GenNtxRsoKcl() // Коды классов объектов распознаваемой выборки GenNtxRsoKpr() // Коды признаков объектов распознаваемой выборки DC_Impl(oScr) AADD(A_OpSc, "Делители: ") // 1, числа от 1 до Chislo2, являющиеся делителями чисел от Chislo1 до Chislo2 AADD(A_OpSc, "Количество делителей: ") // 2, количество делителей чисел от Chislo1 до Chislo2 AADD(A_OpSc, "Основание степени: ") // 3, числа от 1 до Chislo2, степенями которых являются числа от Chislo1 до Chislo2 AADD(A_OpSc, "Показатель степени: ") // 4, количество степеней от 1 до mStepMax, такой, что: 2^mStepMax < Chislo2 AADD(A_OpSc, "Простые множители: ") // 5, массив простых множителей чисел от Chislo1 до Chislo2 AADD(A_OpSc, "Количество простых множителей:") // 6, количество простых от 1 до mPrMnMax множителей чисел от Chislo1 до Chislo2 CrLf = CHR(13)+CHR(10) // Конец строки (записи) String = "Числа: " + CrLf +; "Делители: " + CrLf +; "Количество делителей: " + CrLf +; "Основание степени: " + CrLf +; "Показатель степени: " + CrLf +; "Простые множители: " + CrLf +; "Количество простых множителей:" DIRCHANGE(Disk_dir+"\AID_DATA\Inp_data\") // Перейти в папку Inp_data StrFile(String, "Inp_name.txt") // Запись текстового файла "Inp_name.txt" ******* Сформировать и записать файл параметров диалога для режима 2.3.2.2: Regim = 1 // Формализации ПО или ген.расп.выб. Flag_zer = 1 // Считать нули и пробелы отсутствием данных? [1]-да, [2]-нет M_ClSc1 = 2 // Номер начального столбца диапазона классификационных шкал M_ClSc2 = 2 // Номер конечного столбца диапазона классификационных шкал M_OpSc1 = 3 // Номер начального столбца диапазона описательных шкал M_OpSc2 = 8 // Номер конечного столбца диапазона описательных шкал N_SKGrCl = 40 N_SKGrPr = 40 K_N_ClSc = 1 // Кол-во числовых классификационных шкал K_N_OpSc = 6 // Кол-во числовых описательных шкал K_N_GrClSc = 3 K_N_GrOpSc = 3 M_ObAnk = 3 // Создавать анкеты исходной выборки по строкам Inp_data-[1], по классам-[2], и 1-е, и 2-е [3] N_Chast = 1 // На сколько частей N разбивать обучающую или распознавемую выборку (в зависимости от Regim) M_Interval = 1 // 1-равные интервалы, 2-адаптивные интервалы (с примерно равным количеством наблюдений, по Котельникову) M_Scenario = .F. K_GradNClSc = 3 K_GradNOpSc = 3 mGorizMin = 5 mGorizMax = 5 mGlubMin = 5 mGlubMax = 5 M_ChastObi = .F. M_ChastRso = .F. N_ChastObi = 1 N_ChastRso = 1 M_XlsDbf = 3 // Тип файла исходных данных: 1-xls, 2-xlsx, 3-dbf, 4-csv (в разработке) mTxtCSField = 1 // Способ интерпретации значений текстовых полей - значения рассматриваются как целое * mTxtCSField = 1 // Значения рассматриваются как целое * mTxtCSField = 2 // Значения рассматриваются как состоящие из элементов - символов * mTxtCSField = 3 // Значения рассматриваются как состоящие из элементов, разделенных разделителем (слов) mTxtOSField = 3 // Способ интерпретации значений текстовых полей - описательных шкал файла исходных данных (слова) * mTxtOSField = 1 // Значения рассматриваются как целое * mTxtOSField = 2 // Значения рассматриваются как состоящие из элементов - символов * mTxtOSField = 3 // Значения рассматриваются как состоящие из элементов, разделенных разделителем (слов) mTxtCSSep = " " // Разделитель элементов классификационных шкал, если mTxtCSField=3 mTxtOSSep = " " // Разделитель элементов описательных шкал, если mTxtOSField=3 mScenario = 1 // mScenario=1 Не применять сценарный метод АСК-анализа и спец.интерпретацию TXT-полей (старый вариант) mSpecInterprCls = .T. // Применять спец.интерпретацию текстовых полей классов mSpecInterprAtr = .T. // Применять спец.интерпретацию текстовых полей признаков mNameGrNumSc= 1 // Какие наименования ГРАДАЦИЙ числовых шкал использовать mClsAvr =.F. // .F. - делать модель из Inp_data, .T. - делать модель из Inp_data_avr mSortUnqCls = 2 // Выделять уникальные значения классов и сортировать, 1-да, 2-нет mLemmatCls = 2 // Проводить лемматизацию классов, 1-да, 2-нет mSortUnqGos = 2 // Выделять уникальные значения признаков и сортировать, 1-да, 2-нет mLemmatGos = 2 // Проводить лемматизацию признаков, 1-да, 2-нет PRIVATE aSoftInt[40] aSoftInt[ 1] = Regim aSoftInt[ 2] = Flag_zer aSoftInt[ 3] = M_ClSc1 aSoftInt[ 4] = M_ClSc2 aSoftInt[ 5] = M_OpSc1 aSoftInt[ 6] = M_OpSc2 aSoftInt[ 7] = N_SKGrCl aSoftInt[ 8] = N_SKGrPr aSoftInt[ 9] = K_N_ClSc aSoftInt[10] = K_N_OpSc aSoftInt[11] = K_N_GrClSc aSoftInt[12] = K_N_GrOpSc aSoftInt[13] = M_ObAnk aSoftInt[14] = N_Chast aSoftInt[15] = M_Interval aSoftInt[16] = M_Scenario aSoftInt[17] = K_GradNClSc // Количество градаций в числовой классификационной шкале aSoftInt[18] = K_GradNOpSc // Количество градаций в числовой описательной шкале aSoftInt[19] = mGorizMin aSoftInt[20] = mGorizMax aSoftInt[21] = mGlubMin aSoftInt[22] = mGlubMax aSoftInt[23] = M_ChastObi aSoftInt[24] = M_ChastRso aSoftInt[25] = N_ChastObi aSoftInt[26] = N_ChastRso aSoftInt[27] = M_XlsDbf aSoftInt[28] = mTxtCSField aSoftInt[29] = mTxtOSField aSoftInt[30] = mTxtCSSep aSoftInt[31] = mTxtOSSep * aSoftInt[32] = mScenario // mScenario=1 Не применять сценарный метод АСК-анализа и спец.интерпретацию TXT-полей (старый вариант) aSoftInt[32] = mScenario // mScenario=1 Не применять сценарный метод АСК-анализа aSoftInt[33] = mSpecInterprCls // Применить спец.интерпретацию текстовых полей классов aSoftInt[34] = mSpecInterprAtr // Применить спец.интерпретацию текстовых полей признаков aSoftInt[35] = mNameGrNumSc // Какие наименования ГРАДАЦИЙ числовых шкал использовать aSoftInt[36] = mClsAvr // .F. = модель без усреднения по классам aSoftInt[37] = mSortUnqCls // Выделять уникальные значения классов и сортировать, 1-да, 2-нет aSoftInt[38] = IF(mSpecInterprCls,mLemmatCls,2) // Проводить лемматизацию классов, 1-да, 2-нет aSoftInt[39] = mSortUnqGos // Выделять уникальные значения признаков и сортировать, 1-да, 2-нет aSoftInt[40] = IF(mSpecInterprAtr,mLemmatGos,2) // Проводить лемматизацию признаков, 1-да, 2-нет DC_ASave(aSoftInt , Disk_dir +"\_2_3_2_2.arx") DC_ASave(aSoftInt , M_NewAppl+"\_2_3_2_2.arx") ******* Запустить режим 2.3.2.2 DIRCHANGE(Disk_dir) // Перейти в папку системы mLW = ALLTRIM(aLabWName[M_CurrLab])+' (чисел: '+ALLTRIM(STR(Chislo2 - Chislo1 + 1))+')'+', исх.данные из: "Inp_data.dbf"' M_NewAppl = ADD_ZAPPL(mLW) // Путь на БД новой лабораторной работы в папке приложений DIRCHANGE(M_NewAppl) // Перейти в папку с БД новой модели и создать БД формализации предметной области: GenDbfClSc(.F.) // Классификационные шкалы ######### GenDbfGrClSc(.F.) // Градации классификационных шкал ######### GenDbfClass(.F.) // Классификационные шкалы и градации GenDbfOpSc(.F.) // Описательные шкалы GenDbfGrOpSc(.F.) // Градации описательных шкал GenDbfAttr(.F.) // Описательные шкалы и градации ######### GenDbfObiZag() // Заголовки объектов обучающей выборки GenDbfObiKcl() // Коды классов объектов обучающей выборки GenDbfObiKpr() // Коды признаков объектов обучающей выборки GenDbfRsoZag() // Заголовки объектов распознаваемой выборки GenDbfRsoKcl() // Коды классов объектов распознаваемой выборки GenDbfRsoKpr() // Коды признаков объектов распознаваемой выборки F2_3_2_2(mLW,"1.3()") // Запуск универсального программного интерфейса с внешними базами данных ******* Выдать сообщение о дальнейших действиях aMess := {} AADD(aMess, L(mLW)+L(", успешно установлена!")) AADD(aMess, L(" ")) AADD(aMess, L("Для дальнейшего ее изучения и выполнения необходимо:")) AADD(aMess, L(" ")) AADD(aMess, L("1. Открыть файл исходных данных: "+Disk_dir+"\AID_DATA\Inp_data\Inp_data.dbf"+".")) AADD(aMess, L(" ")) AADD(aMess, L("2. Прочитать описание данной лабораторной работы в режиме 5.14.")) AADD(aMess, L(" ")) AADD(aMess, L("3. Выполнить режимы: 2.1, 2.2, 2.3.1, 3.5, 5.5, 3.4 и другие")) AADD(aMess, L(" в соответствии со схемой преобразования данных в информацию,")) AADD(aMess, L(" а ее в знания, приведенной в режиме 6.4.")) LB_Warning(aMess, L('(C) Универсальная когнитивная аналитическая система "Эйдос-Х++"')) N_InsLFakt = 1 // Кол-во фактически установленных лабораторных работ (факт) * DC_DataRest( aSave_LW09 ) // Восстановление вычислительной среды (открытые и текущие БД и индексы) * aMess := {} * AADD(aMess, L('Лаб.раб.№ 2.02: Исследование свойств натуральных чисел') * AADD(aMess, L('при различных объемах выборки успешно установлена!') * LB_Warning(aMess, L("1.3. Установка лабораторных работ" ) ***************************************************************************************************** CASE M_CurrLab=13 // Лаб.раб.№ 13: Исследование детерминации свойств системы ее структурой ******************************************************************************* *** Исследование влияния подсистем различных уровней иерархии на эмер- *** *** джентные свойства системы в целом с применением автоматизированного *** *** системно-когнитивного анализа и интеллектуальной системы "Эйдос" *** ******************************************************************************* *** Подготовка данных для моделирования взаимосвязи *** *** генетических признаков с фенотипическими признаками *** ******************************************************************************* *** 1. Задание в диалоге диапазона простых чисел, являющихся базовыми *** *** для образования геномов объектов *** *** 2. Задание количества генетических признаков в объектах *** *** 3. Задание максимальной сложности подсистем фенотипических признаков *** *** 4. Генерация простых чисел без повторов в заданных диапазонах, *** *** являющихся базовыми для образования геномов объектов *** *** 5. Генерация на основе простых чисел, являющихся базовыми элементами, *** *** геномов объектов заданной сложности, путем перебора всех вариантов *** *** сочетаний: каждый вариант реализуется в новом объекте *** *** 6. Генерация на основе простых чисел, составляющих геномы объектов, *** *** составных натуральных чисел, моделирующих фенотипические признаки *** *** разного уровня сложности: от 1 до максимальной, заданной в диалоге *** *** 7. Сюда можно вставить определение других свойств сгенерированных чисел как в ЛР 9 *** 8. Формирование БД классов, признаков и обучающей выборки *** ******************************************************************************* @ 0,0 DCGROUP oGroup1 CAPTION L('Задание параметров синтеза модели') SIZE 88, 22 PUBLIC Ch_Min1 := 2, Ch_Max1 := 7 Mess1 = L('Задайте минимальное число диапазона простых чисел:') Mess2 = L('Задайте максимальное число диапазона простых чисел:') @ 1, 1 DCSAY Mess1 PARENT oGroup1 @ 2, 1 DCSAY Mess2 PARENT oGroup1 @ 1,50 DCSAY L(" ") GET Ch_Min1 PARENT oGroup1 PICTURE "###############" @ 2,50 DCSAY L(" ") GET Ch_Max1 PARENT oGroup1 PICTURE "###############" PUBLIC UrSlog_Obj := 4 Mess3 = L('Задайте макс.количество базовых признаков в объектах:') @ 3, 1 DCSAY Mess3 PARENT oGroup1 @ 3,50 DCSAY L(" ") GET UrSlog_Obj PARENT oGroup1 PICTURE "###############" // Количество признаков в объектах должно быть > 2 и < 10 PUBLIC UrSlog_FP := 15 Mess4 = L('Задайте максимальную сложность подсистем базовых признаков:') @ 4, 1 DCSAY Mess4 PARENT oGroup1 @ 4,50 DCSAY L(" ") GET UrSlog_FP PARENT oGroup1 PICTURE "###############" // Максимальный уровень сложности фенотипических признаков должен быть > 1 и < # PUBLIC Podsys_01 := 0 @ 5.2, 1 DCGROUP oGroup2 CAPTION L('Кодировать ли подсистемы базовых признаков?') SIZE 86, 3.5 PARENT oGroup1 @ 1, 1 DCRADIO Podsys_01 VALUE 0 PROMPT L('Не кодировать') PARENT oGroup2 @ 2, 1 DCRADIO Podsys_01 VALUE 1 PROMPT L('Кодировать' ) PARENT oGroup2 PUBLIC Podsystem := 0 @ 9.2, 1 DCGROUP oGroup3 CAPTION L('Какие подсистемы базовых признаков оставлять в модели?') SIZE 86, 3.5 PARENT oGroup1 @ 1, 1 DCRADIO Podsys_01 VALUE 0 PROMPT L('Всех уровней сложности' ) PARENT oGroup3 @ 2, 1 DCRADIO Podsys_01 VALUE 1 PROMPT L('Только макс.уровня сложности') PARENT oGroup3 @13.2, 1 DCGROUP oGroup4 CAPTION L('Принцип моделирования состава и свойств системы простыми и составными числами' ) SIZE 86, 8.5 PARENT oGroup1 @ 1, 1 DCSAY L('В лабораторной работе №12 исследуются числовые системы, основанные на базовых элементах, в качестве ') PARENT oGroup4 @ 2, 1 DCSAY L('которых выступают простые числа, с подсистемами различной сложности (уровней иерархии), образующими-') PARENT oGroup4 @ 3, 1 DCSAY L('ся путем перемножения простых чисел в различных сочетаниях. Это не накладывает ограничений на приме-') PARENT oGroup4 @ 4, 1 DCSAY L('нимость полученных на этом примере выводов в различных предметных областях, т.к. простые числа можно') PARENT oGroup4 @ 5, 1 DCSAY L('рассматривать как признаки, характеризующие состав систем, а составные числа как эмерджентные свой-') PARENT oGroup4 @ 6, 1 DCSAY L('ства этих систем, образующиеся путем взаимодействия соответствующих базовых элементов. Использование') PARENT oGroup4 @ 7, 1 DCSAY L('этой метафоры очень удобно, т.к. разложение сложных чисел на простые множители является единственным') PARENT oGroup4 DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; OPTIONS GetOptions ; ADDBUTTONS ; MODAL ; TITLE L('1.3. Задание параметров модели детерминации свойств системы ее структурой') ************************************************************************************************** *************************************************** IF lExit ** Button Ok ELSE ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF *************************************************** // Подготовка данных для отображения графического прогресс-бар // Задание максимальной величины параметра Time Wsego = IF(Podsys_01 = 0, 20, 21) // Отображение стадии исполнения. Будет написано прямо в окне Progress-bar @ 0,0 DCGROUP oGroup1 CAPTION L('Стадии исполнения процесса') FONT "6.Helv" SIZE 105,8.5 ; PARENT oTabPage1 @10,0 DCGROUP oGroup2 CAPTION L('Прогноз времени исполнения') FONT "6.Helv" SIZE 105,5.0 ; PARENT oTabPage2 PRIVATE aSay[12] s = 1 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 1] FONT "10.Helv" @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 2] FONT "10.Helv" @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 3] FONT "10.Helv" @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 4] FONT "10.Helv" @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 5] FONT "10.Helv" @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 6] FONT "10.Helv" @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 7] FONT "10.Helv" s++ @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay97 FONT "10.HelvBold" s++ @0.2+s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay98 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @1.5+s ,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay99 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @s ,1 DCPROGRESS oProgress ; SIZE 95,1.5 ; PERCENT ; EVERY 1+INT(Wsego/nEvery) ; // Кол-во обновлений изображения MAXCOUNT Wsego ; COLOR GRA_CLR_CYAN // Цвет полосы @s++,97 DCPUSHBUTTON CAPTION L('&Cancel') ; ACTION {||lOk:=.T.} OBJECT oButton ; SIZE 7,1.5 DCREAD GUI ; TITLE L('1.3. Установка ')+L(aLabWName[M_CurrLab]) ; PARENT @oDialog ; FIT ; EXIT ; MODAL oDialog:show() ************************************************************************************************** // Начало отсчета времени для прогнозирования длительности исполнения Time_progress = 0 // Прошло секунд с начала процесса // Процесс может идти больше суток, поэтому для определения // во всех случаях вычисляется время, прошедшее с начала года T_Mess1 = L("Начало:")+" "+TIME() // Начало Sec_1 = (DOY(DATE())-1)*86400+SECONDS() PUBLIC T1 := (DOY(DATE())-1)*86400+SECONDS() // Время предыдущей индикации процесса исполнения PUBLIC T2 := (DOY(DATE())-1)*86400+SECONDS()+1 // Текущее время (1-й раз оно заметно больше T1 чтобы было отображение) PUBLIC T1tp := T1 PUBLIC T2tp := T2 aSay[1]:SetCaption(L('Создание нового приложения с пустыми базами данных')) // Создание нового приложения * LB_Warning(STR(M_CurrLab)) M_NewAppl = ADD_ZAPPL(aLabWName[M_CurrLab]) // Путь на БД новой лабораторной работы в папке приложений aSave_LW10 := DC_DataSave() // Сохранение вычислительной среды // Создание пустых баз данных нового приложения DIRCHANGE(M_NewAppl) // Перейти в папку с БД новой модели и создать БД формализации предметной области: GenDbfClSc(.F.) // Классификационные шкалы ######### GenDbfGrClSc(.F.) // Градации классификационных шкал ######### GenDbfClass(.F.) // Классификационные шкалы и градации GenDbfOpSc(.F.) // Описательные шкалы GenDbfGrOpSc(.F.) // Градации описательных шкал GenDbfAttr(.F.) // Описательные шкалы и градации ######### GenDbfObiZag() // Заголовки объектов обучающей выборки GenDbfObiKcl() // Коды классов объектов обучающей выборки GenDbfObiKpr() // Коды признаков объектов обучающей выборки GenDbfRsoZag() // Заголовки объектов распознаваемой выборки GenDbfRsoKcl() // Коды классов объектов распознаваемой выборки GenDbfRsoKpr() // Коды признаков объектов распознаваемой выборки lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // 01 aSay[1]:SetCaption(aSay[1]:caption+L(' - Готово ')) aSay[2]:SetCaption(L('Генерация простых чисел в заданном диапазоне без повторов')) ***** Создать БД простых чисел CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций CREATE Struc APPEND BLANK REPLACE Field_name WITH "Pr_Chis",; Field_type WITH "N",; Field_len WITH 15 ,; Field_dec WITH 0 ****** Создаем БД CREATE Pr_chis FROM Struc ERASE Struc.dbf lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // 02 ***** База и массив простых чисел Ar_prch := {} CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Pr_chis EXCLUSIVE NEW SELECT Pr_chis FOR j=Ch_Min1 TO Ch_Max1 **** Проверка, является ли j простым числом Flag = .T. FOR i=2 TO j-1 IF j=i*INT(j/i) // Делится ли j на i Flag = .F. EXIT ENDIF NEXT IF Flag APPEND BLANK REPLACE Pr_Chis WITH j AADD(Ar_prch, Pr_chis) ENDIF NEXT lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // 03 aSay[2]:SetCaption(aSay[2]:caption+L(' - Готово ')) aSay[3]:SetCaption(L('Генерация подсистем простых чисел путем перебора всех вариантов их сочетаний')) ******* Суммарное количество всех возможных подсистем всех уровней сложности ******* от 1 до максимального, заданного в диалоге UrSlog_FP - 1 Sum_Cnm = 0 FOR m=1 TO UrSlog_FP // от 1 до UrSlog_FP n = UrSlog_Obj Sum_Cnm = Sum_Cnm + F(n)/(F(m)*F(n-m)) // C(n,m) = число сочетаний из n по m NEXT lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // 04 ***** Создать БД объектов CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций CREATE Struc APPEND BLANK REPLACE Field_name WITH "Obj_name",; Field_type WITH "C",; Field_len WITH 250; Field_dec WITH 0 FOR j=1 TO Sum_Cnm Mfn = "SlCh"+ALLTRIM(STR(j,2)) APPEND BLANK REPLACE Field_name WITH Mfn,; Field_type WITH "N",; Field_len WITH 15,; Field_dec WITH 0 NEXT FOR j=1 TO UrSlog_Obj Mfn = "PrCh"+ALLTRIM(STR(j,2)) APPEND BLANK REPLACE Field_name WITH Mfn,; Field_type WITH "N",; Field_len WITH 15 ,; Field_dec WITH 0 NEXT APPEND BLANK REPLACE Field_name WITH "Zero",; Field_type WITH "N",; Field_len WITH 1,; Field_dec WITH 0 ****** Создаем БД CREATE ObuchInf FROM Struc ERASE Struc.dbf lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // 05 CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE ObuchInf EXCLUSIVE NEW N = 0 FOR z=1 TO UrSlog_Obj SELECT ObuchInf ADD_ObInf(z) NEXT lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // 06 ***** Создать БД сложных чисел CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций CREATE Struc APPEND BLANK REPLACE Field_name WITH "Sl_Chis",; Field_type WITH "N",; Field_len WITH 15 ,; Field_dec WITH 0 FOR j=1 TO UrSlog_FP Mfn = "PrCh"+ALLTRIM(STR(j,2)) APPEND BLANK REPLACE Field_name WITH Mfn,; Field_type WITH "N",; Field_len WITH 15 ,; Field_dec WITH 0 NEXT ****** Создаем БД CREATE Sl_chis FROM Struc ERASE Struc.dbf lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // 07 CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Sl_chis EXCLUSIVE NEW INDEX ON STR(Sl_Chis,19) TO Sl_Chis lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // 08 CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Sl_chis INDEX Sl_Chis EXCLUSIVE NEW lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // 09 USE ObuchInf EXCLUSIVE NEW SELECT ObuchInf DBGOTOP() DO WHILE .NOT. EOF() Ar_GenObj := {} FOR j=1 TO UrSlog_Obj Mfn = "PrCh"+ALLTRIM(STR(j,2)) IF &Mfn > 0 AADD(Ar_GenObj, &Mfn) ELSE EXIT ENDIF NEXT Ar_slch := {} SELECT Sl_Chis;SET ORDER TO 1 FOR z=1 TO UrSlog_FP ADD_SlChis(z) NEXT SELECT ObuchInf FOR j=1 TO LEN(Ar_Slch) Mfn = "SlCh"+ALLTRIM(STR(j,2)) REPLACE &Mfn WITH Ar_Slch[j] M_Zero = 1 FOR i=2 TO FCOUNT()-1 IF FIELDGET(i) = 0 M_Zero = 0 EXIT ENDIF NEXT REPLACE Zero WITH M_Zero NEXT DBSKIP(1) ENDDO lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // 10 aSay[3]:SetCaption(aSay[3]:caption+L(' - Готово ')) aSay[4]:SetCaption(L('Формирование справочника классов')) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;ZAP INDEX ON Name_cls TO Cls_name lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // 11 CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes INDEX Cls_name EXCLUSIVE NEW;ZAP USE Sl_chis EXCLUSIVE NEW SELECT Sl_chis lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // 12 M_KodCls = 0 DBGOTOP() DO WHILE .NOT. EOF() M_SlCh = Sl_chis M_Name = ALLTRIM(STR(M_SlCh,13))+" = " Ar_PrCh := {} FOR j=1 TO UrSlog_FP M_PrCh =FIELDGET(1+j) IF M_PrCh > 0 AADD(Ar_PrCh, M_PrCh) ELSE EXIT ENDIF NEXT FOR j=1 TO LEN(Ar_PrCh) M_Name = M_Name+ALLTRIM(STR(Ar_PrCh[j],19))+IF(j 0 k=2 FOR jj=1 TO LEN(Ar_klass) IF k <= 5 FIELDPUT(k++,Ar_klass[jj]) ELSE APPEND BLANK REPLACE Kod_obj WITH M_KodObj k=2 FIELDPUT(k++,Ar_klass[jj]) ENDIF NEXT ENDIF SELECT Obi_Kpr APPEND BLANK REPLACE Kod_obj WITH M_KodObj IF LEN(Ar_atrib) > 0 k=2 FOR jj=1 TO LEN(Ar_atrib) IF k <= 8 FIELDPUT(k++,Ar_atrib[jj]) ELSE APPEND BLANK REPLACE Kod_obj WITH M_KodObj k=2 FIELDPUT(k++,Ar_atrib[jj]) ENDIF NEXT ENDIF SELECT ObuchInf DBSKIP(1) ENDDO lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // 18 ** Кодировать подсистемы базовых признаков IF Podsys_01 = 1 GenNtxObiKcl() SELECT Classes DBGOTOP() DO WHILE .NOT. EOF() M_Kod = Kod_cls M_Name = Name_cls M_Univ = Universal SELECT Gr_OpSc APPEND BLANK REPLACE Kod_OpSc WITH 1 REPLACE Kod_GrOs WITH M_Kod REPLACE Name_GrOs WITH M_Name REPLACE Universal WITH M_Univ SELECT Classes DBSKIP(1) ENDDO lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // 19 SELECT Obi_Zag DBGOTOP() DO WHILE .NOT. EOF() M_KodObj = Kod_obj SELECT Obi_Kcl;SET ORDER TO 1;T=DBSEEK(STR(M_KodObj,19)) IF T Ar := {} DO WHILE .NOT. EOF() .AND. M_KodObj = Kod_obj FOR j=2 TO 5 Mv = FIELDGET(j) IF 0 < Mv .AND. Mv <= N_Gos AADD(Ar, Mv) ENDIF NEXT DBSKIP(1) ENDDO ****** Запись массива кодов признаков в БД Obi_Kpr SELECT Obi_Kpr APPEND BLANK FIELDPUT(1,M_KodObj) IF LEN(Ar) > 0 k=2 FOR jj=1 TO LEN(Ar) IF k <= 8 FIELDPUT(k++,Ar[jj]) ELSE APPEND BLANK FIELDPUT(1,M_KodObj) k=2 FIELDPUT(k ,Ar[jj]) ENDIF NEXT ENDIF ENDIF SELECT Obi_Zag DBSKIP(1) ENDDO ENDIF lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // 20 aSay[6]:SetCaption(aSay[6]:caption+L(' - Готово ')) aSay[7]:SetCaption(L('Переиндексация всех БД созданного приложения')) GenNtxClass() // Классификационные шкалы и градации GenNtxOpSc() // Описательные шкалы GenNtxGrOpSc() // Градации описательных шкал GenNtxObiZag() // Заголовки объектов обучающей выборки GenNtxObiKcl() // Коды классов объектов обучающей выборки GenNtxObiKpr() // Коды признаков объектов обучающей выборки GenNtxRsoZag() // Заголовки объектов распознаваемой выборки GenNtxRsoKcl() // Коды классов объектов распознаваемой выборки GenNtxRsoKpr() // Коды признаков объектов распознаваемой выборки aSay[7]:SetCaption(aSay[7]:caption+L(' - Готово ')) lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // 21 N_InsLFakt = 1 // Кол-во фактически установленных лабораторных работ (факт) DC_DataRest( aSave_LW10 ) // Восстановление вычислительной среды (открытые и текущие БД и индексы) Running(.T.) // Чтобы не могли запустить какой-нибудь режим пока висит окно окончания работы oSay97:SetCaption(oSay97:caption) oButton:SetCaption(L('&Ok')) // Деструктурирование окна отображения графического Progress-bar oButton:activate := {||PostAppEvent(xbeP_Close,,,oDialog)} //<<<<<< Add This DC_AppEvent( @lOk ) oDialog:Destroy() ***************************************************************************************************** // Лаб.работы, устанавливаемые путем расчета исходных БД: CASE M_CurrLab=14 // Лаб.раб.№ 14: Исследование зашумленных когнитивных функций на примере свип-сигнала aSave_LW13 := DC_DataSave() // Сохранение вычислительной среды ************************************************************************************************** ** Массив с параметрами модели ******************** ** Если файл _1_3_13.arx существует, то ** присвоить всем переменным, задаваемым в диалоге, начальные значения ** из этого файла и с этими значениями начинать диалог ** Если файл _1_3_13.arx не существует, то ** присвоить всем переменным, задаваемым в диалоге, начальные значения по умолчанию ** и начинать диалог с этих значений IF FILE(Disk_dir+"\_1_3_LW13.arx") aParLW13 = DC_ARestore(Disk_dir+"\_1_3_LW13.arx") Arg_MinV = aParLW13[ 1] // Начальное значение аргумента Arg_MaxV = aParLW13[ 2] // Конечное значение аргумента Arg_Delta = aParLW13[ 3] // Шаг изменения аргумента Ampl = aParLW13[ 4] // Начальная ампилитуда свип-сигнала Chast = aParLW13[ 5] // Начальная частота свип-сигнала Faza = aParLW13[ 6] // Фаза свип-сигнала KZat_Ampl = aParLW13[ 7] // Коэффициент затухания амплитуды KZat_Chast = aParLW13[ 8] // Коэффициент возрастания частоты *** Параметры гауссовского шума Mean = aParLW13[ 9] // Среднее значение Sigma = aParLW13[10] // Средне-квадратичное отклонение N_Izmer = aParLW13[11] // Количество измерений знач.функции ELSE PUBLIC Arg_MinV := 0 // Начальное значение аргумента PUBLIC Arg_MaxV := 360 // Конечное значение аргумента PUBLIC Arg_Delta := 1 // Шаг изменения аргумента PUBLIC Ampl := 1 // Начальная ампилитуда свип-сигнала PUBLIC Chast := 3 // Начальная частота свип-сигнала PUBLIC Faza := 0 // Фаза свип-сигнала PUBLIC KZat_Ampl := 0.005 // Коэффициент затухания амплитуды PUBLIC KZat_Chast := 0.015 // Коэффициент возрастания частоты *** Параметры гауссовского шума PUBLIC Mean := 0 // Среднее значение PUBLIC Sigma := 10 // Средне-квадратичное отклонение PUBLIC N_Izmer := 3 // Количество измерений знач.функции ENDIF ************************************************************************************************** @ 0 , 0 DCSAY L('Исследование когнитивных функций') FONT "10.Helvetica Bold" SIZE 0 @ 0.8, 0 DCSAY L('на примере свип-сигнала с шумом' ) FONT "10.Helvetica Bold" SIZE 0 @ 0 ,38 DCPUSHBUTTON CAPTION L('Помощь') SIZE 15, 1.8 ACTION {||Help_LW13()} @ 2 , 0 DCGROUP oGroup1 CAPTION L('Задайте параметры синтеза модели:') SIZE 53, 19 @ 1 , 1 DCGROUP oGroup2 CAPTION L('Задайте параметры свип-сигнала:' ) SIZE 51, 10.5 PARENT oGroup1 Mess1 = L('Начальное значение аргумента:') Mess2 = L('Конечное значение аргумента:') Mess3 = L('Шаг изменения аргумента:' ) @ 1, 1 DCSAY Mess1 PARENT oGroup2 @ 2, 1 DCSAY Mess2 PARENT oGroup2 @ 3, 1 DCSAY Mess3 PARENT oGroup2 @ 1,30 DCSAY L(" ") GET Arg_MinV PARENT oGroup2 PICTURE "###############" @ 2,30 DCSAY L(" ") GET Arg_MaxV PARENT oGroup2 PICTURE "###############" @ 3,30 DCSAY L(" ") GET Arg_Delta PARENT oGroup2 PICTURE "#######.#######" Mess1 = L('Начальная ампилитуда свип-сигнала:') @ 5, 1 DCSAY Mess1 PARENT oGroup2 @ 5,30 DCSAY L(" ") GET Ampl PARENT oGroup2 PICTURE "###############" Mess1 = L('Начальная частота свип-сигнала:') @ 6, 1 DCSAY Mess1 PARENT oGroup2 @ 6,30 DCSAY L(" ") GET Chast PARENT oGroup2 PICTURE "###############" Mess1 = L('Фаза свип-сигнала:') @ 7, 1 DCSAY Mess1 PARENT oGroup2 @ 7,30 DCSAY L(" ") GET Faza PARENT oGroup2 PICTURE "###############" Mess1 = L('Коэффициент затухания амплитуды:') @ 8, 1 DCSAY Mess1 PARENT oGroup2 @ 8,30 DCSAY L(" ") GET KZat_Ampl PARENT oGroup2 PICTURE "#######.#######" Mess1 = L('Коэффициент возрастания частоты:') @ 9, 1 DCSAY Mess1 PARENT oGroup2 @ 9,30 DCSAY L(" ") GET KZat_Chast PARENT oGroup2 PICTURE "#######.#######" * @12.5, 1 DCGROUP oGroup3 CAPTION L('Задайте параметры аддитивного гауссовского шума:') SIZE 51, 5.5 PARENT oGroup1 @12.5, 1 DCGROUP oGroup3 CAPTION L('Задайте параметры шума:' ) SIZE 51, 5.5 PARENT oGroup1 Mess1 = 'Среднее значение:' @1, 1 DCSAY Mess1 PARENT oGroup3 @1,30 DCSAY L(" ") GET Mean PARENT oGroup3 PICTURE "#######.#######" * Mess1 = L('Средне-квадратичное отклонение:') Mess1 = 'Ампилитуда:' @2, 1 DCSAY Mess1 PARENT oGroup3 @2,30 DCSAY L(" ") GET Sigma PARENT oGroup3 PICTURE "#######.#######" Mess1 = L('Количество измерений знач.функции') Mess2 = L('для каждого значения аргумента:' ) @ 3 , 1 DCSAY Mess1 PARENT oGroup3 @ 3.7, 1 DCSAY Mess2 PARENT oGroup3 @ 3.4,30 DCSAY L(" ") GET N_Izmer PARENT oGroup3 PICTURE "###############" DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; OPTIONS GetOptions ; ADDBUTTONS ; MODAL ; TITLE L('1.3. Задание параметров модели Лаб.раб.№14') *************************************************** IF lExit ** Button Ok ELSE ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF *************************************************** ************************************************************************************************** N_Izmer = IF(N_Izmer >=1, N_Izmer, 1) // Сохранить файл с информацией о заданых параметрах модели в текущей директории системы // и в папке приложения, чтобы можно было потом узнать при каких параметрах оно создано PUBLIC aParLW13[11] aParLW13[ 1] = Arg_MinV // Начальное значение аргумента aParLW13[ 2] = Arg_MaxV // Конечное значение аргумента aParLW13[ 3] = Arg_Delta // Шаг изменения аргумента aParLW13[ 4] = Ampl // Начальная ампилитуда свип-сигнала aParLW13[ 5] = Chast // Начальная частота свип-сигнала aParLW13[ 6] = Faza // Фаза свип-сигнала aParLW13[ 7] = KZat_Ampl // Коэффициент затухания амплитуды aParLW13[ 8] = KZat_Chast // Коэффициент возрастания частоты *** Параметры гауссовского шума aParLW13[ 9] = Mean // Среднее значение aParLW13[10] = Sigma // Средне-квадратичное отклонение aParLW13[11] = N_Izmer // Количество измерений знач.функции DC_ASave(aParLW13 , Disk_dir +"\_1_3_LW13.arx") * DC_ASave(aParLW13 , M_NewAppl+"\_1_3_LW13.arx") ************************************************************************************************** // Задание максимальной величины параметра Time IF Sigma > 0 Wsego = 2 + ( ( Arg_MaxV - Arg_MinV + 1 ) / Arg_Delta ) * 2 * N_Izmer + 1 ELSE Wsego = 2 + ( ( Arg_MaxV - Arg_MinV + 1 ) / Arg_Delta ) * 1 * N_Izmer + 1 ENDIF // Начало отсчета времени для прогнозирования длительности исполнения Time_progress = 0 // Прошло секунд с начала процесса // Процесс может идти больше суток, поэтому для определения // во всех случаях вычисляется время, прошедшее с начала года T_Mess1 = L("Начало:")+" "+TIME() // Начало Sec_1 = (DOY(DATE())-1)*86400+SECONDS() PUBLIC T1 := (DOY(DATE())-1)*86400+SECONDS() // Время предыдущей индикации процесса исполнения PUBLIC T2 := (DOY(DATE())-1)*86400+SECONDS()+1 // Текущее время (1-й раз оно заметно больше T1 чтобы было отображение) PUBLIC T1tp := T1 PUBLIC T2tp := T2 ************************************************************************************************** // Подготовка данных для отображения графического прогресс-бар // Отображение стадии исполнения. Будет написано прямо в окне Progress-bar @ 0,0 DCGROUP oGroup1 CAPTION L('Стадии исполнения процесса') FONT "6.Helv" SIZE 105,5.5 ; PARENT oTabPage1 @ 7,0 DCGROUP oGroup2 CAPTION L('Прогноз времени исполнения') FONT "6.Helv" SIZE 105,5.0 ; PARENT oTabPage2 PRIVATE aSay[12] s = 1 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 1] FONT "10.Helv" // Создание файла исходных данных: "Inp_data.dbf" @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 2] FONT "10.Helv" // Создание файла наим.класс.и опис.шкал и градаций: "Inp_name.txt" @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 3] FONT "10.Helv" // Заполнение файла исходных данных: "Inp_data.dbf" @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 4] FONT "10.Helv" // Формирование файла параметров программного интерфейса: "_2_3_2_2.arx" s++ @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay97 FONT "10.HelvBold" s++ @0.2+s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay98 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @1.5+s ,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay99 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @s ,1 DCPROGRESS oProgress ; SIZE 95,1.5 ; PERCENT ; EVERY 1+INT(Wsego/nEvery) ; // Кол-во обновлений изображения MAXCOUNT Wsego ; COLOR GRA_CLR_CYAN // Цвет полосы @s++,97 DCPUSHBUTTON CAPTION L('&Cancel') ; ACTION {||lOk:=.T.} OBJECT oButton ; SIZE 7,1.5 DCREAD GUI ; TITLE L('1.3. Установка ')+aLabWName[M_CurrLab] ; PARENT @oDialog ; FIT ; EXIT ; MODAL oDialog:show() ************************************************************************************************** aSay[1]:SetCaption(L('1/4. Создание файла исходных данных: "Inp_data.dbf"')) //******************************************** // Путь на папку с исходными БД лабораторной работы M_PathInpData = UPPER(Disk_dir + "\AID_DATA\Inp_data\") DIRCHANGE(M_PathInpData) aStructure := { { "Obj_name" , "C", 25, 0 }, ; // Наименование объекта обучающей выборки { "Funct_TUni", "N", 19, 7 }, ; // Зашумленное (эмпирическое) значение функции (равномерное распределение) { "Funct_TNor", "N", 19, 7 }, ; // Зашумленное (эмпирическое) значение функции (нормальное распределение (аддитивный гауссовский шум)) { "Funct_True", "N", 19, 7 }, ; // Истинное (теоретическое) значение функции { "Noise_Unif", "N", 19, 7 }, ; // Значение шума (равномерное распределение) { "Noise_Norm", "N", 19, 7 }, ; // Значение шума (нормальное распределение (аддитивный гауссовский шум)) { "Argument" , "N", 19, 7 } } // Аргумент DbCreate( 'Inp_data.dbf', aStructure ) lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // 1 aSay[1]:SetCaption(aSay[1]:caption+L(' - Готово ')) aSay[2]:SetCaption(L('2/4. Создание файла наим.класс.и опис.шкал и градаций: "Inp_name.txt"')) //*************************** CrLf = CHR(13)+CHR(10) // Конец строки (записи) String = "Равномерно зашумленное (эмпирическое) значение функции" + CrLf +; "Нормально зашумленное (эмпирическое) значение функции" + CrLf +; "Истинное (теоретическое) значение функции" + CrLf +; "Значение шума (равномерное распределение)" + CrLf +; "Значение шума (нормальное распределение)" + CrLf +; "Значение аргумента" StrFile(String, "Inp_name.txt") // Запись текстового файла "Inp_name.txt" lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // 2 aSay[2]:SetCaption(aSay[2]:caption+L(' - Готово ')) aSay[3]:SetCaption(L('3/4. Заполнение файла исходных данных: "Inp_data.dbf"')) //******************************************* * aParLW13[ 1] = Arg_MinV // Начальное значение аргумента * aParLW13[ 2] = Arg_MaxV // Конечное значение аргумента * aParLW13[ 3] = Arg_Delta // Шаг изменения аргумента * aParLW13[ 4] = Ampl // Начальная ампилитуда свип-сигнала * aParLW13[ 5] = Chast // Начальная частота свип-сигнала * aParLW13[ 6] = Faza // Фаза свип-сигнала * aParLW13[ 7] = KZat_Ampl // Коэффициент затухания амплитуды * aParLW13[ 8] = KZat_Chast // Коэффициент возрастания частоты * *** Параметры гауссовского шума * aParLW13[ 9] = Mean // Среднее значение * aParLW13[10] = Sigma // Средне-квадратичное отклонение * aParLW13[11] = N_Izmer // Количество измерений знач.функции ** F(X) для r=0 и заданных Mean и Sigma: rn = 0 IF Sigma > 0 r0 = 1 / ( Sigma * SQRT( 2 * PI())) * EXP( -1/2 * ( rn - Mean )^2 / Sigma^2 ) ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Inp_data EXCLUSIVE NEW;ZAP SELECT Inp_data ********** Расчет и нормирование амплитуды шума ************ IF Sigma > 0 ru = Sec_1 rn = Sec_1 A_NoiseUnif := {} A_NoiseNorm := {} mMin_NoiseUnif = +9999999999 mMax_NoiseUnif = -9999999999 mMin_NoiseNorm = +9999999999 mMax_NoiseNorm = -9999999999 FOR mArg = Arg_MinV TO Arg_MaxV STEP Arg_Delta FOR mIzm = 1 TO N_Izmer ru = Mean + LC_RANDOM(ru) * 2 * Sigma - Sigma rn = Mean + LC_RANDOM(rn) * 2 * Sigma - Sigma r1 = 1 / ( Sigma * SQRT( 2 * PI())) * EXP( -1/2 * ( rn - Mean )^2 / Sigma^2 ) Gauss = IF(rn > 0, 1, -1) * (r0-r1) AADD(A_NoiseUnif, ru ) // Равномерное распределение AADD(A_NoiseNorm, Gauss ) // Нормальное распределение (аддитивный гауссовский шум) mMin_NoiseUnif = MIN(mMin_NoiseUnif, ru) mMax_NoiseUnif = MAX(mMax_NoiseUnif, ru) mMin_NoiseNorm = MIN(mMin_NoiseNorm, Gauss) mMax_NoiseNorm = MAX(mMax_NoiseNorm, Gauss) lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // 3 NEXT NEXT KNA_NoiseUnif = ( 2 * Sigma ) / (mMax_NoiseUnif - mMin_NoiseUnif) FOR j=1 TO LEN(A_NoiseUnif) A_NoiseUnif[j] = A_NoiseUnif[j] * KNA_NoiseUnif NEXT KNA_NoiseNorm = ( 2 * Sigma ) / (mMax_NoiseNorm - mMin_NoiseNorm) FOR j=1 TO LEN(A_NoiseNorm) A_NoiseNorm[j] = A_NoiseNorm[j] * KNA_NoiseNorm NEXT ENDIF un = 0 FOR mArg = Arg_MinV TO Arg_MaxV STEP Arg_Delta FOR mIzm = 1 TO N_Izmer F = Ampl*EXP(-KZat_Ampl*mArg)*COS(DTOR(Chast*mArg+Chast*EXP(+KZat_Chast*mArg)+Faza)) ++un APPEND BLANK IF Sigma > 0 REPLACE Obj_name WITH ALLTRIM(STR(mArg)) // Наименование объекта обучающей выборки REPLACE Funct_TUni WITH F + A_NoiseUnif[un] // Зашумленное (эмпирическое) значение функции (равномерное распределение) REPLACE Funct_TNor WITH F + A_NoiseNorm[un] // Зашумленное (эмпирическое) значение функции (нормальное распределение (аддитивный гауссовский шум)) REPLACE Funct_True WITH F // Истинное (теоретическое) значение функции REPLACE Noise_Unif WITH A_NoiseUnif[un] // Значение шума (равномерное распределение) REPLACE Noise_Norm WITH A_NoiseNorm[un] // Значение шума (нормальное распределение (аддитивный гауссовский шум)) REPLACE Argument WITH mArg // Аргумент ELSE REPLACE Obj_name WITH ALLTRIM(STR(mArg)) // Наименование объекта обучающей выборки REPLACE Funct_TUni WITH F // Зашумленное (эмпирическое) значение функции (равномерное распределение) REPLACE Funct_TNor WITH F // Зашумленное (эмпирическое) значение функции (нормальное распределение (аддитивный гауссовский шум)) REPLACE Funct_True WITH F // Истинное (теоретическое) значение функции REPLACE Noise_Unif WITH 0 // Значение шума (равномерное распределение) REPLACE Noise_Norm WITH 0 // Значение шума (нормальное распределение (аддитивный гауссовский шум)) REPLACE Argument WITH mArg // Аргумент ENDIF lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // 3 NEXT NEXT aSay[3]:SetCaption(aSay[3]:caption+L(' - Готово ')) aSay[4]:SetCaption(L('4/4. Формирование файла параметров программного интерфейса: "_2_3_2_2.arx"')) //********************** Regim = 1 // Формализации ПО или ген.расп.выб. Flag_zer = 1 // Считать нули и пробелы отсутствием данных? [1]-да, [2]-нет N_Chast = 1 // На сколько частей N разбивать обучающую или распознаваемую выборку (в зависимости от Regim) M_ClSc1 = 2 // Номер начального столбца диапазона классификационных шкал M_ClSc2 = 4 // Номер конечного столбца диапазона классификационных шкал M_OpSc1 = 7 // Номер начального столбца диапазона описательных шкал M_OpSc2 = 7 // Номер конечного столбца диапазона описательных шкал M_ObAnk = 3 // Создавать анкеты исходной выборки по строкам Inp_data-[1], по классам-[2], и 1-е, и 2-е [3] M_Interval = 1 // 1-равные интервалы, 2-адаптивные интервалы (с примерно равным количеством наблюдений, по Котельникову) N_SKGrCl = 30 N_SKGrPr = 30 K_N_ClSc = 1 K_N_OpSc = 1 K_N_GrClSc = 30 K_N_GrOpSc = 30 M_Scenario = .F. mGorizMin = 5 mGorizMax = 5 mGlubMin = 5 mGlubMax = 5 K_GradNClSc = 30 K_GradNOpSc = 30 M_ChastObi = .F. M_ChastRso = .F. N_ChastObi = 1 N_ChastRso = 1 M_XlsDbf = 3 mTxtCSField = 1 // Способ интерпретации значений текстовых полей - классификационных шкал файла исходных данных mTxtOSField = 1 // Способ интерпретации значений текстовых полей - описательных шкал файла исходных данных mTxtCSSep = " " // Разделитель элементов классификационных шкал, если mTxtCSField=3 mTxtOSSep = " " // Разделитель элементов описательных шкал, если mTxtOSField=3 * mScenario = 1 // mScenario=1 Не применять сценарный метод АСК-анализа и спец.интерпретацию TXT-полей (старый вариант) mScenario = 1 // Не применять сценарный метод АСК-анализа mSpecInterprCls = .F. // .T. - Применить спец.интерпретацию текстовых полей классов, .F. - не применять mSpecInterprAtr = .F. // .T. - Применить спец.интерпретацию текстовых полей признаков, .F. - не применять mNameGrNumSc= 1 // Какие наименования ГРАДАЦИЙ числовых шкал использовать mClsAvr = .F. // .F. - делать модель из Inp_data, .T. - делать модель из Inp_data_avr mSortUnqCls = 1 // Выделять уникальные значения классов и сортировать, 1-да, 2-нет mLemmatCls = 2 // Проводить лемматизацию классов, 1-да, 2-нет mSortUnqGos = 1 // Выделять уникальные значения признаков и сортировать, 1-да, 2-нет mLemmatGos = 2 // Проводить лемматизацию признаков, 1-да, 2-нет // Сохранить файл с информацией о заданых параметрах программного интерфейса в текущей директории системы PRIVATE aSoftInt[40] aSoftInt[ 1] = Regim aSoftInt[ 2] = Flag_zer aSoftInt[ 3] = M_ClSc1 aSoftInt[ 4] = M_ClSc2 aSoftInt[ 5] = M_OpSc1 aSoftInt[ 6] = M_OpSc2 aSoftInt[ 7] = N_SKGrCl aSoftInt[ 8] = N_SKGrPr aSoftInt[ 9] = K_N_ClSc aSoftInt[10] = K_N_OpSc aSoftInt[11] = K_N_GrClSc aSoftInt[12] = K_N_GrOpSc aSoftInt[13] = M_ObAnk aSoftInt[14] = N_Chast aSoftInt[15] = M_Interval aSoftInt[16] = M_Scenario aSoftInt[17] = K_GradNClSc // Количество градаций в числовой классификационной шкале aSoftInt[18] = K_GradNOpSc // Количество градаций в числовой описательной шкале aSoftInt[19] = mGorizMin aSoftInt[20] = mGorizMax aSoftInt[21] = mGlubMin aSoftInt[22] = mGlubMax aSoftInt[23] = M_ChastObi aSoftInt[24] = M_ChastRso aSoftInt[25] = N_ChastObi aSoftInt[26] = N_ChastRso aSoftInt[27] = M_XlsDbf aSoftInt[28] = mTxtCSField aSoftInt[29] = mTxtOSField aSoftInt[30] = mTxtCSSep aSoftInt[31] = mTxtOSSep * aSoftInt[32] = mScenario // mScenario=1 Не применять сценарный метод АСК-анализа и спец.интерпретацию TXT-полей (старый вариант) aSoftInt[32] = mScenario // mScenario=1 Не применять сценарный метод АСК-анализа aSoftInt[33] = mSpecInterprCls // Применить спец.интерпретацию текстовых полей классов aSoftInt[34] = mSpecInterprAtr // Применить спец.интерпретацию текстовых полей признаков aSoftInt[35] = mNameGrNumSc // Какие наименования ГРАДАЦИЙ числовых шкал использовать aSoftInt[36] = mClsAvr // .F. = модель без усреднения по классам aSoftInt[37] = mSortUnqCls // Выделять уникальные значения классов и сортировать, 1-да, 2-нет aSoftInt[38] = IF(mSpecInterprCls,mLemmatCls,2) // Проводить лемматизацию классов, 1-да, 2-нет aSoftInt[39] = mSortUnqGos // Выделять уникальные значения признаков и сортировать, 1-да, 2-нет aSoftInt[40] = IF(mSpecInterprAtr,mLemmatGos,2) // Проводить лемматизацию признаков, 1-да, 2-нет DC_ASave(aSoftInt , Disk_dir +"\_2_3_2_2.arx") * DC_ASave(aSoftInt , M_NewAppl+"\_2_3_2_2.arx") lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // 4 aSay[4]:SetCaption(aSay[4]:caption+L(' - Готово ')) Running(.T.) // Чтобы не могли запустить какой-нибудь режим пока висит окно окончания работы oSay97:SetCaption(oSay97:caption) oButton:SetCaption(L('&Ok')) // Деструктурирование окна отображения графического Progress-bar oButton:activate := {||PostAppEvent(xbeP_Close,,,oDialog)} //<<<<<< Add This DC_AppEvent( @lOk ) oDialog:Destroy() **** Отображение графических диаграмм PointChart("Norm") PointChart("Unif") *** Вызов функции 2.3.2.2() ********************************** ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW // Создать папку приложения - новой лабораторной работы M_NewAppl = ADD_ZAPPL(aLabWName[M_CurrLab]) // Путь на БД новой лабораторной работы в папке приложений и наименование ЛР в БД приложений // Создание пустых баз данных нового приложения DIRCHANGE(M_NewAppl) // Перейти в папку с новым приложением и создать БД формализации предметной области: GenDbfClSc(.F.) // Классификационные шкалы ######### GenDbfGrClSc(.F.) // Градации классификационных шкал ######### GenDbfClass(.F.) // Классификационные шкалы и градации GenDbfOpSc(.F.) // Описательные шкалы GenDbfGrOpSc(.F.) // Градации описательных шкал GenDbfAttr(.F.) // Описательные шкалы и градации ######### GenDbfObiZag() // Заголовки объектов обучающей выборки GenDbfObiKcl() // Коды классов объектов обучающей выборки GenDbfObiKpr() // Коды признаков объектов обучающей выборки GenDbfRsoZag() // Заголовки объектов распознаваемой выборки GenDbfRsoKcl() // Коды классов объектов распознаваемой выборки GenDbfRsoKpr() // Коды признаков объектов распознаваемой выборки F2_3_2_2(aLabWName[M_CurrLab],"1.3()") // Запуск универсального программного интерфейса с внешними базами данных aMess := {} mLW = ALLTRIM(aLabWName[M_CurrLab]) AADD(aMess, STRTRAN(mLW, ":", ': "')+'" успешно установлена!') AADD(aMess, L(" ")) AADD(aMess, L("Для дальнейшего ее изучения и выполнения необходимо:")) AADD(aMess, L(" ")) AADD(aMess, L("1. Открыть файл исходных данных: "+M_PathInpData+"Inp_data.dbf.")) AADD(aMess, L(" ")) AADD(aMess, L("2. Прочитать описание данной лабораторной работы в режиме 5.14.")) AADD(aMess, L(" ")) AADD(aMess, L("3. Выполнить режимы: 2.1, 2.2, 2.3.1, 3.5, 5.5, 3.4 и другие")) AADD(aMess, L(" в соответствии со схемой преобразования данных в информацию,")) AADD(aMess, L(" а ее в знания, приведенной в режиме 6.4.")) LB_Warning(aMess, L('(C) Универсальная когнитивная аналитическая система "Эйдос-Х++"')) N_InsLFakt = 1 // Кол-во фактически установленных лабораторных работ (факт) CASE M_CurrLab=15 // Лаб.раб.№ 15: Исследование нормального распределения ************************************************************************************************** ** Массив с параметрами модели ******************** ** Если файл _1_3_15.arx существует, то ** присвоить всем переменным, задаваемым в диалоге, начальные значения ** из этого файла и с этими значениями начинать диалог ** Если файл _1_3_15.arx не существует, то ** присвоить всем переменным, задаваемым в диалоге, начальные значения по умолчанию ** и начинать диалог с этих значений IF FILE(Disk_dir+"\_1_3_LW15.arx") aParLW15 = DC_ARestore(Disk_dir+"\_1_3_LW15.arx") *** Параметры исходных данных Arg_MinV = aParLW15[ 1] // Начальное значение аргумента Arg_MaxV = aParLW15[ 2] // Конечное значение аргумента N_Arg = aParLW15[ 3] // Количество значений аргумента N_Nabl = aParLW15[ 4] // Количество наблюдений *** Параметры нормальных распределений Mean_MinV = aParLW15[ 5] // Начальное значение среднего Mean_MaxV = aParLW15[ 6] // Конечное значение среднего N_Mean = aParLW15[ 7] // Количество значений среднего Sigma_MinV = aParLW15[ 8] // Начальное значение среднеквадратичного отклонения Sigma_MaxV = aParLW15[ 9] // Конечное значение среднеквадратичного отклонения N_Sigma = aParLW15[10] // Количество значений среднеквадратичного отклонения ELSE *** Параметры исходных данных PUBLIC Arg_MinV := -4 // Начальное значение аргумента PUBLIC Arg_MaxV := +4 // Конечное значение аргумента PUBLIC N_Arg := 500 // Количество значений аргумента PUBLIC N_Nabl := 250 // Количество наблюдений *** Параметры нормальных распределений PUBLIC Mean_MinV := -0.5 // Начальное значение среднего PUBLIC Mean_MaxV := +0.5 // Конечное значение среднего PUBLIC N_Mean := 3 // Количество значений среднего PUBLIC Sigma_MinV := 0.5 // Начальное значение среднеквадратичного отклонения PUBLIC Sigma_MaxV := 1.5 // Конечное значение среднеквадратичного отклонения PUBLIC N_Sigma := 3 // Количество значений среднеквадратичного отклонения ENDIF ************************************************************************************************** @ 0 , 0 DCSAY L('Исследование нормальных распреде-') FONT "10.Helvetica Bold" SIZE 0 @ 0.8, 0 DCSAY L('лений методами теории информации ') FONT "10.Helvetica Bold" SIZE 0 @ 0 ,42 DCPUSHBUTTON CAPTION L('Помощь') SIZE 12, 1.8 ACTION {||Help_LW13()} @ 2.0, 0 DCGROUP oGroup1 CAPTION L('Задайте параметры исходных данных:') SIZE 54, 5.5 Mess1 = L('Начальное значение аргумента:') Mess2 = L('Конечное значение аргумента:') Mess3 = L('Количество значений аргумента:') Mess4 = L('Количество наблюдений в распределении:') @ 1 , 1 DCSAY Mess1 PARENT oGroup1 @ 2 , 1 DCSAY Mess2 PARENT oGroup1 @ 3 , 1 DCSAY Mess3 PARENT oGroup1 @ 4 , 1 DCSAY Mess4 PARENT oGroup1 @ 1.0,32 DCSAY L(" ") GET Arg_MinV PARENT oGroup1 PICTURE "###############" @ 2.0,32 DCSAY L(" ") GET Arg_MaxV PARENT oGroup1 PICTURE "###############" @ 3.0,32 DCSAY L(" ") GET N_Arg PARENT oGroup1 PICTURE "###############" @ 4.0,32 DCSAY L(" ") GET N_Nabl PARENT oGroup1 PICTURE "###############" @ 8.0, 0 DCGROUP oGroup2 CAPTION L('Задайте параметры среднего значения:') SIZE 54, 4.5 Mess1 = L('Начальное значение среднего:') Mess2 = L('Конечное значение среднего:') Mess3 = L('Количество значений среднего:') @ 1 , 1 DCSAY Mess1 PARENT oGroup2 @ 2 , 1 DCSAY Mess2 PARENT oGroup2 @ 3 , 1 DCSAY Mess3 PARENT oGroup2 @ 1.0,32 DCSAY L(" ") GET Mean_MinV PARENT oGroup2 PICTURE "#######.#######" @ 2.0,32 DCSAY L(" ") GET Mean_MaxV PARENT oGroup2 PICTURE "#######.#######" @ 3.0,32 DCSAY L(" ") GET N_Mean PARENT oGroup2 PICTURE "###############" @13.0, 0 DCGROUP oGroup3 CAPTION L('Задайте параметры стандартного отклонения:') SIZE 54, 4.5 Mess1 = L('Начальное значение станд.отклонения:') Mess2 = L('Конечное значение станд.отклонения:') Mess3 = L('Количество значений станд.отклонения:') @ 1 , 1 DCSAY Mess1 PARENT oGroup3 @ 2 , 1 DCSAY Mess2 PARENT oGroup3 @ 3 , 1 DCSAY Mess3 PARENT oGroup3 @ 1.0,32 DCSAY L(" ") GET Sigma_MinV PARENT oGroup3 PICTURE "#######.#######" @ 2.0,32 DCSAY L(" ") GET Sigma_MaxV PARENT oGroup3 PICTURE "#######.#######" @ 3.0,32 DCSAY L(" ") GET N_Sigma PARENT oGroup3 PICTURE "###############" DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; OPTIONS GetOptions ; ADDBUTTONS ; MODAL ; TITLE L('1.5. Задание параметров модели Лаб.раб.№15') *************************************************** IF lExit ** Button Ok ELSE ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF *************************************************** ************************************************************************************************** * N_Arg // Кол-во значений аргумента * N_Nabl = IF(N_Nabl >=N_Arg, N_Nabl, N_Arg) // Сохранить файл с информацией о заданых параметрах модели в текущей директории системы // и в папке приложения, чтобы можно было потом узнать при каких параметрах оно создано PUBLIC aParLW15[10] *** Параметры исходных данных aParLW15[ 1] = Arg_MinV // Начальное значение аргумента aParLW15[ 2] = Arg_MaxV // Конечное значение аргумента aParLW15[ 3] = N_Arg // Количество значений аргумента aParLW15[ 4] = N_Nabl // Количество наблюдений *** Параметры нормальных распределений aParLW15[ 5] = Mean_MinV // Начальное значение среднего aParLW15[ 6] = Mean_MaxV // Конечное значение среднего aParLW15[ 7] = N_Mean // Количество значений среднего aParLW15[ 8] = Sigma_MinV // Начальное значение среднеквадратичного отклонения aParLW15[ 9] = Sigma_MaxV // Конечное значение среднеквадратичного отклонения aParLW15[10] = N_Sigma // Количество значений среднеквадратичного отклонения ************************************************************************************************** ** Проверить корректность заданных параметров FlagErr = .F. IF Arg_MinV < Arg_MaxV ELSE MessErr = 'Неверно задан диапазон значений аргументов: конечное значение должно быть больше начального !' FlagErr = .T. ENDIF IF N_Arg > 2 ELSE MessErr = 'Неверно задано количество значений аргумента: их должно быть больше одного !' FlagErr = .T. ENDIF IF N_Nabl > 2 ELSE MessErr = 'Неверно задано количество наблюдений: их должно быть больше одного !' FlagErr = .T. ENDIF IF Mean_MinV < Mean_MaxV ELSE MessErr = 'Неверно задан диапазон значений среднего: конечное значение должно быть больше начального !' FlagErr = .T. ENDIF IF N_Mean > 2 ELSE MessErr = 'Неверно задано количество значений среднего: их должно быть больше одного !' FlagErr = .T. ENDIF IF Sigma_MinV < Sigma_MaxV ELSE MessErr = 'Неверно задан диапазон значений станд.отклонения: конечное значение должно быть больше начального !' FlagErr = .T. ENDIF IF N_Sigma > 2 ELSE MessErr = 'Неверно задано количество значений станд.отклонения: их должно быть больше одного !' FlagErr = .T. ENDIF IF FlagErr LB_Warning(MessErr, '(C) Универсальная когнитивная аналитическая система "Эйдос-Х++"') ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN(.F.) ENDIF DC_ASave(aParLW15 , Disk_dir +"\_1_3_LW15.arx") * DC_ASave(aParLW15 , M_NewAppl+"\_1_3_LW15.arx") ************************************************************************************************** // Задание максимальной величины параметра Time Wsego = N_Mean * 2 + N_Arg + 1 + 1 + N_Arg + N_Mean * 5 + N_Arg + 1 // Начало отсчета времени для прогнозирования длительности исполнения Time_progress = 0 // Прошло секунд с начала процесса // Процесс может идти больше суток, поэтому для определения // во всех случаях вычисляется время, прошедшее с начала года T_Mess1 = L("Начало:")+" "+TIME() // Начало Sec_1 = (DOY(DATE())-1)*86400+SECONDS() PUBLIC T1 := (DOY(DATE())-1)*86400+SECONDS() // Время предыдущей индикации процесса исполнения PUBLIC T2 := (DOY(DATE())-1)*86400+SECONDS()+1 // Текущее время (1-й раз оно заметно больше T1 чтобы было отображение) PUBLIC T1tp := T1 PUBLIC T2tp := T2 ************************************************************************************************** // Подготовка данных для отображения графического прогресс-бар // Отображение стадии исполнения. Будет написано прямо в окне Progress-bar @ 0,0 DCGROUP oGroup1 CAPTION L('Стадии исполнения процесса') FONT "6.Helv" SIZE 105,6.5 ; PARENT oTabPage1 @ 8,0 DCGROUP oGroup2 CAPTION L('Прогноз времени исполнения') FONT "6.Helv" SIZE 105,5.0 ; PARENT oTabPage2 PRIVATE aSay[12] s = 1 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 1] FONT "10.Helv" // Создание файла для расчета норм.рапределений: "Norm_raspr.dbf" @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 2] FONT "10.Helv" // Создание файла исходных данных: "Inp_data.dbf" @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 3] FONT "10.Helv" // Создание файла наим.класс.и опис.шкал и градаций: "Inp_name.txt" @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 4] FONT "10.Helv" // Заполнение файла исходных данных: "Inp_data.dbf" @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 5] FONT "10.Helv" // Формирование файла параметров программного интерфейса: "_2_3_2_2.arx" s++ @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay97 FONT "10.HelvBold" s++ @0.2+s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay98 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @1.5+s ,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay99 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @s ,1 DCPROGRESS oProgress ; SIZE 95,1.5 ; PERCENT ; EVERY 1+INT(Wsego/nEvery) ; // Кол-во обновлений изображения MAXCOUNT Wsego ; COLOR GRA_CLR_CYAN // Цвет полосы @s++,97 DCPUSHBUTTON CAPTION L('&Cancel') ; ACTION {||lOk:=.T.} OBJECT oButton ; SIZE 7,1.5 DCREAD GUI ; TITLE L('1.3. Установка ')+aLabWName[M_CurrLab] ; PARENT @oDialog ; FIT ; EXIT ; MODAL oDialog:alwaysOnTop = .T. // Окно открывается на переднем плане oDialog:show() ************************************************************************************************** aSay[1]:SetCaption(L('1/5. Создание файла для расчета норм.рапр.: "Norm_raspr.dbf"')) //*********************************** // Путь на папку с исходными БД лабораторной работы M_PathInpData = UPPER(Disk_dir + "\AID_DATA\Inp_data\") DIRCHANGE(M_PathInpData) aStructure := { { "Num_pp" , "N", 15, 0 },; // Порядковый номер { "Agrument", "N", 19, 7 } } // Значение аргумента FOR im=1 TO N_Mean FOR jm=1 TO N_Sigma mFun = "NR-"+ALLTRIM(STR(im,19))+"-"+ALLTRIM(STR(jm,19)) AADD(aStructure, { mFun, "N", 19, 7 }) NEXT lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // N_Mean NEXT DbCreate( 'Norm_raspr.dbf', aStructure ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Norm_raspr EXCLUSIVE NEW SELECT Norm_raspr * ********************************************************************************** * *** Параметры исходных данных * aParLW15[ 1] = Arg_MinV // Начальное значение аргумента * aParLW15[ 2] = Arg_MaxV // Конечное значение аргумента * aParLW15[ 3] = N_Arg // Количество значений аргумента * aParLW15[ 4] = N_Nabl // Количество наблюдений * *** Параметры нормальных распределений * aParLW15[ 5] = Mean_MinV // Начальное значение среднего * aParLW15[ 6] = Mean_MaxV // Конечное значение среднего * aParLW15[ 7] = N_Mean // Количество значений среднего * aParLW15[ 8] = Sigma_MinV // Начальное значение среднеквадратичного отклонения * aParLW15[ 9] = Sigma_MaxV // Конечное значение среднеквадратичного отклонения * aParLW15[10] = N_Sigma // Количество значений среднеквадратичного отклонения * ********************************************************************************** ****** Заполнение БД значениями аргумента и функции для разных распределений PUBLIC aMean[N_Mean*N_Sigma] PUBLIC aSigma[N_Mean*N_Sigma] c = 0 FOR im=1 TO N_Mean FOR jm=1 TO N_Sigma c++ aMean[c] = Mean_MinV + (im-1) * (Mean_MaxV - Mean_MinV ) / (N_Mean -1) aSigma[c] = Sigma_MinV + (jm-1) * (Sigma_MaxV - Sigma_MinV) / (N_Sigma-1) NEXT lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // N_Mean * 2 NEXT FOR km = 1 TO N_Arg xm = Arg_MinV + (km-1) * (Arg_MaxV - Arg_MinV) / (N_Arg-1) APPEND BLANK REPLACE Num_pp WITH km REPLACE Agrument WITH xm c = 0 FOR im=1 TO N_Mean FOR jm=1 TO N_Sigma c++ FIELDPUT(2+c, 1 / ( aSigma[c] * SQRT( 2 * PI())) * EXP( -1/2 * ( xm - aMean[c] )^2 / aSigma[c]^2 )) NEXT NEXT lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // N_Mean * 2 + N_Arg NEXT aSay[1]:SetCaption(aSay[1]:caption+L(' - Готово ')) ************************************************************************************************************************ * MsgBox('STOP') aSay[2]:SetCaption(L('2/5. Создание файла исходных данных: "Inp_data.dbf"')) //******************************************** // Путь на папку с исходными БД лабораторной работы M_PathInpData = UPPER(Disk_dir + "\AID_DATA\Inp_data\") DIRCHANGE(M_PathInpData) aStructure := { { "Num_obj" , "C", 15, 0 },; // 1 Порядковый номер { "FunctChr", "C", 19, 0 },; // 2 Значение функции текстовое { "FunctNum", "N", 19, 7 },; // 3 Значение функции числовое { "Argument", "N", 19, 7 },; // 4 Значение аргумента { "Mean" , "N", 19, 7 },; // 5 Среднее значение { "Sigma" , "N", 19, 7 } } // 6 Стандартное отклонение DbCreate( 'Inp_data.dbf', aStructure ) lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // N_Mean * 2 + N_Arg + 1 aSay[2]:SetCaption(aSay[2]:caption+L(' - Готово ')) ************************************************************************************************************************ * MsgBox('STOP') aSay[3]:SetCaption(L('3/5. Создание файла наим.класс.и опис.шкал и градаций: "Inp_name.txt"')) //*************************** CrLf = CHR(13)+CHR(10) // Конец строки (записи) String = "Текстовое значение функции" + CrLf +; "Числовое значение функции" + CrLf +; "Значение аргумента" + CrLf +; "Среднее значение" + CrLf +; "Стандартное отклонение" StrFile(String, "Inp_name.txt") // Запись текстового файла "Inp_name.txt" lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // N_Mean * 2 + N_Arg + 1 + 1 aSay[3]:SetCaption(aSay[3]:caption+L(' - Готово ')) ************************************************************************************************************************ * MsgBox('STOP') aSay[4]:SetCaption(L('4/5. Заполнение файла исходных данных: "Inp_data.dbf"')) //******************************************* * ********************************************************************************** * *** Параметры исходных данных * aParLW15[ 1] = Arg_MinV // Начальное значение аргумента * aParLW15[ 2] = Arg_MaxV // Конечное значение аргумента * aParLW15[ 3] = N_Arg // Количество значений аргумента * aParLW15[ 4] = N_Nabl // Количество наблюдений * *** Параметры нормальных распределений * aParLW15[ 5] = Mean_MinV // Начальное значение среднего * aParLW15[ 6] = Mean_MaxV // Конечное значение среднего * aParLW15[ 7] = N_Mean // Количество значений среднего * aParLW15[ 8] = Sigma_MinV // Начальное значение среднеквадратичного отклонения * aParLW15[ 9] = Sigma_MaxV // Конечное значение среднеквадратичного отклонения * aParLW15[10] = N_Sigma // Количество значений среднеквадратичного отклонения * ********************************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Inp_data EXCLUSIVE NEW USE Norm_raspr EXCLUSIVE NEW PUBLIC aSumma[N_Mean*N_Sigma] PUBLIC aPrice[N_Mean*N_Sigma] AFILL(aSumma, 0) AFILL(aPrice, -1) SELECT Norm_raspr DBGOTOP() DO WHILE .NOT. EOF() c = 0 FOR im=1 TO N_Mean FOR jm=1 TO N_Sigma c++ aSumma[c] = aSumma[c] + FIELDGET(2+c) NEXT NEXT lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // N_Mean * 2 + N_Arg + 1 + 1 + N_Arg DBSKIP(1) ENDDO c = 0 FOR im=1 TO N_Mean FOR jm=1 TO N_Sigma c++ IF aSumma[c] <> 0 aPrice[c] = N_Nabl / aSumma[c] ENDIF NEXT lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // N_Mean * 2 + N_Arg + 1 + 1 + N_Arg + N_Mean NEXT APPEND BLANK c = 0 FOR im=1 TO N_Mean FOR jm=1 TO N_Sigma c++ FIELDPUT(2+c, aSumma[c]) NEXT lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // N_Mean * 2 + N_Arg + 1 + 1 + N_Arg + N_Mean * 2 NEXT APPEND BLANK c = 0 FOR im=1 TO N_Mean FOR jm=1 TO N_Sigma c++ FIELDPUT(2+c, aPrice[c]) NEXT lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // N_Mean * 2 + N_Arg + 1 + 1 + N_Arg + N_Mean * 3 NEXT APPEND BLANK c = 0 FOR im=1 TO N_Mean FOR jm=1 TO N_Sigma c++ FIELDPUT(2+c, aMean[c]) NEXT lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // N_Mean * 2 + N_Arg + 1 + 1 + N_Arg + N_Mean * 4 NEXT APPEND BLANK c = 0 FOR im=1 TO N_Mean FOR jm=1 TO N_Sigma c++ FIELDPUT(2+c, aSigma[c]) NEXT lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // N_Mean * 2 + N_Arg + 1 + 1 + N_Arg + N_Mean * 5 NEXT * aStructure := { { "Num_obj" , "C", 15, 0 },; // 1 Порядковый номер * { "FunctChr", "C", 19, 0 },; // 2 Значение функции текстовое * { "FunctNum", "N", 19, 7 },; // 3 Значение функции числовое * { "Argument", "N", 19, 7 },; // 4 Значение аргумента * { "Mean" , "N", 19, 7 },; // 5 Среднее значение * { "Sigma" , "N", 19, 7 } } // 6 Стандартное отклонение SELECT Inp_data mNumObj = 0 FOR km = 1 TO N_Arg xm = Arg_MinV + (km-1) * (Arg_MaxV - Arg_MinV) / N_Arg c = 0 FOR im=1 TO N_Mean FOR jm=1 TO N_Sigma c++ N_Record = aPrice[c] / ( aSigma[c] * SQRT( 2 * PI())) * EXP( -1/2 * ( xm - aMean[c] )^2 / aSigma[c]^2 ) IF N_Record > 0 FOR r=1 TO ROUND(N_Record,0) APPEND BLANK REPLACE Num_obj WITH ALLTRIM(STR(++mNumObj)) REPLACE FunctChr WITH "Gauss-"+ALLTRIM(STR(im,19))+"-"+ALLTRIM(STR(jm,19)) REPLACE FunctNum WITH N_Record REPLACE Argument WITH xm REPLACE Mean WITH aMean[c] REPLACE Sigma WITH aSigma[c] NEXT ENDIF NEXT NEXT lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // N_Mean * 2 + N_Arg + 1 + 1 + N_Arg + N_Mean * 5 + N_Arg NEXT aSay[4]:SetCaption(aSay[4]:caption+L(' - Готово ')) ************************************************************************************************************************ * MsgBox('STOP') aSay[5]:SetCaption(L('5/5. Формирование файла параметров программного интерфейса: "_2_3_2_2.arx"')) //********************** * IF FILE("_2_3_2_2.arx") * * aSoftInt = DC_ARestore(Disk_dir+"\_2_3_2_2.arx") // Если параметры были заданы ранее, то использовать их * * ELSE Regim = 1 // Формализации ПО или ген.расп.выб. Flag_zer = 1 // Считать нули и пробелы отсутствием данных? [1]-да, [2]-нет N_Chast = 1 // На сколько частей N разбивать обучающую или распознаваемую выборку (в зависимости от Regim) M_ClSc1 = 2 // Номер начального столбца диапазона классификационных шкал M_ClSc2 = 2 // Номер конечного столбца диапазона классификационных шкал M_OpSc1 = 3 // Номер начального столбца диапазона описательных шкал M_OpSc2 = 6 // Номер конечного столбца диапазона описательных шкал M_ObAnk = 3 // Создавать анкеты исходной выборки по строкам Inp_data-[1], по классам-[2], и 1-е, и 2-е [3] M_Interval = 1 // 1-равные интервалы, 2-адаптивные интервалы (с примерно равным количеством наблюдений, по Котельникову) N_SKGrCl = 30 N_SKGrPr = 30 K_N_ClSc = 1 K_N_OpSc = 1 K_N_GrClSc = 30 K_N_GrOpSc = 30 M_Scenario = .F. mGorizMin = 5 mGorizMax = 5 mGlubMin = 5 mGlubMax = 5 K_GradNClSc = 30 K_GradNOpSc = 30 M_ChastObi = .F. M_ChastRso = .F. N_ChastObi = 1 N_ChastRso = 1 M_XlsDbf = 3 mTxtCSField = 1 // Способ интерпретации значений текстовых полей - классификационных шкал файла исходных данных mTxtOSField = 1 // Способ интерпретации значений текстовых полей - описательных шкал файла исходных данных mTxtCSSep = " " // Разделитель элементов классификационных шкал, если mTxtCSField=3 mTxtOSSep = " " // Разделитель элементов описательных шкал, если mTxtOSField=3 * mScenario = 1 // mScenario=1 Не применять сценарный метод АСК-анализа и спец.интерпретацию TXT-полей mScenario = 1 // Не применять сценарный метод АСК-анализа mSpecInterprCls = .F. // Не применять спец.интерпретацию текстовых полей классов mSpecInterprAtr = .F. // Не применять спец.интерпретацию текстовых полей признаков mNameGrNumSc= 1 // Какие наименования ГРАДАЦИЙ числовых шкал использовать mClsAvr = .F. // .F. - делать модель из Inp_data, .T. - делать модель из Inp_data_avr mSortUnqCls = 1 // Выделять уникальные значения классов и сортировать, 1-да, 2-нет mLemmatCls = 2 // Проводить лемматизацию классов, 1-да, 2-нет mSortUnqGos = 1 // Выделять уникальные значения признаков и сортировать, 1-да, 2-нет mLemmatGos = 2 // Проводить лемматизацию признаков, 1-да, 2-нет // Сохранить файл с информацией о заданых параметрах программного интерфейса в текущей директории системы PRIVATE aSoftInt[40] aSoftInt[ 1] = Regim aSoftInt[ 2] = Flag_zer aSoftInt[ 3] = M_ClSc1 aSoftInt[ 4] = M_ClSc2 aSoftInt[ 5] = M_OpSc1 aSoftInt[ 6] = M_OpSc2 aSoftInt[ 7] = N_SKGrCl aSoftInt[ 8] = N_SKGrPr aSoftInt[ 9] = K_N_ClSc aSoftInt[10] = K_N_OpSc aSoftInt[11] = K_N_GrClSc aSoftInt[12] = K_N_GrOpSc aSoftInt[13] = M_ObAnk aSoftInt[14] = N_Chast aSoftInt[15] = M_Interval aSoftInt[16] = M_Scenario aSoftInt[17] = K_GradNClSc // Количество градаций в числовой классификационной шкале aSoftInt[18] = K_GradNOpSc // Количество градаций в числовой описательной шкале aSoftInt[19] = mGorizMin aSoftInt[20] = mGorizMax aSoftInt[21] = mGlubMin aSoftInt[22] = mGlubMax aSoftInt[23] = M_ChastObi aSoftInt[24] = M_ChastRso aSoftInt[25] = N_ChastObi aSoftInt[26] = N_ChastRso aSoftInt[27] = M_XlsDbf aSoftInt[28] = mTxtCSField aSoftInt[29] = mTxtOSField aSoftInt[30] = mTxtCSSep aSoftInt[31] = mTxtOSSep * aSoftInt[32] = mScenario // mScenario=1 Не применять сценарный метод АСК-анализа и спец.интерпретацию TXT-полей (старый вариант) aSoftInt[32] = mScenario // mScenario=1 Не применять сценарный метод АСК-анализа aSoftInt[33] = mSpecInterprCls // Применить спец.интерпретацию текстовых полей классов aSoftInt[34] = mSpecInterprAtr // Применить спец.интерпретацию текстовых полей признаков aSoftInt[35] = mNameGrNumSc // Какие наименования ГРАДАЦИЙ числовых шкал использовать aSoftInt[36] = mClsAvr // .F. = модель без усреднения по классам aSoftInt[37] = mSortUnqCls // Выделять уникальные значения классов и сортировать, 1-да, 2-нет aSoftInt[38] = IF(mSpecInterprCls,mLemmatCls,2) // Проводить лемматизацию классов, 1-да, 2-нет aSoftInt[39] = mSortUnqGos // Выделять уникальные значения признаков и сортировать, 1-да, 2-нет aSoftInt[40] = IF(mSpecInterprAtr,mLemmatGos,2) // Проводить лемматизацию признаков, 1-да, 2-нет * ENDIF DC_ASave(aSoftInt , Disk_dir +"\_2_3_2_2.arx") * DC_ASave(aSoftInt , M_NewAppl+"\_2_3_2_2.arx") lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // N_Mean * 2 + N_Arg + 1 + 1 + N_Arg + N_Mean * 5 + N_Arg + 1 aSay[5]:SetCaption(aSay[5]:caption+L(' - Готово ')) ************************************************************************************************************************ * MsgBox('STOP') Running(.T.) // Чтобы не могли запустить какой-нибудь режим пока висит окно окончания работы oSay97:SetCaption(oSay97:caption) oButton:SetCaption(L('&Ok')) // Деструктурирование окна отображения графического Progress-bar oButton:activate := {||PostAppEvent(xbeP_Close,,,oDialog)} //<<<<<< Add This DC_AppEvent( @lOk ) oDialog:Destroy() **** Отображение графических диаграмм * PointChart("Norm") * PointChart("Unif") *** Вызов функции 2.3.2.2() ********************************** ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW // Создать папку приложения - новой лабораторной работы M_NewAppl = ADD_ZAPPL(aLabWName[M_CurrLab]) // Путь на БД новой лабораторной работы в папке приложений и наименование ЛР в БД приложений // Создание пустых баз данных нового приложения DIRCHANGE(M_NewAppl) // Перейти в папку с новым приложением и создать БД формализации предметной области: GenDbfClSc(.F.) // Классификационные шкалы ######### GenDbfGrClSc(.F.) // Градации классификационных шкал ######### GenDbfClass(.F.) // Классификационные шкалы и градации GenDbfOpSc(.F.) // Описательные шкалы GenDbfGrOpSc(.F.) // Градации описательных шкал GenDbfAttr(.F.) // Описательные шкалы и градации ######### GenDbfObiZag() // Заголовки объектов обучающей выборки GenDbfObiKcl() // Коды классов объектов обучающей выборки GenDbfObiKpr() // Коды признаков объектов обучающей выборки GenDbfRsoZag() // Заголовки объектов распознаваемой выборки GenDbfRsoKcl() // Коды классов объектов распознаваемой выборки GenDbfRsoKpr() // Коды признаков объектов распознаваемой выборки F2_3_2_2(aLabWName[M_CurrLab],"1.3()") // Запуск универсального программного интерфейса с внешними базами данных **************************************************************************************************************** ***** Подготовка распознаваемой выборки ************************************************************************ **************************************************************************************************************** ***** На основе БД EventsKO.dbf сделать БД распознаваемой выборки, ***** включающие столько описаний объектов, сколько задано распределений ***** для каждого распределения в кодах классов включить все уникальные коды классов всех объектов обучающей выборки, ***** а в коды признаков включить ВСЕ коды признаков всех объектов обучающей выборки ***** Сделать краткое отображение времени исполнения DIRCHANGE(M_NewAppl) // Перейти в папку с новым приложением и создать БД формализации предметной области: CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE EventsKO EXCLUSIVE NEW INDEX ON FunctCHR TO NR_tmp CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE EventsKO INDEX NR_tmp EXCLUSIVE NEW USE Rso_Zag EXCLUSIVE NEW;ZAP USE Rso_Kcl EXCLUSIVE NEW;ZAP USE Rso_Kpr EXCLUSIVE NEW;ZAP SELECT EventsKO SET ORDER TO 1 DBGOTOP() mFunctCHR = FunctCHR A_KodCls := {} A_KodAtr := {} M_KodObj = 0 DO WHILE .NOT. EOF() IF mFunctCHR = FunctCHR IF ASCAN(A_KodCls, FunctCHR) = 0 AADD (A_KodCls, FunctCHR) ENDIF AADD (A_KodCls, FunctNum) FOR j=4 TO 6 AADD (A_KodAtr, FIELDGET(j)) NEXT ELSE ****** Запись заголовка в БД Rso_Zag SELECT Rso_Zag APPEND BLANK REPLACE Kod_obj WITH ++M_KodObj REPLACE Name_obj WITH ALLTRIM(STR(M_KodObj)) ****** Запись массива кодов классов в БД Rso_Kcl * ASORT(A_KodCls) SELECT Rso_Kcl APPEND BLANK FIELDPUT(1,M_KodObj) IF LEN(A_KodCls) > 0 k=2 FOR jj=1 TO LEN(A_KodCls) IF k <= 5 FIELDPUT(k++,A_KodCls[jj]) ELSE k=2 APPEND BLANK FIELDPUT(1,M_KodObj) FIELDPUT(k++,A_KodCls[jj]) ENDIF NEXT ENDIF ****** Запись массива кодов признаков в БД Rso_Kpr * ASORT(A_KodAtr) SELECT Rso_Kpr APPEND BLANK FIELDPUT(1,M_KodObj) IF LEN(A_KodAtr) > 0 k=2 FOR jj=1 TO LEN(A_KodAtr) IF k <= 8 FIELDPUT(k++,A_KodAtr[jj]) ELSE k=2 APPEND BLANK FIELDPUT(1,M_KodObj) FIELDPUT(k++,A_KodAtr[jj]) ENDIF NEXT ENDIF SELECT EventsKO mFunctCHR = FunctCHR A_KodCls := {} A_KodAtr := {} ENDIF DBSKIP(1) ENDDO ****** Запись заголовка в БД Rso_Zag SELECT Rso_Zag APPEND BLANK REPLACE Kod_obj WITH ++M_KodObj REPLACE Name_obj WITH ALLTRIM(STR(M_KodObj)) ****** Запись массива кодов классов в БД Rso_Kcl * ASORT(A_KodCls) SELECT Rso_Kcl APPEND BLANK FIELDPUT(1,M_KodObj) IF LEN(A_KodCls) > 0 k=2 FOR jj=1 TO LEN(A_KodCls) IF k <= 5 FIELDPUT(k++,A_KodCls[jj]) ELSE k=2 APPEND BLANK FIELDPUT(1,M_KodObj) FIELDPUT(k++,A_KodCls[jj]) ENDIF NEXT ENDIF ****** Запись массива кодов признаков в БД Rso_Kpr * ASORT(A_KodAtr) SELECT Rso_Kpr APPEND BLANK FIELDPUT(1,M_KodObj) IF LEN(A_KodAtr) > 0 k=2 FOR jj=1 TO LEN(A_KodAtr) IF k <= 8 FIELDPUT(k++,A_KodAtr[jj]) ELSE k=2 APPEND BLANK FIELDPUT(1,M_KodObj) FIELDPUT(k++,A_KodAtr[jj]) ENDIF NEXT ENDIF ****** Формирование массива параметров и запуск 3.5() **************************************************************************************************************** aMess := {} mLW = ALLTRIM(aLabWName[M_CurrLab]) AADD(aMess, STRTRAN(mLW, ":", ': "')+'" успешно установлена!') AADD(aMess, L(" ")) AADD(aMess, L("Для дальнейшего ее изучения и выполнения необходимо:")) AADD(aMess, L(" ")) AADD(aMess, L("1. Открыть файл исходных данных: "+M_PathInpData+"Inp_data.dbf.")) AADD(aMess, L(" ")) AADD(aMess, L("2. Прочитать описание данной лабораторной работы в режиме 5.14.")) AADD(aMess, L(" ")) AADD(aMess, L("3. Выполнить режимы: 2.1, 2.2, 2.3.1, 3.5, 5.5, 3.4 и другие")) AADD(aMess, L(" в соответствии со схемой преобразования данных в информацию,")) AADD(aMess, L(" а ее в знания, приведенной в режиме 6.4.")) LB_Warning(aMess, L('(C) Универсальная когнитивная аналитическая система "Эйдос-Х++"')) N_InsLFakt = 1 // Кол-во фактически установленных лабораторных работ (факт) ****************************************************************************************************************** CASE M_CurrLab=16 // Лаб.раб.№ 2.06: АСК-анализ изображений (на примере символов) // Путь на папку с исходными БД лабораторной работы M_PathInpData = UPPER(Disk_dir + "\AID_DATA\Inp_data\") aMess := {} AADD(aMess, L("Лаб.раб.№ 2.06: АСК-анализ изображений (на примере символов)")) AADD(aMess, L('запускается также из диспетчера приложений кликом на кнопке: "АСК-анализ изображений"')) AADD(aMess, L("и предполагает выполнение следующих ЭТАПОВ:")) AADD(aMess, L(" ")) AADD(aMess, L("1. Задание параметров и генерация изображений символов, просмотр таблицы шрифта")) AADD(aMess, L(" ")) AADD(aMess, L("2. Выбор одного из способов оцифровки изображений: по всем пикселям, по внешним контурам,")) AADD(aMess, L(" по внешним и внутренним контурам и оцифровка изображений")) AADD(aMess, L(" ")) AADD(aMess, L('3. Ввод оцифрованных изображений в систему "Эйдос" с помощью одного из программных интерфейсов')) AADD(aMess, L(' После этого возникает новое приложение, название которого можно поменять в режиме 1.3.')) AADD(aMess, L(" ")) AADD(aMess, L("4. Просмотр классификационных и описательных шкал и градаций и обучающей выборки: 2.1, 2.2, 2.3.1, 2.4.")) AADD(aMess, L(" ")) AADD(aMess, L("5. Синтез и верификация системно-когнитивных моделей изображений: 3.4., 3.5, 4.1.3.6.")) AADD(aMess, L(" ")) AADD(aMess, L("6. Решение задач идентификации и исследования изображений: 4.1.3.1, 4.1.3.2.")) AADD(aMess, L(" ")) AADD(aMess, L("7. Просмотр и запись информационных портретов классов - обобщенных изображений символов.")) LB_Warning(aMess, L('(C) Универсальная когнитивная аналитическая система "Эйдос-Х++"')) F4_7() ****************************************************************************************************************** CASE M_CurrLab=18 // Лаб.раб.№ 2.08: АСК-анализ символьных и числовых рядов aMess := {} AADD(aMess, L("Лаб.раб.№ 2.08: АСК-анализ исмвольных и числовых рядов")) AADD(aMess, L("и предполагает выполнение следующих ЭТАПОВ:")) AADD(aMess, L(" ")) AADD(aMess, L("1. Загрузка или генерация символьного или числового ряда")) AADD(aMess, L(" ")) AADD(aMess, L('2. Ввод исследуемого ряда в систему "Эйдос" с помощью универсального программного интерфейса 2.3.2.2.')) AADD(aMess, L(' После этого возникает новое приложение, название которого можно поменять в режиме 1.3.')) AADD(aMess, L(" ")) AADD(aMess, L("3. Просмотр классификационных и описательных шкал и градаций и обучающей выборки: 2.1, 2.2, 2.3.1, 2.4.")) AADD(aMess, L(" ")) AADD(aMess, L("4. Синтез и верификация системно-когнитивных моделей изображений: 3.4., 3.5, 4.1.3.6.")) AADD(aMess, L(" ")) AADD(aMess, L("5. Решение задач идентификации и исследования: 4.1.3.1, 4.1.3.2, 4.4.8, 4.4.9 и др.")) LB_Warning(aMess, L('(C) Универсальная когнитивная аналитическая система "Эйдос-Х++"')) F2_3_2_6() *** Вызов функции 2.3.2.2() ********************************** ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW // Создать папку приложения - новой лабораторной работы M_NewAppl = ADD_ZAPPL(aLabWName[M_CurrLab]) // Путь на БД новой лабораторной работы в папке приложений и наименование ЛР в БД приложений // Создание пустых баз данных нового приложения DIRCHANGE(M_NewAppl) // Перейти в папку с новым приложением и создать БД формализации предметной области: GenDbfClSc(.F.) // Классификационные шкалы ######### GenDbfGrClSc(.F.) // Градации классификационных шкал ######### GenDbfClass(.F.) // Классификационные шкалы и градации GenDbfOpSc(.F.) // Описательные шкалы GenDbfGrOpSc(.F.) // Градации описательных шкал GenDbfAttr(.F.) // Описательные шкалы и градации ######### GenDbfObiZag() // Заголовки объектов обучающей выборки GenDbfObiKcl() // Коды классов объектов обучающей выборки GenDbfObiKpr() // Коды признаков объектов обучающей выборки GenDbfRsoZag() // Заголовки объектов распознаваемой выборки GenDbfRsoKcl() // Коды классов объектов распознаваемой выборки GenDbfRsoKpr() // Коды признаков объектов распознаваемой выборки F2_3_2_2(aLabWName[M_CurrLab],"1.3()") // Запуск универсального программного интерфейса с внешними базами данных CASE M_CurrLab=19 // Лаб.раб.№ 19: Исследование RND-модели при различных объемах выборки, НОВАЯ: ######################### ****************************************************************************************************************************************** DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы ****** Выпонять ли лабораторную работу? mLogin = "Y" @0,0 DCGROUP oGroup1 CAPTION L('Выполнять лаб.работу?') SIZE 53.0, 3.5 @4,0 DCGROUP oGroup2 CAPTION L('Внимание!' ) SIZE 53.0, 3.0 @1.5,2 DCSAY L("Продолжить? :") GET mLogin PICTURE 'X' PARENT oGroup1 **** Если файл существует изображения и его контрольная сумма совпадает, то он отображается cFile = Disk_dir+"\_Aidos_gr55.jpg" IF FILE(cFile) IF FILECHECK(cFile) = 1847316 @8,240 DCSTATIC TYPE XBPSTATIC_TYPE_BITMAP CAPTION cFile SIZE 59,59 PIXEL PARENT oGroup1 ELSE Mess = L('Графический файл: "#" поврежден и не может быть отображен!') Mess = STRTRAN(Mess, "#", cFile) * Mess = STRTRAN(Mess, "#", ALLTRIM(STR(FILECHECK(cFile),19))) // Отображение контрольной суммы файлы LB_Warning(Mess) ENDIF ENDIF s = 1 d = 0.8 @s,2 DCSAY L('Выполнение лаб.работы приведет к удалению всех приложений') PARENT oGroup2;s=s+d @s,2 DCSAY L('Нажиме "OK" для продолжения или "Esc" для отмены. ') PARENT oGroup2;s=s+d DCREAD GUI; TO lExit ; FIT; ADDBUTTONS; MODAL; TITLE L('Лаб.работа №2.09: "Исследование RND-моделей"') ******************************************************************** IF lExit ** Button Ok ELSE RETURN NIL ENDIF ******************************************************************** IF mLogin = "N" RETURN NIL ENDIF F1_11() // Сброс всех приложений, если они есть ********** Создание БД параметров RND-приложений PRIVATE bItems aStructure := { { "Num" , "N", 5, 0 }, ; // 1 { "ParamName" , "C", 40, 0 }, ; // 2 { "InitValue" , "N", 15, 0 }, ; // 3 { "StepChang" , "N", 15, 0 }, ; // 4 { "FinalValue", "N", 15, 0 } } // 5 DbCreate( 'ParamRND', aStructure ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE ParamRND EXCLUSIVE NEW SELECT ParamRND ****** Начальные значения в таблице параметров ******** APPEND BLANK REPLACE Num WITH 1 REPLACE ParamName WITH L("Классификационных шкал") REPLACE InitValue WITH 10 REPLACE StepChang WITH 0 APPEND BLANK REPLACE Num WITH 2 REPLACE ParamName WITH L("Градаций в класс.шкале") REPLACE InitValue WITH 3 REPLACE StepChang WITH 0 APPEND BLANK REPLACE Num WITH 3 REPLACE ParamName WITH L("Описательных шкал") REPLACE InitValue WITH 10 REPLACE StepChang WITH 0 APPEND BLANK REPLACE Num WITH 4 REPLACE ParamName WITH L("Градаций в опис.шкале") REPLACE InitValue WITH 3 REPLACE StepChang WITH 0 APPEND BLANK REPLACE Num WITH 5 REPLACE ParamName WITH L("Объектов обучающей выборки") REPLACE InitValue WITH 10 REPLACE StepChang WITH 10 APPEND BLANK REPLACE Num WITH 6 REPLACE ParamName WITH L("Классов в объекте обуч.выборки") REPLACE InitValue WITH 5 REPLACE StepChang WITH 0 APPEND BLANK REPLACE Num WITH 7 REPLACE ParamName WITH L("Признаков в объекте обуч.выборки") REPLACE InitValue WITH 20 REPLACE StepChang WITH 0 APPEND BLANK REPLACE Num WITH 8 REPLACE ParamName WITH L("Число создаваемых RND-моделей") REPLACE InitValue WITH 3 REPLACE StepChang WITH 0 DBGOTO(8);mNumberCycles=FIELDGET(3) // Кодичество циклов создания приложений ******* В ЦИКЛЕ. ВЫХОД ИЗ ЦИКЛА ПО ЗАПУСКУ ФУНКЦИИ: 'Выход на расчет RND-приложений' PUBLIC mFlagExit := .T. RecalcParam() // Пересчитать параметры DO WHILE mFlagExit ******* Отображение БД ******* DBGOTOP() /* ----- Create ToolBar ----- */ d = 120 @13.2, 0 DCPUSHBUTTON CAPTION L('Помощь' ) SIZE 10, 1.5 ACTION {||HelpLW209() , DC_GetRefresh(GetList)} @13.2, DCGUI_COL+d DCPUSHBUTTON CAPTION L('Пересчитать параметры' ) SIZE 24, 1.5 ACTION {||RecalcParam(), DC_GetRefresh(GetList)} @13.2, DCGUI_COL+d+4 DCPUSHBUTTON CAPTION L('Выход на расчет RND-приложений') SIZE 32, 1.5 ACTION {||OutputCalc() , DC_GetRefresh(GetList)} FONT '9.Arial Bold' ****** Отображение таблицы *************** DCSETPARENT TO @ 1, 0 DCBROWSE ParamRND ALIAS 'ParamRND' SIZE 101,12.0 ; EDIT xbeBRW_ItemSelected MODE DCGUI_BROWSE_EDITDOWN ; // Редактирование БД NOSOFTTRACK ; HEADLINES 3 ; // Кол-во строк в заголовке (перенос строки - ";") NOHSCROLL NOVSCROLL ; // Убрать горизонтальную и вертикальную полосы прокрутки SCOPE ; ITEMMARKED bItems DCSETPARENT ParamRND * aStructure := { { "Num" , "N", 5, 0 }, ; // 1 * { "ParamName" , "C", 40, 0 }, ; // 2 * { "InitValue" , "N", 15, 0 }, ; // 3 * { "StepChang" , "N", 15, 0 }, ; // 4 * { "FinalValue", "N", 15, 0 } } // 5 * DbCreate( 'ParamRND', aStructure ) *** Подарок от Роджера DCBROWSECOL FIELD ParamRND->Num HEADER L("Номер;параметра" ) PARENT ParamRND FONT "9.Courier" WIDTH 5 PROTECT {|| .T. } COLOR {||{nil,aColor[100]}} ALIGN XBPALIGN_HCENTER+XBPALIGN_VCENTER DCBROWSECOL FIELD ParamRND->ParamName HEADER L("Наименование;параметра" ) PARENT ParamRND FONT "9.Courier" WIDTH 45 PROTECT {|| .T. } COLOR {||{nil,aColor[100]}} ALIGN XBPALIGN_HCENTER+XBPALIGN_VCENTER DCBROWSECOL FIELD ParamRND->InitValue HEADER L("Начальное;значение;параметра") PARENT ParamRND FONT "9.Courier" WIDTH 15 COLOR {||{nil,aColor[ 38]}} ALIGN XBPALIGN_HCENTER+XBPALIGN_VCENTER DCBROWSECOL FIELD ParamRND->StepChang HEADER L("Шаг;изменения;параметра" ) PARENT ParamRND FONT "9.Courier" WIDTH 15 COLOR {||{nil,aColor[ 38]}} ALIGN XBPALIGN_HCENTER+XBPALIGN_VCENTER DCBROWSECOL FIELD ParamRND->FinalValue HEADER L("Конечное;значение;параметра" ) PARENT ParamRND FONT "9.Courier" WIDTH 15 PROTECT {|| .T. } COLOR {||{nil,aColor[100]}} ALIGN XBPALIGN_HCENTER+XBPALIGN_VCENTER * DCBROWSECOL DATA {||Alltrim(Str(ParamRND->Num ))} HEADER L("Номер;параметра" ) PARENT ParamRND FONT "9.Courier" WIDTH 5 PROTECT {|| .T. } COLOR {||{nil,aColor[100]}} ALIGN XBPALIGN_HCENTER+XBPALIGN_VCENTER * DCBROWSECOL FIELD ParamRND->ParamName HEADER L("Наименование;параметра" ) PARENT ParamRND FONT "9.Courier" WIDTH 45 PROTECT {|| .T. } COLOR {||{nil,aColor[100]}} ALIGN XBPALIGN_HCENTER+XBPALIGN_VCENTER * DCBROWSECOL DATA {||Alltrim(Str(ParamRND->InitValue ))} HEADER L("Начальное;значение;параметра") PARENT ParamRND FONT "9.Courier" WIDTH 15 COLOR {||{nil,aColor[ 38]}} ALIGN XBPALIGN_HCENTER+XBPALIGN_VCENTER * DCBROWSECOL DATA {||Alltrim(Str(ParamRND->StepChang ))} HEADER L("Шаг;изменения;параметра" ) PARENT ParamRND FONT "9.Courier" WIDTH 15 COLOR {||{nil,aColor[ 38]}} ALIGN XBPALIGN_HCENTER+XBPALIGN_VCENTER * DCBROWSECOL DATA {||Alltrim(Str(ParamRND->FinalValue))} HEADER L("Конечное;значение;параметра" ) PARENT ParamRND FONT "9.Courier" WIDTH 15 PROTECT {|| .T. } COLOR {||{nil,aColor[100]}} ALIGN XBPALIGN_HCENTER+XBPALIGN_VCENTER DCGETOPTIONS SAYFONT '10.Helv Bold' TABSTOP AUTORESIZE DCREAD GUI ; FIT ; OPTIONS GetOptions ; MODAL ; TITLE L('Задание параметров для расчета RND-моделей') ; EVAL {|o|SetAppFocus(ParamRND:GetColumn(1))} ****************************************************************************************************************************************** ENDDO DBGOTO(8);mNumberCycles=FIELDGET(3) // Число создаваемых RND-моделей RecalcParam() // Пересчитать параметры ****** Формирование параметров цикла по приложениям ************ * mNumberCycles // Кодичество циклов создания приложений PRIVATE aInitValue[8] // Начальные значения параметров PRIVATE aStepChang[8] // Шаг изменения значений параметров AFILL(aInitValue, 0) AFILL(aStepChang, 0) SELECT ParamRND * 1. Классификационных шкал * 2. Градаций в класс.шкале * 3. Описательных шкал * 4. Градаций в опис.шкале * 5. Объектов обучающей выборки * 6. Классов в объекте обуч.выборки * 7. Признаков в объекте обуч.выборки * 8. Число создаваемых RND-моделей FOR j=1 TO 7 DBGOTO(j) aInitValue[j] = FIELDGET(3) // Начальные значения параметров aStepChang[j] = FIELDGET(4) // Шаг изменения значений параметров NEXT ****** Проверка на корректность заданных параметров ######################### FOR mNumAppl = 1 TO mNumberCycles // Кодичество циклов создания приложений * FinalValue = InitValue + StepChang * ( mNumberCycles - 1 ) * mFinalValue = mInitValue + mStepChang * ( mNumAppl - 1 ) N_Csc = aInitValue[1] + aStepChang[1] * ( mNumAppl - 1 ) // 1. Классификационных шкал N_AvrGrCs = aInitValue[2] + aStepChang[2] * ( mNumAppl - 1 ) // 2. Градаций в класс.шкале N_Osc = aInitValue[3] + aStepChang[3] * ( mNumAppl - 1 ) // 3. Описательных шкал N_AvrGrOs = aInitValue[4] + aStepChang[4] * ( mNumAppl - 1 ) // 4. Градаций в опис.шкале N_Obj = aInitValue[5] + aStepChang[5] * ( mNumAppl - 1 ) // 5. Объектов обучающей выборки N_AvrGcs = aInitValue[6] + aStepChang[6] * ( mNumAppl - 1 ) // 6. Классов в объекте обуч.выборки N_AvrGos = aInitValue[7] + aStepChang[7] * ( mNumAppl - 1 ) // 7. Признаков в объекте обуч.выборки N_Gcs = N_Csc * N_AvrGrCs // Суммарное кол-во градаций клас.шкал (классов) N_Gos = N_Osc * N_AvrGrOs // Суммарное кол-во градаций опис.шкал (признаков) N_Cls = N_Gcs N_ObiKcl = N_AvrGcs*N_Obj/4 // Кол-во записей в БД кодов классов обучающей выборки N_ObiKpr = N_AvrGos*N_Obj/7 // Кол-во записей в БД кодов признаков обучающей выборки IF N_Csc * N_Osc * N_Gos * N_Gcs * N_Obj * N_AvrGcs * N_AvrGos * N_AvrGrOs * N_AvrGrCs = 0 LB_Warning(L("Параметры модели равные нулю недопустимы !!!"), L('Лаб.работа №2.09: "Исследование RND-моделей"')) RETURN NIL ENDIF // УСТАНОВКА ЛАБОРАТОРНОЙ РАБОТЫ ******************************** ########### Сделать функцию и обратиться здесь в 2.01 M_NewNAppl = aLabWName[M_CurrLab]+' ('+ALLTRIM(STR(N_Obj))+' объектов)' M_NewAppl = ADD_ZAPPL(M_NewNAppl) // Путь на БД новой лабораторной работы в папке приложений // Создание пустых баз данных нового приложения DIRCHANGE(M_NewAppl) // Перейти в папку с новым приложением и создать БД формализации предметной области: GenDbfClSc(.F.) // Классификационные шкалы ######### GenDbfGrClSc(.F.) // Градации классификационных шкал ######### GenDbfClass(.F.) // Классификационные шкалы и градации GenDbfOpSc(.F.) // Описательные шкалы GenDbfGrOpSc(.F.) // Градации описательных шкал GenDbfAttr(.F.) // Описательные шкалы и градации ######### GenDbfObiZag() // Заголовки объектов обучающей выборки GenDbfObiKcl() // Коды классов объектов обучающей выборки GenDbfObiKpr() // Коды признаков объектов обучающей выборки GenDbfRsoZag() // Заголовки объектов распознаваемой выборки GenDbfRsoKcl() // Коды классов объектов распознаваемой выборки GenDbfRsoKpr() // Коды признаков объектов распознаваемой выборки CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW USE Class_Sc EXCLUSIVE NEW USE Gr_ClSc EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW USE Opis_Sc EXCLUSIVE NEW USE Gr_OpSc EXCLUSIVE NEW USE Obi_zag EXCLUSIVE NEW USE Obi_Kcl EXCLUSIVE NEW USE Obi_Kpr EXCLUSIVE NEW ********* Генерация случайных классификационных шкал и градаций M_KodGrCs = 0 FOR i=1 TO N_Csc SELECT Class_Sc APPEND BLANK REPLACE Kod_ClSc WITH i REPLACE Name_ClSc WITH "Классификационная шкала_"+ALLTRIM(STR(i,19))+"/"+ALLTRIM(STR(N_Csc,19)) FOR j=1 TO N_AvrGrCs SELECT Gr_ClSc APPEND BLANK REPLACE Kod_ClSc WITH i REPLACE Kod_GrCs WITH ++M_KodGrCs REPLACE Name_GrCs WITH ALLTRIM(STR(j,19))+"/"+ALLTRIM(STR(N_AvrGrCs,19))+"-Градация классификационной шкалы_"+ALLTRIM(STR(i,19))+"/"+ALLTRIM(STR(N_Csc,19)) SELECT Classes APPEND BLANK REPLACE Kod_Cls WITH M_KodGrCs REPLACE Name_Cls WITH "Классификационная шкала_"+ALLTRIM(STR(i,19))+"/"+ALLTRIM(STR(N_Csc,19))+"-Градация классификационной шкалы_"+ALLTRIM(STR(j,19))+"/"+ALLTRIM(STR(N_AvrGrCs,19)) REPLACE Kod_ClSc WITH i REPLACE N_CHRCLSC WITH LEN("Классификационная шкала_"+ALLTRIM(STR(i,19))+"/"+ALLTRIM(STR(N_Csc,19))) NEXT NEXT ********* Генерация случайных описательных шкал и градаций M_KodGrOs = 0 FOR i=1 TO N_Osc SELECT Opis_Sc APPEND BLANK REPLACE Kod_OpSc WITH i REPLACE Name_OpSc WITH "Описательная шкала_"+ALLTRIM(STR(i,19))+"/"+ALLTRIM(STR(N_Osc,19)) FOR j=1 TO N_AvrGrOs SELECT Gr_OpSc APPEND BLANK REPLACE Kod_OpSc WITH i REPLACE Kod_GrOs WITH ++M_KodGrOs REPLACE Name_GrOs WITH ALLTRIM(STR(j,19))+"/"+ALLTRIM(STR(N_AvrGrOs,19))+"-Градация описательной шкалы_"+ALLTRIM(STR(i,19))+"/"+ALLTRIM(STR(N_Osc,19)) SELECT Attributes APPEND BLANK REPLACE Kod_Atr WITH M_KodGrOs REPLACE Name_Atr WITH "Описательная шкала_"+ALLTRIM(STR(i,19))+"/"+ALLTRIM(STR(N_Osc,19))+"-Градация описательной шкалы_"+ALLTRIM(STR(j,19))+"/"+ALLTRIM(STR(N_AvrGrOs,19)) REPLACE Kod_OpSc WITH i REPLACE N_CHROPSC WITH LEN("Описательная шкала_"+ALLTRIM(STR(i,19))+"/"+ALLTRIM(STR(N_Osc,19))) NEXT NEXT *** Генерация баз данных обучающей выборки FOR M_KodObj=1 TO N_Obj SELECT Obi_Zag APPEND BLANK REPLACE Kod_obj WITH M_KodObj REPLACE Name_obj WITH "Объект обучающей выборки_"+ALLTRIM(STR(M_KodObj,19))+"/"+ALLTRIM(STR(N_Obj,19)) ***** Генерация массива кодов классов для БД ObI_Kcl A_Kcl := {} DO WHILE LEN(A_Kcl) < N_AvrGcs M_KodCl = 1 + RANDOM()%N_Cls // Код класса IF ASCAN(A_Kcl, M_KodCl) = 0 // Если класс еще не встречался AADD (A_Kcl, M_KodCl) ENDIF ENDDO * ASORT(A_Kcl) *** Занести массив кодов классов в БД ObI_Kcl SELECT Obi_Kcl APPEND BLANK REPLACE Kod_Obj WITH M_KodObj IF LEN(A_Kcl) > 0 k=1 FOR j=1 TO LEN(A_Kcl) IF k <= 4 FIELDPUT(1+k++,A_Kcl[j]) ELSE k=1 APPEND BLANK REPLACE Kod_Obj WITH M_KodObj FIELDPUT(1+k++,A_Kcl[j]) ENDIF NEXT ENDIF ***** Генерация массива кодов признаков для БД ObI_Kpr A_Kpr := {} DO WHILE LEN(A_Kpr) < N_AvrGos M_KodPr = 1 + RANDOM()%N_Gos // Код признака AADD (A_Kpr, M_KodPr) ENDDO * ASORT(A_KPr) *** Занести массив кодов признаков в БД ObI_Kpr SELECT Obi_Kpr APPEND BLANK REPLACE Kod_Obj WITH M_KodObj IF LEN(A_Kpr) > 0 k=1 FOR j=1 TO LEN(A_Kpr) IF k <= 7 FIELDPUT(1+k++,A_Kpr[j]) ELSE k=1 APPEND BLANK REPLACE Kod_Obj WITH M_KodObj FIELDPUT(1+k++,A_Kpr[j]) ENDIF NEXT ENDIF NEXT ***** Переиндексация всех БД созданного приложения GenNtxClass() // Классификационные шкалы и градации GenNtxOpSc() // Описательные шкалы GenNtxGrOpSc() // Градации описательных шкал GenNtxObiZag() // Заголовки объектов обучающей выборки GenNtxObiKcl() // Коды классов объектов обучающей выборки GenNtxObiKpr() // Коды признаков объектов обучающей выборки GenNtxRsoZag() // Заголовки объектов распознаваемой выборки GenNtxRsoKcl() // Коды классов объектов распознаваемой выборки GenNtxRsoKpr() // Коды признаков объектов распознаваемой выборки F3_5('GPU','SintRec','3.3') // Синтез и верификация всех моделей NEXT // Конец цикла по приложениям **** Перейти в папку с системой и запустить AddData F4_1_3_11(.F.) aMess := {} AADD(aMess, L('Успешно установлено ')+ALLTRIM(STR(mNumberCycles))+L(' RND-приложения(й) с заданными параметрами.') ) AADD(aMess, L('В каждом приложении выбрана модель с макс.достоверностью по F-критерию Ван Ризбергена, а также') ) AADD(aMess, L('по L1 и L2-критериям проф.Е.В.Луценко. Данные о достоверности этих моделей (те же, что в 4.1.3.6)') ) AADD(aMess, L('Записаны в базы данных:')) AADD(aMess, L('- по F-критерию Ван Ризбергена : ')+Disk_dir+'\"AddDataF.dbf"') AADD(aMess, L('- по L1-критерию проф.Е.В.Луценко: ' )+Disk_dir+'\"AddDataL1.dbf"') AADD(aMess, L('- по L2-критерию проф.Е.В.Луценко: ' )+Disk_dir+'\"AddDataL2.dbf"') AADD(aMess, L(' ')) AADD(aMess, L('Все эти базы данных открыватся в MS Excel.')) FOR j=1 TO LEN(aMess);aMess[j] = L(aMess[j]);NEXT // Перевод LB_Warning(aMess, L('Лаб.работа №2.09: "Исследование RND-моделей"')) ENDCASE CASE nRadio=4 // 4. Лаб.работы 4-го типа, устанавливаемые путем СКАЧИВАНИЯ исходных данных из INTERNET N_InsLPlan = 1 N_InsLFakt = 1 DO CASE CASE M_CurrLab=31 // Лаб.раб.№ 4.01: АСК-анализ мирового времени по данным сайта: "ftp://tai.bipm.org", НОВАЯ: ######################### LW401() CASE M_CurrLab=32 // Лаб.раб.№ 4.02: АСК-анализ текстового контента сайтов, найденных по запросам LabWork32() CASE M_CurrLab=33 // Лаб.раб.№ 4.03: в процессе разработки CASE M_CurrLab=34 // Лаб.раб.№ 4.04: в процессе разработки CASE M_CurrLab=35 // Лаб.раб.№ 4.05: в процессе разработки CASE M_CurrLab=36 // Лаб.раб.№ 4.06: в процессе разработки CASE M_CurrLab=37 // Лаб.раб.№ 4.07: в процессе разработки CASE M_CurrLab=38 // Лаб.раб.№ 4.08: в процессе разработки CASE M_CurrLab=39 // Лаб.раб.№ 4.09: в процессе разработки CASE M_CurrLab=40 // Лаб.раб.№ 4.10: в процессе разработки ENDCASE ENDCASE ***************************************************************************************************** ***************************************************************************************************** Mess = L("УСТАНОВКА # ИЗ $ ЗАДАННЫХ ЛАБОРАТОРНЫХ РАБОТ УСПЕШНО ЗАВЕРШЕНА !!!") Mess = STRTRAN(Mess, "#", ALLTRIM(STR(N_InsLFakt,10))) Mess = STRTRAN(Mess, "$", ALLTRIM(STR(N_InsLPlan,10))) * LB_Warning(Mess, L('(C) Универсальная когнитивная аналитическая система "Эйдос-Х++"')) * oSay97:SetCaption(Mess) IF 1 <= M_CurrLab .AND. M_CurrLab <= 10 // Лаб.работы, устанавливаемые путем копирования файлов Inp_data.xls в папку Inp_data, а файла _2_3_2_2.arx в папку системы Running(.T.) // Чтобы не могли запустить какой-нибудь режим пока висит окно окончания работы oSay97:SetCaption(oSay97:caption) oButton:SetCaption(L('&Ok')) // Деструктурирование окна отображения графического Progress-bar oButton:activate := {||PostAppEvent(xbeP_Close,,,oDialog)} //<<<<<< Add This DC_AppEvent( @lOk ) * PostAppEvent(xbeP_Activate,,,DC_GetObject(GetList,'DCGUI_BUTTON_OK')) // Роджер oDialog:Destroy() ENDIF DIRCHANGE(Disk_dir) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE USERS INDEX ON Kod_AdmApp TO USERS CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Appls EXCLUSIVE NEW INDEX ON Kod_AdmApp TO APPLS USE USERS INDEX USERS EXCLUSIVE SELECT Users DO CASE CASE Flag_SysAdmin = .T. SET FILTER TO // Сисадмин видит все CASE Flag_AdmAppl = .T. SET FILTER TO Kod_AdmApp = M_KodAdmAppls // Адм.прил. и пользователь CASE Flag_User = .T. // Видят только свои приложения SET FILTER TO Kod_AdmApp = M_KodAdmAppls OTHERWISE LB_Warning(L("Этот режим доступен только после авторизации в режиме 1.1 !!!")) RETURN NIL ENDCASE DBGOTOP();DBGOBOTTOM();DBGOTOP() USE APPLS INDEX APPLS EXCLUSIVE NEW SELECT Appls DO CASE CASE Flag_SysAdmin = .T. SET FILTER TO // Сисадмин видит и может все CASE Flag_AdmAppl = .T. SET FILTER TO Kod_AdmApp = M_KodAdmAppls // Адм.приложения и пользователь CASE Flag_User = .T. // Видят только свои приложения SET FILTER TO Kod_AdmApp = M_KodAdmAppls OTHERWISE LB_Warning(L("Этот режим доступен только после авторизации в режиме 1.1 !!!")) RETURN NIL ENDCASE DBGOTOP();DBGOBOTTOM();DBGOTOP() RETURN NIL ********** ************************************************************************************************** ***************************************************************************************************** ******** 4.6. Подготовка баз данных для визуализация когнитивных функций в MS Excel ******** Данный режим готовит базы данных для визуализации в MS Excel прямых и обратных, ******** позитивных и негативных точечных и средневзвешенных редуцированных когнитивных функций, ******** созданных на основе различных стат.моделей и моделей знаний ***************************************************************************************************** #include "inkey.ch" #include "dcdir.ch" #include "appevent.ch" #include "xbp.ch" #include "dll.ch" #include "dccursor.ch" #Include "thread.ch" #include "class.ch" #include "dmlb.ch" #include "fileio.ch" #include "dctree.ch" *#include "SystemMetrics.ch" *#include "axcdxcmx.ch" // Графика ActiveX #include "collat.ch" #include "common.ch" #include "dbedit.ch" #include "Dbfdbe.ch" #include "dcapp.ch" #include "dcbitmap.ch" #include "dccargo.ch" #include "dcdialog.ch" #include "dcdir.ch" #include "dcfiles.ch" #include "dcgra.ch" #include "dcgraph.ch" // графика #include "BdColors.Ch" // графика #include "dccolors.ch" // графика #include "dcprint.ch" // графика #include "Dcicon.ch" #include "dcmsg.ch" #include "dcpick.ch" #include "deldbe.ch" #include "directry.ch" #include "dmlb.ch" #include "express.ch" #include "fileio.ch" #include "font.ch" #include "gra.ch" #include "inkey.ch" #include "memvar.ch" #include "natmsg.ch" #include "prompt.ch" #include '_dcdbfil.ch' #include "set.ch" #include "std.ch" #include "xbp.ch" #include '_dcappe.ch' #include 'dcscope.ch' #include '_dcstru.ch' #include 'dcfields.ch' #include 'dccolor.ch' *#include "Fileio.ch" // Max_DB *#include "rmchart.ch" // Графика ActiveX #include "dcads.ch" #pragma Library( "ASINet10.lib" ) // 2.0 // Для альтернативного и неальтернативного выбора в просмотре таблиц *#define BMP_CHECKED "check1.bmp" *#define BMP_UNCHECKED "check2.bmp" *#define BMP_RACHECKED "radio1.bmp" *#define BMP_RAUNCHECKED "radio2.bmp" *#include "test.ch" #define BMP_CHECKED 10002 #define BMP_UNCHECKED 10003 #define BMP_RACHECKED 10004 #define BMP_RAUNCHECKED 10005 #pragma library( "ascom10.lib" ) #pragma library( "dclip1.lib" ) #pragma library( "dclip2.lib" ) #pragma library( "dclipx.lib" ) #pragma library( "xbtbase1.lib" ) #pragma library( "xbtbase2.lib" ) #pragma library( "xppui2.lib" ) #pragma library( "XPPRT0.LIB" ) #Pragma Library("Taskbar.lib") #xtranslate NTrim() => LTrim(Str()) #define USE_HTTPCLIENT // comment out to try Method2 //#include "Imgview.ch" /* * We use user defined events */ #define xbeDS_DirChanged xbeP_User + 100 #define xbeFS_FileMarked xbeP_User + 101 #define xbeFS_FileSelected xbeP_User + 102 #define DCAREAMSG_1 'Invalid Expression in Index Key:' /* * This directive calculates a centered position */ #xtrans CenterPos( , ) => ; { Int( (\[1] - \[1]) / 2 ) ; , Int( (\[2] - \[2]) / 2 ) } #define DC_RDDMSG_1 'Invalid RDD selection - '+cSuperRdd #define DC_RDDMSG_2 'DBE Name Description' #define DC_RDDMSG_3 'Select a Database Driver' *#define ADSDBE_MEMOFILE_EXT (DBE_USER+1) // RO *#define ADSDBE_INDEX_EXT (DBE_USER+2) // RW *#define ADSDBE_TBL_MODE (DBE_USER+3) // RW *#define ADSDBE_LOCK_MODE (DBE_USER+4) // RW *#define ADSDBE_RIGHTS_MODE (DBE_USER+5) // RW *#define ADSDBE_MEMOBLOCKSIZE (DBE_USER+6) // RW *#define ADSDBE_PASSWORD (DBE_USER+7) // RW // Return types of ADSDBE_TBL_MODE *#define ADSDBE_NTX 1 *#define ADSDBE_CDX 2 *#define ADSDBE_ADT 3 // Для опредедения разрешения монитора от Джимми #define DESKTOPVERTRES 117 #define DESKTOPHORZRES 118 // Excel Orientation #DEFINE xlLandscape 2 #DEFINE xlPortrait 1 #DEFINE xlWorkbookNormal -4143 #DEFINE xlCellTypeLastCell 11 #DEFINE SRCCOPY 0xCC0020 // Для быстрой графики Роджера #define KEYEVENTF_KEYUP 0x02 #define VK_MENU 0x12 #define VK_SNAPSHOT 0x2C #DEFINE VK_LBUTTON 0x01 #DEFINE VK_RBUTTON 0x02 * Для CSV=>DBF конвертера *#include "ot4xb.ch" // => ot4xb.dll => www.xbwin.com #ifndef CRLF #define CRLF chr(13)+chr(10) #endif * Klasse zum sequentiellen Einlesen groбer Dateien *#IF .t. // zum Einbinden in eigenes Projekt, .f. setzen ! STATIC snHdll ****************************************************************************** FUNCTION F4_6() LOCAL Getlist := {}, oProgress, oDialog PUBLIC Time_progress, Wsego, lOk := .T., Sec_1, GetOptions Running(.T.) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF ApplChange("4.6()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF IF FILEDATE("Cogn_fun",16) = CTOD("//") DIRMAKE("Cogn_fun") Mess = L('В папке текущего приложения: "#" не было директории "Cogn_fun" для когнитивных функций и она была создана!') Mess = STRTRAN(Mess, "#", UPPER(ALLTRIM(M_PathAppl))) LB_Warning(Mess, L('4.6. Подготовка баз данных для визуализация когнитивных функций в MS Excel' )) ENDIF IF .NOT. FILE( "ABS.txt" ) .OR. ; .NOT. FILE( "PRC1.txt" ) .OR. ; .NOT. FILE( "PRC2.txt" ) .OR. ; .NOT. FILE( "INF1.txt" ) .OR. ; .NOT. FILE( "INF2.txt" ) .OR. ; .NOT. FILE( "INF3.txt" ) .OR. ; .NOT. FILE( "INF4.txt" ) .OR. ; .NOT. FILE( "INF5.txt" ) .OR. ; .NOT. FILE( "INF6.txt" ) .OR. ; .NOT. FILE( "INF7.txt" ) aMess := {} AADD(aMess, L('В папке текущего приложения: "#"')) AADD(aMess, L('должны быть файлы: Abs.dbf, Prc1.dbf, Prc2.dbf, Inf1.dbf, Inf2.dbf, Inf3.dbf, Inf4.dbf, Inf5.dbf, Inf6.dbf, Inf7.dbf')) aMess[1] = STRTRAN(aMess[1], "#", UPPER(ALLTRIM(M_PathAppl))) AADD(aMess, L("Для того, чтобы их создать необходимо выполнить режим 3.4 или 3.5.")) LB_Warning(aMess, L('4.6. Подготовка баз данных для визуализация когнитивных функций в MS Excel' )) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы Running(.F.) RETURN NIL ENDIF ****** Задание на верификацию баз знаний IF FILE("_CognFun.arx") // Файл с информацией о том, какие модели были верифицированы ранее aCognFun = DC_ARestore("_CognFun.arx") ELSE PRIVATE aCognFun[19] // 1-10 - Модели для создания CF // Тип CF: прямая, обратная, позитивная, негативная, по точкам с max инф., замена ед.наблюд., число интервалов информативностей, рассеяние в %, способ взвешивания ******* 11------12 13----------14 15--------------------16 17 18 19 AFILL(aCognFun, .T.) aCognFun[18] = 100 aCognFun[19] = 3 DC_ASave(aCognFun, "_CognFun.arx") ENDIF ********************************************************************************************************************** // Диалог задания моделей для создания БД когнитивных функций @ 0, 0 DCGROUP oGroup1 CAPTION L('Задайте стат.модели и модели знаний для синтеза когнитивных функций') SIZE 87,13.5 @ 1, 1 DCSAY L('Статистические модели:') PARENT oGroup1 @ 2, 3 DCCHECKBOX aCognFun[ 1] PROMPT L('1. ABS - частный критерий: количество встреч сочетаний: "класс-признак" у объектов обуч.выборки') PARENT oGroup1 @ 3, 3 DCCHECKBOX aCognFun[ 2] PROMPT L('2. PRC1 - частный критерий: усл. вероятность i-го признака среди признаков объектов j-го класса ') PARENT oGroup1 @ 4, 3 DCCHECKBOX aCognFun[ 3] PROMPT L('3. PRC2 - частный критерий: условная вероятность i-го признака у объектов j-го класса ') PARENT oGroup1 @ 5.2,1 DCSAY L('Модели знаний:') PARENT oGroup1 @ 6, 3 DCCHECKBOX aCognFun[ 4] PROMPT L('4. INF1 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC1 ') PARENT oGroup1 @ 7, 3 DCCHECKBOX aCognFun[ 5] PROMPT L('5. INF2 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC2 ') PARENT oGroup1 @ 8, 3 DCCHECKBOX aCognFun[ 6] PROMPT L('6. INF3 - частный критерий: Xи-квадрат, разности между фактическими и ожидаемыми абс.частотами ') PARENT oGroup1 @ 9, 3 DCCHECKBOX aCognFun[ 7] PROMPT L('7. INF4 - частный критерий: ROI (Return On Investment); вероятности из PRC1 ') PARENT oGroup1 @10, 3 DCCHECKBOX aCognFun[ 8] PROMPT L('8. INF5 - частный критерий: ROI (Return On Investment); вероятности из PRC2 ') PARENT oGroup1 @11, 3 DCCHECKBOX aCognFun[ 9] PROMPT L('9. INF6 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC1 ') PARENT oGroup1 @12, 3 DCCHECKBOX aCognFun[10] PROMPT L('10.INF7 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC2 ') PARENT oGroup1 @14 , 0 DCGROUP oGroup2 CAPTION L('Задайте свойства когнитивных функций') SIZE 87,12.5 @1 , 3 DCCHECKBOX aCognFun[11] PROMPT L('11. Прямые: Y=F[X]') PARENT oGroup2 @2 , 3 DCCHECKBOX aCognFun[12] PROMPT L('12. Обратные: X=F[Y]' ) PARENT oGroup2 @1 ,27 DCCHECKBOX aCognFun[13] PROMPT L('13. Позитивные: количество информации I[X,Y] > 0') PARENT oGroup2 @2 ,27 DCCHECKBOX aCognFun[14] PROMPT L('14. Негативные: количество информации I[X,Y] < 0') PARENT oGroup2 @4.8 ,74.8 DCPUSHBUTTON CAPTION L('Help') SIZE 7.8, 1.8 PARENT oGroup2 ACTION {||Help4_6()} FONT '10.Helv Bold' @10.8, 2.0 DCPUSHBUTTON CAPTION L('Ссылки на публикации по когнитивным функциям') SIZE 40, 1.1 PARENT oGroup2 ACTION {||Publ_CognFun()} @10.8,45.0 DCPUSHBUTTON CAPTION L('Скачать подборку публикаций по когн.функциям') SIZE 40, 1.1 PARENT oGroup2 ACTION {||ShellOpenFile("http://lc.kubagro.ru/Install_Aidos-X/PublCognFun.rar")} @3.5, 3 DCCHECKBOX aCognFun[15] PROMPT L('15. Учет только наблюдений для каждого значения аргумента с MAX колич. информации') PARENT oGroup2 @4.5, 3 DCCHECKBOX aCognFun[16] PROMPT L('16. Замена всех наблюдений для каждого значения аргумента одним средневзевешенным') PARENT oGroup2 @5.5, 3 DCCHECKBOX aCognFun[17] PROMPT L('17. Замена наблюдения с количеством информации Iij наблюдениями с единичным весом') PARENT oGroup2 ***************************** @6.8, 2 DCGROUP oGroup3 CAPTION L(' ') SIZE 83, 3.5 PARENT oGroup2 HIDE {|| .NOT.aCognFun[17] } @1.1, 2 DCSAY L("Количество точек единичного веса в максимальной информативности MAX(I[X,Y]):") PARENT oGroup3 EDITPROTECT {|| .NOT.aCognFun[17] } HIDE {|| .NOT.aCognFun[17] } SIZE 0 @1.0,71 DCSAY L(" ") GET aCognFun[18] PICTURE "######" PARENT oGroup3 EDITPROTECT {|| .NOT.aCognFun[17] } HIDE {|| .NOT.aCognFun[17] } @2.1, 2 DCSAY L("Максимальная величина случайного рассеяния точек единичного веса в %:") PARENT oGroup3 EDITPROTECT {|| .NOT.aCognFun[17] } HIDE {|| .NOT.aCognFun[17] } SIZE 0 @2.0,71 DCSAY L(" ") GET aCognFun[19] PICTURE "###.##" PARENT oGroup3 EDITPROTECT {|| .NOT.aCognFun[17] } HIDE {|| .NOT.aCognFun[17] } ***************************** D=175 @6.8, 2 DCGROUP oGroup4 CAPTION L(' ') SIZE 83, 3.5 PARENT oGroup2 HIDE {|| aCognFun[17] } @1.1, 2 DCSAY SPACE(D) PARENT oGroup5 EDITPROTECT {|| aCognFun[17] } HIDE {|| aCognFun[17] } SIZE 0 @1.0, 2 DCSAY SPACE(D) PARENT oGroup5 EDITPROTECT {|| aCognFun[17] } HIDE {|| aCognFun[17] } SIZE 0 @2.1, 2 DCSAY SPACE(D) PARENT oGroup5 EDITPROTECT {|| aCognFun[17] } HIDE {|| aCognFun[17] } SIZE 0 @2.0, 2 DCSAY SPACE(D) PARENT oGroup5 EDITPROTECT {|| aCognFun[17] } HIDE {|| aCognFun[17] } SIZE 0 ***************************** DCREAD GUI ; TO lExit ; FIT ; OPTIONS GetOptions ; ADDBUTTONS; MODAL ; TITLE L('4.6. Подготовка баз данных для визуализация когнитивных функций в MS Excel') ********************************************************************************************************************** ******************************************************************** IF lExit ** Button Ok ELSE ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ******************************************************************** IF ASCAN(aCognFun, .T.) > 0 ELSE LB_Warning(L("Необходимо задать хотя бы одну стат.модель или модель знаний!"),L('4.6. Подготовка баз данных для визуализация когнитивных функций в MS Excel')) Running(.F.) RETURN NIL ENDIF DC_ASave(aCognFun , "_CognFun.arx") // Файл с информацией о том, создание каких CF было задано ************************************************************************************************* *** Удаление всех dbf-файлов из папки: M_PathAppl+"\Cogn_fun\" N_dbf = ADIR(M_PathAppl+"\Cogn_fun\"+"*.dbf") IF N_dbf > 0 PRIVATE aFileName[N_dbf] ADIR(M_PathAppl+"\Cogn_fun\"+"*.dbf",aFileName) // Имена ВСЕХ dbf-файлов в папке "Cogn_fun" FOR j=1 TO N_dbf ERASE(M_PathAppl+"\Cogn_fun\"+aFileName[j]) NEXT ENDIF *MsgBox(STR(N_dbf)) ************************************************************************************************* mLenNameMax = CreateStructAll() // Создание файлов структур баз данных всех моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Class_Sc EXCLUSIVE NEW;N_ClSc = RECCOUNT() USE Gr_ClSc EXCLUSIVE NEW;N_GrClSc = RECCOUNT() USE Attributes EXCLUSIVE NEW;N_Gos = RECCOUNT() USE Opis_Sc EXCLUSIVE NEW;N_OpSc = RECCOUNT() USE Gr_OpSc EXCLUSIVE NEW;N_GrOpSc = RECCOUNT() ****** Определить максимальную длину наименования градации описательной шкалы SELECT Gr_OpSc mMaxGrOpSc = -999 DBGOTOP() DO WHILE .NOT. EOF() mMaxGrOpSc = MAX(mMaxGrOpSc, LEN(ALLTRIM(Name_GrOS))) DBSKIP(1) ENDDO ****** Определить максимальную длину наименования градации классификационной шкалы SELECT Gr_ClSc mMaxGrClSc = -999 DBGOTOP() DO WHILE .NOT. EOF() mMaxGrClSc = MAX(mMaxGrClSc, LEN(ALLTRIM(Name_GrCS))) DBSKIP(1) ENDDO DiapGradSc() // Занести в БД описательных и лкассификационных шкал информацию о начальной и конечной градации каждой шкалы * ########################################################################### // Открыть все текстовые базы данных ######################################## *DC_ASave(aInfStruct, "_InfStruct.arx") // Когда БД создается - записывать структуру, когда открывается - считывать aInfStruct = DC_ARestore("_InfStruct.arx") *DC_ASave(aStrEmpty, "_aStrEmpty.arx") // Записывать только после расчета Abs.txt, а при расчете остальных БД только считывать *DC_ASave(aColEmpty, "_aColEmpty.arx") aStrEmpty = DC_ARestore("_aStrEmpty.arx") aColEmpty = DC_ARestore("_aColEmpty.arx") ************************************************* ***** Формирование пустой записи N_Col = N_Cls+6 // Число полей CrLf = CHR(13)+CHR(10) // Конец строки (записи) Lc_buf = "" FOR j=1 TO N_Col * S = IF(j=2*INT(j/2),"#","X") // Для отладки S = " " // Для работы Lc_buf = Lc_buf + REPLICATE(S, aInfStruct[j,3]) NEXT Lc_buf = Lc_buf + CrLf PUBLIC Len_LcBuf := LEN(Lc_buf) ****** Создаем стат.базы и базы знаний (7 по частным критериям знаний) Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } PUBLIC nHandle[LEN(Ar_Model)] FOR z=1 TO LEN(Ar_Model) IF aCognFun[z] nHandle[z] := FOpen( Ar_Model[z]+".txt", FO_READWRITE ) ENDIF NEXT **** Рассчет массива начальных позиций полей в строке PUBLIC aPos[N_Col] aPos[1] = 1 FOR j=2 TO N_Col aPos[j] = aPos[j-1] + aInfStruct[j-1,3] NEXT * ########################################################################### ** Виды когнитивных функций в режиме 4.6 ******************************************************************************************************************************************************************* ** 1 - 11. Прямые: Y=F[X] - 13. Позитивные: количество информации I[X,Y] > 0 - 15. Построение ТОЛЬКО по точкам (X,Y) с максимальным количеством информации ** 2 - 11. Прямые: Y=F[X] - 13. Позитивные: количество информации I[X,Y] > 0 - 16. Замена всех наблюдений для каждого значения аргумента одним средневзвешенным ** 3 - 11. Прямые: Y=F[X] - 13. Позитивные: количество информации I[X,Y] > 0 - 17. Замена наблюдения с количеством информации Iij наблюдениями с единичным весом ** 4 - 11. Прямые: Y=F[X] - 14. Негативные: количество информации I[X,Y] < 0 - 15. Построение ТОЛЬКО по точкам (X,Y) с максимальным количеством информации ** 5 - 11. Прямые: Y=F[X] - 14. Негативные: количество информации I[X,Y] < 0 - 16. Замена всех наблюдений для каждого значения аргумента одним средневзвешенным ** 6 - 11. Прямые: Y=F[X] - 14. Негативные: количество информации I[X,Y] < 0 - 17. Замена наблюдения с количеством информации Iij наблюдениями с единичным весом ** 7 - 12. Обратные: X=F[Y] - 13. Позитивные: количество информации I[X,Y] > 0 - 15. Построение ТОЛЬКО по точкам (X,Y) с максимальным количеством информации ** 8 - 12. Обратные: X=F[Y] - 13. Позитивные: количество информации I[X,Y] > 0 - 16. Замена всех наблюдений для каждого значения аргумента одним средневзвешенным ** 9 - 12. Обратные: X=F[Y] - 13. Позитивные: количество информации I[X,Y] > 0 - 17. Замена наблюдения с количеством информации Iij наблюдениями с единичным весом ** 10 - 12. Обратные: X=F[Y] - 14. Негативные: количество информации I[X,Y] < 0 - 15. Построение ТОЛЬКО по точкам (X,Y) с максимальным количеством информации ** 11 - 12. Обратные: X=F[Y] - 14. Негативные: количество информации I[X,Y] < 0 - 16. Замена всех наблюдений для каждого значения аргумента одним средневзвешенным ** 12 - 12. Обратные: X=F[Y] - 14. Негативные: количество информации I[X,Y] < 0 - 17. Замена наблюдения с количеством информации Iij наблюдениями с единичным весом ******************************************************************************************************************************************************************* * IF aCognFun[11] .AND. aCognFun[13] .AND. aCognFun[15] * IF aCognFun[11] .AND. aCognFun[13] .AND. aCognFun[16] * IF aCognFun[11] .AND. aCognFun[13] .AND. aCognFun[17] * IF aCognFun[11] .AND. aCognFun[14] .AND. aCognFun[15] * IF aCognFun[11] .AND. aCognFun[14] .AND. aCognFun[16] * IF aCognFun[11] .AND. aCognFun[14] .AND. aCognFun[17] * IF aCognFun[12] .AND. aCognFun[13] .AND. aCognFun[15] * IF aCognFun[12] .AND. aCognFun[13] .AND. aCognFun[16] * IF aCognFun[12] .AND. aCognFun[13] .AND. aCognFun[17] * IF aCognFun[12] .AND. aCognFun[14] .AND. aCognFun[15] * IF aCognFun[12] .AND. aCognFun[14] .AND. aCognFun[16] * IF aCognFun[12] .AND. aCognFun[14] .AND. aCognFun[17] * DbName = Ar_Model[mModel] +"-"+; // Имя модели * IF(aCognFun[11],"Y(X)","") +"-"+; // 11. Прямые: Y=F[X] * IF(aCognFun[12],"X(Y)","") +"-"+; // 12. Обратные: X=F[Y] * IF(aCognFun[13],"Pos","") +"-"+; // 13. Позитивные: I[X,Y] > 0 * IF(aCognFun[14],"Neg","") +"-"+; // 14. Негативные: I[X,Y] < 0 * IF(aCognFun[15],"One_point","") +"-"+; // 15. По одной точке с max количеством информации * IF(aCognFun[16],"All_points_Avr","") +"-"+; // 16. Замена всех наблюдений для каждого значения аргумента одним средневзвешенным * IF(aCognFun[17],"All_points_N1","") +"-"+; // 17. Замена наблюдения с количеством информации Iij наблюдениями с единичным весом * ALLTRIM(STR(mClSc)) +"-"+; // Код класс.шкалы * ALLTRIM(STR(mOpSc)) // Код описательной шкалы ****************************************************************************************** *** Определение значения "nMax" ****************************************************************************************** nMax = 0 FOR mModel = 1 TO LEN(Ar_Model) // Цикл по моделям IF aCognFun[mModel] // Создавать КФ по данной модели? ************************************************************************************************************************************************************ ** 1 - 11. Прямые: Y=F[X] - 13. Позитивные: количество информации I[X,Y] > 0 - 15. Построение ТОЛЬКО по точкам (X,Y) с максимальным количеством информации ************************************************************************************************************************************************************ IF aCognFun[11] .AND. aCognFun[13] .AND. aCognFun[15] FOR mClSc = 1 TO N_ClSc // Цикл по классификационным шкалам SELECT Class_Sc DBGOTO(mClSc) mKodGrCSMin = KodGr_Min mKodGrCSMax = KodGr_Max FOR mOpSc = 1 TO N_OpSc // Цикл по описательным шкалам***** SELECT Opis_Sc DBGOTO(mOpSc) mKodGrOSMin = KodGr_Min mKodGrOSMax = KodGr_Max FOR mGrOpSc = mKodGrOSMin TO mKodGrOSMax // Цикл по градациям описательной шкалы INF# FOR mGrClSc = mKodGrCSMin TO mKodGrCSMax // Цикл по градациям классификационной шкалы INF# nMax++ NEXT NEXT NEXT NEXT ENDIF ************************************************************************************************************************************************************ ** 2 - 11. Прямые: Y=F[X] - 13. Позитивные: количество информации I[X,Y] > 0 - 16. Замена всех наблюдений для каждого значения аргумента одним средневзвешенным ************************************************************************************************************************************************************ IF aCognFun[11] .AND. aCognFun[13] .AND. aCognFun[16] // ########################## FOR mClSc = 1 TO N_ClSc // Цикл по классификационным шкалам SELECT Class_Sc DBGOTO(mClSc) mKodGrCSMin = KodGr_Min mKodGrCSMax = KodGr_Max FOR mOpSc = 1 TO N_OpSc // Цикл по описательным шкалам***** SELECT Opis_Sc DBGOTO(mOpSc) mKodGrOSMin = KodGr_Min mKodGrOSMax = KodGr_Max FOR mGrOpSc = mKodGrOSMin TO mKodGrOSMax // Цикл по градациям описательной шкалы INF# FOR mGrClSc = mKodGrCSMin TO mKodGrCSMax // Цикл по градациям классификационной шкалы INF# nMax++ NEXT NEXT NEXT NEXT ENDIF ************************************************************************************************************************************************************ ** 3 - 11. Прямые: Y=F[X] - 13. Позитивные: количество информации I[X,Y] > 0 - 17. Замена наблюдения с количеством информации Iij наблюдениями с единичным весом ************************************************************************************************************************************************************ IF aCognFun[11] .AND. aCognFun[13] .AND. aCognFun[17] // ########################## FOR mClSc = 1 TO N_ClSc // Цикл по классификационным шкалам SELECT Class_Sc DBGOTO(mClSc) mKodGrCSMin = KodGr_Min mKodGrCSMax = KodGr_Max FOR mOpSc = 1 TO N_OpSc // Цикл по описательным шкалам **** SELECT Opis_Sc DBGOTO(mOpSc) mKodGrOSMin = KodGr_Min mKodGrOSMax = KodGr_Max FOR mGrOpSc = mKodGrOSMin TO mKodGrOSMax // Цикл по градациям описательной шкалы INF# FOR mGrClSc = mKodGrCSMin TO mKodGrCSMax // Цикл по градациям классификационной шкалы INF# nMax++ NEXT NEXT FOR mGrOpSc = mKodGrOSMin TO mKodGrOSMax // Цикл по градациям описательной шкалы INF# FOR mGrClSc = mKodGrCSMin TO mKodGrCSMax // Цикл по градациям классификационной шкалы INF# nMax++ NEXT NEXT NEXT NEXT ENDIF ************************************************************************************************************************************************************ ** 4 - 11. Прямые: Y=F[X] - 14. Негативные: количество информации I[X,Y] < 0 - 15. Построение ТОЛЬКО по точкам (X,Y) с максимальным количеством информации ************************************************************************************************************************************************************ IF aCognFun[11] .AND. aCognFun[14] .AND. aCognFun[15] // ########################## FOR mClSc = 1 TO N_ClSc // Цикл по классификационным шкалам SELECT Class_Sc DBGOTO(mClSc) mKodGrCSMin = KodGr_Min mKodGrCSMax = KodGr_Max FOR mOpSc = 1 TO N_OpSc // Цикл по описательным шкалам***** SELECT Opis_Sc DBGOTO(mOpSc) mKodGrOSMin = KodGr_Min mKodGrOSMax = KodGr_Max FOR mGrOpSc = mKodGrOSMin TO mKodGrOSMax // Цикл по градациям описательной шкалы INF# FOR mGrClSc = mKodGrCSMin TO mKodGrCSMax // Цикл по градациям классификационной шкалы INF# nMax++ NEXT NEXT NEXT NEXT ENDIF ************************************************************************************************************************************************************ ** 5 - 11. Прямые: Y=F[X] - 14. Негативные: количество информации I[X,Y] < 0 - 16. Замена всех наблюдений для каждого значения аргумента одним средневзвешенным ************************************************************************************************************************************************************ IF aCognFun[11] .AND. aCognFun[14] .AND. aCognFun[16] // ########################## FOR mClSc = 1 TO N_ClSc // Цикл по классификационным шкалам SELECT Class_Sc DBGOTO(mClSc) mKodGrCSMin = KodGr_Min mKodGrCSMax = KodGr_Max FOR mOpSc = 1 TO N_OpSc // Цикл по описательным шкалам***** SELECT Opis_Sc DBGOTO(mOpSc) mKodGrOSMin = KodGr_Min mKodGrOSMax = KodGr_Max FOR mGrOpSc = mKodGrOSMin TO mKodGrOSMax // Цикл по градациям описательной шкалы INF# FOR mGrClSc = mKodGrCSMin TO mKodGrCSMax // Цикл по градациям классификационной шкалы INF# nMax++ NEXT NEXT NEXT NEXT ENDIF ************************************************************************************************************************************************************ ** 6 - 11. Прямые: Y=F[X] - 14. Негативные: количество информации I[X,Y] < 0 - 17. Замена наблюдения с количеством информации Iij наблюдениями с единичным весом ************************************************************************************************************************************************************ IF aCognFun[11] .AND. aCognFun[14] .AND. aCognFun[17] // ########################## FOR mClSc = 1 TO N_ClSc // Цикл по классификационным шкалам SELECT Class_Sc DBGOTO(mClSc) mKodGrCSMin = KodGr_Min mKodGrCSMax = KodGr_Max FOR mOpSc = 1 TO N_OpSc // Цикл по описательным шкалам **** SELECT Opis_Sc DBGOTO(mOpSc) mKodGrOSMin = KodGr_Min mKodGrOSMax = KodGr_Max FOR mGrOpSc = mKodGrOSMin TO mKodGrOSMax // Цикл по градациям описательной шкалы INF# FOR mGrClSc = mKodGrCSMin TO mKodGrCSMax // Цикл по градациям классификационной шкалы INF# nMax++ NEXT NEXT FOR mGrOpSc = mKodGrOSMin TO mKodGrOSMax // Цикл по градациям описательной шкалы INF# FOR mGrClSc = mKodGrCSMin TO mKodGrCSMax // Цикл по градациям классификационной шкалы INF# nMax++ NEXT NEXT NEXT NEXT ENDIF ************************************************************************************************************************************************************ ** 7 - 12. Обратные: X=F[Y] - 13. Позитивные: количество информации I[X,Y] > 0 - 15. Построение ТОЛЬКО по точкам (X,Y) с максимальным количеством информации ************************************************************************************************************************************************************ IF aCognFun[12] .AND. aCognFun[13] .AND. aCognFun[15] // ########################## Просто поменять местами столбцы шкал в БД FOR mClSc = 1 TO N_ClSc // Цикл по классификационным шкалам SELECT Class_Sc DBGOTO(mClSc) mKodGrCSMin = KodGr_Min mKodGrCSMax = KodGr_Max FOR mOpSc = 1 TO N_OpSc // Цикл по описательным шкалам***** SELECT Opis_Sc DBGOTO(mOpSc) mKodGrOSMin = KodGr_Min mKodGrOSMax = KodGr_Max FOR mGrOpSc = mKodGrOSMin TO mKodGrOSMax // Цикл по градациям описательной шкалы INF# FOR mGrClSc = mKodGrCSMin TO mKodGrCSMax // Цикл по градациям классификационной шкалы INF# nMax++ NEXT NEXT NEXT NEXT ENDIF ************************************************************************************************************************************************************ ** 8 - 12. Обратные: X=F[Y] - 13. Позитивные: количество информации I[X,Y] > 0 - 16. Замена всех наблюдений для каждого значения аргумента одним средневзвешенным ************************************************************************************************************************************************************ IF aCognFun[12] .AND. aCognFun[13] .AND. aCognFun[16] // ########################## Просто поменять местами столбцы шкал в БД FOR mClSc = 1 TO N_ClSc // Цикл по классификационным шкалам SELECT Class_Sc DBGOTO(mClSc) mKodGrCSMin = KodGr_Min mKodGrCSMax = KodGr_Max FOR mOpSc = 1 TO N_OpSc // Цикл по описательным шкалам***** SELECT Opis_Sc DBGOTO(mOpSc) mKodGrOSMin = KodGr_Min mKodGrOSMax = KodGr_Max FOR mGrOpSc = mKodGrOSMin TO mKodGrOSMax // Цикл по градациям описательной шкалы INF# FOR mGrClSc = mKodGrCSMin TO mKodGrCSMax // Цикл по градациям классификационной шкалы INF# nMax++ NEXT NEXT NEXT NEXT ENDIF ************************************************************************************************************************************************************ ** 9 - 12. Обратные: X=F[Y] - 13. Позитивные: количество информации I[X,Y] > 0 - 17. Замена наблюдения с количеством информации Iij наблюдениями с единичным весом ************************************************************************************************************************************************************ IF aCognFun[12] .AND. aCognFun[13] .AND. aCognFun[17] // ########################## Просто поменять местами столбцы шкал в БД FOR mClSc = 1 TO N_ClSc // Цикл по классификационным шкалам SELECT Class_Sc DBGOTO(mClSc) mKodGrCSMin = KodGr_Min mKodGrCSMax = KodGr_Max FOR mOpSc = 1 TO N_OpSc // Цикл по описательным шкалам **** SELECT Opis_Sc DBGOTO(mOpSc) mKodGrOSMin = KodGr_Min mKodGrOSMax = KodGr_Max FOR mGrOpSc = mKodGrOSMin TO mKodGrOSMax // Цикл по градациям описательной шкалы INF# FOR mGrClSc = mKodGrCSMin TO mKodGrCSMax // Цикл по градациям классификационной шкалы INF# nMax++ NEXT NEXT FOR mGrOpSc = mKodGrOSMin TO mKodGrOSMax // Цикл по градациям описательной шкалы INF# FOR mGrClSc = mKodGrCSMin TO mKodGrCSMax // Цикл по градациям классификационной шкалы INF# nMax++ NEXT NEXT NEXT NEXT ENDIF ************************************************************************************************************************************************************ ** 10 - 12. Обратные: X=F[Y] - 14. Негативные: количество информации I[X,Y] < 0 - 15. Построение ТОЛЬКО по точкам (X,Y) с максимальным количеством информации ************************************************************************************************************************************************************ IF aCognFun[12] .AND. aCognFun[14] .AND. aCognFun[15] // ########################## Просто поменять местами столбцы шкал в БД FOR mClSc = 1 TO N_ClSc // Цикл по классификационным шкалам SELECT Class_Sc DBGOTO(mClSc) mKodGrCSMin = KodGr_Min mKodGrCSMax = KodGr_Max FOR mOpSc = 1 TO N_OpSc // Цикл по описательным шкалам***** SELECT Opis_Sc DBGOTO(mOpSc) mKodGrOSMin = KodGr_Min mKodGrOSMax = KodGr_Max FOR mGrOpSc = mKodGrOSMin TO mKodGrOSMax // Цикл по градациям описательной шкалы INF# FOR mGrClSc = mKodGrCSMin TO mKodGrCSMax // Цикл по градациям классификационной шкалы INF# nMax++ NEXT NEXT NEXT NEXT ENDIF ************************************************************************************************************************************************************ ** 11 - 12. Обратные: X=F[Y] - 14. Негативные: количество информации I[X,Y] < 0 - 16. Замена всех наблюдений для каждого значения аргумента одним средневзвешенным ************************************************************************************************************************************************************ IF aCognFun[12] .AND. aCognFun[14] .AND. aCognFun[16] // ########################## Просто поменять местами столбцы шкал в БД FOR mClSc = 1 TO N_ClSc // Цикл по классификационным шкалам SELECT Class_Sc DBGOTO(mClSc) mKodGrCSMin = KodGr_Min mKodGrCSMax = KodGr_Max FOR mOpSc = 1 TO N_OpSc // Цикл по описательным шкалам***** SELECT Opis_Sc DBGOTO(mOpSc) mKodGrOSMin = KodGr_Min mKodGrOSMax = KodGr_Max FOR mGrOpSc = mKodGrOSMin TO mKodGrOSMax // Цикл по градациям описательной шкалы INF# FOR mGrClSc = mKodGrCSMin TO mKodGrCSMax // Цикл по градациям классификационной шкалы INF# nMax++ NEXT NEXT NEXT NEXT ENDIF ************************************************************************************************************************************************************ ** 12 - 12. Обратные: X=F[Y] - 14. Негативные: количество информации I[X,Y] < 0 - 17. Замена наблюдения с количеством информации Iij наблюдениями с единичным весом ************************************************************************************************************************************************************ IF aCognFun[12] .AND. aCognFun[14] .AND. aCognFun[17] // ########################## Просто поменять местами столбцы шкал в БД FOR mClSc = 1 TO N_ClSc // Цикл по классификационным шкалам SELECT Class_Sc DBGOTO(mClSc) mKodGrCSMin = KodGr_Min mKodGrCSMax = KodGr_Max FOR mOpSc = 1 TO N_OpSc // Цикл по описательным шкалам **** SELECT Opis_Sc DBGOTO(mOpSc) mKodGrOSMin = KodGr_Min mKodGrOSMax = KodGr_Max FOR mGrOpSc = mKodGrOSMin TO mKodGrOSMax // Цикл по градациям описательной шкалы INF# FOR mGrClSc = mKodGrCSMin TO mKodGrCSMax // Цикл по градациям классификационной шкалы INF# nMax++ NEXT NEXT FOR mGrOpSc = mKodGrOSMin TO mKodGrOSMax // Цикл по градациям описательной шкалы INF# FOR mGrClSc = mKodGrCSMin TO mKodGrCSMax // Цикл по градациям классификационной шкалы INF# nMax++ NEXT NEXT NEXT NEXT ENDIF ENDIF NEXT ****************************************************************************************** ****************************************************************************************** * nMax = LEN(Ar_Model) nTime = 0 Mess = L('4.6. Подготовка баз данных для визуализации когнитивных функций в MS Excel') @ 4,5 DCPROGRESS oProgress SIZE 100,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 DCREAD GUI TITLE Mess PARENT @oDialog FIT EXIT oDialog:show() DC_GetProgress(oProgress,0,nMax) ****************************************************************************************** FOR mModel = 1 TO LEN(Ar_Model) // Цикл по моделям IF aCognFun[mModel] // Создавать КФ по данной модели? ************************************************************************************************************************************************************ ** 1 - 11. Прямые: Y=F[X] - 13. Позитивные: количество информации I[X,Y] > 0 - 15. Построение ТОЛЬКО по точкам (X,Y) с максимальным количеством информации ************************************************************************************************************************************************************ IF aCognFun[11] .AND. aCognFun[13] .AND. aCognFun[15] *** Начало цикла по подматрицам ************************************* FOR mClSc = 1 TO N_ClSc // Цикл по классификационным шкалам SELECT Class_Sc DBGOTO(mClSc) mKodGrCSMin = KodGr_Min mKodGrCSMax = KodGr_Max FOR mOpSc = 1 TO N_OpSc // Цикл по описательным шкалам***** **** Создание БД для КФ **************************** aStr := { { "NameGrOpSc", "C", mMaxGrOpSc, 0},; // 1 { "NameGrClSc", "C", mMaxGrClSc, 0},; // 2 { "GrOpSc_Vol", "N", 21 , 7},; // 3 Если шкала числовая - брать Avr_GrInt, а иначе - код градации { "GrClSc_Vol", "N", 21 , 7},; // 4 Если шкала числовая - брать Avr_GrInt, а иначе - код градации { "Num_Point" , "N", 9 , 0},; // 5 Номер точки единичного веса (максимальный соответствует кол-ву информации) { "Inf_Point" , "N", 21 , 7} } // 6 Количество информации в точке * DbName = Ar_Model[mModel] +"-"+; // Имя модели * IF(aCognFun[11],"Y(X)","") +"-"+; // 11. Прямые: Y=F[X] * IF(aCognFun[12],"X(Y)","") +"-"+; // 12. Обратные: X=F[Y] * IF(aCognFun[13],"Pos","") +"-"+; // 13. Позитивные: I[X,Y] > 0 * IF(aCognFun[14],"Neg","") +"-"+; // 14. Негативные: I[X,Y] < 0 * IF(aCognFun[15],"One_point","") +"-"+; // 15. По одной точке с max количеством информации * IF(aCognFun[16],"All_points_Avr","") +"-"+; // 16. Замена всех наблюдений для каждого значения аргумента одним средневзвешенным * IF(aCognFun[17],"All_points_N1","") +"-"+; // 17. Замена наблюдения с количеством информации Iij наблюдениями с единичным весом * ALLTRIM(STR(mClSc)) +"-"+; // Код класс.шкалы * ALLTRIM(STR(mOpSc)) // Код описательной шкалы DbName = Ar_Model[mModel] +"-"+; // Имя модели IF(aCognFun[11],"Y(X)","") +"-"+; // 11. Прямые: Y=F[X] IF(aCognFun[13],"Pos","") +"-"+; // 13. Позитивные: I[X,Y] > 0 IF(aCognFun[15],"One_point","") +"-"+; // 15. По одной точке с max количеством информации ALLTRIM(STR(mClSc)) +"-"+; // Код класс.шкалы ALLTRIM(STR(mOpSc)) // Код описательной шкалы DbCreate( DbName, aStr ) // Создать БД для визуализации КФ USE (DbName) EXCLUSIVE NEW SELECT Opis_Sc DBGOTO(mOpSc) mKodGrOSMin = KodGr_Min mKodGrOSMax = KodGr_Max FOR mGrOpSc = mKodGrOSMin TO mKodGrOSMax // Цикл по градациям описательной шкалы INF# ******* Для каждой градации описательной шкалы найти градацию класс.шкалы с Max информативностью и занести их в БД DbName mInfMax = 0 mKodCl = 0 FOR mGrClSc = mKodGrCSMin TO mKodGrCSMax // Цикл по градациям классификационной шкалы INF# Iij = VAL(LC_FieldGet( Ar_Model[mModel]+".txt", nHandle[mModel], mGrOpSc, 2+mGrClSc )) // Информативность-элемент (i,j) IF Iij > 0 IF mInfMax < Iij mInfMax = Iij mKodCl = mGrClSc // Код класса о котором в признаке макс. кол-во информации ENDIF ENDIF DC_GetProgress(oProgress, ++nTime, nMax) NEXT IF mKodCl > 0 SELECT Gr_OpSc DBGOTO(mGrOpSc) mNameGrOS = Name_GrOS SELECT Attributes DBGOTO(mGrOpSc) // Если шкала числовая - брать Avr_GrInt, а иначе - код градации IF Min_GrInt+Max_GrInt+Avr_GrInt=0 // Шкала текстовая mVolGOS = mGrOpSc ELSE // Шкала числовая mVolGOS = Avr_GrInt ENDIF SELECT Gr_ClSc DBGOTO(mKodCl) mNameGrCS = Name_GrCS SELECT Classes DBGOTO(mKodCl) // Если шкала числовая - брать Avr_GrInt, а иначе - код градации IF Min_GrInt+Max_GrInt+Avr_GrInt=0 // Шкала текстовая mVolGCS = mKodCl ELSE // Шкала числовая mVolGCS = Avr_GrInt ENDIF SELECT(DbName) APPEND BLANK REPLACE NameGrOpSc WITH mNameGrOS REPLACE NameGrClSc WITH mNameGrCS REPLACE GrOpSc_Vol WITH mVolGOS REPLACE GrClSc_Vol WITH mVolGCS ENDIF NEXT CLOSE(DbName) ***** Переписать БД КФ подматрицы в папку: Cogn_fun, а здесь удалить ERASE("Cogn_fun\"+DbName+".dbf") RenameFile( DbName+".dbf", "Cogn_fun\"+DbName+".dbf" ) ERASE(DbName+".dbf") NEXT NEXT ENDIF ************************************************************************************************************************************************************ ** 2 - 11. Прямые: Y=F[X] - 13. Позитивные: количество информации I[X,Y] > 0 - 16. Замена всех наблюдений для каждого значения аргумента одним средневзвешенным ************************************************************************************************************************************************************ IF aCognFun[11] .AND. aCognFun[13] .AND. aCognFun[16] *** Начало цикла по подматрицам ************************************* FOR mClSc = 1 TO N_ClSc // Цикл по классификационным шкалам SELECT Class_Sc DBGOTO(mClSc) mKodGrCSMin = KodGr_Min mKodGrCSMax = KodGr_Max FOR mOpSc = 1 TO N_OpSc // Цикл по описательным шкалам***** **** Создание БД для КФ **************************** aStr := { { "NameGrOpSc", "C", mMaxGrOpSc, 0},; // 1 { "NameGrClSc", "C", mMaxGrClSc, 0},; // 2 { "GrOpSc_Vol", "N", 21 , 7},; // 3 Если шкала числовая - брать Avr_GrInt, а иначе - код градации { "GrClSc_Vol", "N", 21 , 7},; // 4 Если шкала числовая - брать Avr_GrInt, а иначе - код градации { "Num_Point" , "N", 9 , 0},; // 5 Номер точки единичного веса (максимальный соответствует кол-ву информации) { "Inf_Point" , "N", 21 , 7} } // 6 Количество информации в точке * DbName = Ar_Model[mModel] +"-"+; // Имя модели * IF(aCognFun[11],"Y(X)","") +"-"+; // 11. Прямые: Y=F[X] * IF(aCognFun[12],"X(Y)","") +"-"+; // 12. Обратные: X=F[Y] * IF(aCognFun[13],"Pos","") +"-"+; // 13. Позитивные: I[X,Y] > 0 * IF(aCognFun[14],"Neg","") +"-"+; // 14. Негативные: I[X,Y] < 0 * IF(aCognFun[15],"One_point","") +"-"+; // 15. По одной точке с max количеством информации * IF(aCognFun[16],"All_points_Avr","") +"-"+; // 16. Замена всех наблюдений для каждого значения аргумента одним средневзвешенным * IF(aCognFun[17],"All_points_N1","") +"-"+; // 17. Замена наблюдения с количеством информации Iij наблюдениями с единичным весом * ALLTRIM(STR(mClSc)) +"-"+; // Код класс.шкалы * ALLTRIM(STR(mOpSc)) // Код описательной шкалы DbName = Ar_Model[mModel] +"-"+; // Имя модели IF(aCognFun[11],"Y(X)","") +"-"+; // 11. Прямые: Y=F[X] IF(aCognFun[13],"Pos","") +"-"+; // 13. Позитивные: I[X,Y] > 0 IF(aCognFun[16],"All_points_Avr","") +"-"+; // 16. Замена всех наблюдений для каждого значения аргумента одним средневзвешенным ALLTRIM(STR(mClSc)) +"-"+; // Код класс.шкалы ALLTRIM(STR(mOpSc)) // Код описательной шкалы DbCreate( DbName, aStr ) // Создать БД для визуализации КФ USE (DbName) EXCLUSIVE NEW SELECT Opis_Sc DBGOTO(mOpSc) mKodGrOSMin = KodGr_Min mKodGrOSMax = KodGr_Max FOR mGrOpSc = mKodGrOSMin TO mKodGrOSMax // Цикл по градациям описательной шкалы INF# ******* Для каждой градации описательной шкалы найти средневзвешенную градацию класс.шкалы и занести их в БД DbName mSumInfAvr = 0 // Сумма значений * кол-во информации mSumInf = 0 // Сумма кол-во информации SELECT Classes FOR mGrClSc = mKodGrCSMin TO mKodGrCSMax // Цикл по градациям классификационной шкалы INF# Iij = VAL(LC_FieldGet( Ar_Model[mModel]+".txt", nHandle[mModel], mGrOpSc, 2+mGrClSc )) // Информативность-элемент (i,j) IF Iij > 0 DBGOTO(mGrClSc) // Если шкала числовая - брать Avr_GrInt, а иначе - код градации IF Min_GrInt+Max_GrInt+Avr_GrInt=0 // Шкала текстовая mVolGCS = mGrClSc ELSE // Шкала числовая mVolGCS = Avr_GrInt ENDIF mSumInfAvr = mSumInfAvr + Iij * mVolGCS // Сумма значений * кол-во информации ################################# mSumInf = mSumInf + Iij // Сумма кол-во информации ################################# ENDIF DC_GetProgress(oProgress, ++nTime, nMax) NEXT SELECT Gr_OpSc DBGOTO(mGrOpSc) mNameGrOS = Name_GrOS SELECT Attributes DBGOTO(mGrOpSc) // Если шкала числовая - брать Avr_GrInt, а иначе - код градации IF Min_GrInt+Max_GrInt+Avr_GrInt=0 // Шкала текстовая mVolGOS = mGrOpSc ELSE // Шкала числовая mVolGOS = Avr_GrInt ENDIF mAvrGrCS = mSumInfAvr / mSumInf // Средневзвешенная градация класс.шкалы SELECT Classes DBGOTOP() DO WHILE .NOT. EOF() IF Min_GrInt <= mAvrGrCS .AND. mAvrGrCS <= Max_GrInt mKodCl = Kod_ClS EXIT ENDIF DBSKIP(1) ENDDO * MsgBox(STR(mAvrGrCS)) IF mKodCl > 0 SELECT Gr_ClSc DBGOTO(mKodCl) mNameGrCS = Name_GrCS SELECT(DbName) APPEND BLANK REPLACE NameGrOpSc WITH mNameGrOS REPLACE NameGrClSc WITH mNameGrCS REPLACE GrOpSc_Vol WITH mVolGOS REPLACE GrClSc_Vol WITH mAvrGrCS // Средневзвешенная градация класс.шкалы ENDIF NEXT CLOSE(DbName) ***** Переписать БД КФ подматрицы в папку: Cogn_fun, а здесь удалить ERASE("Cogn_fun\"+DbName+".dbf") RenameFile( DbName+".dbf", "Cogn_fun\"+DbName+".dbf" ) ERASE(DbName+".dbf") NEXT NEXT ENDIF ************************************************************************************************************************************************************ ** 3 - 11. Прямые: Y=F[X] - 13. Позитивные: количество информации I[X,Y] > 0 - 17. Замена наблюдения с количеством информации Iij наблюдениями с единичным весом ************************************************************************************************************************************************************ IF aCognFun[11] .AND. aCognFun[13] .AND. aCognFun[17] // ########################## *** Начало цикла по подматрицам ************************************* FOR mClSc = 1 TO N_ClSc // Цикл по классификационным шкалам SELECT Class_Sc DBGOTO(mClSc) mKodGrCSMin = KodGr_Min mKodGrCSMax = KodGr_Max FOR mOpSc = 1 TO N_OpSc // Цикл по описательным шкалам **** **** Создание БД для КФ **************************** aStr := { { "NameGrOpSc", "C", mMaxGrOpSc, 0},; // 1 { "NameGrClSc", "C", mMaxGrClSc, 0},; // 2 { "GrOpSc_Vol", "N", 21 , 7},; // 3 Если шкала числовая - брать Avr_GrInt, а иначе - код градации { "GrClSc_Vol", "N", 21 , 7},; // 4 Если шкала числовая - брать Avr_GrInt, а иначе - код градации { "Num_Point" , "N", 9 , 0},; // 5 Номер точки единичного веса (максимальный соответствует кол-ву информации) { "Inf_Point" , "N", 21 , 7} } // 6 Количество информации в точке * DbName = Ar_Model[mModel] +"-"+; // Имя модели * IF(aCognFun[11],"Y(X)","") +"-"+; // 11. Прямые: Y=F[X] * IF(aCognFun[12],"X(Y)","") +"-"+; // 12. Обратные: X=F[Y] * IF(aCognFun[13],"Pos","") +"-"+; // 13. Позитивные: I[X,Y] > 0 * IF(aCognFun[14],"Neg","") +"-"+; // 14. Негативные: I[X,Y] < 0 * IF(aCognFun[15],"One_point","") +"-"+; // 15. По одной точке с max количеством информации * IF(aCognFun[16],"All_points_Avr","") +"-"+; // 16. Замена всех наблюдений для каждого значения аргумента одним средневзвешенным * IF(aCognFun[17],"All_points_N1","") +"-"+; // 17. Замена наблюдения с количеством информации Iij наблюдениями с единичным весом * ALLTRIM(STR(mClSc)) +"-"+; // Код класс.шкалы * ALLTRIM(STR(mOpSc)) // Код описательной шкалы DbName = Ar_Model[mModel] +"-"+; // Имя модели IF(aCognFun[11],"Y(X)","") +"-"+; // 11. Прямые: Y=F[X] IF(aCognFun[13],"Pos","") +"-"+; // 13. Позитивные: I[X,Y] > 0 IF(aCognFun[17],"All_points_N1","") +"-"+; // 17. Замена наблюдения с количеством информации Iij наблюдениями с единичным весом ALLTRIM(STR(mClSc)) +"-"+; // Код класс.шкалы ALLTRIM(STR(mOpSc)) // Код описательной шкалы DbCreate( DbName, aStr ) // Создать БД для визуализации КФ USE (DbName) EXCLUSIVE NEW SELECT Opis_Sc DBGOTO(mOpSc) mKodGrOSMin = KodGr_Min mKodGrOSMax = KodGr_Max *** Найти максимальную и минимальную информативность в подматрице БД INF# и использовать ее *** для расчета весового коэффициента и определения количества точек с единичным весом в единице информации для Iij > 0 *** Заодно определить диапазоны изменения значений градаций классификационных и описательных шкал и градаций для подматрицы функции mIijMin = +99999999999 mIijMax = -99999999999 mVolGOSmin = +99999999999 mVolGOSmax = -99999999999 mVolGCSmin = +99999999999 mVolGCSmax = -99999999999 FOR mGrOpSc = mKodGrOSMin TO mKodGrOSMax // Цикл по градациям описательной шкалы INF# FOR mGrClSc = mKodGrCSMin TO mKodGrCSMax // Цикл по градациям классификационной шкалы INF# Iij = VAL(LC_FieldGet( Ar_Model[mModel]+".txt", nHandle[mModel], mGrOpSc, 2+mGrClSc )) // Информативность-элемент (i,j) IF Iij > 0 mIijMin = MIN(mIijMin, Iij) mIijMax = MAX(mIijMax, Iij) SELECT Attributes DBGOTO(mGrOpSc) // Если шкала числовая - брать Avr_GrInt, а иначе - код градации IF Min_GrInt+Max_GrInt+Avr_GrInt=0 // Шкала текстовая mVolGOSmin = MIN(mVolGOSmin, mGrOpSc) mVolGOSmax = MAX(mVolGOSmax, mGrOpSc) ELSE // Шкала числовая mVolGOSmin = MIN(mVolGOSmin, Avr_GrInt) mVolGOSmax = MAX(mVolGOSmax, Avr_GrInt) ENDIF SELECT Classes DBGOTO(mGrClSc) // Если шкала числовая - брать Avr_GrInt, а иначе - код градации IF Min_GrInt+Max_GrInt+Avr_GrInt=0 // Шкала текстовая mVolGCSmin = MIN(mVolGCSmin, mGrClSc) mVolGCSmax = MAX(mVolGCSmax, mGrClSc) ELSE // Шкала числовая mVolGCSmin = MIN(mVolGCSmin, Avr_GrInt) mVolGCSmax = MAX(mVolGCSmax, Avr_GrInt) ENDIF ENDIF DC_GetProgress(oProgress, ++nTime, nMax) NEXT NEXT ******* Для каждой градации описательной шкалы найти все градации класс.шкалы и для каждой из них ******* занести в БД DbName количество точек единичного веса, соответствующее количеству информации в X об Y FOR mGrOpSc = mKodGrOSMin TO mKodGrOSMax // Цикл по градациям описательной шкалы INF# FOR mGrClSc = mKodGrCSMin TO mKodGrCSMax // Цикл по градациям классификационной шкалы INF# Iij = VAL(LC_FieldGet( Ar_Model[mModel]+".txt", nHandle[mModel], mGrOpSc, 2+mGrClSc )) // Информативность-элемент (i,j) IF Iij > 0 SELECT Gr_OpSc DBGOTO(mGrOpSc) mNameGrOS = Name_GrOS SELECT Attributes DBGOTO(mGrOpSc) // Если шкала числовая - брать Avr_GrInt, а иначе - код градации IF Min_GrInt+Max_GrInt+Avr_GrInt=0 // Шкала текстовая mVolGOS = mGrOpSc ELSE // Шкала числовая mVolGOS = Avr_GrInt ENDIF SELECT Gr_ClSc DBGOTO(mGrClSc) mNameGrCS = Name_GrCS SELECT Classes DBGOTO(mGrClSc) // Если шкала числовая - брать Avr_GrInt, а иначе - код градации IF Min_GrInt+Max_GrInt+Avr_GrInt=0 // Шкала текстовая mVolGCS = mKodCl ELSE // Шкала числовая mVolGCS = Avr_GrInt ENDIF N_Point = ROUND(Iij/(mIijMax/aCognFun[18]),0) // Количество точек, соответствующее количеству информации Df = 360/N_Point // Угол в градусах между соседними точками рассеяния SELECT(DbName) FOR mPoint = 1 TO N_Point Rx = RAND() * (mVolGOSmax-mVolGOSmin) * aCognFun[19]/100 // Радиус по оси X Ry = RAND() * (mVolGCSmax-mVolGCSmin) * aCognFun[19]/100 // Радиус по оси Y APPEND BLANK REPLACE NameGrOpSc WITH mNameGrOS REPLACE NameGrClSc WITH mNameGrCS REPLACE GrOpSc_Vol WITH mVolGOS + Rx * COS(Df*mPoint*3.141592653/180) // Рассеяние по эллипсу REPLACE GrClSc_Vol WITH mVolGCS + Ry * SIN(Df*mPoint*3.141592653/180) // Рассеяние по эллипсу REPLACE Num_Point WITH mPoint REPLACE Inf_Point WITH Iij NEXT ENDIF DC_GetProgress(oProgress, ++nTime, nMax) NEXT NEXT CLOSE(DbName) ***** Переписать БД КФ подматрицы в папку: Cogn_fun, а здесь удалить ERASE("Cogn_fun\"+DbName+".dbf") RenameFile( DbName+".dbf", "Cogn_fun\"+DbName+".dbf" ) ERASE(DbName+".dbf") NEXT NEXT ENDIF ************************************************************************************************************************************************************ ** 4 - 11. Прямые: Y=F[X] - 14. Негативные: количество информации I[X,Y] < 0 - 15. Построение ТОЛЬКО по точкам (X,Y) с максимальным количеством информации ************************************************************************************************************************************************************ IF aCognFun[11] .AND. aCognFun[14] .AND. aCognFun[15] // ########################## *** Начало цикла по подматрицам *************************************** FOR mClSc = 1 TO N_ClSc // Цикл по классификационным шкалам SELECT Class_Sc DBGOTO(mClSc) mKodGrCSMin = KodGr_Min mKodGrCSMax = KodGr_Max FOR mOpSc = 1 TO N_OpSc // Цикл по описательным шкалам***** **** Создание БД для КФ **************************** aStr := { { "NameGrOpSc", "C", mMaxGrOpSc, 0},; // 1 { "NameGrClSc", "C", mMaxGrClSc, 0},; // 2 { "GrOpSc_Vol", "N", 21 , 7},; // 3 Если шкала числовая - брать Avr_GrInt, а иначе - код градации { "GrClSc_Vol", "N", 21 , 7},; // 4 Если шкала числовая - брать Avr_GrInt, а иначе - код градации { "Num_Point" , "N", 9 , 0},; // 5 Номер точки единичного веса (максимальный соответствует кол-ву информации) { "Inf_Point" , "N", 21 , 7} } // 6 Количество информации в точке * DbName = Ar_Model[mModel] +"-"+; // Имя модели * IF(aCognFun[11],"Y(X)","") +"-"+; // 11. Прямые: Y=F[X] * IF(aCognFun[12],"X(Y)","") +"-"+; // 12. Обратные: X=F[Y] * IF(aCognFun[13],"Pos","") +"-"+; // 13. Позитивные: I[X,Y] > 0 * IF(aCognFun[14],"Neg","") +"-"+; // 14. Негативные: I[X,Y] < 0 * IF(aCognFun[15],"One_point","") +"-"+; // 15. По одной точке с max количеством информации * IF(aCognFun[16],"All_points_Avr","") +"-"+; // 16. Замена всех наблюдений для каждого значения аргумента одним средневзвешенным * IF(aCognFun[17],"All_points_N1","") +"-"+; // 17. Замена наблюдения с количеством информации Iij наблюдениями с единичным весом * ALLTRIM(STR(mClSc)) +"-"+; // Код класс.шкалы * ALLTRIM(STR(mOpSc)) // Код описательной шкалы DbName = Ar_Model[mModel] +"-"+; // Имя модели IF(aCognFun[11],"Y(X)","") +"-"+; // 11. Прямые: Y=F[X] IF(aCognFun[14],"Neg","") +"-"+; // 14. Негативные: I[X,Y] < 0 IF(aCognFun[15],"One_point","") +"-"+; // 15. По одной точке с max количеством информации ALLTRIM(STR(mClSc)) +"-"+; // Код класс.шкалы ALLTRIM(STR(mOpSc)) // Код описательной шкалы DbCreate( DbName, aStr ) // БД для КФ USE (DbName) EXCLUSIVE NEW SELECT Opis_Sc DBGOTO(mOpSc) mKodGrOSMin = KodGr_Min mKodGrOSMax = KodGr_Max FOR mGrOpSc = mKodGrOSMin TO mKodGrOSMax // Цикл по градациям описательной шкалы INF# ******* Для каждой градации описательной шкалы найти градацию класс.шкалы с Min информативностью и занести их в БД DbName mInfMin = 0 mKodCl = 0 FOR mGrClSc = mKodGrCSMin TO mKodGrCSMax // Цикл по градациям классификационной шкалы INF# Iij = VAL(LC_FieldGet( Ar_Model[mModel]+".txt", nHandle[mModel], mGrOpSc, 2+mGrClSc )) // Информативность-элемент (i,j) IF Iij < 0 IF mInfMin > Iij mInfMin = Iij mKodCl = mGrClSc // Код класса о котором в признаке мин. кол-во информации ENDIF ENDIF DC_GetProgress(oProgress, ++nTime, nMax) NEXT IF mKodCl > 0 SELECT Gr_OpSc DBGOTO(mGrOpSc) mNameGrOS = Name_GrOS SELECT Attributes DBGOTO(mGrOpSc) // Если шкала числовая - брать Avr_GrInt, а иначе - код градации IF Min_GrInt+Max_GrInt+Avr_GrInt=0 // Шкала текстовая mVolGOS = mGrOpSc ELSE // Шкала числовая mVolGOS = Avr_GrInt ENDIF SELECT Gr_ClSc DBGOTO(mGrClSc) mNameGrCS = Name_GrCS SELECT Classes DBGOTO(mGrClSc) // Если шкала числовая - брать Avr_GrInt, а иначе - код градации IF Min_GrInt+Max_GrInt+Avr_GrInt=0 // Шкала текстовая mVolGCS = mKodCl ELSE // Шкала числовая mVolGCS = Avr_GrInt ENDIF SELECT(DbName) APPEND BLANK REPLACE NameGrOpSc WITH mNameGrOS REPLACE NameGrClSc WITH mNameGrCS REPLACE GrOpSc_Vol WITH mVolGOS REPLACE GrClSc_Vol WITH mVolGCS ENDIF NEXT CLOSE(DbName) ***** Переписать БД КФ подматрицы в папку: Cogn_fun, а здесь удалить ERASE("Cogn_fun\"+DbName+".dbf") RenameFile( DbName+".dbf", "Cogn_fun\"+DbName+".dbf" ) ERASE(DbName+".dbf") NEXT NEXT ENDIF ************************************************************************************************************************************************************ ** 5 - 11. Прямые: Y=F[X] - 14. Негативные: количество информации I[X,Y] < 0 - 16. Замена всех наблюдений для каждого значения аргумента одним средневзвешенным ************************************************************************************************************************************************************ IF aCognFun[11] .AND. aCognFun[14] .AND. aCognFun[16] *** Начало цикла по подматрицам ************************************* FOR mClSc = 1 TO N_ClSc // Цикл по классификационным шкалам SELECT Class_Sc DBGOTO(mClSc) mKodGrCSMin = KodGr_Min mKodGrCSMax = KodGr_Max FOR mOpSc = 1 TO N_OpSc // Цикл по описательным шкалам***** **** Создание БД для КФ **************************** aStr := { { "NameGrOpSc", "C", mMaxGrOpSc, 0},; // 1 { "NameGrClSc", "C", mMaxGrClSc, 0},; // 2 { "GrOpSc_Vol", "N", 21 , 7},; // 3 Если шкала числовая - брать Avr_GrInt, а иначе - код градации { "GrClSc_Vol", "N", 21 , 7},; // 4 Если шкала числовая - брать Avr_GrInt, а иначе - код градации { "Num_Point" , "N", 9 , 0},; // 5 Номер точки единичного веса (максимальный соответствует кол-ву информации) { "Inf_Point" , "N", 21 , 7} } // 6 Количество информации в точке * DbName = Ar_Model[mModel] +"-"+; // Имя модели * IF(aCognFun[11],"Y(X)","") +"-"+; // 11. Прямые: Y=F[X] * IF(aCognFun[12],"X(Y)","") +"-"+; // 12. Обратные: X=F[Y] * IF(aCognFun[13],"Pos","") +"-"+; // 13. Позитивные: I[X,Y] > 0 * IF(aCognFun[14],"Neg","") +"-"+; // 14. Негативные: I[X,Y] < 0 * IF(aCognFun[15],"One_point","") +"-"+; // 15. По одной точке с max количеством информации * IF(aCognFun[16],"All_points_Avr","") +"-"+; // 16. Замена всех наблюдений для каждого значения аргумента одним средневзвешенным * IF(aCognFun[17],"All_points_N1","") +"-"+; // 17. Замена наблюдения с количеством информации Iij наблюдениями с единичным весом * ALLTRIM(STR(mClSc)) +"-"+; // Код класс.шкалы * ALLTRIM(STR(mOpSc)) // Код описательной шкалы DbName = Ar_Model[mModel] +"-"+; // Имя модели IF(aCognFun[11],"Y(X)","") +"-"+; // 11. Прямые: Y=F[X] IF(aCognFun[14],"Neg","") +"-"+; // 14. Негативные: I[X,Y] < 0 IF(aCognFun[16],"All_points_Avr","") +"-"+; // 16. Замена всех наблюдений для каждого значения аргумента одним средневзвешенным ALLTRIM(STR(mClSc)) +"-"+; // Код класс.шкалы ALLTRIM(STR(mOpSc)) // Код описательной шкалы DbCreate( DbName, aStr ) // Создать БД для визуализации КФ USE (DbName) EXCLUSIVE NEW SELECT Opis_Sc DBGOTO(mOpSc) mKodGrOSMin = KodGr_Min mKodGrOSMax = KodGr_Max FOR mGrOpSc = mKodGrOSMin TO mKodGrOSMax // Цикл по градациям описательной шкалы INF# ******* Для каждой градации описательной шкалы найти средневзвешенную градацию класс.шкалы и занести их в БД DbName mSumInfAvr = 0 // Сумма значений * кол-во информации mSumInf = 0 // Сумма кол-во информации SELECT Classes FOR mGrClSc = mKodGrCSMin TO mKodGrCSMax // Цикл по градациям классификационной шкалы INF# Iij = VAL(LC_FieldGet( Ar_Model[mModel]+".txt", nHandle[mModel], mGrOpSc, 2+mGrClSc )) // Информативность-элемент (i,j) IF Iij < 0 DBGOTO(mGrClSc) // Если шкала числовая - брать Avr_GrInt, а иначе - код градации IF Min_GrInt+Max_GrInt+Avr_GrInt=0 // Шкала текстовая mVolGCS = mGrClSc ELSE // Шкала числовая mVolGCS = Avr_GrInt ENDIF mSumInfAvr = mSumInfAvr + Iij * mVolGCS // Сумма значений * кол-во информации ################################# mSumInf = mSumInf + Iij // Сумма кол-во информации ################################# ENDIF DC_GetProgress(oProgress, ++nTime, nMax) NEXT SELECT Gr_OpSc DBGOTO(mGrOpSc) mNameGrOS = Name_GrOS SELECT Attributes DBGOTO(mGrOpSc) // Если шкала числовая - брать Avr_GrInt, а иначе - код градации IF Min_GrInt+Max_GrInt+Avr_GrInt=0 // Шкала текстовая mVolGOS = mGrOpSc ELSE // Шкала числовая mVolGOS = Avr_GrInt ENDIF mAvrGrCS = mSumInfAvr / mSumInf // Средневзвешенная градация класс.шкалы SELECT Classes DBGOTOP() DO WHILE .NOT. EOF() IF Min_GrInt <= mAvrGrCS .AND. mAvrGrCS <= Max_GrInt mKodCl = Kod_ClS EXIT ENDIF DBSKIP(1) ENDDO * MsgBox(STR(mAvrGrCS)) IF mKodCl > 0 SELECT Gr_ClSc DBGOTO(mKodCl) mNameGrCS = Name_GrCS SELECT(DbName) APPEND BLANK REPLACE NameGrOpSc WITH mNameGrOS REPLACE NameGrClSc WITH mNameGrCS REPLACE GrOpSc_Vol WITH mVolGOS REPLACE GrClSc_Vol WITH mAvrGrCS // Средневзвешенная градация класс.шкалы ENDIF NEXT CLOSE(DbName) ***** Переписать БД КФ подматрицы в папку: Cogn_fun, а здесь удалить ERASE("Cogn_fun\"+DbName+".dbf") RenameFile( DbName+".dbf", "Cogn_fun\"+DbName+".dbf" ) ERASE(DbName+".dbf") NEXT NEXT ENDIF ************************************************************************************************************************************************************ ** 6 - 11. Прямые: Y=F[X] - 14. Негативные: количество информации I[X,Y] < 0 - 17. Замена наблюдения с количеством информации Iij наблюдениями с единичным весом ************************************************************************************************************************************************************ IF aCognFun[11] .AND. aCognFun[14] .AND. aCognFun[17] // ########################## *** Начало цикла по подматрицам ************************************* FOR mClSc = 1 TO N_ClSc // Цикл по классификационным шкалам SELECT Class_Sc DBGOTO(mClSc) mKodGrCSMin = KodGr_Min mKodGrCSMax = KodGr_Max FOR mOpSc = 1 TO N_OpSc // Цикл по описательным шкалам **** **** Создание БД для КФ **************************** aStr := { { "NameGrOpSc", "C", mMaxGrOpSc, 0},; // 1 { "NameGrClSc", "C", mMaxGrClSc, 0},; // 2 { "GrOpSc_Vol", "N", 21 , 7},; // 3 Если шкала числовая - брать Avr_GrInt, а иначе - код градации { "GrClSc_Vol", "N", 21 , 7},; // 4 Если шкала числовая - брать Avr_GrInt, а иначе - код градации { "Num_Point" , "N", 9 , 0},; // 5 Номер точки единичного веса (максимальный соответствует кол-ву информации) { "Inf_Point" , "N", 21 , 7} } // 6 Количество информации в точке * DbName = Ar_Model[mModel] +"-"+; // Имя модели * IF(aCognFun[11],"Y(X)","") +"-"+; // 11. Прямые: Y=F[X] * IF(aCognFun[12],"X(Y)","") +"-"+; // 12. Обратные: X=F[Y] * IF(aCognFun[13],"Pos","") +"-"+; // 13. Позитивные: I[X,Y] > 0 * IF(aCognFun[14],"Neg","") +"-"+; // 14. Негативные: I[X,Y] < 0 * IF(aCognFun[15],"One_point","") +"-"+; // 15. По одной точке с max количеством информации * IF(aCognFun[16],"All_points_Avr","") +"-"+; // 16. Замена всех наблюдений для каждого значения аргумента одним средневзвешенным * IF(aCognFun[17],"All_points_N1","") +"-"+; // 17. Замена наблюдения с количеством информации Iij наблюдениями с единичным весом * ALLTRIM(STR(mClSc)) +"-"+; // Код класс.шкалы * ALLTRIM(STR(mOpSc)) // Код описательной шкалы DbName = Ar_Model[mModel] +"-"+; // Имя модели IF(aCognFun[11],"Y(X)","") +"-"+; // 11. Прямые: Y=F[X] IF(aCognFun[14],"Neg","") +"-"+; // 14. Негативные: I[X,Y] < 0 IF(aCognFun[17],"All_points_N1","") +"-"+; // 17. Замена наблюдения с количеством информации Iij наблюдениями с единичным весом ALLTRIM(STR(mClSc)) +"-"+; // Код класс.шкалы ALLTRIM(STR(mOpSc)) // Код описательной шкалы DbCreate( DbName, aStr ) // Создать БД для визуализации КФ USE (DbName) EXCLUSIVE NEW SELECT Opis_Sc DBGOTO(mOpSc) mKodGrOSMin = KodGr_Min mKodGrOSMax = KodGr_Max *** Найти максимальную и минимальную информативность в подматрице БД INF# и использовать ее *** для расчета весового коэффициента и определения количества точек с единичным весом в единице информации для Iij > 0 *** Заодно определить диапазоны изменения градаций классификационных и описательных шкал и градаций для подматрицы функции mIijMin = +99999999999 mIijMax = -99999999999 mVolGOSmin = +99999999999 mVolGOSmax = -99999999999 mVolGCSmin = +99999999999 mVolGCSmax = -99999999999 FOR mGrOpSc = mKodGrOSMin TO mKodGrOSMax // Цикл по градациям описательной шкалы INF# FOR mGrClSc = mKodGrCSMin TO mKodGrCSMax // Цикл по градациям классификационной шкалы INF# Iij = VAL(LC_FieldGet( Ar_Model[mModel]+".txt", nHandle[mModel], mGrOpSc, 2+mGrClSc )) // Информативность-элемент (i,j) IF Iij < 0 mIijMin = MIN(mIijMin, Iij) mIijMax = MAX(mIijMax, Iij) SELECT Attributes DBGOTO(mGrOpSc) // Если шкала числовая - брать Avr_GrInt, а иначе - код градации IF Min_GrInt+Max_GrInt+Avr_GrInt=0 // Шкала текстовая mVolGOSmin = MIN(mVolGOSmin, mGrOpSc) mVolGOSmax = MAX(mVolGOSmax, mGrOpSc) ELSE // Шкала числовая mVolGOSmin = MIN(mVolGOSmin, Avr_GrInt) mVolGOSmax = MAX(mVolGOSmax, Avr_GrInt) ENDIF SELECT Classes DBGOTO(mGrClSc) // Если шкала числовая - брать Avr_GrInt, а иначе - код градации IF Min_GrInt+Max_GrInt+Avr_GrInt=0 // Шкала текстовая mVolGCSmin = MIN(mVolGCSmin, mGrClSc) mVolGCSmax = MAX(mVolGCSmax, mGrClSc) ELSE // Шкала числовая mVolGCSmin = MIN(mVolGCSmin, Avr_GrInt) mVolGCSmax = MAX(mVolGCSmax, Avr_GrInt) ENDIF ENDIF DC_GetProgress(oProgress, ++nTime, nMax) NEXT NEXT ******* Для каждой градации описательной шкалы найти все градации класс.шкалы и для каждой из них ******* занести в БД DbName количество точек единичного веса, соответствующее количеству информации в X об Y FOR mGrOpSc = mKodGrOSMin TO mKodGrOSMax // Цикл по градациям описательной шкалы INF# FOR mGrClSc = mKodGrCSMin TO mKodGrCSMax // Цикл по градациям классификационной шкалы INF# Iij = VAL(LC_FieldGet( Ar_Model[mModel]+".txt", nHandle[mModel], mGrOpSc, 2+mGrClSc )) // Информативность-элемент (i,j) IF Iij < 0 SELECT Gr_OpSc DBGOTO(mGrOpSc) mNameGrOS = Name_GrOS SELECT Attributes DBGOTO(mGrOpSc) // Если шкала числовая - брать Avr_GrInt, а иначе - код градации IF Min_GrInt+Max_GrInt+Avr_GrInt=0 // Шкала текстовая mVolGOS = mGrOpSc ELSE // Шкала числовая mVolGOS = Avr_GrInt ENDIF SELECT Gr_ClSc DBGOTO(mGrClSc) mNameGrCS = Name_GrCS SELECT Classes DBGOTO(mGrClSc) // Если шкала числовая - брать Avr_GrInt, а иначе - код градации IF Min_GrInt+Max_GrInt+Avr_GrInt=0 // Шкала текстовая mVolGCS = mKodCl ELSE // Шкала числовая mVolGCS = Avr_GrInt ENDIF N_Point = ROUND(Iij/(mIijMin/aCognFun[18]),0) // Количество точек, соответствующее количеству информации Df = 360/N_Point // Угол в градусах между соседними точками рассеяния SELECT(DbName) FOR mPoint = 1 TO N_Point Rx = RAND() * (mVolGOSmax-mVolGOSmin) * aCognFun[19]/100 // Радиус по оси X Ry = RAND() * (mVolGCSmax-mVolGCSmin) * aCognFun[19]/100 // Радиус по оси Y APPEND BLANK REPLACE NameGrOpSc WITH mNameGrOS REPLACE NameGrClSc WITH mNameGrCS REPLACE GrOpSc_Vol WITH mVolGOS + Rx * COS(Df*mPoint*3.141592653/180) // Рассеяние по эллипсу REPLACE GrClSc_Vol WITH mVolGCS + Ry * SIN(Df*mPoint*3.141592653/180) // Рассеяние по эллипсу REPLACE Num_Point WITH mPoint REPLACE Inf_Point WITH Iij NEXT ENDIF DC_GetProgress(oProgress, ++nTime, nMax) NEXT NEXT CLOSE(DbName) ***** Переписать БД КФ подматрицы в папку: Cogn_fun, а здесь удалить ERASE("Cogn_fun\"+DbName+".dbf") RenameFile( DbName+".dbf", "Cogn_fun\"+DbName+".dbf" ) ERASE(DbName+".dbf") NEXT NEXT ENDIF ************************************************************************************************************************************************************ ** 7 - 12. Обратные: X=F[Y] - 13. Позитивные: количество информации I[X,Y] > 0 - 15. Построение ТОЛЬКО по точкам (X,Y) с максимальным количеством информации ************************************************************************************************************************************************************ IF aCognFun[12] .AND. aCognFun[13] .AND. aCognFun[15] // ########################## Просто поменять местами столбцы шкал в БД *** Начало цикла по подматрицам ************************************* FOR mClSc = 1 TO N_ClSc // Цикл по классификационным шкалам SELECT Class_Sc DBGOTO(mClSc) mKodGrCSMin = KodGr_Min mKodGrCSMax = KodGr_Max FOR mOpSc = 1 TO N_OpSc // Цикл по описательным шкалам***** **** Создание БД для КФ **************************** aStr := { { "NameGrOpSc", "C", mMaxGrOpSc, 0},; // 1 { "NameGrClSc", "C", mMaxGrClSc, 0},; // 2 { "GrClSc_Vol", "N", 21 , 7},; // 3 Если шкала числовая - брать Avr_GrInt, а иначе - код градации { "GrOpSc_Vol", "N", 21 , 7},; // 4 Если шкала числовая - брать Avr_GrInt, а иначе - код градации { "Num_Point" , "N", 9 , 0},; // 5 Номер точки единичного веса (максимальный соответствует кол-ву информации) { "Inf_Point" , "N", 21 , 7} } // 6 Количество информации в точке * DbName = Ar_Model[mModel] +"-"+; // Имя модели * IF(aCognFun[11],"Y(X)","") +"-"+; // 11. Прямые: Y=F[X] * IF(aCognFun[12],"X(Y)","") +"-"+; // 12. Обратные: X=F[Y] * IF(aCognFun[13],"Pos","") +"-"+; // 13. Позитивные: I[X,Y] > 0 * IF(aCognFun[14],"Neg","") +"-"+; // 14. Негативные: I[X,Y] < 0 * IF(aCognFun[15],"One_point","") +"-"+; // 15. По одной точке с max количеством информации * IF(aCognFun[16],"All_points_Avr","") +"-"+; // 16. Замена всех наблюдений для каждого значения аргумента одним средневзвешенным * IF(aCognFun[17],"All_points_N1","") +"-"+; // 17. Замена наблюдения с количеством информации Iij наблюдениями с единичным весом * ALLTRIM(STR(mClSc)) +"-"+; // Код класс.шкалы * ALLTRIM(STR(mOpSc)) // Код описательной шкалы DbName = Ar_Model[mModel] +"-"+; // Имя модели IF(aCognFun[12],"X(Y)","") +"-"+; // 12. Обратные: X=F[Y] IF(aCognFun[13],"Pos","") +"-"+; // 13. Позитивные: I[X,Y] > 0 IF(aCognFun[15],"One_point","") +"-"+; // 15. По одной точке с max количеством информации ALLTRIM(STR(mClSc)) +"-"+; // Код класс.шкалы ALLTRIM(STR(mOpSc)) // Код описательной шкалы DbCreate( DbName, aStr ) // Создать БД для визуализации КФ USE (DbName) EXCLUSIVE NEW SELECT Opis_Sc DBGOTO(mOpSc) mKodGrOSMin = KodGr_Min mKodGrOSMax = KodGr_Max FOR mGrOpSc = mKodGrOSMin TO mKodGrOSMax // Цикл по градациям описательной шкалы INF# ******* Для каждой градации описательной шкалы найти градацию класс.шкалы с Max информативностью и занести их в БД DbName mInfMax = 0 mKodCl = 0 FOR mGrClSc = mKodGrCSMin TO mKodGrCSMax // Цикл по градациям классификационной шкалы INF# Iij = VAL(LC_FieldGet( Ar_Model[mModel]+".txt", nHandle[mModel], mGrOpSc, 2+mGrClSc )) // Информативность-элемент (i,j) IF Iij > 0 IF mInfMax < Iij mInfMax = Iij mKodCl = mGrClSc // Код класса о котором в признаке макс. кол-во информации ENDIF ENDIF DC_GetProgress(oProgress, ++nTime, nMax) NEXT IF mKodCl > 0 SELECT Gr_OpSc DBGOTO(mGrOpSc) mNameGrOS = Name_GrOS SELECT Attributes DBGOTO(mGrOpSc) // Если шкала числовая - брать Avr_GrInt, а иначе - код градации IF Min_GrInt+Max_GrInt+Avr_GrInt=0 // Шкала текстовая mVolGOS = mGrOpSc ELSE // Шкала числовая mVolGOS = Avr_GrInt ENDIF SELECT Gr_ClSc DBGOTO(mKodCl) mNameGrCS = Name_GrCS SELECT Classes DBGOTO(mKodCl) // Если шкала числовая - брать Avr_GrInt, а иначе - код градации IF Min_GrInt+Max_GrInt+Avr_GrInt=0 // Шкала текстовая mVolGCS = mKodCl ELSE // Шкала числовая mVolGCS = Avr_GrInt ENDIF SELECT(DbName) APPEND BLANK REPLACE NameGrOpSc WITH mNameGrOS REPLACE NameGrClSc WITH mNameGrCS REPLACE GrOpSc_Vol WITH mVolGOS REPLACE GrClSc_Vol WITH mVolGCS ENDIF NEXT CLOSE(DbName) ***** Переписать БД КФ подматрицы в папку: Cogn_fun, а здесь удалить ERASE("Cogn_fun\"+DbName+".dbf") RenameFile( DbName+".dbf", "Cogn_fun\"+DbName+".dbf" ) ERASE(DbName+".dbf") NEXT NEXT ENDIF ************************************************************************************************************************************************************ ** 8 - 12. Обратные: X=F[Y] - 13. Позитивные: количество информации I[X,Y] > 0 - 16. Замена всех наблюдений для каждого значения аргумента одним средневзвешенным ************************************************************************************************************************************************************ IF aCognFun[12] .AND. aCognFun[13] .AND. aCognFun[16] *** Начало цикла по подматрицам ************************************* FOR mClSc = 1 TO N_ClSc // Цикл по классификационным шкалам SELECT Class_Sc DBGOTO(mClSc) mKodGrCSMin = KodGr_Min mKodGrCSMax = KodGr_Max FOR mOpSc = 1 TO N_OpSc // Цикл по описательным шкалам***** **** Создание БД для КФ **************************** aStr := { { "NameGrOpSc", "C", mMaxGrOpSc, 0},; // 1 { "NameGrClSc", "C", mMaxGrClSc, 0},; // 2 { "GrClSc_Vol", "N", 21 , 7},; // 3 Если шкала числовая - брать Avr_GrInt, а иначе - код градации { "GrOpSc_Vol", "N", 21 , 7},; // 3 Если шкала числовая - брать Avr_GrInt, а иначе - код градации { "Num_Point" , "N", 9 , 0},; // 5 Номер точки единичного веса (максимальный соответствует кол-ву информации) { "Inf_Point" , "N", 21 , 7} } // 6 Количество информации в точке * DbName = Ar_Model[mModel] +"-"+; // Имя модели * IF(aCognFun[11],"Y(X)","") +"-"+; // 11. Прямые: Y=F[X] * IF(aCognFun[12],"X(Y)","") +"-"+; // 12. Обратные: X=F[Y] * IF(aCognFun[13],"Pos","") +"-"+; // 13. Позитивные: I[X,Y] > 0 * IF(aCognFun[14],"Neg","") +"-"+; // 14. Негативные: I[X,Y] < 0 * IF(aCognFun[15],"One_point","") +"-"+; // 15. По одной точке с max количеством информации * IF(aCognFun[16],"All_points_Avr","") +"-"+; // 16. Замена всех наблюдений для каждого значения аргумента одним средневзвешенным * IF(aCognFun[17],"All_points_N1","") +"-"+; // 17. Замена наблюдения с количеством информации Iij наблюдениями с единичным весом * ALLTRIM(STR(mClSc)) +"-"+; // Код класс.шкалы * ALLTRIM(STR(mOpSc)) // Код описательной шкалы DbName = Ar_Model[mModel] +"-"+; // Имя модели IF(aCognFun[12],"X(Y)","") +"-"+; // 12. Обратные: X=F[Y] IF(aCognFun[13],"Pos","") +"-"+; // 13. Позитивные: I[X,Y] > 0 IF(aCognFun[16],"All_points_Avr","") +"-"+; // 16. Замена всех наблюдений для каждого значения аргумента одним средневзвешенным ALLTRIM(STR(mClSc)) +"-"+; // Код класс.шкалы ALLTRIM(STR(mOpSc)) // Код описательной шкалы DbCreate( DbName, aStr ) // Создать БД для визуализации КФ USE (DbName) EXCLUSIVE NEW SELECT Opis_Sc DBGOTO(mOpSc) mKodGrOSMin = KodGr_Min mKodGrOSMax = KodGr_Max FOR mGrOpSc = mKodGrOSMin TO mKodGrOSMax // Цикл по градациям описательной шкалы INF# ******* Для каждой градации описательной шкалы найти средневзвешенную градацию класс.шкалы и занести их в БД DbName mSumInfAvr = 0 // Сумма значений * кол-во информации mSumInf = 0 // Сумма кол-во информации SELECT Classes FOR mGrClSc = mKodGrCSMin TO mKodGrCSMax // Цикл по градациям классификационной шкалы INF# Iij = VAL(LC_FieldGet( Ar_Model[mModel]+".txt", nHandle[mModel], mGrOpSc, 2+mGrClSc )) // Информативность-элемент (i,j) IF Iij > 0 DBGOTO(mGrClSc) // Если шкала числовая - брать Avr_GrInt, а иначе - код градации IF Min_GrInt+Max_GrInt+Avr_GrInt=0 // Шкала текстовая mVolGCS = mGrClSc ELSE // Шкала числовая mVolGCS = Avr_GrInt ENDIF mSumInfAvr = mSumInfAvr + Iij * mVolGCS // Сумма значений * кол-во информации ################################# mSumInf = mSumInf + Iij // Сумма кол-во информации ################################# ENDIF DC_GetProgress(oProgress, ++nTime, nMax) NEXT SELECT Gr_OpSc DBGOTO(mGrOpSc) mNameGrOS = Name_GrOS SELECT Attributes DBGOTO(mGrOpSc) // Если шкала числовая - брать Avr_GrInt, а иначе - код градации IF Min_GrInt+Max_GrInt+Avr_GrInt=0 // Шкала текстовая mVolGOS = mGrOpSc ELSE // Шкала числовая mVolGOS = Avr_GrInt ENDIF mAvrGrCS = mSumInfAvr / mSumInf // Средневзвешенная градация класс.шкалы SELECT Classes DBGOTOP() DO WHILE .NOT. EOF() IF Min_GrInt <= mAvrGrCS .AND. mAvrGrCS <= Max_GrInt mKodCl = Kod_ClS EXIT ENDIF DBSKIP(1) ENDDO * MsgBox(STR(mAvrGrCS)) IF mKodCl > 0 SELECT Gr_ClSc DBGOTO(mKodCl) mNameGrCS = Name_GrCS SELECT(DbName) APPEND BLANK REPLACE NameGrOpSc WITH mNameGrOS REPLACE NameGrClSc WITH mNameGrCS REPLACE GrOpSc_Vol WITH mVolGOS REPLACE GrClSc_Vol WITH mAvrGrCS // Средневзвешенная градация класс.шкалы ENDIF NEXT CLOSE(DbName) ***** Переписать БД КФ подматрицы в папку: Cogn_fun, а здесь удалить ERASE("Cogn_fun\"+DbName+".dbf") RenameFile( DbName+".dbf", "Cogn_fun\"+DbName+".dbf" ) ERASE(DbName+".dbf") NEXT NEXT ENDIF ************************************************************************************************************************************************************ ** 9 - 12. Обратные: X=F[Y] - 13. Позитивные: количество информации I[X,Y] > 0 - 17. Замена наблюдения с количеством информации Iij наблюдениями с единичным весом ************************************************************************************************************************************************************ IF aCognFun[12] .AND. aCognFun[13] .AND. aCognFun[17] // ########################## Просто поменять местами столбцы шкал в БД *** Начало цикла по подматрицам ************************************* FOR mClSc = 1 TO N_ClSc // Цикл по классификационным шкалам SELECT Class_Sc DBGOTO(mClSc) mKodGrCSMin = KodGr_Min mKodGrCSMax = KodGr_Max FOR mOpSc = 1 TO N_OpSc // Цикл по описательным шкалам **** **** Создание БД для КФ **************************** aStr := { { "NameGrOpSc", "C", mMaxGrOpSc, 0},; // 1 { "NameGrClSc", "C", mMaxGrClSc, 0},; // 2 { "GrClSc_Vol", "N", 21 , 7},; // 3 Если шкала числовая - брать Avr_GrInt, а иначе - код градации { "GrOpSc_Vol", "N", 21 , 7},; // 4 Если шкала числовая - брать Avr_GrInt, а иначе - код градации { "Num_Point" , "N", 9 , 0},; // 5 Номер точки единичного веса (максимальный соответствует кол-ву информации) { "Inf_Point" , "N", 21 , 7} } // 6 Количество информации в точке * DbName = Ar_Model[mModel] +"-"+; // Имя модели * IF(aCognFun[11],"Y(X)","") +"-"+; // 11. Прямые: Y=F[X] * IF(aCognFun[12],"X(Y)","") +"-"+; // 12. Обратные: X=F[Y] * IF(aCognFun[13],"Pos","") +"-"+; // 13. Позитивные: I[X,Y] > 0 * IF(aCognFun[14],"Neg","") +"-"+; // 14. Негативные: I[X,Y] < 0 * IF(aCognFun[15],"One_point","") +"-"+; // 15. По одной точке с max количеством информации * IF(aCognFun[16],"All_points_Avr","") +"-"+; // 16. Замена всех наблюдений для каждого значения аргумента одним средневзвешенным * IF(aCognFun[17],"All_points_N1","") +"-"+; // 17. Замена наблюдения с количеством информации Iij наблюдениями с единичным весом * ALLTRIM(STR(mClSc)) +"-"+; // Код класс.шкалы * ALLTRIM(STR(mOpSc)) // Код описательной шкалы DbName = Ar_Model[mModel] +"-"+; // Имя модели IF(aCognFun[12],"X(Y)","") +"-"+; // 12. Обратные: X=F[Y] IF(aCognFun[13],"Pos","") +"-"+; // 13. Позитивные: I[X,Y] > 0 IF(aCognFun[17],"All_points_N1","") +"-"+; // 17. Замена наблюдения с количеством информации Iij наблюдениями с единичным весом ALLTRIM(STR(mClSc)) +"-"+; // Код класс.шкалы ALLTRIM(STR(mOpSc)) // Код описательной шкалы DbCreate( DbName, aStr ) // Создать БД для визуализации КФ USE (DbName) EXCLUSIVE NEW SELECT Opis_Sc DBGOTO(mOpSc) mKodGrOSMin = KodGr_Min mKodGrOSMax = KodGr_Max *** Найти максимальную и минимальную информативность в подматрице БД INF# и использовать ее *** для расчета весового коэффициента и определения количества точек с единичным весом в единице информации для Iij > 0 *** Заодно определить диапазоны изменения градаций классификационных и описательных шкал и градаций для подматрицы функции mIijMin = +99999999999 mIijMax = -99999999999 mVolGOSmin = +99999999999 mVolGOSmax = -99999999999 mVolGCSmin = +99999999999 mVolGCSmax = -99999999999 FOR mGrOpSc = mKodGrOSMin TO mKodGrOSMax // Цикл по градациям описательной шкалы INF# FOR mGrClSc = mKodGrCSMin TO mKodGrCSMax // Цикл по градациям классификационной шкалы INF# Iij = VAL(LC_FieldGet( Ar_Model[mModel]+".txt", nHandle[mModel], mGrOpSc, 2+mGrClSc )) // Информативность-элемент (i,j) IF Iij > 0 mIijMin = MIN(mIijMin, Iij) mIijMax = MAX(mIijMax, Iij) SELECT Attributes DBGOTO(mGrOpSc) // Если шкала числовая - брать Avr_GrInt, а иначе - код градации IF Min_GrInt+Max_GrInt+Avr_GrInt=0 // Шкала текстовая mVolGOSmin = MIN(mVolGOSmin, mGrOpSc) mVolGOSmax = MAX(mVolGOSmax, mGrOpSc) ELSE // Шкала числовая mVolGOSmin = MIN(mVolGOSmin, Avr_GrInt) mVolGOSmax = MAX(mVolGOSmax, Avr_GrInt) ENDIF SELECT Classes DBGOTO(mGrClSc) // Если шкала числовая - брать Avr_GrInt, а иначе - код градации IF Min_GrInt+Max_GrInt+Avr_GrInt=0 // Шкала текстовая mVolGCSmin = MIN(mVolGCSmin, mGrClSc) mVolGCSmax = MAX(mVolGCSmax, mGrClSc) ELSE // Шкала числовая mVolGCSmin = MIN(mVolGCSmin, Avr_GrInt) mVolGCSmax = MAX(mVolGCSmax, Avr_GrInt) ENDIF ENDIF DC_GetProgress(oProgress, ++nTime, nMax) NEXT NEXT ******* Для каждой градации описательной шкалы найти все градации класс.шкалы и для каждой из них ******* занести в БД DbName количество точек единичного веса, соответствующее количеству информации в X об Y FOR mGrOpSc = mKodGrOSMin TO mKodGrOSMax // Цикл по градациям описательной шкалы INF# FOR mGrClSc = mKodGrCSMin TO mKodGrCSMax // Цикл по градациям классификационной шкалы INF# Iij = VAL(LC_FieldGet( Ar_Model[mModel]+".txt", nHandle[mModel], mGrOpSc, 2+mGrClSc )) // Информативность-элемент (i,j) IF Iij > 0 SELECT Gr_OpSc DBGOTO(mGrOpSc) mNameGrOS = Name_GrOS SELECT Attributes DBGOTO(mGrOpSc) // Если шкала числовая - брать Avr_GrInt, а иначе - код градации IF Min_GrInt+Max_GrInt+Avr_GrInt=0 // Шкала текстовая mVolGOS = mGrOpSc ELSE // Шкала числовая mVolGOS = Avr_GrInt ENDIF SELECT Gr_ClSc DBGOTO(mGrClSc) mNameGrCS = Name_GrCS SELECT Classes DBGOTO(mGrClSc) // Если шкала числовая - брать Avr_GrInt, а иначе - код градации IF Min_GrInt+Max_GrInt+Avr_GrInt=0 // Шкала текстовая mVolGCS = mKodCl ELSE // Шкала числовая mVolGCS = Avr_GrInt ENDIF N_Point = ROUND(Iij/(mIijMax/aCognFun[18]),0) // Количество точек, соответствующее количеству информации Df = 360/N_Point // Угол в градусах между соседними точками рассеяния SELECT(DbName) FOR mPoint = 1 TO N_Point Rx = RAND() * (mVolGOSmax-mVolGOSmin) * aCognFun[19]/100 // Радиус по оси X Ry = RAND() * (mVolGCSmax-mVolGCSmin) * aCognFun[19]/100 // Радиус по оси Y APPEND BLANK REPLACE NameGrOpSc WITH mNameGrOS REPLACE NameGrClSc WITH mNameGrCS REPLACE GrOpSc_Vol WITH mVolGOS + Rx * COS(Df*mPoint*3.141592653/180) // Рассеяние по эллипсу REPLACE GrClSc_Vol WITH mVolGCS + Ry * SIN(Df*mPoint*3.141592653/180) // Рассеяние по эллипсу REPLACE Num_Point WITH mPoint REPLACE Inf_Point WITH Iij NEXT ENDIF DC_GetProgress(oProgress, ++nTime, nMax) NEXT NEXT CLOSE(DbName) ***** Переписать БД КФ подматрицы в папку: Cogn_fun, а здесь удалить ERASE("Cogn_fun\"+DbName+".dbf") RenameFile( DbName+".dbf", "Cogn_fun\"+DbName+".dbf" ) ERASE(DbName+".dbf") NEXT NEXT ENDIF ************************************************************************************************************************************************************ ** 10 - 12. Обратные: X=F[Y] - 14. Негативные: количество информации I[X,Y] < 0 - 15. Построение ТОЛЬКО по точкам (X,Y) с максимальным количеством информации ************************************************************************************************************************************************************ IF aCognFun[12] .AND. aCognFun[14] .AND. aCognFun[15] // ########################## Просто поменять местами столбцы шкал в БД *** Начало цикла по подматрицам *************************************** FOR mClSc = 1 TO N_ClSc // Цикл по классификационным шкалам SELECT Class_Sc DBGOTO(mClSc) mKodGrCSMin = KodGr_Min mKodGrCSMax = KodGr_Max FOR mOpSc = 1 TO N_OpSc // Цикл по описательным шкалам***** **** Создание БД для КФ **************************** aStr := { { "NameGrOpSc", "C", mMaxGrOpSc, 0},; // 1 { "NameGrClSc", "C", mMaxGrClSc, 0},; // 2 { "GrClSc_Vol", "N", 21 , 7},; // 3 Если шкала числовая - брать Avr_GrInt, а иначе - код градации { "GrOpSc_Vol", "N", 21 , 7},; // 4 Если шкала числовая - брать Avr_GrInt, а иначе - код градации { "Num_Point" , "N", 9 , 0},; // 5 Номер точки единичного веса (максимальный соответствует кол-ву информации) { "Inf_Point" , "N", 21 , 7} } // 6 Количество информации в точке * DbName = Ar_Model[mModel] +"-"+; // Имя модели * IF(aCognFun[11],"Y(X)","") +"-"+; // 11. Прямые: Y=F[X] * IF(aCognFun[12],"X(Y)","") +"-"+; // 12. Обратные: X=F[Y] * IF(aCognFun[13],"Pos","") +"-"+; // 13. Позитивные: I[X,Y] > 0 * IF(aCognFun[14],"Neg","") +"-"+; // 14. Негативные: I[X,Y] < 0 * IF(aCognFun[15],"One_point","") +"-"+; // 15. По одной точке с max количеством информации * IF(aCognFun[16],"All_points_Avr","") +"-"+; // 16. Замена всех наблюдений для каждого значения аргумента одним средневзвешенным * IF(aCognFun[17],"All_points_N1","") +"-"+; // 17. Замена наблюдения с количеством информации Iij наблюдениями с единичным весом * ALLTRIM(STR(mClSc)) +"-"+; // Код класс.шкалы * ALLTRIM(STR(mOpSc)) // Код описательной шкалы DbName = Ar_Model[mModel] +"-"+; // Имя модели IF(aCognFun[12],"X(Y)","") +"-"+; // 12. Обратные: X=F[Y] IF(aCognFun[14],"Neg","") +"-"+; // 14. Негативные: I[X,Y] < 0 IF(aCognFun[15],"One_point","") +"-"+; // 15. По одной точке с max количеством информации ALLTRIM(STR(mClSc)) +"-"+; // Код класс.шкалы ALLTRIM(STR(mOpSc)) // Код описательной шкалы DbCreate( DbName, aStr ) // БД для КФ USE (DbName) EXCLUSIVE NEW SELECT Opis_Sc DBGOTO(mOpSc) mKodGrOSMin = KodGr_Min mKodGrOSMax = KodGr_Max FOR mGrOpSc = mKodGrOSMin TO mKodGrOSMax // Цикл по градациям описательной шкалы INF# ******* Для каждой градации описательной шкалы найти градацию класс.шкалы с Min информативностью и занести их в БД DbName mInfMin = 0 mKodCl = 0 FOR mGrClSc = mKodGrCSMin TO mKodGrCSMax // Цикл по градациям классификационной шкалы INF# Iij = VAL(LC_FieldGet( Ar_Model[mModel]+".txt", nHandle[mModel], mGrOpSc, 2+mGrClSc )) // Информативность-элемент (i,j) IF Iij < 0 IF mInfMin > Iij mInfMin = Iij mKodCl = mGrClSc // Код класса о котором в признаке мин. кол-во информации ENDIF ENDIF DC_GetProgress(oProgress, ++nTime, nMax) NEXT IF mKodCl > 0 SELECT Gr_OpSc DBGOTO(mGrOpSc) mNameGrOS = Name_GrOS SELECT Attributes DBGOTO(mGrOpSc) // Если шкала числовая - брать Avr_GrInt, а иначе - код градации IF Min_GrInt+Max_GrInt+Avr_GrInt=0 // Шкала текстовая mVolGOS = mGrOpSc ELSE // Шкала числовая mVolGOS = Avr_GrInt ENDIF SELECT Gr_ClSc DBGOTO(mGrClSc) mNameGrCS = Name_GrCS SELECT Classes DBGOTO(mGrClSc) // Если шкала числовая - брать Avr_GrInt, а иначе - код градации IF Min_GrInt+Max_GrInt+Avr_GrInt=0 // Шкала текстовая mVolGCS = mKodCl ELSE // Шкала числовая mVolGCS = Avr_GrInt ENDIF SELECT(DbName) APPEND BLANK REPLACE NameGrOpSc WITH mNameGrOS REPLACE NameGrClSc WITH mNameGrCS REPLACE GrOpSc_Vol WITH mVolGOS REPLACE GrClSc_Vol WITH mVolGCS ENDIF NEXT CLOSE(DbName) ***** Переписать БД КФ подматрицы в папку: Cogn_fun, а здесь удалить ERASE("Cogn_fun\"+DbName+".dbf") RenameFile( DbName+".dbf", "Cogn_fun\"+DbName+".dbf" ) ERASE(DbName+".dbf") NEXT NEXT ENDIF ************************************************************************************************************************************************************ ** 11 - 12. Обратные: X=F[Y] - 14. Негативные: количество информации I[X,Y] < 0 - 16. Замена всех наблюдений для каждого значения аргумента одним средневзвешенным ************************************************************************************************************************************************************ IF aCognFun[12] .AND. aCognFun[14] .AND. aCognFun[16] *** Начало цикла по подматрицам ************************************* FOR mClSc = 1 TO N_ClSc // Цикл по классификационным шкалам SELECT Class_Sc DBGOTO(mClSc) mKodGrCSMin = KodGr_Min mKodGrCSMax = KodGr_Max FOR mOpSc = 1 TO N_OpSc // Цикл по описательным шкалам***** **** Создание БД для КФ **************************** aStr := { { "NameGrOpSc", "C", mMaxGrOpSc, 0},; // 1 { "NameGrClSc", "C", mMaxGrClSc, 0},; // 2 { "GrClSc_Vol", "N", 21 , 7},; // 4 Если шкала числовая - брать Avr_GrInt, а иначе - код градации { "GrOpSc_Vol", "N", 21 , 7},; // 3 Если шкала числовая - брать Avr_GrInt, а иначе - код градации { "Num_Point" , "N", 9 , 0},; // 5 Номер точки единичного веса (максимальный соответствует кол-ву информации) { "Inf_Point" , "N", 21 , 7} } // 6 Количество информации в точке * DbName = Ar_Model[mModel] +"-"+; // Имя модели * IF(aCognFun[11],"Y(X)","") +"-"+; // 11. Прямые: Y=F[X] * IF(aCognFun[12],"X(Y)","") +"-"+; // 12. Обратные: X=F[Y] * IF(aCognFun[13],"Pos","") +"-"+; // 13. Позитивные: I[X,Y] > 0 * IF(aCognFun[14],"Neg","") +"-"+; // 14. Негативные: I[X,Y] < 0 * IF(aCognFun[15],"One_point","") +"-"+; // 15. По одной точке с max количеством информации * IF(aCognFun[16],"All_points_Avr","") +"-"+; // 16. Замена всех наблюдений для каждого значения аргумента одним средневзвешенным * IF(aCognFun[17],"All_points_N1","") +"-"+; // 17. Замена наблюдения с количеством информации Iij наблюдениями с единичным весом * ALLTRIM(STR(mClSc)) +"-"+; // Код класс.шкалы * ALLTRIM(STR(mOpSc)) // Код описательной шкалы DbName = Ar_Model[mModel] +"-"+; // Имя модели IF(aCognFun[12],"X(Y)","") +"-"+; // 12. Обратные: X=F[Y] IF(aCognFun[14],"Neg","") +"-"+; // 14. Негативные: I[X,Y] < 0 IF(aCognFun[16],"All_points_Avr","") +"-"+; // 16. Замена всех наблюдений для каждого значения аргумента одним средневзвешенным ALLTRIM(STR(mClSc)) +"-"+; // Код класс.шкалы ALLTRIM(STR(mOpSc)) // Код описательной шкалы DbCreate( DbName, aStr ) // Создать БД для визуализации КФ USE (DbName) EXCLUSIVE NEW SELECT Opis_Sc DBGOTO(mOpSc) mKodGrOSMin = KodGr_Min mKodGrOSMax = KodGr_Max FOR mGrOpSc = mKodGrOSMin TO mKodGrOSMax // Цикл по градациям описательной шкалы INF# ******* Для каждой градации описательной шкалы найти средневзвешенную градацию класс.шкалы и занести их в БД DbName mSumInfAvr = 0 // Сумма значений * кол-во информации mSumInf = 0 // Сумма кол-во информации SELECT Classes FOR mGrClSc = mKodGrCSMin TO mKodGrCSMax // Цикл по градациям классификационной шкалы INF# Iij = VAL(LC_FieldGet( Ar_Model[mModel]+".txt", nHandle[mModel], mGrOpSc, 2+mGrClSc )) // Информативность-элемент (i,j) IF Iij < 0 DBGOTO(mGrClSc) // Если шкала числовая - брать Avr_GrInt, а иначе - код градации IF Min_GrInt+Max_GrInt+Avr_GrInt=0 // Шкала текстовая mVolGCS = mGrClSc ELSE // Шкала числовая mVolGCS = Avr_GrInt ENDIF mSumInfAvr = mSumInfAvr + Iij * mVolGCS // Сумма значений * кол-во информации ################################# mSumInf = mSumInf + Iij // Сумма кол-во информации ################################# ENDIF DC_GetProgress(oProgress, ++nTime, nMax) NEXT SELECT Gr_OpSc DBGOTO(mGrOpSc) mNameGrOS = Name_GrOS SELECT Attributes DBGOTO(mGrOpSc) // Если шкала числовая - брать Avr_GrInt, а иначе - код градации IF Min_GrInt+Max_GrInt+Avr_GrInt=0 // Шкала текстовая mVolGOS = mGrOpSc ELSE // Шкала числовая mVolGOS = Avr_GrInt ENDIF mAvrGrCS = mSumInfAvr / mSumInf // Средневзвешенная градация класс.шкалы SELECT Classes DBGOTOP() DO WHILE .NOT. EOF() IF Min_GrInt <= mAvrGrCS .AND. mAvrGrCS <= Max_GrInt mKodCl = Kod_ClS EXIT ENDIF DBSKIP(1) ENDDO * MsgBox(STR(mAvrGrCS)) IF mKodCl > 0 SELECT Gr_ClSc DBGOTO(mKodCl) mNameGrCS = Name_GrCS SELECT(DbName) APPEND BLANK REPLACE NameGrOpSc WITH mNameGrOS REPLACE NameGrClSc WITH mNameGrCS REPLACE GrOpSc_Vol WITH mVolGOS REPLACE GrClSc_Vol WITH mAvrGrCS // Средневзвешенная градация класс.шкалы ENDIF NEXT CLOSE(DbName) ***** Переписать БД КФ подматрицы в папку: Cogn_fun, а здесь удалить ERASE("Cogn_fun\"+DbName+".dbf") RenameFile( DbName+".dbf", "Cogn_fun\"+DbName+".dbf" ) ERASE(DbName+".dbf") NEXT NEXT ENDIF ************************************************************************************************************************************************************ ** 12 - 12. Обратные: X=F[Y] - 14. Негативные: количество информации I[X,Y] < 0 - 17. Замена наблюдения с количеством информации Iij наблюдениями с единичным весом ************************************************************************************************************************************************************ IF aCognFun[12] .AND. aCognFun[14] .AND. aCognFun[17] // ########################## Просто поменять местами столбцы шкал в БД *** Начало цикла по подматрицам ************************************* FOR mClSc = 1 TO N_ClSc // Цикл по классификационным шкалам SELECT Class_Sc DBGOTO(mClSc) mKodGrCSMin = KodGr_Min mKodGrCSMax = KodGr_Max FOR mOpSc = 1 TO N_OpSc // Цикл по описательным шкалам **** **** Создание БД для КФ **************************** aStr := { { "NameGrOpSc", "C", mMaxGrOpSc, 0},; // 1 { "NameGrClSc", "C", mMaxGrClSc, 0},; // 2 { "GrClSc_Vol", "N", 21 , 7},; // 3 Если шкала числовая - брать Avr_GrInt, а иначе - код градации { "GrOpSc_Vol", "N", 21 , 7},; // 4 Если шкала числовая - брать Avr_GrInt, а иначе - код градации { "Num_Point" , "N", 9 , 0},; // 5 Номер точки единичного веса (максимальный соответствует кол-ву информации) { "Inf_Point" , "N", 21 , 7} } // 6 Количество информации в точке * DbName = Ar_Model[mModel] +"-"+; // Имя модели * IF(aCognFun[11],"Y(X)","") +"-"+; // 11. Прямые: Y=F[X] * IF(aCognFun[12],"X(Y)","") +"-"+; // 12. Обратные: X=F[Y] * IF(aCognFun[13],"Pos","") +"-"+; // 13. Позитивные: I[X,Y] > 0 * IF(aCognFun[14],"Neg","") +"-"+; // 14. Негативные: I[X,Y] < 0 * IF(aCognFun[15],"One_point","") +"-"+; // 15. По одной точке с max количеством информации * IF(aCognFun[16],"All_points_Avr","") +"-"+; // 16. Замена всех наблюдений для каждого значения аргумента одним средневзвешенным * IF(aCognFun[17],"All_points_N1","") +"-"+; // 17. Замена наблюдения с количеством информации Iij наблюдениями с единичным весом * ALLTRIM(STR(mClSc)) +"-"+; // Код класс.шкалы * ALLTRIM(STR(mOpSc)) // Код описательной шкалы DbName = Ar_Model[mModel] +"-"+; // Имя модели IF(aCognFun[12],"X(Y)","") +"-"+; // 12. Обратные: X=F[Y] IF(aCognFun[14],"Neg","") +"-"+; // 14. Негативные: I[X,Y] < 0 IF(aCognFun[17],"All_points_N1","") +"-"+; // 17. Замена наблюдения с количеством информации Iij наблюдениями с единичным весом ALLTRIM(STR(mClSc)) +"-"+; // Код класс.шкалы ALLTRIM(STR(mOpSc)) // Код описательной шкалы DbCreate( DbName, aStr ) // Создать БД для визуализации КФ USE (DbName) EXCLUSIVE NEW SELECT Opis_Sc DBGOTO(mOpSc) mKodGrOSMin = KodGr_Min mKodGrOSMax = KodGr_Max *** Найти максимальную и минимальную информативность в подматрице БД INF# и использовать ее *** для расчета весового коэффициента и определения количества точек с единичным весом в единице информации для Iij > 0 *** Заодно определить диапазоны изменения градаций классификационных и описательных шкал и градаций для подматрицы функции mIijMin = +99999999999 mIijMax = -99999999999 mVolGOSmin = +99999999999 mVolGOSmax = -99999999999 mVolGCSmin = +99999999999 mVolGCSmax = -99999999999 FOR mGrOpSc = mKodGrOSMin TO mKodGrOSMax // Цикл по градациям описательной шкалы INF# FOR mGrClSc = mKodGrCSMin TO mKodGrCSMax // Цикл по градациям классификационной шкалы INF# Iij = VAL(LC_FieldGet( Ar_Model[mModel]+".txt", nHandle[mModel], mGrOpSc, 2+mGrClSc )) // Информативность-элемент (i,j) IF Iij < 0 mIijMin = MIN(mIijMin, Iij) mIijMax = MAX(mIijMax, Iij) SELECT Attributes DBGOTO(mGrOpSc) // Если шкала числовая - брать Avr_GrInt, а иначе - код градации IF Min_GrInt+Max_GrInt+Avr_GrInt=0 // Шкала текстовая mVolGOSmin = MIN(mVolGOSmin, mGrOpSc) mVolGOSmax = MAX(mVolGOSmax, mGrOpSc) ELSE // Шкала числовая mVolGOSmin = MIN(mVolGOSmin, Avr_GrInt) mVolGOSmax = MAX(mVolGOSmax, Avr_GrInt) ENDIF SELECT Classes DBGOTO(mGrClSc) // Если шкала числовая - брать Avr_GrInt, а иначе - код градации IF Min_GrInt+Max_GrInt+Avr_GrInt=0 // Шкала текстовая mVolGCSmin = MIN(mVolGCSmin, mGrClSc) mVolGCSmax = MAX(mVolGCSmax, mGrClSc) ELSE // Шкала числовая mVolGCSmin = MIN(mVolGCSmin, Avr_GrInt) mVolGCSmax = MAX(mVolGCSmax, Avr_GrInt) ENDIF ENDIF DC_GetProgress(oProgress, ++nTime, nMax) NEXT NEXT ******* Для каждой градации описательной шкалы найти все градации класс.шкалы и для каждой из них ******* занести в БД DbName количество точек единичного веса, соответствующее количеству информации в X об Y FOR mGrOpSc = mKodGrOSMin TO mKodGrOSMax // Цикл по градациям описательной шкалы INF# FOR mGrClSc = mKodGrCSMin TO mKodGrCSMax // Цикл по градациям классификационной шкалы INF# Iij = VAL(LC_FieldGet( Ar_Model[mModel]+".txt", nHandle[mModel], mGrOpSc, 2+mGrClSc )) // Информативность-элемент (i,j) IF Iij < 0 SELECT Gr_OpSc DBGOTO(mGrOpSc) mNameGrOS = Name_GrOS SELECT Attributes DBGOTO(mGrOpSc) // Если шкала числовая - брать Avr_GrInt, а иначе - код градации IF Min_GrInt+Max_GrInt+Avr_GrInt=0 // Шкала текстовая mVolGOS = mGrOpSc ELSE // Шкала числовая mVolGOS = Avr_GrInt ENDIF SELECT Gr_ClSc DBGOTO(mGrClSc) mNameGrCS = Name_GrCS SELECT Classes DBGOTO(mGrClSc) // Если шкала числовая - брать Avr_GrInt, а иначе - код градации IF Min_GrInt+Max_GrInt+Avr_GrInt=0 // Шкала текстовая mVolGCS = mKodCl ELSE // Шкала числовая mVolGCS = Avr_GrInt ENDIF N_Point = ROUND(Iij/(mIijMin/aCognFun[18]),0) // Количество точек, соответствующее количеству информации Df = 360/N_Point // Угол в градусах между соседними точками рассеяния SELECT(DbName) FOR mPoint = 1 TO N_Point Rx = RAND() * (mVolGOSmax-mVolGOSmin) * aCognFun[19]/100 // Радиус по оси X Ry = RAND() * (mVolGCSmax-mVolGCSmin) * aCognFun[19]/100 // Радиус по оси Y APPEND BLANK REPLACE NameGrOpSc WITH mNameGrOS REPLACE NameGrClSc WITH mNameGrCS REPLACE GrOpSc_Vol WITH mVolGOS + Rx * COS(Df*mPoint*3.141592653/180) // Рассеяние по эллипсу REPLACE GrClSc_Vol WITH mVolGCS + Ry * SIN(Df*mPoint*3.141592653/180) // Рассеяние по эллипсу REPLACE Num_Point WITH mPoint REPLACE Inf_Point WITH Iij NEXT ENDIF DC_GetProgress(oProgress, ++nTime, nMax) NEXT NEXT CLOSE(DbName) ***** Переписать БД КФ подматрицы в папку: Cogn_fun, а здесь удалить ERASE("Cogn_fun\"+DbName+".dbf") RenameFile( DbName+".dbf", "Cogn_fun\"+DbName+".dbf" ) ERASE(DbName+".dbf") NEXT NEXT ENDIF ENDIF NEXT * MsgBox('STOP') DC_GetProgress(oProgress,nMax,nMax) oDialog:Destroy() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций FOR z=1 TO LEN(Ar_Model) IF aCognFun[z] FClose( nHandle[z] ) // Закрытие текстовой базы данных, если она открывалась ENDIF NEXT ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** N_dbf = ADIR(M_PathAppl+"\Cogn_fun\"+"*.dbf") aMess := {} AADD(aMess, L('Формирование БД для визуализации когнитивных функций завершено успешно !')) AADD(aMess, L(' ')) AADD(aMess, L('Всего по заданию в режиме создано '+ALLTRIM(STR(N_dbf))+' баз данных!')) AADD(aMess, L(' ')) AADD(aMess, L('Все эти базы данных имеют расширение ".dbf" и открываются в MS Excel!')) AADD(aMess, L(' ')) AADD(aMess, L('Принцип формирования имен созданных баз данных описан в "Help" режима !')) AADD(aMess, L(' ')) AADD(aMess, L("Созданные БД находятся в папке: ")+ALLTRIM(M_PathAppl)+"\Cogn_fun\"+".") LB_Warning(aMess, L('4.6. Подготовка баз данных для визуализация когнитивных функций в MS Excel')) Running(.F.) RETURN NIL ******************************************************************************************** ******** Выбор режима оцифровки изображений: ******** - по всем пикселям; ******** - по внешним контурам; ******** - по внешним и внутренним контурам. ******************************************************************************************** ******** 2.3.2.15. Вставка промежуточных строк в файл исходных данных Inp_data' ******** Вставка промежуточных строк в файл исходных данных с интерполяцией значений соседних строк в числовых шкалах ******** и объединением (через разделитель) значений в текстовых щкалах') FUNCTION F2_3_2_15() LOCAL Getlist := {}, oProgress, oDialog, lCancelled := .F., lStatus := .T. LOCAL aSay[30], Mess97, Mess98, Mess99, lOk // Массив сообщений отображаемых стадий исполнения (до 30 на экране) Running(.T.) * oScr := DC_WaitOn(L('Вставка промежуточных строк в файл исходных данных "Inp_data.dbf"'),,,,,,,,,,,.F.) DIRCHANGE(Disk_dir+"\AID_DATA\Inp_data\") // Перейти в папку Inp_data IF .NOT. FILE("Inp_data.dbf") LB_Warning(L('В папке:')+' '+Disk_dir+"\AID_DATA\Inp_data\"+' '+L('нет файла: "Inp_data.dbf"')) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Inp_data EXCLUSIVE NEW * COPY STRUCTURE TO InpDataNew.dbf ********** Создать БД InpDataNew, по структуре, такую же как Inp_data, но с увеличенной длиной полей aStructure := DbStruct() // read file structure * DC_DebugQout( aStructure ) FOR j=1 TO LEN(aStructure) DO CASE CASE aStructure[j,2] = "C" aStructure[j,3] = 255 CASE aStructure[j,2] = "N" aStructure[j,3] = 19 aStructure[j,4] = 7 ENDCASE NEXT DbCreate( "InpDataNew.dbf", aStructure ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Inp_data EXCLUSIVE NEW N_Rec = RECCOUNT() N_Col = FCOUNT() USE InpDataNew EXCLUSIVE NEW ********************************************************************************* Wsego = N_Rec mTitleName = L('2.3.2.15. Вставка промежуточных строк в файл исходных данных Inp_data') // Отображение стадии исполнения. Будет написано прямо в окне Progress-bar d = 0 @0,0 DCGROUP oGroup1 CAPTION L('Стадии исполнения процесса') FONT "6.Helv" SIZE 105+d, 2.5 PARENT oTabPage1 @4,0 DCGROUP oGroup2 CAPTION L('Прогноз времени исполнения') FONT "6.Helv" SIZE 105+d, 5.0 PARENT oTabPage2 s = 1 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 1] FONT "10.Helv" s++ @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay97 FONT "10.HelvBold" s++ @0.2+s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay98 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @1.5+s ,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay99 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @s ,1 DCPROGRESS oProgress ; SIZE 95,1.5 ; PERCENT ; EVERY 1+INT(Wsego/nEvery) ; // Кол-во обновлений изображения MAXCOUNT Wsego ; COLOR GRA_CLR_CYAN // Цвет полосы @s++,97 DCPUSHBUTTON CAPTION L('&Cancel') ; ACTION {||lOk:=.T.} OBJECT oButton ; SIZE 7,1.5 DCREAD GUI ; TITLE mTitleName ; PARENT @oDialog ; FIT ; EXIT ; MODAL oDialog:alwaysOnTop = .T. // Окно открывается на переднем плане oDialog:show() // Начало отсчета времени для прогнозирования длительности исполнения Time_progress = 0 // Прошло секунд с начала процесса // Процесс может идти больше суток, поэтому для определения // во всех случаях вычисляется время, прошедшее с начала года T_Mess1 = L("Начало:")+" "+TIME() // Начало Sec_1 = (DOY(DATE())-1)*86400+SECONDS() PUBLIC T1 := (DOY(DATE())-1)*86400+SECONDS() // Время предыдущей индикации процесса исполнения PUBLIC T2 := (DOY(DATE())-1)*86400+SECONDS()+1 // Текущее время (1-й раз оно заметно больше T1 чтобы было отображение) PUBLIC T1tp := T1 PUBLIC T2tp := T2 ********************************************************************************* aSay[ 1]:SetCaption(L('2.3.2.15. Вставка промежуточных строк в файл исходных данных "Inp_data.dbf"')) SELECT Inp_data DBGOTOP() aRec1 := {} FOR j=1 TO N_Col DO CASE CASE FIELDTYPE(j) = 'N' AADD(aRec1, FIELDGET(j)) CASE FIELDTYPE(j) = 'C' AADD(aRec1, STRTRAN(ALLTRIM(FIELDGET(j)),' ','_')) ENDCASE NEXT lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) DBSKIP(1) mFlag = .T. DO WHILE .NOT. EOF() aRec2 := {} FOR j=1 TO N_Col DO CASE CASE FIELDTYPE(j) = 'N' AADD(aRec2, FIELDGET(j)) CASE FIELDTYPE(j) = 'C' AADD(aRec2, STRTRAN(ALLTRIM(FIELDGET(j)),' ','_')) ENDCASE NEXT SELECT InpDataNew IF mFlag APPEND BLANK // 1-я исходная строка FOR j=1 TO N_Col FIELDPUT(j, aRec1[j]) NEXT mFlag = .F. ENDIF APPEND BLANK // Вставляемая строка: для числовых полей = среднее 1-й и 2-й строки, для текстовых полей = объединение 1-й и 2-й строки через разделитель FOR j=1 TO N_Col DO CASE CASE FIELDTYPE(j) = 'N' FIELDPUT(j, (aRec1[j]+aRec2[j])/2) CASE FIELDTYPE(j) = 'C' FIELDPUT(j, aRec1[j]+','+aRec2[j]) ENDCASE NEXT APPEND BLANK // 2-я исходная строка FOR j=1 TO N_Col FIELDPUT(j, aRec2[j]) NEXT aRec1 = aRec2 lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) SELECT Inp_data DBSKIP(1) ENDDO CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций COPY FILE ("Inp_data.dbf") TO ("InpDataOld.dbf") COPY FILE ("InpDataNew.dbf") TO ("Inp_data.dbf") DIRCHANGE(Disk_dir) // Перейти в папку с системой IF .NOT. FILE("_2_3_2_2.arx") LB_Warning(L('Необходимо выполнить режим: 2.3.2.2.')) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ELSE aSoftInt = DC_ARestore("_2_3_2_2.arx") // Если параметры были заданы ранее, то использовать их Regim = aSoftInt[ 1] // Формализация предметной области (1) или ввод распознаваемой выборки (2) Flag_zer = aSoftInt[ 2] M_ClSc1 = aSoftInt[ 3] M_ClSc2 = aSoftInt[ 4] M_OpSc1 = aSoftInt[ 5] M_OpSc2 = aSoftInt[ 6] N_SKGrCl = aSoftInt[ 7] N_SKGrPr = aSoftInt[ 8] K_N_ClSc = aSoftInt[ 9] K_N_OpSc = aSoftInt[10] K_N_GrClSc = aSoftInt[11] K_N_GrOpSc = aSoftInt[12] M_ObAnk = aSoftInt[13] N_Chast = aSoftInt[14] M_Interval = aSoftInt[15] M_Scenario = aSoftInt[16] K_GradNClSc = aSoftInt[17] // Количество градаций в числовой классификационной шкале K_GradNOpSc = aSoftInt[18] // Количество градаций в числовой описательной шкале mGorizMin = aSoftInt[19] mGorizMax = aSoftInt[20] mGlubMin = aSoftInt[21] mGlubMax = aSoftInt[22] M_ChastObi = aSoftInt[23] M_ChastRso = aSoftInt[24] N_ChastObi = aSoftInt[25] N_ChastRso = aSoftInt[26] M_XlsDbf = 3 // 1-xls, 2-xlsx, 3-dbf mTxtCSField = 3 // Способ интерпретации значений текстовых полей - классификационных шкал файла исходных данных: 1-целиком, 2-символы, 3-слова mTxtOSField = 3 // Способ интерпретации значений текстовых полей - описательных шкал файла исходных данных 1-целиком, 2-символы, 3-слова mTxtCSSep = ',' mTxtOSSep = ',' * mScenario = aSoftInt[32] // mScenario=1 Не применять сценарный метод АСК-анализа и спец.интерпретацию TXT-полей (старый вариант) mScenario = aSoftInt[32] // mScenario=1 Не применять сценарный метод АСК-анализа mSpecInterprCls = .T. // .T. - Применить спец.интерпретацию текстовых полей классов, .F. - не применять mSpecInterprAtr = .T. // .T. - Применить спец.интерпретацию текстовых полей признаков, .F. - не применять mNameGrNumSc= aSoftInt[35] // Какие наименования ГРАДАЦИЙ числовых шкал использовать mClsAvr = .F. // .F. - делать модель из Inp_data, .T. - делать модель из Inp_data_avr mSortUnqCls = aSoftInt[37] // Выделять уникальные значения классов и сортировать, 1-да, 2-нет mLemmatCls = 2 // Проводить лемматизацию классов, 1-да, 2-нет mSortUnqGos = aSoftInt[39] // Выделять уникальные значения признаков и сортировать, 1-да, 2-нет mLemmatGos = IF(mSpecInterprAtr,aSoftInt[40],2) // Проводить лемматизацию классов, 1-да, 2-нет // Сохранить файл с информацией о заданых параметрах программного интерфейса в текущей директории системы PRIVATE aSoftInt[40] aSoftInt[ 1] = 1 aSoftInt[ 2] = Flag_zer aSoftInt[ 3] = M_ClSc1 aSoftInt[ 4] = M_ClSc2 aSoftInt[ 5] = M_OpSc1 aSoftInt[ 6] = M_OpSc2 aSoftInt[ 7] = N_SKGrCl aSoftInt[ 8] = N_SKGrPr aSoftInt[ 9] = K_N_ClSc aSoftInt[10] = K_N_OpSc aSoftInt[11] = K_N_GrClSc aSoftInt[12] = K_N_GrOpSc aSoftInt[13] = M_ObAnk aSoftInt[14] = N_Chast aSoftInt[15] = M_Interval aSoftInt[16] = M_Scenario aSoftInt[17] = K_GradNClSc // Количество градаций в числовой классификационной шкале aSoftInt[18] = K_GradNOpSc // Количество градаций в числовой описательной шкале aSoftInt[19] = mGorizMin aSoftInt[20] = mGorizMax aSoftInt[21] = mGlubMin aSoftInt[22] = mGlubMax aSoftInt[23] = M_ChastObi aSoftInt[24] = M_ChastRso aSoftInt[25] = N_ChastObi aSoftInt[26] = N_ChastRso aSoftInt[27] = M_XlsDbf aSoftInt[28] = mTxtCSField aSoftInt[29] = mTxtOSField aSoftInt[30] = mTxtCSSep aSoftInt[31] = mTxtOSSep * aSoftInt[32] = mScenario // mScenario=1 Не применять сценарный метод АСК-анализа и спец.интерпретацию TXT-полей (старый вариант) aSoftInt[32] = mScenario // mScenario=1 Не применять сценарный метод АСК-анализа aSoftInt[33] = mSpecInterprCls // .T. - Применить спец.интерпретацию текстовых полей классов, .F. - не применять aSoftInt[34] = mSpecInterprAtr // .T. - Применить спец.интерпретацию текстовых полей признаков, .F. - не применять aSoftInt[35] = mNameGrNumSc // Какие наименования ГРАДАЦИЙ числовых шкал использовать aSoftInt[36] = mClsAvr // .F. = модель без усреднения по классам aSoftInt[37] = mSortUnqCls // Выделять уникальные значения классов и сортировать, 1-да, 2-нет aSoftInt[38] = IF(mSpecInterprCls,mLemmatCls,2) // Проводить лемматизацию классов, 1-да, 2-нет aSoftInt[39] = mSortUnqGos // Выделять уникальные значения признаков и сортировать, 1-да, 2-нет aSoftInt[40] = IF(mSpecInterprAtr,mLemmatGos,2) // Проводить лемматизацию признаков, 1-да, 2-нет DC_ASave(aSoftInt , "_2_3_2_2.arx") DC_ASave(aSoftInt , Disk_dir +"\_2_3_2_2.arx") DC_ASave(aSoftInt , Disk_dir+"\AID_DATA\Inp_data\"+"\_2_3_2_2.arx") DC_ASave(aSoftInt , M_PathAppl+"\_2_3_2_2.arx") ENDIF oSay97:SetCaption(L('2.3.2.15. Вставка промежуточных строк в файл исходных данных "Inp_data.dbf" завершена успешно !!!')) * DC_Impl(oScr) // Сделать прогресс-бар с прогнозированием времени исполнения как в кластеризации <<<===############################ oSay97:SetCaption(L('2.3.2.15. Вставка промежуточных строк в файл исходных данных "Inp_data.dbf" завершена успешно !!!')) oSay97:SetCaption(oSay97:caption) oButton:SetCaption(L('&Ok')) // Деструктурирование окна отображения графического Progress-bar oButton:activate := {||PostAppEvent(xbeP_Close,,,oDialog)} //<<<<<< Add This DC_AppEvent( @lOk ) * PostAppEvent(xbeP_Activate,,,DC_GetObject(GetList,'DCGUI_BUTTON_OK')) // Роджер oDialog:Destroy() aMess := {} AADD(aMess, L('Вставка промежуточных строк в файл исходных данных "Inp_data.dbf" завершено успешно!')) AADD(aMess, L('Во вставленных строках:')) AADD(aMess, L('- значения числовых полей = среднее значений данного поля 1-й и 2-й строк;')) AADD(aMess, L('- значения текстовых полей = объединение значений поля 1-й и 2-й строк через разделитель- пробел.')) AADD(aMess, '') AADD(aMess, L('Если повторять данный режим, то каждый раз в файл: "Inp_data.dbf" будут вставляться промежуточные')) AADD(aMess, L('строки. Затем можно запустить режим 2.3.2.2 с параметрами по умолчанию (они сформированы в данном')) AADD(aMess, L('режиме) или с параметрами, заданными ВРУЧНУЮ. Например, можно задать специальную интерпретацию ')) AADD(aMess, L('текстовых полей классов и признаков с признаками - словами, длиной > 0 (нуля) символов. ')) LB_Warning(aMess) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ************************************************************************************ ******** 5.5. Просмотр основных БД всех моделей ************************************************************************************ FUNCTION F5_5(mView) LOCAL GetList := {}, GetOptions Running(.T.) PUBLIC M_NumModel := 1 Num_Model := M_NumModel IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF mView IF ApplChange("5.5()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения RETURN NIL Running(.F.) ENDIF ELSE IF ApplChange("") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF ENDIF dbeSetDefault('DBFNTX') ***** Проверка наличия основных БД всех моделей. Ar_Model := {"Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } Flag = .F. FOR z=1 TO LEN(Ar_Model) IF .NOT. FILE(Ar_Model[z]+'.txt') Mess = L('Модель: "#" отсутствует. Необходимо провести расчет моделей в режиме 3.5 !!!') Mess = STRTRAN(Mess, '#', Ar_Model[z]) LB_Warning(Mess, L('5.5. Просмотр основных БД всех моделей')) Flag = .T. EXIT ENDIF NEXT IF Flag // Если какой-нибудь БД нет, то режим не запускать ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN(Flag) ENDIF ***** Копировать txt=>dbf mLenNameMax = CreateStructAll() // Создание файлов структур баз данных всех моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() // Количество классов (градаций классификационных шкал) USE Attributes EXCLUSIVE NEW;N_Gos = RECCOUNT() // Количество признаков (градаций описательных шкал) USE Gr_OpSc EXCLUSIVE NEW;N_Gos = RECCOUNT() // Количество признаков (градаций описательных шкал) USE Opis_Sc EXCLUSIVE NEW PRIVATE aInfTime[LEN(Ar_Model)] // Время создания основных баз данных моделей: Abs, Prc#, Inf# FOR z=1 TO LEN(Ar_Model) aInfTime[z] = FileTime(Ar_Model[z]+'.txt') NEXT DC_ASave(aInfTime, "_InfTime.arx") // Сформировать и записать массив времен создания основных баз данных моделей, если его не было *aInfTime = DC_ARestore("_InfTime.arx") ***** Копирование основных БД всех моделей из txt в dbf формат с числом полей до 2035 IF N_Cls > 2035 LB_Warning(L("Будут показаны только первые 2035 колонок"), L('5.5. Просмотр основных БД всех моделей' )) ENDIF * ########################################################################### // Открытие текстовых баз данных ******************************************** *** Создание баз данных в dbf-формате с найденной максимальной длиной наименования шкалы + строки и столбцы, как в Inf# GenDbfAbsOld(mLenNameMax) GenDbfPrcOld(mLenNameMax) GenDbfInfOld(mLenNameMax) *DC_ASave(aInfStruct, "_InfStruct.arx") // Когда БД создается - записывать структуру, когда открывается - считывать aInfStruct = DC_ARestore("_InfStruct.arx") *DC_ASave(aStrEmpty, "_aStrEmpty.arx") // Записывать только после расчета Abs.txt, а при расчете остальных БД только считывать *DC_ASave(aColEmpty, "_aColEmpty.arx") aStrEmpty = DC_ARestore("_aStrEmpty.arx") aColEmpty = DC_ARestore("_aColEmpty.arx") ************************************************* ***** Формирование пустой записи N_Col = N_Cls+6 // Число полей CrLf = CHR(13)+CHR(10) // Конец строки (записи) Lc_buf = "" FOR j=1 TO N_Col * S = IF(j=2*INT(j/2),"#","X") // Для отладки S = " " // Для работы Lc_buf = Lc_buf + REPLICATE(S, aInfStruct[j,3]) NEXT Lc_buf = Lc_buf + CrLf PUBLIC Len_LcBuf := LEN(Lc_buf) ****** Создаем стат.базы и базы знаний (7 по частным критериям знаний) Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } PUBLIC nHandle[LEN(Ar_Model)] FOR z=1 TO LEN(Ar_Model) nHandle[z] := FOpen( Ar_Model[z]+".txt", FO_READWRITE ) // Открыть все текстовые базы данных ######################################## NEXT **** Рассчет массива начальных позиций полей в строке PUBLIC aPos[N_Col] aPos[1] = 1 FOR j=2 TO N_Col aPos[j] = aPos[j-1] + aInfStruct[j-1,3] NEXT * ########################################################################### ***** Открытие основных БД.dbf всех моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() // Количество классов (градаций классификационных шкал) FOR z=1 TO LEN(Ar_Model) M_Inf = Ar_Model[z] USE (M_Inf) EXCLUSIVE NEW NEXT ***************************** nMax = N_Gos + 4 + ( N_Gos + 4 ) * 9 Mess = L('Копирование основных баз данных моделей: Abs, Prc#, Inf#: txt=>dbf') @ 4,5 DCPROGRESS oProgr SIZE 80,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 DCREAD GUI TITLE Mess PARENT @oDial FIT EXIT oDial:show() nTime = 0 DC_GetProgress(oProgr,0,nMax) ***************************** *** Копирование БД.txt => БД.dbf ************** (но не более 2035 полей классов) mNCls = IF(N_Cls<=2035,N_Cls,2035) FOR z=1 TO LEN(Ar_Model) M_Inf = Ar_Model[z] SELECT(M_Inf) FOR i=1 TO N_Gos * IF aStrEmpty[i] DBGOTO(i) Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], i, 1 ));FIELDPUT(1, Fv) Fv = LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], i, 2 ) ;FIELDPUT(2, Fv) FOR j=1 TO mNCls * IF aColEmpty[j] Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], i, 2+j ));FIELDPUT(2+j, Fv) * ENDIF NEXT FOR j=1 TO 4 Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], i, mNCls+2+j ));FIELDPUT(mNCls+2+j, Fv) NEXT * ENDIF DC_GetProgress(oProgr, ++nTime, nMax) NEXT FOR i=1 TO 4 DBGOTO(N_Gos+i) Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], N_Gos+i, 1 ));FIELDPUT(1, Fv) Fv = LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], N_Gos+i, 2 ) ;FIELDPUT(2, Fv) FOR j=1 TO mNCls * IF aColEmpty[j] Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], N_Gos+i, 2+j ));FIELDPUT(2+j, Fv) * ENDIF NEXT FOR j=1 TO 4 Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], N_Gos+i, mNCls+2+j ));FIELDPUT(mNCls+2+j, Fv) NEXT DC_GetProgress(oProgr, ++nTime, nMax) NEXT NEXT DC_GetProgress(oProgr,nMax,nMax) oDial:Destroy() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций FOR z=1 TO LEN(nHandle) FClose( nHandle[z] ) // Закрытие txt баз данных ###################################### NEXT IF mView ***** Открытие основных БД.dbf всех моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() // Количество классов (градаций классификационных шкал) Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } FOR z=1 TO LEN(Ar_Model) M_Inf = Ar_Model[z] USE (M_Inf) EXCLUSIVE NEW NEXT ********************************************************************************************** *********************** Меню выбора модели *************************************************** DC_XbpMenuConfig( ; { GRA_CLR_WHITE,; // 1 - Sub Menu Background Color fColor, ; // 2 - Sub Menu Vertical Bar Foreground Color bColor,; // 3 - Sub Menu Vertical Bar Background Color GRA_CLR_BLACK,; // 4 - Sub Menu Outline Color '11.Arial Bold', ; // 5 - Sub Menu Vertical Bar Font .F., ; '10.Marlett', ; // 6 - Sub Menu Check Character Font 'b', ; // 7 - Sub Menu Check Character fColor, ; // 8 - Menu Bar Foreground Color bColor, ; // 9 - Menu Bar Background Color GRA_CLR_BLACK,; // 10 - Sub Menu Foreground Color '10.Helvetica Bold' } ) // 11 - Menu Bar Font ******* Наименования моделей. Загрузить и отобразить соответствующие наименования моделей <<<===######################## PRIVATE aModName[10] * DC_ASave(aModFullNm, "_aModFullNm.arx") // Наименования создаваемых моделей для режима 3.4 aModName = DC_ARestore("_aModFullNm.arx") DCMENUBAR oMenuBar OWNERDRAW BARBITMAP 'Checkers.bmp' DCMENUITEM L('1.Abs' ) PARENT oMenuBar ACTION {||ChooseModel( 1)} MESSAGE aModName[ 1] DCMENUITEM L('2.Prc1' ) PARENT oMenuBar ACTION {||ChooseModel( 2)} MESSAGE aModName[ 2] DCMENUITEM L('3.Prc2' ) PARENT oMenuBar ACTION {||ChooseModel( 3)} MESSAGE aModName[ 3] * DCMENUITEM SEPARATOR PARENT oMenuBar DCMENUITEM L('4.Inf1' ) PARENT oMenuBar ACTION {||ChooseModel( 4)} MESSAGE aModName[ 4] DCMENUITEM L('5.Inf2' ) PARENT oMenuBar ACTION {||ChooseModel( 5)} MESSAGE aModName[ 5] DCMENUITEM L('6.Inf3' ) PARENT oMenuBar ACTION {||ChooseModel( 6)} MESSAGE aModName[ 6] DCMENUITEM L('7.Inf4' ) PARENT oMenuBar ACTION {||ChooseModel( 7)} MESSAGE aModName[ 7] DCMENUITEM L('8.Inf5' ) PARENT oMenuBar ACTION {||ChooseModel( 8)} MESSAGE aModName[ 8] DCMENUITEM L('9.Inf6' ) PARENT oMenuBar ACTION {||ChooseModel( 9)} MESSAGE aModName[ 9] DCMENUITEM L('10.Inf7') PARENT oMenuBar ACTION {||ChooseModel(10)} MESSAGE aModName[10] DCMENUITEM L('Помощь' ) PARENT oMenuBar ACTION {||Help33() } MESSAGE L('Помощь по режиму') DCMENUITEM L('Частотные распр.знач.част.крит.' ) PARENT oMenuBar ACTION {||FreqPartCrit() } MESSAGE L('Частотные распределения абсолютных и относительных частот и других значений частных критериев') DCMENUITEM L('Конвертация всех моделей в dbf и xls' ) PARENT oMenuBar ACTION {||Copy_All_models_to_dbf_xls() } MESSAGE L('Конвертация всех моделей: Abs,Prc1,Prc2,Inf1,Inf2,Inf3,Inf4,Inf5,Inf6,Inf7 в dbf и xls') @ 100,100 DCSTATIC TYPE XBPSTATIC_TYPE_RAISEDBOX ; OBJECT oMessageBox ; INVISIBLE ; COLOR DC_XbpMenuConfig()[2], DC_XbpMenuConfig()[3] @ 4,4 DCSAY L('System Aidos') ; PARENT oMessageBox ; FONT '8.MS Sans Serif' ; SAYOPTION XBPSTATIC_TEXT_VCENTER + XBPSTATIC_TEXT_CENTER + XBPSTATIC_TEXT_WORDBREAK ; COLOR DC_XbpMenuConfig()[9], DC_XbpMenuConfig()[1] DCGETOPTIONS WINDOWROW 40 WINDOWHEIGHT 670 WINDOWWIDTH 1100 DCREAD GUI ; TITLE L('5.5. Просмотр основных баз данных всех моделей') ; HANDLER MenuHandler REFERENCE @oMessageBox ; OPTIONS GetOptions ; EVAL {|o|oDlg := o} ********************************************************************************************** ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций FOR z=1 TO LEN(nHandle) FClose( nHandle[z] ) // Закрытие dbf и txt баз данных ###################################### NEXT ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL *********************************************************************************************** ******** Конвертация всех моделей: Abs,Prc1,Prc2,Inf1,Inf2,Inf3,Inf4,Inf5,Inf6,Inf7 в dbf и xls *********************************************************************************************** FUNCTION Copy_All_models_to_dbf_xls() * @s, 2 DCRADIO nRadModelCr VALUE 1 PROMPT L('дисперсия, сравнение путем вычитания ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=2 } HIDE {|| .NOT.nRadioModel=2};s=s+d * @s, 2 DCRADIO nRadModelCr VALUE 2 PROMPT L('дисперсия, сравнение путем деления ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=2 } HIDE {|| .NOT.nRadioModel=2};s=s+d * @s, 2 DCRADIO nRadModelCr VALUE 3 PROMPT L('среднее, сравнение путем вычитания ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=2 } HIDE {|| .NOT.nRadioModel=2};s=s+d * @s, 2 DCRADIO nRadModelCr VALUE 4 PROMPT L('среднее, сравнение путем деления ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=2 } HIDE {|| .NOT.nRadioModel=2};s=s+d * @s, 2 DCRADIO nRadModelCr VALUE 5 PROMPT L('средн.модуль отклон.от средн., сравн.путем вычит. ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=2 } HIDE {|| .NOT.nRadioModel=2};s=s+d * @s, 2 DCRADIO nRadModelCr VALUE 6 PROMPT L('средн.модуль отклон.от средн., сравн.путем делен. ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=2 } HIDE {|| .NOT.nRadioModel=2};s=s+d *DC_ASave(aParModel, "_ParModel.arx") aParModel := DC_ARestore("_ParModel.arx") mModel_2nd_level = aParModel[1] mRadModelCr = aParModel[2] *MsgBox(STR(mModel_2nd_level)) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций *model_2nd_level aTypeModel := {} AADD(aTypeModel,'Var_comp_sub') // 1 AADD(aTypeModel,'Var_comp_div') // 2 AADD(aTypeModel,'Avr_comp_sub') // 3 AADD(aTypeModel,'Avr_comp_div') // 4 AADD(aTypeModel,'MAD_comp_sub') // 5 AADD(aTypeModel,'MAD_comp_div') // 6 oScr := DC_WaitOn(L('Копирование мариц всех моделей: Abs.dbf,Prc#.dbf,Inf#.dbf => Abs.xls,Prc#.xls,Inf#.xls. Немного подождите!!!'),,,,,,,,,,,.F.) Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } FOR m=1 TO LEN(Ar_Model) Name_SS = Ar_Model[m]+".dbf" IF mModel_2nd_level = 1 Name_DDdbf = Ar_Model[m]+"_basic_level.dbf" Name_DDxls = Ar_Model[m]+"_basic_level.xls" ELSE Name_DDdbf = Ar_Model[m]+'_'+ALLTRIM(STR(mModel_2nd_level))+'nd_level_'+aTypeModel[mRadModelCr]+".dbf" Name_DDxls = Ar_Model[m]+'_'+ALLTRIM(STR(mModel_2nd_level))+'nd_level_'+aTypeModel[mRadModelCr]+".xls" ENDIF * LB_Warning(L("Источник: "+Name_SS+", приемник: "+Name_DDdbf)) * LB_Warning(L("Источник: "+Name_SS+", приемник: "+Name_DDxls)) COPY FILE (Name_SS) TO (Name_DDdbf) COPY FILE (Name_SS) TO (Name_DDxls) NEXT ***** Открытие основных БД.dbf всех моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() // Количество классов (градаций классификационных шкал) Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } FOR z=1 TO LEN(Ar_Model) M_Inf = Ar_Model[z] USE (M_Inf) EXCLUSIVE NEW NEXT DC_Impl(oScr) RETURN NIL ************************************************* ******** Выбрать модель для просмотра основной БД ************************************************* FUNCTION ChooseModel(M_NumModel) LOCAL Getlist := {}, oProgress, oDialog, GetOptions, oBrowse57, bApp, bItems57 Num_Model := M_NumModel M_Inf = Ar_Model[M_NumModel] SELECT (M_Inf) nMax = RECCOUNT() nTime = 0 mLN = -9999999 DBGOTOP() DO WHILE .NOT. EOF() * aTxtPar = DC_GraQueryTextbox(ALLTRIM(Name), '8.MS Sans Serif') * mLN = MAX(mLN, aTxtPar[1]) * MsgBox("Длина текста в пикселях="+ALLTRIM(STR(aTxtPar[1]))+". Высота текста в пикселях="+ALLTRIM(STR(aTxtPar[2]))) mLN = MAX(mLN, LEN(ALLTRIM(Name))) DBSKIP(1) ENDDO mLN = MIN(mLN, 50) // Максимальная длина наименования градации описательной шкалы, но не более 50 символов DBGOTOP() DO CASE CASE Num_Model = 1 // Если Abs *********************************************************************** /* ----- Create ToolBar ----- */ @ 26.5, 0 DCTOOLBAR oToolBar SIZE 133, 1.5 K=3.0 DCADDBUTTON CAPTION L('Помощь') ; SIZE K+LEN(L("Помощь")) ; ACTION {||Help33(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Помощь по режиму 4.3.1') DCADDBUTTON CAPTION L('MS Excel') ; SIZE K+LEN(L("MS Excel")) ; ACTION {||Razrab(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Экспорт инф.портрета в MS Excel') DCADDBUTTON CAPTION L('MS Word') ; SIZE K+LEN(L("MS Word")) ; ACTION {||Razrab(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Экспорт инф.портрета в MS Word') /* ----- Create browse ----- */ ******* Формирование массива заголовков столбцов PRIVATE aHeadName[2+N_Cls+4] aHeadName[1] = L("Код;признака") aHeadName[2] = L("Наименование описательной;шкалы и градации") aHeadName[2+N_Cls+1] = L("Сумма") aHeadName[2+N_Cls+2] = L("Среднее") aHeadName[2+N_Cls+3] = L("Средн.;квадр.;откл.") aHeadName[2+N_Cls+4] = L("Среднее;откл.мод.;от средн.") // Заполнять строки заголовков целыми словами до тех пор, пока не превышена макс.ширина заголовка SELECT Classes DL = 9 // Ширина заголовка в кол-ве символов Max_HeadLines = -999999999 FOR j=1 TO N_Cls DBGOTO(j) M_NameCls = ALLTRIM(Name_cls) M_NameCls = STRTRAN(M_NameCls,'-',' ') aHeadString := {} // Массив строк заголовка j-й колонки AADD(aHeadString, ALLTRIM(STR(j,19))+". ") // Код класса *** Начало цикла по словам FOR w=1 TO NUMTOKEN(M_NameCls," ") // Разделитель между словами - пробел M_Word = UPPER(TOKEN(M_NameCls," ",w)) IF LEN(aHeadString[LEN(aHeadString)]+" "+M_Word) <= DL // Если после добавления слова к строке заголовка ее ширина меньше заданной, // то добавлять слово к этой же строке заголовка aHeadString[LEN(aHeadString)] = aHeadString[LEN(aHeadString)]+" "+M_Word ELSE // Если после добавления слова к строке заголовка ее ширина больше заданной, // то делать новую строку (";") и к ней добавлять слово AADD(aHeadString, ";"+M_Word) ENDIF NEXT // Переписать строки заголовка в массив наименований колонок aHeadName[2+j] = "" FOR s=1 TO LEN(aHeadString) aHeadName[2+j] = aHeadName[2+j] + aHeadString[s] NEXT Max_HeadLines = MAX(Max_HeadLines,LEN(aHeadString)) // Определение максимального количества строк в заголовке NEXT SELECT (M_Inf) DBGOTOP() * @ 1, 0 DCBROWSE oBrowse57 ALIAS (M_Inf) SIZE 200,30 ; @ 1, 0 DCBROWSE oBrowse57 ALIAS (M_Inf) SIZE 250,45 ; PRESENTATION LC_BrowPres() ; // Только просмотр БД NOSOFTTRACK ; HEADLINES Max_HeadLines ; // Кол-во строк в заголовке SCOPE ; ITEMMARKED bItems57; FREEZELEFT {1,2} ; // При горизонтальной прокрутке не прокручивать первые 2 колонки COLOR {||IIF(2*INT((M_Inf)->Kod_pr/2)==(M_Inf)->Kod_pr,nil,{nil,GraMakeRGBColor({230,252,213})})} // Вывод строки цветом RGB DCSETPARENT oBrowse57 DCBROWSECOL DATA FldAnchINT(1) HEADER aHeadName[1] PARENT oBrowse57 WIDTH 5; COLOR {||IIF(AT('SPECTRINTERV:',(M_Inf)->Name)=0,nil,{nil,GraMakeRGBColor({VAL(SUBSTR((M_Inf)->Name, AT('{', (M_Inf)->Name)+1, AT('{', (M_Inf)->Name)+ 3-AT('{', (M_Inf)->Name)+1+1)),VAL(SUBSTR((M_Inf)->Name, AT('{', (M_Inf)->Name)+5, AT('{', (M_Inf)->Name)+ 7-AT('{', (M_Inf)->Name)+5+1)),VAL(SUBSTR((M_Inf)->Name, AT('{', (M_Inf)->Name)+9, AT('{', (M_Inf)->Name)+11-AT('{', (M_Inf)->Name)+9+1))})})} // Вывод поля цветом RGB, как в 2.2 DCBROWSECOL FIELD (M_Inf)->Name HEADER aHeadName[2] PARENT oBrowse57 WIDTH mLN WNF = 11 // Ширина числового поля: ######## V > 0 - красным, < 0 - синим, 0 - пробел **** Подарки от Роджера и Клиффорда FOR j=1 TO N_Cls DCBROWSECOL DATA FldAnchINT(2+j) HEADER aHeadName[2+j] PARENT oBrowse57 COLOR ColorBlock(2+j) FONT "9.Courier" WIDTH WNF NEXT * DCBROWSECOL DATA FldAnchINT (2+N_Cls+1) HEADER aHeadName[2+N_Cls+1] PARENT oBrowse57 COLOR ColorBlock(2+N_Cls+1) FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(2+N_Cls+1,10,3) HEADER aHeadName[2+N_Cls+1] PARENT oBrowse57 COLOR ColorBlock(2+N_Cls+1) FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(2+N_Cls+2,10,3) HEADER aHeadName[2+N_Cls+2] PARENT oBrowse57 COLOR ColorBlock(2+N_Cls+2) FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(2+N_Cls+3,10,3) HEADER aHeadName[2+N_Cls+3] PARENT oBrowse57 COLOR ColorBlock(2+N_Cls+3) FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(2+N_Cls+4,10,3) HEADER aHeadName[2+N_Cls+4] PARENT oBrowse57 COLOR ColorBlock(2+N_Cls+4) FONT "9.Courier" WIDTH WNF DCGETOPTIONS SAYFONT '10.Helv Bold' TABSTOP AUTORESIZE DCGETOPTIONS WINDOWROW 62 WINDOWHEIGHT 650 WINDOWWIDTH 970 DCREAD GUI ; FIT ; OPTIONS GetOptions ; MODAL ; TITLE L('5.5. Модель: "')+ALLTRIM(aModName[Num_Model])+'"' ; CLEAREVENTS CASE Num_Model = 2 .OR. Num_Model = 3 // Если Prc1 или Prc2 ********************************************* /* ----- Create ToolBar ----- */ @ 26.5, 0 DCTOOLBAR oToolBar SIZE 133, 1.5 K=3.0 DCADDBUTTON CAPTION L('Помощь') ; SIZE K+LEN(L("Помощь")) ; ACTION {||Help33(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Помощь по режиму 4.3.1') DCADDBUTTON CAPTION L('MS Excel') ; SIZE K+LEN(L("MS Excel")) ; ACTION {||Razrab(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Экспорт инф.портрета в MS Excel') DCADDBUTTON CAPTION L('MS Word') ; SIZE K+LEN(L("MS Word")) ; ACTION {||Razrab(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Экспорт инф.портрета в MS Word') /* ----- Create browse ----- */ ******* Формирование массива заголовков столбцов PRIVATE aHeadName[2+N_Cls+4] aHeadName[1] = L("Код;признака") aHeadName[2] = L("Наименование описательной;шкалы и градации") aHeadName[2+N_Cls+1] = L("Безусл.;вероятн.") aHeadName[2+N_Cls+2] = L("Среднее") aHeadName[2+N_Cls+3] = L("Средн.;квадр.;откл.") aHeadName[2+N_Cls+4] = L("Среднее;откл.мод.;от средн.") // Заполнять строки заголовков целыми словами до тех пор, пока не превышена макс.ширина заголовка SELECT Classes DL = 9 // Ширина заголовка в кол-ве символов Max_HeadLines = -999999999 FOR j=1 TO N_Cls DBGOTO(j) M_NameCls = ALLTRIM(Name_cls) M_NameCls = STRTRAN(M_NameCls,'-',' ') aHeadString := {} // Массив строк заголовка j-й колонки AADD(aHeadString, ALLTRIM(STR(j,19))+". ") // Код класса *** Начало цикла по словам FOR w=1 TO NUMTOKEN(M_NameCls," ") // Разделитель между словами - пробел M_Word = UPPER(TOKEN(M_NameCls," ",w)) IF LEN(aHeadString[LEN(aHeadString)]+" "+M_Word) <= DL // Если после добавления слова к строке заголовка ее ширина меньше заданной, // то добавлять слово к этой же строке заголовка aHeadString[LEN(aHeadString)] = aHeadString[LEN(aHeadString)]+" "+M_Word ELSE // Если после добавления слова к строке заголовка ее ширина больше заданной, // то делать новую строку (";") и к ней добавлять слово AADD(aHeadString, ";"+M_Word) ENDIF NEXT // Переписать строки заголовка в массив наименований колонок aHeadName[2+j] = "" FOR s=1 TO LEN(aHeadString) aHeadName[2+j] = aHeadName[2+j] + aHeadString[s] NEXT Max_HeadLines = MAX(Max_HeadLines,LEN(aHeadString)) // Определение максимального количества строк в заголовке NEXT SELECT (M_Inf) DBGOTOP() * @ 1, 0 DCBROWSE oBrowse57 ALIAS (M_Inf) SIZE 200,30 ; @ 1, 0 DCBROWSE oBrowse57 ALIAS (M_Inf) SIZE 250,45 ; PRESENTATION LC_BrowPres() ; // Только просмотр БД NOSOFTTRACK ; HEADLINES Max_HeadLines ; // Кол-во строк в заголовке SCOPE ; ITEMMARKED bItems57; FREEZELEFT {1,2} ; // При горизонтальной прокрутке не прокручивать первые 2 колонки COLOR {||IIF(2*INT((M_Inf)->Kod_pr/2)==(M_Inf)->Kod_pr,nil,{nil,GraMakeRGBColor({230,252,213})})} // Вывод строки цветом RGB DCSETPARENT oBrowse57 DCBROWSECOL DATA FldAnchINT(1) HEADER aHeadName[1] PARENT oBrowse57 WIDTH 5; COLOR {||IIF(AT('SPECTRINTERV:',(M_Inf)->Name)=0,nil,{nil,GraMakeRGBColor({VAL(SUBSTR((M_Inf)->Name, AT('{', (M_Inf)->Name)+1, AT('{', (M_Inf)->Name)+ 3-AT('{', (M_Inf)->Name)+1+1)),VAL(SUBSTR((M_Inf)->Name, AT('{', (M_Inf)->Name)+5, AT('{', (M_Inf)->Name)+ 7-AT('{', (M_Inf)->Name)+5+1)),VAL(SUBSTR((M_Inf)->Name, AT('{', (M_Inf)->Name)+9, AT('{', (M_Inf)->Name)+11-AT('{', (M_Inf)->Name)+9+1))})})} // Вывод поля цветом RGB, как в 2.2 DCBROWSECOL FIELD (M_Inf)->Name HEADER aHeadName[2] PARENT oBrowse57 WIDTH mLN WNF = 9 // Ширина числового поля: ######## V > 0 - красным, < 0 - синим, 0 - пробел **** Подарки от Роджера и Клиффорда FOR j=1 TO N_Cls DCBROWSECOL DATA FieldAnchor(2+j,9,3) HEADER aHeadName[2+j] PARENT oBrowse57 COLOR ColorBlock(2+j) FONT "9.Courier" WIDTH WNF NEXT DCBROWSECOL DATA FieldAnchor(2+N_Cls+1,9,3) HEADER aHeadName[2+N_Cls+1] PARENT oBrowse57 COLOR ColorBlock(2+N_Cls+1) FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(2+N_Cls+2,9,3) HEADER aHeadName[2+N_Cls+2] PARENT oBrowse57 COLOR ColorBlock(2+N_Cls+2) FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(2+N_Cls+3,9,3) HEADER aHeadName[2+N_Cls+3] PARENT oBrowse57 COLOR ColorBlock(2+N_Cls+3) FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(2+N_Cls+4,9,3) HEADER aHeadName[2+N_Cls+4] PARENT oBrowse57 COLOR ColorBlock(2+N_Cls+4) FONT "9.Courier" WIDTH WNF DCGETOPTIONS SAYFONT '10.Helv Bold' TABSTOP AUTORESIZE DCGETOPTIONS WINDOWROW 62 WINDOWHEIGHT 650 WINDOWWIDTH 970 DCREAD GUI ; FIT ; OPTIONS GetOptions ; MODAL ; TITLE L('5.5. Модель: "')+L(ALLTRIM(aModName[Num_Model])+'"') ; CLEAREVENTS OTHERWISE // Если Inf# ********************************************************************** /* ----- Create ToolBar ----- */ @ 26.5, 0 DCTOOLBAR oToolBar SIZE 133, 1.5 K=3.0 DCADDBUTTON CAPTION L('Помощь') ; SIZE K+LEN(L("Помощь")) ; ACTION {||Help33(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Помощь по режиму 4.3.1') DCADDBUTTON CAPTION L('MS Excel') ; SIZE K+LEN(L("MS Excel")) ; ACTION {||Razrab(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Экспорт инф.портрета в MS Excel') DCADDBUTTON CAPTION L('MS Word') ; SIZE K+LEN(L("MS Word")) ; ACTION {||Razrab(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Экспорт инф.портрета в MS Word') /* ----- Create browse ----- */ ******* Формирование массива заголовков столбцов PRIVATE aHeadName[2+N_Cls+4] aHeadName[1] = L("Код;признака") aHeadName[2] = L("Наименование описательной;шкалы и градации") aHeadName[2+N_Cls+1] = L("Сумма") aHeadName[2+N_Cls+2] = L("Среднее") aHeadName[2+N_Cls+3] = L("Средн.;квадр.;откл.") aHeadName[2+N_Cls+4] = L("Среднее;откл.мод.;от средн.") // Заполнять строки заголовков целыми словами до тех пор, пока не превышена макс.ширина заголовка SELECT Classes DL = 9 // Ширина заголовка в кол-ве символов Max_HeadLines = -999999999 FOR j=1 TO N_Cls DBGOTO(j) M_NameCls = ALLTRIM(Name_cls) M_NameCls = STRTRAN(M_NameCls,'-',' ') aHeadString := {} // Массив строк заголовка j-й колонки AADD(aHeadString, ALLTRIM(STR(j,19))+". ") // Код класса *** Начало цикла по словам FOR w=1 TO NUMTOKEN(M_NameCls," ") // Разделитель между словами - пробел M_Word = UPPER(TOKEN(M_NameCls," ",w)) IF LEN(aHeadString[LEN(aHeadString)]+" "+M_Word) <= DL // Если после добавления слова к строке заголовка ее ширина меньше заданной, // то добавлять слово к этой же строке заголовка aHeadString[LEN(aHeadString)] = aHeadString[LEN(aHeadString)]+" "+M_Word ELSE // Если после добавления слова к строке заголовка ее ширина больше заданной, // то делать новую строку (";") и к ней добавлять слово AADD(aHeadString, ";"+M_Word) ENDIF NEXT // Переписать строки заголовка в массив наименований колонок aHeadName[2+j] = "" FOR s=1 TO LEN(aHeadString) aHeadName[2+j] = aHeadName[2+j] + aHeadString[s] NEXT Max_HeadLines = MAX(Max_HeadLines,LEN(aHeadString)) // Определение максимального количества строк в заголовке NEXT SELECT (M_Inf) DBGOTOP() * @ 1, 0 DCBROWSE oBrowse57 ALIAS (M_Inf) SIZE 200,30 ; @ 1, 0 DCBROWSE oBrowse57 ALIAS (M_Inf) SIZE 250,45 ; PRESENTATION LC_BrowPres() ; // Только просмотр БД NOSOFTTRACK ; HEADLINES Max_HeadLines ; // Кол-во строк в заголовке SCOPE ; ITEMMARKED bItems57; FREEZELEFT {1,2}; // При горизонтальной прокрутке не прокручивать первые 2 колонки COLOR {||IIF(2*INT((M_Inf)->Kod_pr/2)==(M_Inf)->Kod_pr,nil,{nil,GraMakeRGBColor({230,252,213})})} // Вывод строки цветом RGB DCSETPARENT oBrowse57 DCBROWSECOL DATA FldAnchINT(1) HEADER aHeadName[1] PARENT oBrowse57 WIDTH 5; COLOR {||IIF(AT('SPECTRINTERV:',(M_Inf)->Name)=0,nil,{nil,GraMakeRGBColor({VAL(SUBSTR((M_Inf)->Name, AT('{', (M_Inf)->Name)+1, AT('{', (M_Inf)->Name)+ 3-AT('{', (M_Inf)->Name)+1+1)),VAL(SUBSTR((M_Inf)->Name, AT('{', (M_Inf)->Name)+5, AT('{', (M_Inf)->Name)+ 7-AT('{', (M_Inf)->Name)+5+1)),VAL(SUBSTR((M_Inf)->Name, AT('{', (M_Inf)->Name)+9, AT('{', (M_Inf)->Name)+11-AT('{', (M_Inf)->Name)+9+1))})})} // Вывод поля цветом RGB, как в 2.2 DCBROWSECOL FIELD (M_Inf)->Name HEADER aHeadName[2] PARENT oBrowse57 WIDTH mLN WNF = 12 // Ширина числового поля: ######## V > 0 - красным, < 0 - синим, 0 - пробел **** Подарки от Роджера и Клиффорда FOR j=1 TO N_Cls DCBROWSECOL DATA FieldAnchor(2+j,WNF,3) HEADER aHeadName[2+j] PARENT oBrowse57 COLOR ColorBlock(2+j) FONT "9.Courier" WIDTH WNF NEXT DCBROWSECOL DATA FieldAnchor(2+N_Cls+1,WNF,3) HEADER aHeadName[2+N_Cls+1] PARENT oBrowse57 COLOR ColorBlock(2+N_Cls+1) FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(2+N_Cls+2,WNF,3) HEADER aHeadName[2+N_Cls+2] PARENT oBrowse57 COLOR ColorBlock(2+N_Cls+2) FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(2+N_Cls+3,WNF,3) HEADER aHeadName[2+N_Cls+3] PARENT oBrowse57 COLOR ColorBlock(2+N_Cls+3) FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(2+N_Cls+4,WNF,3) HEADER aHeadName[2+N_Cls+4] PARENT oBrowse57 COLOR ColorBlock(2+N_Cls+4) FONT "9.Courier" WIDTH WNF DCGETOPTIONS SAYFONT '10.Helv Bold' TABSTOP AUTORESIZE DCGETOPTIONS WINDOWROW 62 WINDOWHEIGHT 650 WINDOWWIDTH 970 DCREAD GUI ; FIT ; OPTIONS GetOptions ; MODAL ; TITLE L('5.5. Модель: "')+L(ALLTRIM(aModName[Num_Model])+'"') ; CLEAREVENTS ENDCASE RETURN NIL ****************************************************************************************************** ******** Частотные распределения абсолютных и относительных частот и других значений частных критериев ******** Расчет во всех моделях и визуализация в виде графика, типа парето-кривой значимости признаков ****************************************************************************************************** FUNCTION FreqPartCrit() LOCAL GetList[0], GetOptions, oRmChart, oRegion1, oRegion2, oRegion3, ; oRegion4, oRegion5, oRegion6, aBarGroup[0], aLineGroup[0], aPie[0], ; aDonut[0], aBarGroupFloat[0], aBarGroupIndus[0], aLineGroupIndus[0], ; aDataAxis1[0], aDataAxis5[0], aDataAxis6[0], cRegSvr, ; cRmChart, cClsId, cRegQuery, nWhich, oStatus ******* Проверка возможности работать в системе ****************************************** IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе и не можете ей пользоваться!")) RETURN NIL ENDIF // Еще сделать проверку на то, проинсталлирован ли ActiveX ******* Подготовка данных (расчет значимости признаков во всех моделях) ************* * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций PUBLIC Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } FOR jj=1 TO LEN(Ar_Model) oScr := DC_WaitOn(L('Немного подождите! Идет расчет частотного распределения значений частных критериев в модели:')+' '+Ar_Model[jj],,,,,,,,,,,.F.) mNameInf = Ar_Model[jj] * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * USE (mNameInf) EXCLUSIVE NEW SELECT (mNameInf) SET FILTER TO KOD_PR > 0 N_Atr = RECCOUNT() N_Cls = FCOUNT() - 5 aArg := {} // Массив уникальных значений частного критерия aChKr := {} // Массив всех значений частного критерия с повторами mSumma = 0 // Сумма значений частных критериев mAverage = 0 // Среднее значений частных критериев DBGOTOP() DO WHILE .NOT. EOF() FOR j=1 TO N_Cls mArg = FIELDGET(2+j) AADD(aChKr, mArg) // Можно заменить повторное чтение из базы данных на чтение из массива aChKr. Вопрос только в том, не переполнится ли память при больших размерностях моделей, не возникнет ли ошибка исполнения IF ASCAN(aArg, mArg) = 0 AADD (aArg, mArg) ENDIF NEXT DBSKIP(1) ENDDO ASORT(aArg) N_Znach = LEN(aArg) PRIVATE aVal[N_Znach] AFILL(aVal, 0) ********* Можно заменить повторное чтение из базы данных на чтение из массива aChKr ********* Вопрос только в том, не переполнится ли память при больших размерностях моделей, не возникнет ли ошибка исполнения FOR j=1 TO LEN(aChKr) mPos = ASCAN(aArg, aChKr[j]) mSumma = mSumma + aChKr[j] // Сумма значений частных критериев aVal[mPos] = aVal[mPos] + 1 NEXT mAverage = mSumma / LEN(aChKr) mInfPow = 0 // Иформационная мощность модели (Количественная мера степени выраженности закономерностей в моделируемой предметной области) FOR j=1 TO LEN(aChKr) mInfPow = mInfPow + (aChKr[j] - mAverage)^2 NEXT mInfPow = mInfPow / (LEN(aChKr)-1) * DBGOTOP() * DO WHILE .NOT. EOF() * FOR j=1 TO N_Cls * mPos = ASCAN(aArg, FIELDGET(2+j)) * aVal[mPos] = aVal[mPos] + 1 * NEXT * DBSKIP(1) * ENDDO DC_Impl(oScr) * LB_Warning(aArg) // <<<===######## Преобразует аргумент в текстовый тип данных * LB_Warning(aVal) ***** ВИЗУАЛИЗАЦИЯ частотных распределений значений частных критериев **************** oScr := DC_WaitOn(L('Немного подождите! Идет формирование изображения в памяти и его масштабирование'),,,,,,,,,,,.F.) PUBLIC X_MaxW := 1800, Y_MaxW := 900 // Размер графического окна для отображения когнитивных диаграмм в пикселях PUBLIC nXSize := 1800 PUBLIC nYSize := 900 // Create new bitmap with given size oPS := XBPPRESSPACE() :new() :Create() oBMP := XBPBITMAP() :New() :Create() * oBMP:Make( nXSize, nYSize, nPlanes, nBits ) oBMP:Make( nXSize, nYSize ) oBMP:presSpace( oPS ) // here your GRA* Code **** Закрасить фон прямоугольника *************** * GraSetColor( oPS, GRA_CLR_WHITE, GRA_CLR_WHITE ) GraSetColor( oPS, BD_LIGHTGREY, BD_LIGHTGREY ) GraBox( oPS, { 0, 0 }, { nXSize, nYSize }, GRA_FILL ) *####################################################################################################### mNumMod = jj LC_DrawChart55( oPS, N_Znach, aArg, aVal, mNumMod ) // Графическая функция <<<===########## *####################################################################################################### *My image original, my image scaled DC_Impl(oScr) ****** Запись полноразмерного графического файла в папку: M_PathAppl+"\FreqPartCrit\" DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения IF FILEDATE("FreqPartCrit",16) = CTOD("//") DIRMAKE("FreqPartCrit") aMess := {} AADD(aMess, L('В папке текущего приложения: "'+UPPER(ALLTRIM(M_PathAppl))+'"')) AADD(aMess, L('не было директории "FreqPartCrit" для частотных распределений значений частных критериев и она была создана!')) AADD(aMess, L('В эту папку записываются исходные изображения высокого качества (без масштабирования)')) LB_Warning(aMess, L('5.5. Частотные распределения значений частных критериев' )) ENDIF DIRCHANGE(M_PathAppl+"\FreqPartCrit\") // Перейти в папку ParetoGrOpSc cFileName = "FreqPartCrit"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+".jpg" ERASE(cFileName) oBMP:SaveFile(cFileName,XBPBMP_FORMAT_JPG) IF nWidth > 1800 FullView( cFileName, "по верху", 65 ) // Визуализация полноразмерного файла на мониторе высокого разрешения ELSE ****** Формирование с помощью bmp2bmp() и отображение масштабированного изображения aNewSize := {nWidth,nHeight-29} // Новый размер изображения (еще немного уменьшается, чтобы не рисовать по панели задач) oBMP:loadFile(cFileName) // Загрузка полноразмерного изображения oRet := BMP2BMP(oBMP,aNewSize) // Масштабирование изображения cFileNameScale = SUBSTR(cFileName,1,AT(".jpg",cFileName)-1)+"_scaled.jpg" ERASE(cFileNameScale) oRet:saveFile(cFileNameScale,XBPBMP_FORMAT_JPG) // Запись масштабированного графического файла в в папку приложения для визуализации FullView( cFileNameScale, "по верху", 0 ) // Визуализация масштабированного графического файла на мониторе ограниченного разрешения ENDIF DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения NEXT ************************************************************** * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций aMess := {} AADD(aMess, L('Частотные распределения значений частных критериев успешно построены!')) LB_Warning(aMess, L("Сообщение об успешном завершении операции" )) ** DC_GetProgress(oProgress,nMax,nMax) ** oDialog:Destroy() * ************************************************************** * ***** БД, открытые перед запуском главного меню * ***** Восстанавливать их после выхода из функций главного меню * ************************************************************** * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы * USE PathGrAp EXCLUSIVE NEW * USE Appls EXCLUSIVE NEW * USE Users EXCLUSIVE NEW * ************************************************************** RETURN NIL ********************************************************************************* *************** Визуализация Парето-диаграммы значимости признаков ********************************************************************************* STATIC FUNCTION LC_DrawChart55(oPS, N_Znach, aArg, aVal, mNumMod ) ****** Поиск макс и мин значений аргумента и функции ****** X_MinA = +99999999 // Минимальное значение Y отображаемой функции X_MaxA = -99999999 // Максимальное значение Y отображаемой функции Y_MinF = +99999999 // Минимальное значение Y отображаемой функции Y_MaxF = -99999999 // Максимальное значение Y отображаемой функции FOR j=1 TO LEN(aArg) * MsgBox(STR(X_MinA)+STR(aArg[j])) // <<<===################# X_MinA = MIN(X_MinA, aArg[j]) X_MaxA = MAX(X_MaxA, aArg[j]) Y_MinF = MIN(Y_MinF, aVal[j]) Y_MaxF = MAX(Y_MaxF, aVal[j]) NEXT N_aArg = LEN(aArg) // Кол-во уникальных значений аргумента PRIVATE X0 := 75 PRIVATE Y0 := 165 // Начало координат по осям X и Y с учетом места для легенды PRIVATE W_Wind := X_MaxW - X0 - 25 // Ширина окна для самого графика PRIVATE H_Wind := Y_MaxW - Y0 - 70 // Высота окна для самого графика PRIVATE mNX := 10, mNY := 10 // Кол-во меток и надписей по осям X и Y PRIVATE Kx := W_Wind / ( X_MaxA-X_MinA ) // Коэффициент масштабирования по оси X: преобразует аргумент функции в номер пикселя по оси X PRIVATE Ky := H_Wind / ( Y_MaxF-Y_MinF ) // Коэффициент масштабирования по оси Y: преобразует значение функции в номер пикселя по оси Y PRIVATE Y0A := IF(Y_MinF > 0, Y0, Y0+ABS(Y_MinF)*Ky) // Позиция оси X на оси Y **** Написать заголовок диаграммы aFonts := XbpFont():new():list() // Все доступные шрифты oFont := XbpFont():new():create("18.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты mTitle = 'ЧАСТОТНОЕ РАСПРЕДЕЛЕНИЕ ЗНАЧЕНИЙ ЧАСТНЫХ КРИТЕРИЕВ В МОДЕЛИ: "'+UPPER(Ar_Model[mNumMod])+'"' aTxtPar = DC_GraQueryTextbox(mTitle, oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox("Длина текста в пикселях="+ALLTRIM(STR(aTxtPar[1]))+". Высота текста в пикселях="+ALLTRIM(STR(aTxtPar[2]))) GraStringAt( oPS, { X_MaxW/2, Y_MaxW-25 }, mTitle) oFont := XbpFont():new():create("14.Arial Bold") GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты IF LEN(ALLTRIM(M_NameAppl)) < 70 GraStringAt( oPS, { X_MaxW/2, Y_MaxW-52 }, "Приложение: "+'"'+ALLTRIM(M_NameAppl)+'"' ) ELSE GraStringAt( oPS, { X_MaxW/2, Y_MaxW-52 }, '"'+ALLTRIM(M_NameAppl)+'"' ) ENDIF oFont := XbpFont():new():create("10.Arial") GraSetFont( oPS ,oFont ) aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты ***** Закрасить фон прямоугольника *************** GraSetColor( oPS, aColor[98] , aColor[98] ) GraBox( oPS, { X0, Y0 }, { X0+W_Wind, Y0+H_Wind }, GRA_FILL ) GraSetColor( oPS, aColor[222] , aColor[222] ) ***** Нарисовать оси координат ******************* aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 2 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты GraLine( oPS, {X0 , Y0A }, {X0+W_Wind, Y0A } ) // Нарисовать ось X GraLine( oPS, {X0 , Y0 }, {X0 , Y0+H_Wind} ) // Нарисовать границу рамки изображения слева это и есть ось Y GraLine( oPS, {X0 , Y0 }, {X0+W_Wind, Y0 } ) // Нарисовать границу рамки изображения внизу параллельно оси X GraLine( oPS, {X0 , Y0+H_Wind}, {X0+W_Wind, Y0+H_Wind} ) // Нарисовать границу рамки изображения вверху параллельно оси X GraLine( oPS, {X0+W_Wind, Y0 }, {X0+W_Wind, Y0+H_Wind} ) // Нарисовать границу рамки изображения справа параллельно оси Y aAttr := ARRAY( GRA_AM_COUNT ) // Массив для атрибутов маркеров aAttr [ GRA_AM_SYMBOL ] := GRA_MARKSYM_PLUS GraSetAttrMarker( oPS, aAttr ) aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DOT aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты *** Закрасить области между метками на оси X ***** DX = ( X_MaxA-X_MinA ) / mNX // Диапазон значений x, через которое ставить метку GraSetColor( oPS, aColor[99], aColor[99] ) j = 0 FOR X=X_MinA TO X_MaxA STEP 2*DX j = j + 2 X1 = X0 + ( j - 1 ) * DX * Kx X2 = X0 + ( j ) * DX * Kx GraBox( oPS, { X1, Y0 }, { X2, Y0 + H_Wind }, GRA_FILL ) NEXT GraSetColor( oPS, aColor[222], aColor[222] ) *** Сделать сетку и надписать метки на оси X ********************* DX = ( X_MaxA-X_MinA ) / mNX // Диапазон значений x, через которое ставить метку j = 0 FOR X=X_MinA TO X_MaxA STEP DX ++j X1 = X0 + ( j - 1 ) * DX * Kx GraMarker ( oPS, { X1, Y0 } ) aTxtPar = DC_GraQueryTextbox(ALLTRIM(STR(X,15,1)), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox(STR(aTxtPar[1])+" "+STR(aTxtPar[2])) GraStringAt( oPS, { X1-aTxtPar[1]/2, Y0-25 }, ALLTRIM(STR(X,15,1)) ) GraLine ( oPS, { X1, Y0 }, {X1, Y0+H_Wind} ) // Нарисовать пунктирную линию уровня x NEXT j = mNX X1 = X0 + j * DX * Kx GraMarker ( oPS, { X1, Y0 } ) aTxtPar = DC_GraQueryTextbox(ALLTRIM(STR(X_MaxA,15,1)), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox(STR(aTxtPar[1])+" "+STR(aTxtPar[2])) GraStringAt( oPS, { X1-aTxtPar[1]/2, Y0-25 }, ALLTRIM(STR(X_MaxA,15,1)) ) GraLine ( oPS, { X1, Y0 }, {X1, Y0+H_Wind} ) // Нарисовать пунктирную линию уровня x *** Сделать сетку и надписать метки на оси Y ********************* DY = ( Y_MaxF-Y_MinF ) / mNY // Диапазон значений Y, через которое ставить метку j = 0 FOR Y=Y_MinF TO Y_MaxF STEP DY ++j Y1 = Y0 + ( j - 1 ) * DY * Ky GraMarker ( oPS, { X0 , Y1 } ) aTxtPar = DC_GraQueryTextbox(ALLTRIM(STR(Y,15,1)), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox(STR(aTxtPar[1])+" "+STR(aTxtPar[2])) GraStringAt( oPS, { X0-35, Y1-aTxtPar[2]/2 }, ALLTRIM(STR(Y,15,1)) ) GraLine ( oPS, { X0 , Y1 }, {X0+W_Wind, Y1} ) // Нарисовать пунктирную линию уровня Y NEXT j = mNY Y1 = Y0 + j * DY * Ky GraMarker ( oPS, { X0 , Y1 } ) aTxtPar = DC_GraQueryTextbox(ALLTRIM(STR(Y_MaxF,15,1)), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox(STR(aTxtPar[1])+" "+STR(aTxtPar[2])) GraStringAt( oPS, { X0-35, Y1-aTxtPar[2]/2 }, ALLTRIM(STR(Y_MaxF,15,1)) ) GraLine ( oPS, { X0 , Y1 }, {X0+W_Wind, Y1} ) // Нарисовать пунктирную линию уровня Y ***** Рисование маркеров и отрезков прямых *************************************************** ***** Сделать рисование линий двух цветов, внутри посветлее, а снаружи потемнее (эффект объема) ***** для этого рисовать от внешних частей линии к внутренним уменьшающейся толщиной линии и более светлым цветом ПОВЕРХ РАНЕЕ НАРИСОВАННОГО aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DOT aAttr [ GRA_AL_COLOR ] := aColor[181] // Задать цвет снаружи линии aAttr [ GRA_AL_WIDTH ] := 5 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO LEN(aArg) X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aVal[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aVal[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[108] // Задать цвет внутри линии aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO LEN(aArg) X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aVal[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aVal[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT aAttr [ GRA_AL_COLOR ] := aColor[180] // Задать цвет внутри линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO LEN(aArg) X1 := X0 + (aArg[j-1]-X_MinA) * Kx Y1 := Y0A + (aVal[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aVal[j ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT ***** Рисование маркеров на линии IF LEN(aArg) <= 64 aAttr := ARRAY( GRA_AM_COUNT ) // Массив для атрибутов маркеров aAttr[ GRA_AM_SYMBOL ] := GRA_MARKSYM_DOT GraSetAttrMarker( oPS, aAttr ) FOR j=1 TO LEN(aArg) X := X0 + (aArg[j]-X_MinA) * Kx Y := Y0A + (aVal[j]-Y_MinF) * Ky IF LEN(aArg) <= 32 aAttr[ GRA_AM_SYMBOL ] := GRA_MARKSYM_SMALLCIRCLE GraSetAttrMarker( oPS, aAttr ) GraMarker( oPS, { X, Y } ) // отобразить маркер ENDIF aAttr[ GRA_AM_SYMBOL ] := GRA_MARKSYM_DOT GraSetAttrMarker( oPS, aAttr ) GraMarker( oPS, { X, Y } ) // отобразить маркер * GraStringAt( oPS, { X, Y }, '('+ALLTRIM(STR(aArg[j],15,1))+','+ALLTRIM(STR(aVal[j],15,1))+')') NEXT ENDIF ***** Нарисовать оси координат ********************************** aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 2 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты графической линии GraLine( oPS, {X0 , Y0A }, {X0+W_Wind, Y0A } ) // Нарисовать ось X GraLine( oPS, {X0 , Y0 }, {X0 , Y0+H_Wind} ) // Нарисовать границу рамки изображения слева это и есть ось Y GraLine( oPS, {X0 , Y0 }, {X0+W_Wind, Y0 } ) // Нарисовать границу рамки изображения внизу параллельно оси X GraLine( oPS, {X0 , Y0+H_Wind}, {X0+W_Wind, Y0+H_Wind} ) // Нарисовать границу рамки изображения вверху параллельно оси X GraLine( oPS, {X0+W_Wind, Y0 }, {X0+W_Wind, Y0+H_Wind} ) // Нарисовать границу рамки изображения справа параллельно оси Y ****** Легенда *************************************************** Offset = -62 // Смещение вниз относительно нуля Y0 для позиции легенды Interval = 15 ***** Нарисовать рамку легенды aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты графической линии X1 := X0 Y1 := Y0 + Offset X2 := X0 + W_Wind Y2 := Y0 + Offset - 5 * Interval - 22 ***** Закрасить фон прямоугольника *************** GraSetColor( oPS, aColor[129] , aColor[129] ) GraBox( oPS, { X1, Y1 }, { X2, Y2 }, GRA_FILL) GraSetColor( oPS, aColor[222] , aColor[222] ) GraBox( oPS, { X1, Y1 }, { X2, Y2 } ) ***** Сделать надписи в легенде aAttr[ GRA_AL_COLOR ] := aColor[17] // Задать цвет линии aAttr[ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты mStr1 = L('Частотное распределение значений частного критерия в определенной модели представляет собой график, отражающий сколько раз в данной модели встретилось каждое значение интегрального критерия. Идеальным является случай, когда значения частного критерия') mStr2 = L('меньше 5 вообще не встречаются в модели ABS. Если в этой модели такие значения встречаются чаще других, то это говорит о недостаточности статистики, т.е. том, что в обучающей выборке недостаточно примеров. В этом случае желательно увеличить обучающую') mStr3 = L('выборку или/и уменьшить количество градаций в числовых шкалах и использовать адаптивные интервалы. Наилучшей для решения задач идентификации, прогнозирования, принятия решений и исследования предметной области путем исследования ее модели является ') mStr4 = L('та из моделей Abs, Prc#, Inf#, в которой некоторые средние по величине значения частного критерия встречаются чаще всего, а большие и меньшие значения встречаются тем реже, чем сильнее отличаются от этого среднего, как в нормальном распределении. ') X1 := X0 + 20 Y1 := Y0 + Offset - Interval X2 := X1 + 190 Y2 := Y0 + Offset - 1 * Interval;GraStringAt( oPS, { X1, Y2-4 }, mStr1) Y2 := Y0 + Offset - 2 * Interval;GraStringAt( oPS, { X1, Y2-4 }, mStr2) Y2 := Y0 + Offset - 3 * Interval;GraStringAt( oPS, { X1, Y2-4 }, mStr3) Y2 := Y0 + Offset - 4 * Interval;GraStringAt( oPS, { X1, Y2-4 }, mStr4) oFont := XbpFont():new():create("13.ArialBold") GraSetFont( oPS ,oFont ) aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := aColor[123] aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты Y2 := Y0 + Offset - 5 * Interval;GraStringAt( oPS, { X1, Y2-6 }, L('Иформационная мощность модели: "')+UPPER(Ar_Model[mNumMod])+'"='+ALLTRIM(STR(mInfPow,19,5))+'. '+; L('Путь на отображаемый файл:')+' '+M_PathAppl+"FreqPartCrit\"+"FreqPartCrit-"+UPPER(Ar_Model[mNumMod])+".jpg. "+; L('Форма создана:')+' '+DTOC(DATE())+"-"+TIME()) * mInfPow = 0 // Иформационная мощность модели (Количественная мера степени выраженности закономерностей в моделируемой предметной области) ****** Надписи координатных осей ********************************* AxName = L("Значения частного критерия") GraStringAt( oPS, { X0+W_Wind/2-8*LEN(AxName)/2, Y0-45 }, AxName ) // Надпись оси Х AyName = L("Количество значений частного критерия") aMatrix := GraInitMatrix() GraRotate( oPS, aMatrix, 90, { X0-53, Y0+H_Wind/2-8*LEN(AyName)/2 }, GRA_TRANSFORM_ADD ) oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) GraStringAt( oPS, { X0-53, Y0+H_Wind/2-8*LEN(AyName)/2 }, AyName ) // Надпись оси Y ****** Не получается отключить режим вращения изображения ****** Вместо отключения можно докрутить до 360 градусов X_Max := 1800 Y_Max := 850 // Размер графического окна для самого графика в пикселях aMatrix := GraInitMatrix() // <<<########## GraRotate( oPS, aMatrix, 0, {900, 425}, GRA_TRANSFORM_REPLACE ) // <<<########## oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) // <<<########## RETURN NIL ************************************************************************************************************ ******** 4.1.2. Пакетное распознавание в текущей базе знаний ############## ******* Распознаются по очереди все объекты распознаваемой выборки в базе знаний, ############## ******* заданной текущей в режиме 5.6 ############## ******* Почему-то ОЧЕНЬ медленно, на много медленнее, чем при запуске из 3.5. Может быть из-за прогресс-бар? ******* С функцией выдачи результатов распознавания в форме, сходной с Inp_data с обоими интегральными критериями в кодах и наименованиях с указанием уровней сходства (идея Александра Петровича Трунева) ************************************************************************************************************ // В режиме распознавания сделать формирование БД итогов: Rsp_it1k, Rsp_it2k, Rsp_it1i, Rsp_it2i, // достоверность в итогах считать по-другому: ср.кв.откл. уровней сходства деленное на теор.максимальное ср.кв.откл. в % // После расчета записать БД Rsp_it2k, Rsp_it2i с именами: Rsp_it2k_###, Rsp_it2i_###, где ### - наименование модели #include "inkey.ch" #include "dcdir.ch" #include "appevent.ch" #include "xbp.ch" #include "dll.ch" #include "dccursor.ch" #Include "thread.ch" #include "class.ch" #include "dmlb.ch" #include "fileio.ch" #include "dctree.ch" *#include "SystemMetrics.ch" *#include "axcdxcmx.ch" // Графика ActiveX #include "collat.ch" #include "common.ch" #include "dbedit.ch" #include "Dbfdbe.ch" #include "dcapp.ch" #include "dcbitmap.ch" #include "dccargo.ch" #include "dcdialog.ch" #include "dcdir.ch" #include "dcfiles.ch" #include "dcgra.ch" #include "dcgraph.ch" // графика #include "BdColors.Ch" // графика #include "dccolors.ch" // графика #include "dcprint.ch" // графика #include "Dcicon.ch" #include "dcmsg.ch" #include "dcpick.ch" #include "deldbe.ch" #include "directry.ch" #include "dmlb.ch" #include "express.ch" #include "fileio.ch" #include "font.ch" #include "gra.ch" #include "inkey.ch" #include "memvar.ch" #include "natmsg.ch" #include "prompt.ch" #include '_dcdbfil.ch' #include "set.ch" #include "std.ch" #include "xbp.ch" #include '_dcappe.ch' #include 'dcscope.ch' #include '_dcstru.ch' #include 'dcfields.ch' #include 'dccolor.ch' *#include "Fileio.ch" // Max_DB *#include "rmchart.ch" // Графика ActiveX #include "dcads.ch" #pragma Library( "ASINet10.lib" ) // 2.0 // Для альтернативного и неальтернативного выбора в просмотре таблиц *#define BMP_CHECKED "check1.bmp" *#define BMP_UNCHECKED "check2.bmp" *#define BMP_RACHECKED "radio1.bmp" *#define BMP_RAUNCHECKED "radio2.bmp" *#include "test.ch" #define BMP_CHECKED 10002 #define BMP_UNCHECKED 10003 #define BMP_RACHECKED 10004 #define BMP_RAUNCHECKED 10005 #pragma library( "ascom10.lib" ) #pragma library( "dclip1.lib" ) #pragma library( "dclip2.lib" ) #pragma library( "dclipx.lib" ) #pragma library( "xbtbase1.lib" ) #pragma library( "xbtbase2.lib" ) #pragma library( "xppui2.lib" ) #pragma library( "XPPRT0.LIB" ) #Pragma Library("Taskbar.lib") #xtranslate NTrim() => LTrim(Str()) #define USE_HTTPCLIENT // comment out to try Method2 //#include "Imgview.ch" /* * We use user defined events */ #define xbeDS_DirChanged xbeP_User + 100 #define xbeFS_FileMarked xbeP_User + 101 #define xbeFS_FileSelected xbeP_User + 102 #define DCAREAMSG_1 'Invalid Expression in Index Key:' /* * This directive calculates a centered position */ #xtrans CenterPos( , ) => ; { Int( (\[1] - \[1]) / 2 ) ; , Int( (\[2] - \[2]) / 2 ) } #define DC_RDDMSG_1 'Invalid RDD selection - '+cSuperRdd #define DC_RDDMSG_2 'DBE Name Description' #define DC_RDDMSG_3 'Select a Database Driver' *#define ADSDBE_MEMOFILE_EXT (DBE_USER+1) // RO *#define ADSDBE_INDEX_EXT (DBE_USER+2) // RW *#define ADSDBE_TBL_MODE (DBE_USER+3) // RW *#define ADSDBE_LOCK_MODE (DBE_USER+4) // RW *#define ADSDBE_RIGHTS_MODE (DBE_USER+5) // RW *#define ADSDBE_MEMOBLOCKSIZE (DBE_USER+6) // RW *#define ADSDBE_PASSWORD (DBE_USER+7) // RW // Return types of ADSDBE_TBL_MODE *#define ADSDBE_NTX 1 *#define ADSDBE_CDX 2 *#define ADSDBE_ADT 3 // Для опредедения разрешения монитора от Джимми #define DESKTOPVERTRES 117 #define DESKTOPHORZRES 118 // Excel Orientation #DEFINE xlLandscape 2 #DEFINE xlPortrait 1 #DEFINE xlWorkbookNormal -4143 #DEFINE xlCellTypeLastCell 11 #DEFINE SRCCOPY 0xCC0020 // Для быстрой графики Роджера #define KEYEVENTF_KEYUP 0x02 #define VK_MENU 0x12 #define VK_SNAPSHOT 0x2C #DEFINE VK_LBUTTON 0x01 #DEFINE VK_RBUTTON 0x02 * Для CSV=>DBF конвертера *#include "ot4xb.ch" // => ot4xb.dll => www.xbwin.com #ifndef CRLF #define CRLF chr(13)+chr(10) #endif * Klasse zum sequentiellen Einlesen groбer Dateien *#IF .t. // zum Einbinden in eigenes Projekt, .f. setzen ! *STATIC snHdll ********************************************************************************* FUNCTION F4_1_2(mNumModel, Dialog, Regim, mProcessor, mAlgorithm, mVisualization) * F4_1_2(M_NumMod, .F., "3_5", mProcessor, mAlgorithm, mVisualization) // Провести распознавание в текущей модели (без диалога, но с отображением стадии исполнения) включить Model_rec.exe в состав F4_1_2 <===####### LOCAL lOk, lCancelled := .F. Running(.T.) *MsgBox(mProcessor) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF ApplChange("4.1.2()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF mFlagErr = .F. // Проверка существования распознаваемой выборки и исходных баз знаний IF FILE("_CalcInf.arx") // Файл с информацией о том, какие модели были рассчитаны ранее aCalcInf = DC_ARestore("_CalcInf.arx") ELSE LB_Warning(L("Распознавание не может быть проведено, т.к. не просчитаны модели в 3-й подсистеме !!! ", '4.1.2. Пакетное распознавание' )) mFlagErr = .T. ENDIF * FOR j=1 TO LEN(aCalcInf) * IF aCalcInf[j] * MsgBox(STR(j)) * ENDIF * NEXT IF FILE("_CurrInf.arx") // Файл с информацией о том, какая модель задана текущей M_CurrInf = DC_ARestore("_CurrInf.arx") ELSE LB_Warning(L("Распознавание не может быть проведено, т.к. нет информации о том, какая модель знаний является текущей !!! ")) mFlagErr = .T. ENDIF IF 1 <= mNumModel .AND. mNumModel <= 10 Ar_Model := {"Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } IF aCalcInf[mNumModel] M_CurrInf = mNumModel ELSE Mess = L('Распознавание не может быть проведено, т.к. заданная модель: "#" не просчитана в 3-й подсистеме !!! ') Mess = STRTRAN(Mess, "#", Ar_Model[mNumModel]+".txt" ) LB_Warning(Mess, L('4.1.2. Пакетное распознавание' )) mFlagErr = .T. ENDIF ELSE mNumModel = M_CurrInf // Если модель задана некорректно - использовать текущую ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rso_Zag INDEX Roz_kod EXCLUSIVE NEW;N_Obj = RECCOUNT() IF N_Obj = 0 aMess := {} AADD(amess, L("Распознавание не может быть проведено, т.к. распознаваемая выборка пуста !!! ")) AADD(amess, L("Заполнить ее можно в программных интерфейсах (API) в подсистеме 2.3.2 и режиме 4.1.1.")) AADD(amess, L("Также в режимах 3.2, 3.3. и 3.5 в распознаваемую выборку копируется обучающая выборка.")) LB_Warning(aMess) mFlagErr = .T. ENDIF IF .NOT. aCalcInf[M_CurrInf] LB_Warning(L("Распознавание не может быть проведено, т.к. не создана база знаний, заданная как текущая !!! ")) mFlagErr = .T. ENDIF IF mFlagErr ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF IF Dialog IF FILE("_RaspInf.arx") // Файл с информацией о том, в какой модели было проведено распознавание M_RaspInf = DC_ARestore("_RaspInf.arx") Ar_Model := {"Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } IF M_CurrInf <> M_RaspInf Mess = L("Распознавание проводилось ранее в модели: #, отличающейся от текущей: $") Mess = STRTRAN(Mess, "#", Ar_Model[M_RaspInf]) Mess = STRTRAN(Mess, "$", Ar_Model[M_CurrInf]) LB_Warning(Mess, L("Информационное сообщение")) ELSE Mess = L("В этой модели # распознавание уже проводилось ранее") Mess = STRTRAN(Mess, "#", Ar_Model[M_RaspInf]) LB_Warning(Mess, L("Информационное сообщение")) ENDIF ELSE LB_Warning(L("Распознавание проводится впервые !!!"), L("Информационное сообщение")) ENDIF ENDIF IF FILE("Rso_Zag.dbf") // БД заголовков распознаваемой выборки ** Переиндексировать БД Rso_Zag.dbf, ** если не хватает хотя бы одного какого-нибудь индексного массива IF .NOT. FILE("Roz_kod.ntx" ) .OR.; .NOT. FILE("Roz_name.ntx") .OR.; .NOT. FILE("Rso_Zag.ntx" ) GenNtxRsoZag() ENDIF ELSE GenDbfRsoZag() ENDIF IF FILE("Rso_Kcl.dbf") // БД классов распознаваемой выборки ** Переиндексировать БД Rso_Kcl.dbf, ** если не хватает хотя бы одного какого-нибудь индексного массива IF .NOT. FILE("Roc_kod.ntx") .OR.; .NOT. FILE("Rso_Kcl.ntx") GenNtxRsoKcl() ENDIF ELSE GenDbfRsoKcl() ENDIF IF FILE("Rso_Kpr.dbf") // БД признаков распознаваемой выборки ** Переиндексировать БД Rso_Kpr.dbf, ** если не хватает хотя бы одного какого-нибудь индексного массива IF .NOT. FILE("Oip_kod.ntx") .OR.; .NOT. FILE("Rso_Kpr.ntx") GenNtxRsoKpr() ENDIF ELSE GenDbfRsoKpr() ENDIF nRadioP = IF(mProcessor='CPU', 1, 2) IF FILE('_PerDel.txt') mPerDel = VAL(FileStr('_PerDel.txt')) ELSE mPerDel = 0 ENDIF * nRadioP = 2 * mAlgorithm = 2 * mVisualization = 1 IF Dialog @0,0 DCGROUP oGroup1 CAPTION L('На каком процессоре выполнять распознавание:') SIZE 57, 10.7 @1.0, 2 DCRADIO nRadioP VALUE 1 PROMPT L('На центральном процессоре (CPU)') PARENT oGroup1 @2.0, 2 DCRADIO nRadioP VALUE 2 PROMPT L('На графическом процессоре (GPU)') PARENT oGroup1 @4, 2 DCGROUP oGroup2 CAPTION L('Задайте алгоритм идентификации:') SIZE 53, 5.7 PARENT oGroup1 HIDE {|| .NOT.nRadioP=1} @1, 2 DCRADIO mAlgorithm VALUE 1 PROMPT L('Классический, работает дольше') PARENT oGroup2 @2, 2 DCRADIO mAlgorithm VALUE 2 PROMPT L('Упрощенный, работает быстрее') PARENT oGroup2 @4, 2 DCSAY L('Модель для распознавания задается в режиме 5.6') PARENT oGroup2 @4, 2 DCGROUP oGroup3 CAPTION L('Отображать стадию процесса исполнения ?') SIZE 53, 5.7 PARENT oGroup1 HIDE {|| .NOT.nRadioP=2} @1, 2 DCRADIO mVisualization VALUE 1 PROMPT L('Без визуализации:') PARENT oGroup3 @2, 2 DCRADIO mVisualization VALUE 2 PROMPT L('Визуализация 3 с.') PARENT oGroup3 @4, 2 DCSAY L('Модель для распознавания задается в режиме 5.6') PARENT oGroup3 @11 , 0 DCGROUP oGroup4 CAPTION L('Учитывать только наиболее достоверные результаты распознавания:') SIZE 57, 3.7 @1 , 2 DCSAY L('с МОДУЛЕМ интегрального критерия "Резонанс знаний" не менее:') PARENT oGroup4 @2 , 1 DCSAY L('') GET mPerDel PICTURE "###.#######" PARENT oGroup4 @2.12, 16 DCSAY ' % ' PARENT oGroup4 * StrFile(ALLTRIM(STR(mPerDel,17,7)),'_PerDel.txt') * StrFile(ALLTRIM(STR(mAlgorithm,1)),'_Algorithm.txt') * StrFile(ALLTRIM(STR(mVisualization,1)),'_Visualization.txt') DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; OPTIONS GetOptions ; ADDBUTTONS; MODAL ; TITLE L('4.1.2. Пакетное распознавание в текущей модели') mProcessor = IF(nRadioP=1,'CPU','GPU') * mPerDel = IF(mPerDel > 0, mPerDel, 0) * mPerDel = IF(mPerDel < 100, mPerDel, 100) ***************************************************************** IF lExit ** Button Ok ELSE ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ***************************************************************** ENDIF StrFile(ALLTRIM(STR(mPerDel,17,7)),'_PerDel.txt') StrFile(ALLTRIM(STR(mAlgorithm,1)),'_Algorithm.txt') StrFile(ALLTRIM(STR(mVisualization,1)),'_Visualization.txt') dbeSetDefault('DBFNTX') // Создать базы результатов распознавания для расчетов и визуализации, а также итогов распознавания GenDbfRspC() // Для расчетов GenDbfRspV(mNumModel) // Для визуализации GenDbfRspIt() // Для итогов IF Regim = '3_5' .OR. Regim = '3_3' .OR. Regim = '4_1_2' // ЭТО ДЕЛАТЬ ТОЛЬКО ЕСЛИ ПРОВОДИТСЯ ПАКЕТНОЕ РАСПОЗНАВАНИЕ ВО ВСЕХ МОДЕЛЯХ (может быть еще в режиме 3.3.). ***** Создание БД для исследования зависимости ***** количества совпадений результатов распознавания с фактом ***** для различных по величине параметров сходства ПО ОБОИМ ИНТЕГРАЛЬНЫМ КРИТЕРИЯМ ***** Это аргументированный ответ на вопрос о том, отражает ли уровень сходства ***** распознаваемых объектов с классами фактическую принадлежность этих объектов к классам, ***** т.е. можно ли рассматривать уровень сходства объектов с классами как работоспособный ***** количественный критерий дейсвительно отражающий степень принадлежности объектов к классам ***** и самооценку системы по достоверности распознавания объекта, т.е. степени надежности решения об отнесении его к классу aModName := {L('1. ABS -частн.крит.: кол-во встреч сочетаний: "класс-признак" у объектов обуч.выборки '),; L('2. PRC1-частн.крит.: усл. вероятность i-го признака среди признаков объектов j-го класса'),; L('3. PRC2-частн.крит.: усл. вероятность i-го признака у объектов j-го класса '),; L('4. INF1-частн.крит.: кол-во знаний по А.Харкевичу; вероятности из PRC1 '),; L('5. INF2-частн.крит.: кол-во знаний по А.Харкевичу; вероятности из PRC2 '),; L('6. INF3-частн.крит.: Xи-квадрат, разности между фактическими и ожидаемыми абс.частотами '),; L('7. INF4-частн.крит.: ROI (Return On Investment); вероятности из PRC1 '),; L('8. INF5-частн.крит.: ROI (Return On Investment); вероятности из PRC2 '),; L('9. INF6-частн.крит.: разн.усл.и безусл.вероятностей; вероятности из PRC1 '),; L('10.INF7-частн.крит.: разн.усл.и безусл.вероятностей; вероятности из PRC2 ') } mMaxLen = -9999 FOR j=1 TO LEN(aModName) mMaxLen = MAX(mMaxLen, LEN(ALLTRIM(aModName[j]))) NEXT aStructure := { { "Name" , "C",mMaxLen, 0} } // 1 FOR j=1 TO 201 FieldName = "N"+ALLTRIM(STR(j,15)) AADD(aStructure, { FieldName , "N", 15, 0 }) NEXT DbCreate( "DostRasp.dbf", aStructure ) // БД для объединения БД достоверности расп.в текущей модели M_DostRsp := "DostRsp"+ALLTRIM(STR(M_CurrInf,3)) // Имя текущей БД достоверности распознавания в текущей модели DbCreate( M_DostRsp, aStructure ) A_ursx := {} // Массив уровней сходства в диапазоне: {-100%, 0, +100%} всего с нулем 201 элемент // для поиска позиции для суммирования *************** МАССИВЫ для разных инт.критериев: *************** - ИСТИННО-ПОЛОЖИТЕЛЬНЫЕ ########## A_TPk := {} A_TPi := {} *************** - ИСТИННО-ОТРИЦАТЕЛЬНЫЕ ########## A_TNk := {} A_TNi := {} *************** - ЛОЖНО-ПОЛОЖИТЕЛЬНЫЕ ########## A_FPk := {} A_FPi := {} *************** - ЛОЖНО-ОТРИЦАТЕЛЬНЫЕ ########## A_FNk := {} A_FNi := {} *************** ИХ ВСЕ ПОКАЗЫВАТЬ ОТДЕЛЬНО FOR j=-100 TO +100 AADD(A_ursx , j) AADD(A_TPk, 0) AADD(A_TNk, 0) AADD(A_FPk, 0) AADD(A_FNk, 0) AADD(A_TPi, 0) AADD(A_TNi, 0) AADD(A_FPi, 0) AADD(A_FNi, 0) NEXT ENDIF ***** Переиндексация CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rso_Zag EXCLUSIVE NEW INDEX ON STR(Kod_Obj,19) TO Roz_kod CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rso_Kcl EXCLUSIVE NEW INDEX ON STR(Kod_Obj,19) TO Roc_kod CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rso_Kpr EXCLUSIVE NEW INDEX ON STR(Kod_Obj,19) TO Rop_kod ******** Создаем стат.базы и базы знаний (7 по частным критериям знаний) Ar_Model := {"Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } PRIVATE nHandle[LEN(Ar_Model)] AFILL(nHandle, 0) mModelName = Ar_Model[M_CurrInf]+".txt" IF .NOT. FILE(mModelName) // БД заголовков распознаваемой выборки aMess := {} AADD(aMess, L('Распознавание не может быть проведено,')) AADD(aMess, L('т.к. отсутствует текущая база знаний: "#"!')) AADD(aMess, L('Создайте ее в 3-й подсистеме! ')) aMess[1] = STRTRAN(aMess[1], "#", mModelName) LB_Warning(aMess, L('4.1.2. Пакетное распознавание')) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF // Провести пакетное распознавание DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения mLenNameMax = CreateStructAll() // Создание файлов структур баз данных всех моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() // Количество классов (градаций классификационных шкал) USE Gr_OpSc EXCLUSIVE NEW;N_Gos = RECCOUNT() // Количество признаков (градаций описательных шкал) USE Opis_Sc EXCLUSIVE NEW USE Rso_Zag INDEX Roz_kod EXCLUSIVE NEW;N_Obj = RECCOUNT() USE Rso_Kcl INDEX Roc_kod EXCLUSIVE NEW USE Rso_Kpr INDEX Rop_kod EXCLUSIVE NEW USE Rasp EXCLUSIVE NEW;ZAP;N_Rasp = N_Obj * N_Cls IF Regim = '3_5' .OR. Regim = '3_3' .OR. Regim = '4_1_2' // ЭТО ДЕЛАТЬ ТОЛЬКО ЕСЛИ ПРОВОДИТСЯ ПАКЕТНОЕ РАСПОЗНАВАНИЕ ВО ВСЕХ МОДЕЛЯХ (может быть еще в режиме 3.3.). USE (M_DostRsp) EXCLUSIVE NEW;ZAP ENDIF * USE Inf EXCLUSIVE NEW // Распознавание вести в текущей модели ################################################################ * ########################################################################### // Открытие текстовых баз данных ******************************************** *StrFile(ALLTRIM(STR(nRadioModel)), '_Calc_model_2nd_level.txt') mModel_2nd_level = VAL(FileStr('_Calc_model_2nd_level.txt')) // = 1 - создавать только базовые модели, иначе - создавать модели 2-го или 3-го уровней *MsgBox(STR(M_CurrInf)) IF M_CurrInf = 1 .AND. mModel_2nd_level = 1 *DC_ASave(aInfStruct, "_AbsStruct.arx.arx") // Когда БД создается - записывать структуру, когда открывается - считывать aInfStruct = DC_ARestore("_AbsStruct.arx") ELSE *DC_ASave(aInfStruct, "_InfStruct.arx") // Когда БД создается - записывать структуру, когда открывается - считывать aInfStruct = DC_ARestore("_InfStruct.arx") ENDIF *DC_DebugQout( aInfStruct ) ************************************************* ***** Формирование пустой записи N_Col = N_Cls+6 // Число полей CrLf = CHR(13)+CHR(10) // Конец строки (записи) Lc_buf = "" FOR j=1 TO N_Col * S = IF(j=2*INT(j/2),"#","X") // Для отладки S = " " // Для работы Lc_buf = Lc_buf + REPLICATE(S, aInfStruct[j,3]) NEXT Lc_buf = Lc_buf + CrLf Len_LcBuf = LEN(Lc_buf) nHandle[M_CurrInf] := FOpen( Ar_Model[M_CurrInf]+".txt", FO_READWRITE ) // Открыть текущую базу знаний ################################### **** Рассчет массива начальных позиций полей в строке PRIVATE aPos[N_Col] aPos[1] = 1 FOR j=2 TO N_Col aPos[j] = aPos[j-1] + aInfStruct[j-1,3] NEXT * ########################################################################### PRIVATE Ar_Lok[N_Gos] // Создание массива-локатора ****** Создание массива: значение элемента с индексом-кодом класса является код класс.шкалы SELECT Classes PRIVATE aKodClSc[N_Cls] DBGOTOP() DO WHILE .NOT. EOF() aKodClSc[Kod_cls] = Kod_ClSc DBSKIP(1) ENDDO ********************************************************************************* IF Dialog // Подготовка данных для отображения графического прогресс-бар // Определить значение Wsego // Задание максимальной величины параметра Time Что-здесь не так, время рассчитывается ошибочно ############################################## Wsego8 = N_Obj // По шагам 1-11 * Wsego9 = N_Rasp * Wsego10 = N_Obj+N_Rasp+(5+N_Obj)*2 * Wsego11 = N_Rasp * Wsego12 = N_Rasp * Wsego13 = N_Obj * Wsego14 = N_Obj+N_Obj*2 * Wsego15 = N_Rasp * Wsego16 = N_Rasp * Wsego17 = N_Cls * Wsego18 = N_Cls+N_Cls*2 * Wsego = Wsego8+Wsego9+Wsego10+Wsego11+Wsego12+Wsego13+Wsego14+Wsego15+Wsego16+Wsego17+Wsego18 Wsego = Wsego8 + 17 Time_progress = 0 // Прошло секунд с начала процесса // Процесс может идти больше суток, поэтому для определения // во всех случаях вычисляется время, прошедшее с начала года T_Mess1 = L("Начало:")+" "+TIME() // Начало Sec_1 = (DOY(DATE())-1)*86400+SECONDS() PUBLIC T1 := (DOY(DATE())-1)*86400+SECONDS() // Время предыдущей индикации процесса исполнения PUBLIC T2 := (DOY(DATE())-1)*86400+SECONDS()+1 // Текущее время (1-й раз оно заметно больше T1 чтобы было отображение) PUBLIC T1tp := T1 PUBLIC T2tp := T2 // Отображение стадии исполнения. Будет написано прямо в окне Progress-bar @ 0,0 DCGROUP oGroup1 CAPTION L('Стадии исполнения процесса') FONT "6.Helv" SIZE 105,13.5 ; PARENT oTabPage1 @15,0 DCGROUP oGroup2 CAPTION L('Прогноз времени исполнения') FONT "6.Helv" SIZE 105,5.0 ; PARENT oTabPage2 s = 1 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 7] FONT "10.Helv" // Зарезервировано под наименование операции @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 8] FONT "10.Helv" // 1 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 9] FONT "10.Helv" // 2 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[10] FONT "10.Helv" // 3 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[11] FONT "10.Helv" // 4 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[12] FONT "10.Helv" // 5 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[13] FONT "10.Helv" // 6 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[14] FONT "10.Helv" // 7 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[15] FONT "10.Helv" // 8 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[16] FONT "10.Helv" // 9 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[17] FONT "10.Helv" // 10 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[18] FONT "10.Helv" // 11 s++ @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay97 FONT "10.HelvBold" s++ @0.2+s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay98 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @1.5+s ,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay99 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @s ,1 DCPROGRESS oProgress ; SIZE 95,1.5 ; PERCENT ; EVERY 1+INT(Wsego/nEvery) ; // Кол-во обновлений изображения MAXCOUNT Wsego ; COLOR GRA_CLR_CYAN // Цвет полосы @s++,97 DCPUSHBUTTON CAPTION L('&Cancel') ; ACTION {||lCancelled:=.T.} OBJECT oButton ; SIZE 7,1.5 DCREAD GUI ; TITLE L('4.1.2. Пакетное распознавание. Текущая модель: "')+UPPER(Ar_Model[M_CurrInf])+'"' ; PARENT @oDialog ; FIT ; EXIT ; MODAL oDialog:show() // Завершение подготовки данных для отображения графического прогресс-бар ENDIF ********************************************************************************* IF Dialog Mess = L('ОПЕРАЦИЯ: ПАКЕТНОЕ РАСПОЗНАВАНИЕ В ТЕКУЩЕЙ МОДЕЛИ "#":') Mess = STRTRAN(Mess,"#", UPPER(Ar_Model[M_CurrInf])) aSay[ 7]:SetCaption(Mess) ENDIF *MsgBox(STR(N_Obj)) *MsgBox(mProcessor) DO CASE CASE mProcessor = 'CPU' // ЕСЛИ ЗАДАНО, ТО ВЕРИФИКАЦИЯ МОДЕЛЕЙ НА CPU ****** Обработка ошибки ****************** bError := ErrorBlock( {|e| Break(e)} ) // установить новый кодовый блок обработки ошибок BEGIN SEQUENCE // код нормального исполнения *** код нормального исполнения ****** Это если CPU <===############## ****** Сделать массивы средних и ср.кв.откл.по классам PRIVATE aSrCls[N_Cls] PRIVATE aDiCls[N_Cls] AFILL(aSrCls, 0) AFILL(aDiCls, 0) FOR j = 1 TO N_Cls aSrCls[j] = VAL(LC_FieldGet(mModelName, nHandle[M_CurrInf], N_Gos+2, j+2)) // SREDN по классу из БД текущей модели NEXT FOR j = 1 TO N_Cls aDiCls[j] = VAL(LC_FieldGet(mModelName, nHandle[M_CurrInf], N_Gos+3, j+2)) // DISP по классу из БД текущей модели NEXT * DC_DebugQout( aSrCls ) * DC_DebugQout( aDiCls ) // Цикл по объектам распознаваемой выборки и их распознавание ======================================== mPerDel = VAL(FileStr('_PerDel.txt')) * MsgBox(STR(mPerDel)) SELECT Rso_zag SET ORDER TO 1 DBGOTOP() mNumPP = 0 N_ALL = RECCOUNT() mMess = L('1/11: CPU-распознавание объектов распознаваемой выборки:') PUBLIC T1 := (DOY(DATE())-1)*86400+SECONDS() // Время предыдущей индикации процесса исполнения PUBLIC T2 := (DOY(DATE())-1)*86400+SECONDS()+1 // Текущее время (1-й раз оно заметно больше T1 чтобы было отображение) PUBLIC T1tp := T1 PUBLIC T2tp := T2 DO WHILE .NOT. EOF() // Цикл по объектам распознаваемой выборки * aSay[ 8]:SetCaption(mMess+' '+ALLTRIM(STR(++M_NObj/N_RsObj*100,15,7))+'%') PercTimeVisio(8, mMess, N_ALL, Regim) M_KodObj = Kod_obj // Сброс массива-локатора кодов признаков распознаваемого объекта AFILL(Ar_Lok,0) M_SumLok = 0 // Сумма 1 и 0 массива-локатора SELECT Rso_Kpr;SET ORDER TO 1;T=DBSEEK(STR(M_KodObj,19)) IF T ******** Цикл по признакам одного объекта aKodPr := {} // Массив кодов признаков, которые реально есть у объекта DO WHILE M_KodObj = Kod_obj .AND. .NOT. EOF() FOR j=2 TO 8 M_Kpr = FIELDGET(j) IF 0 < M_Kpr .AND. M_Kpr <= N_Gos // Проверка на корректность кода признака // Если признак указан у объкта несколько раз, значит он у него и встречается несколько раз, // например буква "о" в слове "молоко" встречатся 3 раза * DC_DebugQout( M_Kpr ) Ar_Lok[M_Kpr] = Ar_Lok[M_Kpr] + 1 // Подсчет числа встреч признакас кодом M_Kpr у объекта ++M_SumLok // Сумма 1 и 0 массива-локатора IF ASCAN(aKodpr, M_Kpr) = 0 // Код каждого признака учитывается один раз AADD (aKodpr, M_Kpr) ENDIF ENDIF NEXT DBSKIP(1) ENDDO ENDIF * LB_Warning(Ar_Lok, L("Массив-локатор объекта")) // <<<===##################### * LB_Warning(aKodpr, L("Массив кодов признаков объекта")) ******* Массив кодов классов, к которым ФАКТИЧЕСКИ относится данный объект PRIVATE Ar_Kcl := {} SELECT Rso_Kcl;SET ORDER TO 1;T=DBSEEK(STR(M_KodObj,19)) IF T ******** Цикл по классам одного объекта DO WHILE M_KodObj = Kod_obj .AND. .NOT. EOF() FOR j=2 TO 5 M_Kcl = FIELDGET(j) IF 0 < M_Kcl .AND. M_Kcl <= N_Cls // Проверка на корректность кода класса AADD(Ar_Kcl, M_Kcl) ENDIF NEXT DBSKIP(1) ENDDO ENDIF * // Проверка правильности выборки кодов классов и признаков * Mess = L("Код распознаваемого объекта: "+ALLTRIM(STR(M_KodObj,19))+". Коды классов: " * FOR j=1 TO LEN(Ar_Kcl) * Mess = Mess+ALLTRIM(STR(Ar_Kcl[j],19))+" " * NEXT * Mess = Mess + ". Коды признаков: " * FOR j=1 TO LEN(Ar_Lok) * IF Ar_Lok[j] > 0 * Mess = Mess+ALLTRIM(STR(j,19))+" " * ENDIF * NEXT * LB_Warning(Mess) // Использование полученных массивов собственно для распознавания ***** Расчет среднего и дисперсии массива-локатора M_SrObj = M_SumLok/N_Gos // Среднее 1 и 0 массива-локатора M_DiObj = 0 // Дисперсия 1 и 0 массива-локатора FOR i=1 TO N_Gos M_DiObj = M_DiObj + ( M_SrObj - Ar_Lok[i]) ^ 2 NEXT M_DiObj = SQRT( M_DiObj / (N_Gos - 1)) // Дорасчет дисперсии 1 и 0 массива-локатора * DC_DebugQout( { Alias(), IndexOrd() } ) IF M_DiObj > 0 // Объект описан aKod_obj := {} aKod_cls := {} aKorr := {} aSum_inf := {} aDate := {} aTime := {} aFakt := {} FOR j = 1 TO N_Cls // Цикл по классам распознавания в Inf IF aDiCls[j] > 0 // Сформирован ли класс распознавания ? ****** Расчет нормированной к 100% корреляции массивов ****** локатора источника и информативностей признаков класса ****** (ИНТЕГРАЛЬНЫЙ КРИТЕРИЙ СХОДСТВА) ********************* ****** и суммы информативностей имеющихся у объекта признаков M_SumInf = 0 // Сумма информативностей признаков, имеющихся в описании объекта M_Kov = 0 // Ковариация между образом объекта и классом * StrFile(ALLTRIM(STR(mAlgorithm,1)),'_Algorithm.txt') * StrFile(ALLTRIM(STR(mVisualization,1)),'_Visualization.txt') DO CASE CASE mAlgorithm = 1 // Полный вариант (медленный) FOR i=1 TO N_Gos // Перебираются все признаки, котореы есть в модели Iij = VAL(LC_FieldGet(mModelName, nHandle[M_CurrInf], i, 2+j)) // Iij из БД текущей модели M_Kov = M_Kov + (Ar_Lok[i] - M_SrObj) * (Iij - aSrCls[j]) M_SumInf = M_SumInf + Ar_Lok[i] * Iij // Надо нормировать как Korr, но это можно сделать только тогда, когда все будет посчитано <===############## NEXT CASE mAlgorithm = 2 // Упрощенный вариант (ускоренный) FOR i=1 TO LEN(aKodpr) // Перебираются только те признаки, которые есть у объекта. Их намного меньше, чем в модели, поэтому получается намного быстрее Iij = VAL(LC_FieldGet(mModelName, nHandle[M_CurrInf], aKodpr[i], 2+j)) // Iij из БД текущей модели M_Kov = M_Kov + (Ar_Lok[aKodpr[i]] - M_SrObj) * (Iij - aSrCls[j]) // По инт.крит. "Резонанс знаний" расчет не полный (упрощенный), т.к. учитываются не все признаки модели M_SumInf = M_SumInf + Ar_Lok[aKodpr[i]] * Iij // Надо нормировать как Korr, но это можно сделать только тогда, когда все будет посчитано <===############## NEXT ENDCASE * MsgBox(STR(Iij,19,7)) * IF M_SumInf <> 0 M_Kov = 100 * M_Kov / N_Gos M_Korr = M_Kov / (M_DiObj * aDiCls[j] ) // Корреляция между образом объекта и классом IF ABS(M_Korr) >= mPerDel // Учитывать только те результаты распознавания, достоверность которых не ниже заданного порога AADD(aKod_obj, M_KodObj) AADD(aKod_cls, j ) AADD(aKorr , M_Korr ) AADD(aSum_inf, M_SumInf) AADD(aDate , DTOC(DATE())) AADD(aTime , TIME()) *** Если распознаваемый объект ФАКТИЧЕСКИ относится к классу *** с кодом j, то поставить символ "√" в поле БД Rasp *** иначе поставить там пробел IF ASCAN(Ar_Kcl, j) > 0 AADD(aFakt, "√") ELSE AADD(aFakt, " ") ENDIF ENDIF * ENDIF ENDIF NEXT ****** Записать результаты распознавания в БД Rasp SELECT Rasp // Если сделать массивы для полей БД Rasp IF LEN(aKod_obj) > 0 FOR j=1 TO LEN(aKod_obj) APPEND BLANK // и записывать результаты распознавания вне цикла по Inf, то все очень ускорится, но тогда будет ограничение на размерность по памяти ################### REPLACE Kod_obj WITH aKod_obj[j] REPLACE Kod_cls WITH aKod_cls[j] * REPLACE Kod_ClSc WITH aKodClSc[aKod_cls[j]] // Надо перед записью значения в базу данных определять поместиться оно или нет и не пытаться его записывать, если оно не поместится IF LEN(ALLTRIM(STR(aKorr[j] ,19,7))) <= 15 REPLACE Korr WITH aKorr[j] ENDIF IF LEN(ALLTRIM(STR(aSum_inf[j],19,7))) <= 15 REPLACE Sum_inf WITH aSum_inf[j] // <===###################### При очень большом объеме распознаваемой выборки не хватает размера поля. * ELSE * REPLACE Sum_inf WITH aSum_inf[j] ENDIF * REPLACE Date WITH aDate[j] * REPLACE Time WITH aTime[j] REPLACE Fakt WITH aFakt[j] NEXT ENDIF ENDIF IF Regim <> "3_7_9" IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF ENDIF SELECT Rso_zag DBSKIP(1) ENDDO * SELECT Rasp * DELETE FOR ABS(Korr) > 100 * PACK ***** Распознавание на CPU закончено // <===########## RECOVER // код обработки ошибки aMess := {} AADD(aMess, L("При распознавании была попытка превышения максимального допустимого объема БД 2 Гб.")) // НАПРИМЕР AADD(aMess, L("Необходимо уменьшить количество классов или/и объектов распознаваемой выборки !!! ")) AADD(aMess, L("Можно также исключить из результатов распознавания наименее достоверные (режим 3.5)")) LB_Warning(aMess) * EXIT ENDSEQUENCE ErrorBlock( bError ) // переустановить старый кодовый ****************************************** CASE mProcessor = 'GPU' // ВЕРИФИКАЦИЯ МОДЕЛЕЙ НА GPU. ПОДГОТОВИТЬ НУЖНЫЕ БАЗЫ ДЛЯ ПРОДОЛЖЕНИЯ РАБОТЫ НА ОСНОВЕ БД, СОЗДАННЫХ GPU-МОДУЛЕМ РАСПОЗНАВАНИЯ IF Regim <> "3_7_9" aSay[ 8]:SetCaption(L('1/11: GPU-Распознавание (идентификация)'+' '+ALLTRIM(STR(N_Obj))+' '+'объектов распознаваемой выборки')) ENDIF ****** Формирование и запись txt-файла параметров модуля GPU-модуля распознавания **************** cFile = "Model_rec_settings.txt" // <===######################################################## aPar := {} * StrFile(ALLTRIM(STR(mAlgorithm,1)),'_Algorithm.txt') * StrFile(ALLTRIM(STR(mVisualization,1)),'_Visualization.txt') mVisualization = VAL(FileStr('_Visualization.txt')) DO CASE CASE mVisualization=1 AADD(aPar,'Show_progress') // Без визуализации стадии процесса исполнения AADD(aPar,'Show_statistics_(milliseconds) 0') CASE mVisualization=2 AADD(aPar,'Show_progress *') // С визуализацией стадии процесса исполнения AADD(aPar,'Show_statistics_(milliseconds) 3000') ENDCASE AADD(aPar,'Recognition_in_model_Abs '+IF(mNumModel= 1,'*','')) AADD(aPar,'Recognition_in_model_Prc1 '+IF(mNumModel= 2,'*','')) AADD(aPar,'Recognition_in_model_Prc2 '+IF(mNumModel= 3,'*','')) AADD(aPar,'Recognition_in_model_Inf1 '+IF(mNumModel= 4,'*','')) AADD(aPar,'Recognition_in_model_Inf2 '+IF(mNumModel= 5,'*','')) AADD(aPar,'Recognition_in_model_Inf3 '+IF(mNumModel= 6,'*','')) AADD(aPar,'Recognition_in_model_Inf4 '+IF(mNumModel= 7,'*','')) AADD(aPar,'Recognition_in_model_Inf5 '+IF(mNumModel= 8,'*','')) AADD(aPar,'Recognition_in_model_Inf6 '+IF(mNumModel= 9,'*','')) AADD(aPar,'Recognition_in_model_Inf7 '+IF(mNumModel=10,'*','')) AADD(aPar,'_') DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы Эйдос ERASE(cFile) CrLf = CHR(13)+CHR(10) // Конец строки (записи) mPar = '';FOR j=1 TO LEN(aPar);mPar=mPar+aPar[j]+CrLf;NEXT StrFile(mPar,cFile) ************************************************************************************************** ****** Обработка ошибки ****************** bError := ErrorBlock( {|e| Break(e)} ) // установить новый кодовый блок обработки ошибок BEGIN SEQUENCE // код нормального исполнения *** код нормального исполнения LC_RunShell("Model_rec.exe", 90392051) // GPU-модуль распознавания * Переименовать базу результатов распознавания в текущей модели в БД Rasp.dbf PUBLIC FlagRsp := .T. // .T. - удалось полностью записать базу данных результатов (она меньше 2Гб), .F. - не удалось (база больше 2Гб) PUBLIC FlagRspView := .F. // .T. - Сообщение об этом уже отображалось, .F. - еще не отображалось CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения mNameRspOld = M_PathAppl+'Rasp_'+LOWER(Ar_Model[mNumModel])+'.dbf' mNameRspNew = M_PathAppl+'Rasp.dbf' IF FILE(mNameRspNew) ERASE(mNameRspNew) ENDIF FRENAME(mNameRspOld,mNameRspNew) DO WHILE FILE(mNameRspOld) // Ожидание переименования файла ENDDO IF Regim <> "3_7_9" IF Regim<>"3_5";Time_Progress = Time_Progress+N_Obj;lOk = Time_Progress (Time_Progress, Wsego, oProgress, lOk );ENDIF ENDIF ***** Распознавание на GPU закончено // <===########## RECOVER // код обработки ошибки aMess := {} AADD(aMess, L("На данном компьютере установлена видеокарта не на чипсете NVIDIA, не поддерживающая язык")) AADD(aMess, L("OpenGL (Open Graphics Library). Поэтому использование графического процессора (GPU) для ")) AADD(aMess, L("распознавания невозможно и для расчетов надо задать центральный процессор (CPU). ")) LB_Warning(aMess) * EXIT ENDSEQUENCE ErrorBlock( bError ) // переустановить старый кодовый ****************************************** ENDCASE ********** ДАЛЬШЕ ВСЕ ОДИНАКОВО НА CPU И GPU ********************************************************* ****** Обработка ошибки ****************** bError := ErrorBlock( {|e| Break(e)} ) // установить новый кодовый блок обработки ошибок BEGIN SEQUENCE // код нормального исполнения *** код нормального исполнения CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * MsgBox(STR(FILESIZE("Rasp.dbf"))) * ******************************************************** * ** Можно ли вообще обрабатывать БД Rasp.dbf ************ * ******************************************************** * IF FILESIZE("Rasp.dbf") > 2 * 1024 ^ 3 // ПЕРЕД ОТКРЫТИЕМ ЭТОЙ БАЗЫ ДАННЫХ ПРОВЕРЯТЬ, МЕНЬШЕ ЛИ ОНА 2 ГБ. ЕСЛИ БОЛЬШЕ - ВЫДАВАТЬ СООБЩЕНИЕ О НЕОБХОДИМОСТИ ЗАДАТЬ ПАРАМЕТР, УМЕНЬШАЮЩИЙ ЧИСЛО ЗАПИСЕЙ ТАК, ЧТОБЫ БД БЫЛА < 2ГБ * aMess := {} * AADD(aMess, L('Размер БД результатов распознавания Rasp.dbf=# байт, что недопустимо.' )) * AADD(aMess, L('Необходимо задать такое значение параметра удаления незначимых результатов' )) * AADD(aMess, L('распознавания в режиме 3.5 или такое количество объектов распознаваемой выборки,')) * AADD(aMess, L('чтобы база данных результатов распознавания Rasp.dbf стала меньше 2 Гб!' )) * AADD(aMess, L('Корректное продолжение работы системы невозможно и работа будет прервана.' )) * aMess[1] = STRTRAN(aMess[1], "#", ALLTRIM(STR(FILESIZE("Rasp.dbf")))) * LB_Warning(aMess, L('4.1.2. Пакетное распознавание')) * ************************************************************** * ***** БД, открытые перед запуском главного меню * ***** Восстанавливать их после выхода из функций главного меню * ************************************************************** * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы * USE PathGrAp EXCLUSIVE NEW * USE Appls EXCLUSIVE NEW * USE Users EXCLUSIVE NEW * ************************************************************** * Running(.F.) * * RETURN NIL * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * QUIT * ENDIF mPerDel = VAL(FileStr('_PerDel.txt')) * MsgBox(STR(mPerDel)) ******************************************************** ** Возможно ли вообще обрабатывать БД Rasp.dbf ********* ******************************************************** IF mPerDel > 0 CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций COPY FILE ("Rasp.dbf") TO ("Rasp_old.dbf") USE Rasp EXCLUSIVE NEW;N_Rec = RECCOUNT() * INDEX ON STR(9999999.9999999-ABS(Korr ),19,7) TO Rsp_sinf * INDEX ON STR(9999999.9999999-ABS(Sum_inf),19,7) TO Rsp_sinf * DELETE FOR RECNO() > INT( 0.01 * mPerDel * N_Rec ) .AND. LEN(ALLTRIM(FAKT)) = 0 // Удалять записи с результатами распознавания низкой достоверности по внутреннему критерию достоверности и только не подтвержденные фактом DELETE FOR ABS(Korr) < mPerDel .AND. LEN(ALLTRIM(FAKT)) = 0 // Удалять записи с результатами распознавания с достоверностью ниже заданного порога и не подтвержденные фактом PACK ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() // Количество классов (градаций классификационных шкал) USE Gr_OpSc EXCLUSIVE NEW;N_Gos = RECCOUNT() // Количество признаков (градаций описательных шкал) USE Opis_Sc EXCLUSIVE NEW USE Rso_Zag INDEX Roz_kod EXCLUSIVE NEW;N_Obj = RECCOUNT() USE Rso_Kcl INDEX Roc_kod EXCLUSIVE NEW USE Rso_Kpr INDEX Rop_kod EXCLUSIVE NEW USE Rasp EXCLUSIVE NEW // ПЕРЕД ОТКРЫТИЕМ ЭТОЙ БД ПРОВЕРЯТЬ, МЕНЬШЕ ЛИ ОНА 2 ГБ. ЕСЛИ БОЛЬШЕ - ВЫДАВАТЬ СООБЩЕНИЕ О НЕОБХОДИМОСТИ ЗАДАТЬ ПАРАМЕТР, УМЕНЬШАЮЩИЙ ЧИСЛО ЗАПИСЕЙ ТАК, ЧТОБЫ БД БЫЛА < 2ГБ IF Regim = '3_5' .OR. Regim = '3_3' .OR. Regim = '4_1_2' // ЭТО ДЕЛАТЬ ТОЛЬКО ЕСЛИ ПРОВОДИТСЯ ПАКЕТНОЕ РАСПОЗНАВАНИЕ ВО ВСЕХ МОДЕЛЯХ (может быть еще в режиме 3.3.). USE (M_DostRsp) EXCLUSIVE NEW ENDIF IF Regim <> "3_7_9" aSay[ 8]:SetCaption(aSay[ 8]:caption+L(" - Готово ")) ENDIF // Конец цикла по объектам распознаваемой выборки и их распознавания ================================= IF Regim <> "3_7_9" aSay[ 9]:SetCaption(L("2/11: Исследование распределений уровней сходства верно и ошиб.идент.объектов")) ENDIF // Нормировка уровней сходства Korr и Sum_inf к 100% в БД Rasp (делать ее всегда) <===################# SELECT Rasp N_ALL = RECCOUNT() * 2 mNumPP = 0 mMess = L('2/11: Расчет распределений уровней сходства верно и ошиб.идент.объектов:') PUBLIC T1 := (DOY(DATE())-1)*86400+SECONDS() // Время предыдущей индикации процесса исполнения PUBLIC T2 := (DOY(DATE())-1)*86400+SECONDS()+1 // Текущее время (1-й раз оно заметно больше T1 чтобы было отображение) PUBLIC T1tp := T1 PUBLIC T2tp := T2 INDEX ON STR(ABS(Korr) ,19,7) TO Rsp_korr DBGOBOTTOM();M_MaxKorr = ABS(Korr) INDEX ON STR(ABS(Sum_inf),19,7) TO Rsp_sinf DBGOBOTTOM();M_MaxSinf = ABS(Sum_inf) SET ORDER TO DBGOTOP() DO WHILE .NOT. EOF() PercTimeVisio(9, mMess, N_ALL, Regim) mKorr = Korr /M_MaxKorr*100 * mKorr = IF(mKorr>100,+100,mKorr) * mKorr = IF(mKorr<100,-100,mKorr) mSumInf = Sum_Inf/M_MaxSinf*100 REPLACE Korr WITH mKorr // Не хватает размера поля <===############### REPLACE Sum_inf WITH mSumInf DBSKIP(1) ENDDO // Завершение нормировки уровней сходства Korr и Sum_inf к 100% в БД Rasp (делать ее всегда) IF Regim = '3_5' .OR. Regim = '3_3' .OR. Regim = '4_1_2' // ЭТО ДЕЛАТЬ ТОЛЬКО ЕСЛИ ПРОВОДИТСЯ ПАКЕТНОЕ РАСПОЗНАВАНИЕ ВО ВСЕХ МОДЕЛЯХ (может быть еще в режиме 3.3.). // и подсчет количества различных уровней сходства // для верно и ошибочно идентифицированных и неидентифицированных объектов // Нормировка уровней сходства Korr и Sum_inf r 100% в БД Rasp * SELECT Rasp * INDEX ON STR(ABS(Korr) ,19,7) TO Rsp_korr * INDEX ON STR(ABS(Sum_inf),19,7) TO Rsp_sinf * CLOSE Rasp * USE Rasp INDEX Rsp_korr, Rsp_sinf EXCLUSIVE NEW * SELECT Rasp * SET ORDER TO 1;DBGOBOTTOM();M_MaxKorr = ABS(Korr) * SET ORDER TO 2;DBGOBOTTOM();M_MaxSinf = ABS(Sum_inf) M_Num = 0 N_TK = 0 // Количество верно идентифицированных и неидентифицированных объектов (Korr) N_FK = 0 // Количество ошибочно идентифицированных и неидентифицированных объектов (Korr) N_TI = 0 // Количество верно идентифицированных и неидентифицированных объектов (Sum_inf) N_FI = 0 // Количество ошибочно идентифицированных и неидентифицированных объектов (Sum_inf) UrSx_Tk = 0 // Средний уровень сходства (Korr) верно идентифицированных и неидентифицированных объектов UrSx_Ti = 0 // Средний уровень сходства (Sum_inf) верно идентифицированных и неидентифицированных объектов UrSx_Fk = 0 // Средний уровень сходства (Korr) ошибочно идентифицированных и неидентифицированных объектов UrSx_Fi = 0 // Средний уровень сходства (Sum_inf) ошибочно идентифицированных и неидентифицированных объектов SELECT Rasp SET ORDER TO DBGOTOP() DO WHILE .NOT. EOF() * aSay[ 9]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(9, mMess, N_ALL, Regim) * REPLACE Korr WITH Korr /M_MaxKorr*100 * REPLACE Sum_inf WITH Sum_Inf/M_MaxSinf*100 PosK = ASCAN(A_ursx, ROUND(Korr ,0)) // Инт.крит. - Корреляция PosI = ASCAN(A_ursx, ROUND(Sum_Inf,0)) // Инт.крит. - Сумма IF PosK * PosI > 0 DO CASE CASE LEN(ALLTRIM(Fakt)) > 0 // Фактически объект относится к классу DO CASE CASE Korr > 0 // Объект верно отнесен к классу ++N_TK A_TPk[PosK] = A_TPk[PosK] + 1 // Истинно-положительное решение UrSx_Tk = UrSx_Tk + ABS(Korr) // Сумма уровней сходства (Korr) верно идентифицированных и неидентифицированных объектов CASE Korr <=0 // Объект ошибочно не отнесен к классу ++N_FK A_FNk[PosK] = A_FNk[PosK] + 1 // Ложно отрицательное решение UrSx_Fk = UrSx_Fk + ABS(Korr) // Сумма уровней сходства (Korr) ошибочно идентифицированных и неидентифицированных объектов ENDCASE DO CASE CASE Sum_Inf > 0 // Объект верно отнесен к классу ++N_TI A_TPi[PosI] = A_TPi[PosI] + 1 // Истинно-положительное решение UrSx_Ti = UrSx_Ti + ABS(Sum_Inf) // Сумма уровней сходства (Sum_inf) верно идентифицированных и неидентифицированных объектов CASE Sum_Inf <=0 // Объект ошибочно не отнесен к классу ++N_FI A_FNi[PosI] = A_FNi[PosI] + 1 // Ложно отрицательное решение UrSx_Fi = UrSx_Fi + ABS(Sum_Inf) // Сумма уровней сходства (Sum_inf) ошибочно идентифицированных и неидентифицированных объектов ENDCASE CASE LEN(ALLTRIM(Fakt)) = 0 // Фактически объект не относится к классу DO CASE CASE Korr > 0 // Объект ошибочно отнесен к классу ++N_FK A_FPk[PosK] = A_FPk[PosK] + 1 // Ложно-положительное решение UrSx_Fk = UrSx_Fk + ABS(Korr) // Сумма уровней сходства (Korr) ошибочно идентифицированных и неидентифицированных объектов CASE Korr <=0 // Объект верно не отнесен к классу ++N_TK A_TNk[PosK] = A_TNk[PosK] + 1 // Истинно-отрицательное решение UrSx_Tk = UrSx_Tk + ABS(Korr) // Сумма уровней сходства (Korr) верно идентифицированных и неидентифицированных объектов ENDCASE DO CASE CASE Sum_Inf > 0 // Объект ошибочно отнесен к классу ++N_FI A_FPi[PosI] = A_FPi[PosI] + 1 // Ложно-положительное решение UrSx_Fi = UrSx_Fi + ABS(Sum_Inf) // Сумма уровней сходства (Sum_inf) ошибочно идентифицированных и неидентифицированных объектов CASE Sum_Inf <=0 // Объект верно не отнесен к классу ++N_TI A_TNi[PosI] = A_TNi[PosI] + 1 // Истинно-отрицательное решение UrSx_Ti = UrSx_Ti + ABS(Sum_Inf) // Сумма уровней сходства (Sum_inf) верно идентифицированных и неидентифицированных объектов ENDCASE ENDCASE ENDIF * IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF DBSKIP(1) ENDDO * IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF ***** Создание БД для исследования зависимости ***** количества совпадений результатов распознавания с фактом ***** для различных по величине параметров сходства ПО ОБОИМ ИНТЕГРАЛЬНЫМ КРИТЕРИЯМ ***** ПО ОБОИМ ИНТЕГРАЛЬНЫМ КРИТЕРИЯМ ***** Это аргументированный ответ на вопрос о том, отражает ли уровень сходства ***** распознаваемых объектов с классами фактическую принадлежность этих объектов к классам, ***** т.е. можно ли рассматривать уровень сходства объектов с классами как работоспособный ***** количественный критерий дейсвительно отражающий степень принадлежности объектов к классам. ***** Ответ на этот вопрос положительный, т.к. у верно идентифицированных объектов уровень сходства ***** закономерно и значительно выше, чем у ошибочо идентифицированных. ****** Занесение информации в БД // Массив количества результатов распознавания для различных уровей сходства: {-100%, 0, +100%} // для случаев идентификации с классом, к которому объекты фактически относятся √ // Массив количества результатов распознавания для различных уровей сходства: {-100%, 0, +100%} // для случаев идентификации с классом, к которому объекты фактически не относятся " " PRIVATE aModName[10] // Частные критерии, которыми и отличаются друг от друга модели aModName := {L('1. ABS - частный критерий: количество встреч сочетаний: "класс-признак" у объектов обуч.выборки'),; L('2. PRC1 - частный критерий: усл. вероятность i-го признака среди признаков объектов j-го класса '),; L('3. PRC2 - частный критерий: условная вероятность i-го признака у объектов j-го класса '),; L('4. INF1 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC1 '),; L('5. INF2 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC2 '),; L('6. INF3 - частный критерий: Xи-квадрат, разности между фактическими и ожидаемыми абс.частотами '),; L('7. INF4 - частный критерий: ROI (Return On Investment); вероятности из PRC1 '),; L('8. INF5 - частный критерий: ROI (Return On Investment); вероятности из PRC2 '),; L('9. INF6 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC1 '),; L('10.INF7 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC2 ') } SELECT (M_DostRsp) APPEND BLANK REPLACE Name WITH UPPER(SUBSTR(aModName[M_CurrInf],1,255)) FOR M_IntKrit = 1 TO 2 // 1. Корреляция. 2. Сумма // Интегральные критерии DO CASE CASE M_CurrInf = 1 // Abs M_NameIntKrit = IF(M_IntKrit=1,"Корреляция абс.частот с обр.объекта","Сумма абс.частот по признакам объекта") CASE M_CurrInf = 2 .OR. M_CurrInf = 3 // Prc1, Prc2 M_NameIntKrit = IF(M_IntKrit=1,"Корреляция усл.отн.частот с обр.объекта","Сумма усл.отн.частот по признакам объекта") CASE M_CurrInf > 3 // Inf# M_NameIntKrit = IF(M_IntKrit=1,"Семантический резонанс знаний","Сумма знаний") ENDCASE APPEND BLANK REPLACE Name WITH "Интегральный критерий: "+UPPER(M_NameIntKrit) APPEND BLANK REPLACE Name WITH "Уровни сходства (Ур.Сх.) (%):" FOR j=1 TO LEN(A_ursx) FIELDPUT(1+j, A_ursx[j]) NEXT DO CASE CASE M_IntKrit = 1 // Корреляция APPEND BLANK REPLACE Name WITH "Част.распр.Уровней Сходства истинных решений (TP+TN)" FOR j=1 TO LEN(A_TPk) FIELDPUT(1+j, A_TPk[j]+A_TNk[j]) NEXT APPEND BLANK REPLACE Name WITH "Част.распр.Уровней Сходства ложных решений (FP+FN)" FOR j=1 TO LEN(A_FPk) FIELDPUT(1+j, A_FPk[j]+A_FNk[j]) NEXT APPEND BLANK REPLACE Name WITH "Част.распр.Уровней Сходства истинно-положительных решений (TP)" FOR j=1 TO LEN(A_TPk) FIELDPUT(1+j, A_TPk[j]) NEXT APPEND BLANK REPLACE Name WITH "Част.распр.Уровней Сходства истинно-отрицательных решений (TN)" FOR j=1 TO LEN(A_TNk) FIELDPUT(1+j, A_TNk[j]) NEXT APPEND BLANK REPLACE Name WITH "Част.распр.Уровней Сходства ложно-положительных решений (FP)" FOR j=1 TO LEN(A_FPk) FIELDPUT(1+j, A_FPk[j]) NEXT APPEND BLANK REPLACE Name WITH "Част.распр.Уровней Сходства ложно-отрицательных решений (FN)" FOR j=1 TO LEN(A_FNk) FIELDPUT(1+j, A_FNk[j]) NEXT CASE M_IntKrit = 2 // Сумма APPEND BLANK REPLACE Name WITH "Част.распр.Уровней Сходства истинных решений (TP+TN)" FOR j=1 TO LEN(A_TPi) FIELDPUT(1+j, A_TPi[j]+A_TNi[j]) NEXT APPEND BLANK REPLACE Name WITH "Част.распр.Уровней Сходства ложных решений (FP+FN)" FOR j=1 TO LEN(A_FPi) FIELDPUT(1+j, A_FPi[j]+A_FNi[j]) NEXT APPEND BLANK REPLACE Name WITH "Част.распр.Уровней Сходства истинно-положительных решений (TP)" FOR j=1 TO LEN(A_TPi) FIELDPUT(1+j, A_TPi[j]) NEXT APPEND BLANK REPLACE Name WITH "Част.распр.Уровней Сходства истинно-отрицательных решений (TN)" FOR j=1 TO LEN(A_TNi) FIELDPUT(1+j, A_TNi[j]) NEXT APPEND BLANK REPLACE Name WITH "Част.распр.Уровней Сходства ложно-положительных решений (FP)" FOR j=1 TO LEN(A_FPi) FIELDPUT(1+j, A_FPi[j]) NEXT APPEND BLANK REPLACE Name WITH "Част.распр.Уровней Сходства ложно-отрицательных решений (FN)" FOR j=1 TO LEN(A_FNi) FIELDPUT(1+j, A_FNi[j]) NEXT ENDCASE NEXT ENDIF // ЭТО ДЕЛАТЬ ТОЛЬКО ЕСЛИ ПРОВОДИТСЯ ПАКЕТНОЕ РАСПОЗНАВАНИЕ ВО ВСЕХ МОДЕЛЯХ (может быть еще в режиме 3.3.) IF Regim <> "3_7_9" IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF ENDIF IF Regim <> "3_7_9" aSay[ 9]:SetCaption(aSay[ 9]:caption+L(" - Готово ")) ENDIF ************************************************************************** // Переиндексация БД результатов распознавания и формирование БД Rsp1k.dbf, Rsp1i.dbf и Rsp2k.dbf, Rsp2i.dbf * ИМЕНА БАЗ ДАННЫХ РЕЗУЛЬТАТОВ РАСПОЗНАВАНИЯ ДЛЯ ВИЗУАЛИЗАЦИИ: * ============================================================================== * Интегральный критерий | Форма | Один объект | Один класс * | представления | много классов | много объектов * ------------------------------------------------------------------------------ * Семантический резонанс | Подробная наглядная | Rsp1k.dbf | Rsp2k.dbf Для расчета * Сумма информации | Подробная Наглядная | Rsp1i.dbf | Rsp2i.dbf и визуализации * ------------------------------------------------------------------------------ * Семантический резонанс | Итоговая наглядная | Rsp_IT1k.dbf | Rsp_IT2k.dbf Для расчета * Сумма информации | Итоговая наглядная | Rsp_IT1i.dbf | Rsp_IT2i.dbf * ------------------------------------------------------------------------------ * Оба инт.критерия | Итоговая наглядная | Rsp_IT1.dbf | Rsp_IT2.dbf Для визуализации * ------------------------------------------------------------------------------ * Семантический резонанс | Подробная сжатая | Rsp_ITk.dbf Для расчета * Сумма информации | Подробная сжатая | Rsp_ITi.dbf * ------------------------------------------------------------------------------ * Оба инт.критерия | Подробная сжатая | Rsp_IT.dbf Для визуализации * ------------------------------------------------------------------------------ * Факт принадлежности | Подробная сжатая | Rsp_ITf.dbf * ============================================================================== IF Regim <> "3_7_9" aSay[10]:SetCaption(L('3/11: Создание сжатых полных форм результатов распознавания по двум интегр.крит.')) ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() // Кол-во классов USE Rso_Zag EXCLUSIVE NEW;N_Obj = RECCOUNT() // Кол-во объектов расп.выборки USE Rasp EXCLUSIVE NEW;N_Rasp = RECCOUNT() // Кол-во строк в БД Rasp.dbf USE Rsp_ITk EXCLUSIVE NEW;ZAP // Подробная сжатая форма, инт.крит.-корреляция для расчета USE Rsp_ITi EXCLUSIVE NEW;ZAP // Подробная сжатая форма, инт.крит.-сумма инф. для расчета USE Rsp_IT EXCLUSIVE NEW;ZAP // Подробная сжатая форма, по двум инт.критериям для визуалиазции USE Rsp_ITf EXCLUSIVE NEW;ZAP // Подробная сжатая форма, факт принадл.объекта к классу для расчета ********************************** ****** Создать пустые БД с шапками ********************************** * Использовать не все объекты распознаваемой выборки из Rso_zag.dbf, а только те, которые * остались в БД Rasp.dbf после удаления из нее наименее достоверно идентифицированных объектов SELECT Rso_zag // №1, N_Obj <<<############################################# mNumPP = 0 // Для отображения стадии исполнения этапа N_ALL = N_Obj + N_Rasp + N_Obj+5 + N_Obj+5 * №1 №2 №3 №4 mMess = L('3/11: Создание сжатых полных форм результатов распозн.по двум интегр.крит.:') PUBLIC T1 := (DOY(DATE())-1)*86400+SECONDS() // Время предыдущей индикации процесса исполнения PUBLIC T2 := (DOY(DATE())-1)*86400+SECONDS()+1 // Текущее время (1-й раз оно заметно больше T1 чтобы было отображение) PUBLIC T1tp := T1 PUBLIC T2tp := T2 DBGOTOP() DO WHILE .NOT. EOF() * aSay[10]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(10, mMess, N_ALL, Regim) M_KodObj = Kod_obj M_NameObj = Name_obj SELECT Rsp_ITk // БД > 2 Гб <<<===############## APPEND BLANK // БД > 2 Гб <<<===############## REPLACE Kod_obj WITH M_KodObj REPLACE Name_obj WITH M_NameObj REPLACE Max_Value WITH -99999999 SELECT Rsp_ITi APPEND BLANK REPLACE Kod_obj WITH M_KodObj REPLACE Name_obj WITH M_NameObj REPLACE Max_Value WITH -99999999 SELECT Rsp_ITf APPEND BLANK REPLACE Kod_obj WITH M_KodObj REPLACE Name_obj WITH M_NameObj * FOR j=2 TO FCOUNT() * FIELDPUT(j," ") * NEXT SELECT Rso_zag * IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF DBSKIP(1) ENDDO IF Regim <> "3_7_9" IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF ENDIF SELECT Rsp_ITk APPEND BLANK REPLACE Name_obj WITH "MAX.ур.сход.класса с объектом" APPEND BLANK REPLACE Name_obj WITH "Код наиболее похожего объекта" APPEND BLANK REPLACE Name_obj WITH "MIN.ур.сход.класса с объектом" APPEND BLANK REPLACE Name_obj WITH "Код самого непохожего объекта" APPEND BLANK REPLACE Name_obj WITH "Дост: (MAX_ур.сх.-MIN_ур.сх)/2" SELECT Rsp_ITi APPEND BLANK REPLACE Name_obj WITH "MAX.ур.сход.класса с объектом" APPEND BLANK REPLACE Name_obj WITH "Код наиболее похожего объекта" APPEND BLANK REPLACE Name_obj WITH "MIN.ур.сход.класса с объектом" APPEND BLANK REPLACE Name_obj WITH "Код самого непохожего объекта" APPEND BLANK REPLACE Name_obj WITH "Дост: (MAX_ур.сх.-MIN_ур.сх)/2" // Раскидать результаты распознавания по матрицам, // Найти максимальные значения Ур.Сх. по строкам и столбцам // и поместить в них коды соответствующих классов и объектов PRIVATE aMaxValK[N_Cls] // Массив для поиска значений макс.ур.сх.по столбцам по корреляции PRIVATE aMaxKodK[N_Cls] // Массив кодов объектов с которыми у данного класса макс.ур.сх.по корреляции PRIVATE aMaxValI[N_Cls] // Массив для поиска макс.ур.сх.по столбцам по сумме инф. PRIVATE aMaxKodI[N_Cls] // Массив кодов объектов с которыми у данного класса макс.ур.сх.по сумме инф. AFILL(aMaxValK,-99999999) AFILL(aMaxKodK,-99999999) AFILL(aMaxValI,-99999999) AFILL(aMaxKodI,-99999999) PRIVATE aMinValK[N_Cls] // Массив для поиска значений мин.ур.сх.по столбцам по корреляции PRIVATE aMinKodK[N_Cls] // Массив кодов объектов с которыми у данного класса мин.ур.сх.по корреляции PRIVATE aMinValI[N_Cls] // Массив для поиска мин.ур.сх.по столбцам по сумме инф. PRIVATE aMinKodI[N_Cls] // Массив кодов объектов с которыми у данного класса мин.ур.сх.по сумме инф. AFILL(aMinValK,+99999999) AFILL(aMinKodK,+99999999) AFILL(aMinValI,+99999999) AFILL(aMinKodI,+99999999) SELECT Rasp // №2, N_Rasp <<<############################################ DBGOTOP() DO WHILE .NOT. EOF() * aSay[10]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(10, mMess, N_ALL, Regim) M_KodObj = Kod_obj M_KodCls = Kod_cls M_Korr = Korr M_SumInf = Sum_Inf M_Fakt = Fakt IF -100 <= M_Korr .AND. M_Korr <= +100 // Эта проверка сделана потому, что модуль распознавания на GPU иногда (очень редко) дает неверные результаты распознавания <===######### SELECT Rsp_ITk IF M_KodObj > 0 DBGOTO(M_KodObj) FIELDPUT(7+M_KodCls,M_Korr) // На CPU работает, а на GPU дает ошибку, что значение не помещается в поле <===######################################################### IF M_Korr > Max_Value REPLACE Max_Value WITH M_Korr // Макс.знач.ур.сходства REPLACE KodC_MaxV WITH M_KodCls // Код класса с которым у данного объекта Макс.знач.ур.сходства ENDIF IF M_Korr <= Min_Value REPLACE Min_Value WITH M_Korr // Мин.знач.ур.сходства REPLACE KodC_MinV WITH M_KodCls // Код класса с которым у данного объекта Мин.знач.ур.сходства ENDIF REPLACE Dost WITH (Max_Value-Min_Value)/2 // Достоверность IF M_Korr > aMaxValK[M_KodCls] aMaxValK[M_KodCls] = M_Korr // Макс.знач.ур.сходства aMaxKodK[M_KodCls] = M_KodObj // Код объекта с которым у данного класса Макс.знач.ур.сходства ENDIF IF M_Korr <= aMinValK[M_KodCls] aMinValK[M_KodCls] = M_Korr // Мин.знач.ур.сходства aMinKodK[M_KodCls] = M_KodObj // Код объекта с которым у данного класса Мин.знач.ур.сходства ENDIF SELECT Rsp_ITi DBGOTO(M_KodObj) FIELDPUT(7+M_KodCls,M_SumInf) IF M_SumInf > Max_Value REPLACE Max_Value WITH M_SumInf // Макс.знач.ур.сходства REPLACE KodC_MaxV WITH M_KodCls // Код класса с которым у данного объекта Макс.знач.ур.сходства ENDIF IF M_SumInf <= Min_Value REPLACE Min_Value WITH M_SumInf // Мин.знач.ур.сходства REPLACE KodC_MinV WITH M_KodCls // Код класса с которым у данного объекта Мин.знач.ур.сходства ENDIF REPLACE Dost WITH (Max_Value-Min_Value)/2 // Достоверность IF M_SumInf > aMaxValI[M_KodCls] aMaxValI[M_KodCls] = M_SumInf // Макс.знач.ур.сходства aMaxKodI[M_KodCls] = M_KodObj // Код объекта с которым у данного класса Макс.знач.ур.сходства ENDIF IF M_SumInf <= aMinValI[M_KodCls] aMinValI[M_KodCls] = M_SumInf // Мин.знач.ур.сходства aMinKodI[M_KodCls] = M_KodObj // Код объекта с которым у данного класса Мин.знач.ур.сходства ENDIF SELECT Rsp_ITf DBGOTO(M_KodObj) FIELDPUT(2+M_KodCls,M_Fakt) ENDIF ENDIF * IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF SELECT Rasp DBSKIP(1) ENDDO IF Regim <> "3_7_9" IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF ENDIF ****** Перенести массивы в БД SELECT Rsp_ITk DBGOTO(1+N_Obj) FOR j=1 TO N_Cls FIELDPUT(7+j, aMaxValK[j]) NEXT DBGOTO(2+N_Obj) FOR j=1 TO N_Cls FIELDPUT(7+j, aMaxKodK[j]) NEXT DBGOTO(3+N_Obj) FOR j=1 TO N_Cls FIELDPUT(7+j, aMinValK[j]) NEXT DBGOTO(4+N_Obj) FOR j=1 TO N_Cls FIELDPUT(7+j, aMinKodK[j]) NEXT DBGOTO(5+N_Obj) FOR j=1 TO N_Cls FIELDPUT(7+j, (aMaxValK[j]-aMinValK[j])/2) NEXT SELECT Rsp_ITi DBGOTO(1+N_Obj) FOR j=1 TO N_Cls FIELDPUT(7+j, aMaxValI[j]) NEXT DBGOTO(2+N_Obj) FOR j=1 TO N_Cls FIELDPUT(7+j, aMaxKodI[j]) NEXT DBGOTO(3+N_Obj) FOR j=1 TO N_Cls FIELDPUT(7+j, aMinValI[j]) NEXT DBGOTO(4+N_Obj) FOR j=1 TO N_Cls FIELDPUT(7+j, aMinKodI[j]) NEXT DBGOTO(5+N_Obj) FOR j=1 TO N_Cls FIELDPUT(7+j, (aMaxValI[j]-aMinValI[j])/2) NEXT // Объединение БД Rsp_ITk + Rsp_ITi => Rsp_IT для визуализации // Wsego = Wsego+(N_Obj+5)*2 SELECT Rsp_ITk // №3, N_Obj+5 <<<############################################# DBGOTOP() DO WHILE .NOT. EOF() * aSay[10]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(10, mMess, N_ALL, Regim) Ar := {} FOR j=1 TO FCOUNT() AADD(Ar, FIELDGET(j)) NEXT SELECT Rsp_IT APPEND BLANK FOR j=1 TO LEN(Ar) FIELDPUT(j,Ar[j]) NEXT REPLACE Int_krit WITH 1 // Инт.крит.-корреляция * IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF SELECT Rsp_ITk DBSKIP(1) ENDDO IF Regim <> "3_7_9" IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF ENDIF SELECT Rsp_ITi // №4, N_Obj+5 <<<#############################################???????? DBGOTOP() DO WHILE .NOT. EOF() * aSay[10]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(10, mMess, N_ALL, Regim) Ar := {} FOR j=1 TO FCOUNT() AADD(Ar, FIELDGET(j)) NEXT SELECT Rsp_IT APPEND BLANK // <<<===########### вылетает, т.к. файл станвится больше 2 Гб FOR j=1 TO LEN(Ar) FIELDPUT(j,Ar[j]) NEXT REPLACE Int_krit WITH 2 // Инт.крит.-сумма инф. * IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF SELECT Rsp_ITi DBSKIP(1) ENDDO IF Regim <> "3_7_9" IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF ENDIF IF Regim <> "3_7_9" aSay[10]:SetCaption(aSay[10]:caption+L(" - Готово ")) ENDIF IF Regim <> "3_7_9" aSay[11]:SetCaption(L('4/11: Создание подробной наглядной формы: "Объект-классы". Инт.крит.-корреляция')) ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rasp EXCLUSIVE NEW INDEX ON STR(Kod_Obj,19)+STR(99999999.9999999-Korr ,19,7)+STR(Kod_cls,19) TO RspK_obj // Один объект - много классов INDEX ON STR(Kod_Obj,19)+STR(99999999.9999999-Sum_inf,19,7)+STR(Kod_cls,19) TO RspI_obj // Один объект - много классов CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW ;N_Cls = RECCOUNT() // Кол-во классов USE Rso_Zag EXCLUSIVE NEW ;N_Obj = RECCOUNT() // Кол-во объектов расп.выборки USE Rasp INDEX RspK_obj, RspI_obj EXCLUSIVE NEW;N_Rasp = RECCOUNT() // Кол-во строк в БД Rasp.dbf mNumPP = 0 // Для отображения стадии исполнения этапа N_ALL = N_Obj + N_Cls + N_Rasp + N_Rasp + N_Rasp * №1 №2 №3 №4 №5 mMess = L('4/11: Создание подр.нагл.формы: "Объект-классы". Инт.крит.-корреляция:') PUBLIC T1 := (DOY(DATE())-1)*86400+SECONDS() // Время предыдущей индикации процесса исполнения PUBLIC T2 := (DOY(DATE())-1)*86400+SECONDS()+1 // Текущее время (1-й раз оно заметно больше T1 чтобы было отображение) PUBLIC T1tp := T1 PUBLIC T2tp := T2 USE Rsp_ITk EXCLUSIVE NEW // Подробная сжатая форма, инт.крит.-корреляция USE Rsp_ITi EXCLUSIVE NEW // Подробная сжатая форма, инт.крит.-сумма инф. USE Rsp_ITf EXCLUSIVE NEW // Подробная сжатая форма, факт принадл.объекта к классу USE Rsp1k EXCLUSIVE NEW;ZAP // Подробная наглядная форма, инт.крит.-корреляция ("Один объект - много классов") USE Rsp1i EXCLUSIVE NEW;ZAP // Подробная наглядная форма, инт.крит.-сумма инф. ("Один объект - много классов") USE Rsp_it1k EXCLUSIVE NEW;ZAP // Итоговая наглядная форма, инт.крит.-корреляция ("Объект - класс") USE Rsp_it1i EXCLUSIVE NEW;ZAP // Итоговая наглядная форма, инт.крит.-сумма инф. ("Объект - класс") USE Rsp_it1 EXCLUSIVE NEW;ZAP // Итоговая наглядная форма, инт.крит.-сумма инф. ("Объект - класс") для визуализации ****** Формирование массивов для исключения переключений БД и ускорения распознавания SELECT Rso_Zag // №1, N_Obj <<<############################################# PRIVATE aNameObj[N_Obj] mFlagErr = .T. DBGOTOP() DO WHILE .NOT. EOF() * aSay[11]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(11, mMess, N_ALL, Regim) IF Kod_obj <= N_Obj aNameObj[Kod_obj] = Name_obj ELSE IF mFlagErr mFlagErr = .F. aMess := {} AADD(aMess, L('В БД: "Rso_Zag.dbf" коды объектов распознаваемой выборки не соответствуют номерам записей.')) AADD(aMess, L('Скорее всего некоторые объекты распознаваемой выборки НЕКОРРЕКТНО удалены.') ) AADD(aMess, L('Базы данных приложения нарушены и полученные результаты будут некорректны!') ) LB_Warning(aMess, L('4.2.1. Пакетное распознавание' ) ) ENDIF ENDIF DBSKIP(1) ENDDO SELECT Classes // №2, N_Cls <<<############################################# PRIVATE aKodClSc[N_Cls] PRIVATE aNameCls[N_Cls] mFlagErr = .T. DBGOTOP() DO WHILE .NOT. EOF() * aSay[11]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(11, mMess, N_ALL, Regim) IF Kod_cls <= N_Cls aNameCls[Kod_cls] = DelZeroNameGr(Name_cls) aKodClSc[Kod_cls] = Kod_ClSc ELSE IF mFlagErr mFlagErr = .F. aMess := {} AADD(aMess, L('В БД: "Classes.dbf" коды классов не соответствуют номерам записей.') ) AADD(aMess, L('Скорее всего некоторые записи БД "Classes.dbf" НЕКОРРЕКТНО удалены.') ) AADD(aMess, L('Базы данных приложения нарушены и полученные результаты будут некорректны!')) LB_Warning(aMess, L('4.2.1. Пакетное распознавание' ) ) ENDIF ENDIF DBSKIP(1) ENDDO ****** Rsp1k: Один объект - много классов, интегральный критерий - Семантический резонанс PUBLIC FlagRsp := .T. // .T. - удалось полностью записать базу данных результатов (она меньше 2Гб), .F. - не удалось (база больше 2Гб) PUBLIC FlagRspView := .F. // .T. - Сообщение об этом уже отображалось, .F. - еще не отображалось SELECT Rasp // №3, N_Rasp <<<############################################ SET ORDER TO 1 M_Num = 0 set printer to ("Rsp1k_"+Ar_Model[mNumModel]+".txt") ADDITIVE DBGOTOP() mKodObjRasp = Kod_obj DO WHILE .NOT. EOF() * aSay[11]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(11, mMess, N_ALL, Regim) mRecno = RECNO() M_KodObj = Kod_obj M_KodCls = Kod_cls M_Korr = Korr M_SumInf = Sum_inf M_Fakt = Fakt IF -100 <= M_Korr .AND. M_Korr <= +100 IF M_KodObj <= N_Obj .AND. M_KodCls <= N_Cls IF mKodObjRasp <> Kod_obj .AND. M_Num > 0 ?REPLICATE('~',LEN(mS1)) mKodObjRasp = Kod_obj ENDIF ?TABEXPAND(ALLTRIM(STR(M_KodObj)) +CHR(9)+' | ')+; ALLTRIM(aNameObj[M_KodObj])+SPACE(mLO-LEN(ALLTRIM(aNameObj[M_KodObj]))-2)+' | '+; TABEXPAND(ALLTRIM(STR(M_KodCls)) +CHR(9)+' | ')+; ALLTRIM(aNameCls[M_KodCls])+SPACE(mLC-LEN(ALLTRIM(aNameCls[M_KodCls])))+' | '+; TABEXPAND(ALLTRIM(STR(aKodClSc[M_KodCls])) +CHR(9)+' | ')+; TABEXPAND(ALLTRIM(STR(M_Korr,15,7)) +CHR(9)+' | ')+; TABEXPAND(ALLTRIM(STR(M_SumInf,15,7)) +CHR(9)+' | ')+; TABEXPAND(REPLICATE("■", 0.15*ABS(M_Korr)) +CHR(9)+' | ',16)+; M_Fakt+' | '+DTOC(DATE())+' | '+TIME()+' | '+; TABEXPAND(ALLTRIM(STR(++M_Num)) +CHR(9)+' | ') SELECT Rsp1k * IF RECCOUNT()*720 > 1501000000 // Если БД достигает очень большого размера, то оставить только наиболее значимые записи * FlagRsp := .F. // .T. - удалось полностью записать базу данных результатов (она меньше 2 Гб), .F. - не удалось (база больше 2 Гб) * INDEX ON STR(Kod_Obj,15)+STR(9999999.9999999-ABS(Korr),19,7) TO Rsp1kFltr * DBGOTOP() * N = 0 * mKodObj = Kod_obj * DO WHILE .NOT. EOF() * IF mKodObj = Kod_obj * IF N < 9 * REPLACE Filter9 WITH '#' * ++N * ENDIF * ELSE * N = 0 * mKodObj = Kod_obj * REPLACE Filter9 WITH '#' * ++N * ENDIF * DBSKIP(1) * ENDDO * DELETE FOR FILTER9 <> '#' * PACK * SET ORDER TO * ENDIF SELECT Rsp1k APPEND BLANK REPLACE Kod_obj WITH M_KodObj REPLACE Name_obj WITH aNameObj[M_KodObj] REPLACE Kod_cls WITH M_KodCls REPLACE Kod_ClSc WITH aKodClSc[M_KodCls] REPLACE Name_cls WITH DelZeroNameGr(aNameCls[M_KodCls]) REPLACE Korr WITH M_Korr REPLACE Sum_inf WITH M_SumInf REPLACE Fakt WITH M_Fakt REPLACE Histogram WITH REPLICATE("|", ABS(M_Korr)) REPLACE Date WITH DTOC(DATE()) REPLACE Time WITH TIME() REPLACE Num WITH M_Num ENDIF ENDIF * IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF SELECT Rasp DBGOTO(mRecno) DBSKIP(1) ENDDO ?REPLICATE('=',LEN(mS1)) IF Regim <> "3_7_9" IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF ENDIF ****** Подготовка для отображения 9 записей с макс.модулем интегр.критерия сходства ****** и 2-х классов по каждой класс.шкале: с макс.и мин.уровнями сходства SELECT Rsp1k // №4, N_Rasp <<<############################################ INDEX ON STR(Kod_Obj,15)+STR(9999999.9999999-ABS(Korr),19,7) TO Rsp1kFltr DBGOTOP() N = 0 mKodObj = Kod_obj DO WHILE .NOT. EOF() * aSay[11]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(11, mMess, N_ALL, Regim) IF mKodObj = Kod_obj IF N < 9 REPLACE Filter9 WITH '#' ++N ENDIF ELSE N = 0 mKodObj = Kod_obj REPLACE Filter9 WITH '#' ++N ENDIF DBSKIP(1) ENDDO DBGOTOP() * IF RECCOUNT()*720 > 1501000000 // Если БД достигает очень большого размера, то оставить только наиболее значимые записи * FlagRsp := .F. // .T. - удалось полностью записать базу данных результатов (она меньше 2 Гб), .F. - не удалось (база больше 2 Гб) * oScr := DC_WaitOn(L('Немного подождите. Идет сжатие БД "Rsp1k"'),,,,,,,,,,,.F.) * SELECT Rsp1k * DELETE FOR FILTER9 <> '#' * PACK * DC_Impl(oScr) * ENDIF SELECT Rsp1k // №5, N_Rasp <<<############################################ INDEX ON STR(Kod_Obj,15)+STR(Kod_ClSc,15)+STR(9999999.9999999-Korr,19,7) TO Rsp1kFltr DBGOTOP() N = 0 mKodClSc = Kod_ClSc DO WHILE .NOT. EOF() * aSay[11]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(11, mMess, N_ALL, Regim) IF mKodClSc = Kod_ClSc IF N < 1 REPLACE FilterM WITH '#' ++N ENDIF ELSE DBSKIP(-1) mKodClSc = Kod_ClSc REPLACE FilterM WITH '#' DBSKIP(1) N = 0 mKodClSc = Kod_ClSc REPLACE FilterM WITH '#' ++N ENDIF DBSKIP(1) ENDDO DBGOBOTTOM();REPLACE FilterM WITH '#' DBGOTOP() IF Regim <> "3_7_9" aSay[11]:SetCaption(aSay[11]:caption+L(" - Готово ")) ENDIF ****** Rsp1i: Один объект - много классов, интегральный критерий - суммарное количество информации IF Regim <> "3_7_9" aSay[12]:SetCaption(L('5/11: Создание подр.нагл.формы: "Объект-классы". Инт.крит.-сумма инф.')) ENDIF mNumPP = 0 // Для отображения стадии исполнения этапа N_ALL = N_Rasp + N_Rasp + N_Rasp * №1 №2 №3 mMess = L('5/11: Создание подр.нагл.формы: "Объект-классы". Инт.крит.-сумма инф.:') PUBLIC T1 := (DOY(DATE())-1)*86400+SECONDS() // Время предыдущей индикации процесса исполнения PUBLIC T2 := (DOY(DATE())-1)*86400+SECONDS()+1 // Текущее время (1-й раз оно заметно больше T1 чтобы было отображение) PUBLIC T1tp := T1 PUBLIC T2tp := T2 SELECT Rasp // №1, N_Rasp <<<############################################ SET ORDER TO 2 M_Num = 0 set printer to ("Rsp1i_"+Ar_Model[mNumModel]+".txt") ADDITIVE DBGOTOP() mKodObjRasp = Kod_obj DO WHILE .NOT. EOF() * aSay[12]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(12, mMess, N_ALL, Regim) mRecno = RECNO() M_KodObj = Kod_obj M_KodCls = Kod_cls M_Korr = Korr M_SumInf = Sum_inf M_Fakt = Fakt IF -100 <= M_Korr .AND. M_Korr <= +100 IF M_KodObj <= N_Obj .AND. M_KodCls <= N_Cls IF mKodObjRasp <> Kod_obj .AND. M_Num > 0 ?REPLICATE('~',LEN(mS1)) mKodObjRasp = Kod_obj ENDIF ?TABEXPAND(ALLTRIM(STR(M_KodObj)) +CHR(9)+' | ')+; ALLTRIM(aNameObj[M_KodObj])+SPACE(mLO-LEN(ALLTRIM(aNameObj[M_KodObj]))-2)+' | '+; TABEXPAND(ALLTRIM(STR(M_KodCls)) +CHR(9)+' | ')+; ALLTRIM(aNameCls[M_KodCls])+SPACE(mLC-LEN(ALLTRIM(aNameCls[M_KodCls])))+' | '+; TABEXPAND(ALLTRIM(STR(aKodClSc[M_KodCls])) +CHR(9)+' | ')+; TABEXPAND(ALLTRIM(STR(M_Korr,15,7)) +CHR(9)+' | ')+; TABEXPAND(ALLTRIM(STR(M_SumInf,15,7)) +CHR(9)+' | ')+; TABEXPAND(REPLICATE("■", 0.15*ABS(M_SumInf)) +CHR(9)+' | ',16)+; M_Fakt+' | '+DTOC(DATE())+' | '+TIME()+' | '+; TABEXPAND(ALLTRIM(STR(++M_Num)) +CHR(9)+' | ') SELECT Rsp1i * IF RECCOUNT()*720 > 1501000000 // Если БД достигает очень большого размера, то оставить только наиболее значимые записи * FlagRsp := .F. // .T. - удалось полностью записать базу данных результатов (она меньше 2 Гб), .F. - не удалось (база больше 2 Гб) * INDEX ON STR(Kod_Obj,15)+STR(9999999.9999999-ABS(Sum_inf),19,7) TO Rsp1iFltr * DBGOTOP() * N = 0 * mKodObj = Kod_obj * DO WHILE .NOT. EOF() * IF mKodObj = Kod_obj * IF N < 9 * REPLACE Filter9 WITH '#' * ++N * ENDIF * ELSE * N = 0 * mKodObj = Kod_obj * REPLACE Filter9 WITH '#' * ++N * ENDIF * DBSKIP(1) * ENDDO * DELETE FOR FILTER9 <> '#' * PACK * SET ORDER TO * ENDIF SELECT Rsp1i APPEND BLANK REPLACE Kod_obj WITH M_KodObj REPLACE Name_obj WITH aNameObj[M_KodObj] REPLACE Kod_cls WITH M_KodCls REPLACE Kod_ClSc WITH aKodClSc[M_KodCls] REPLACE Name_cls WITH DelZeroNameGr(aNameCls[M_KodCls]) REPLACE Korr WITH M_Korr REPLACE Sum_inf WITH M_SumInf REPLACE Fakt WITH M_Fakt REPLACE Histogram WITH REPLICATE("|",ABS(M_SumInf)) REPLACE Date WITH DTOC(DATE()) REPLACE Time WITH TIME() REPLACE Num WITH M_Num ENDIF ENDIF * IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF SELECT Rasp DBGOTO(mRecno) DBSKIP(1) ENDDO ?REPLICATE('=',LEN(mS1)) IF Regim <> "3_7_9" IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF ENDIF ****** Подготовка для отображения 9 записей с макс.модулем интегр.критерия сходства ****** и 2-х классов по каждой класс.шкале: с макс.и мин.уровнями сходства SELECT Rsp1i // №2, N_Rasp <<<############################################ INDEX ON STR(Kod_Obj,15)+STR(9999999.9999999-ABS(Sum_inf),19,7) TO Rsp1iFltr DBGOTOP() N = 0 mKodObj = Kod_obj DO WHILE .NOT. EOF() * aSay[12]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(12, mMess, N_ALL, Regim) IF mKodObj = Kod_obj IF N < 9 REPLACE Filter9 WITH '#' ++N ENDIF ELSE N = 0 mKodObj = Kod_obj REPLACE Filter9 WITH '#' ++N ENDIF DBSKIP(1) ENDDO DBGOTOP() * IF RECCOUNT()*720 > 1501000000 // Если БД достигает очень большого размера, то оставить только наиболее значимые записи * FlagRsp := .F. // .T. - удалось полностью записать базу данных результатов (она меньше 2 Гб), .F. - не удалось (база больше 2 Гб) * oScr := DC_WaitOn(L('Немного подождите. Идет сжатие БД "Rsp1i"'),,,,,,,,,,,.F.) * SELECT Rsp1i * DELETE FOR FILTER9 <> '#' * PACK * DC_Impl(oScr) * ENDIF SELECT Rsp1i // №3, N_Rasp <<<############################################ INDEX ON STR(Kod_Obj,15)+STR(Kod_ClSc,15)+STR(9999999.9999999-Korr,19,7) TO Rsp1iFltr DBGOTOP() N = 0 mKodClSc = Kod_ClSc DO WHILE .NOT. EOF() * aSay[12]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(12, mMess, N_ALL, Regim) IF mKodClSc = Kod_ClSc IF N < 1 REPLACE FilterM WITH '#' ++N ENDIF ELSE DBSKIP(-1) mKodClSc = Kod_ClSc REPLACE FilterM WITH '#' DBSKIP(1) N = 0 mKodClSc = Kod_ClSc REPLACE FilterM WITH '#' ++N ENDIF DBSKIP(1) ENDDO DBGOBOTTOM();REPLACE FilterM WITH '#' DBGOTOP() IF Regim <> "3_7_9" aSay[12]:SetCaption(aSay[12]:caption+L(" - Готово ")) ENDIF ***** Сделать итоговые наглядные формы: "Объект-классы" IF Regim <> "3_7_9" aSay[13]:SetCaption(L('6/11: Создание итоговой наглядной формы: "Объект-класс". Инт.крит.-корреляция')) ENDIF mNumPP = 0 // Для отображения стадии исполнения этапа N_ALL = N_Obj+5 * №1 mMess = L('6/11: Создание итоговой наглядной формы: "Объект-класс". Инт.крит.-корреляция:') // Если задан 3.7.9, то рассчитывать только эту выходную форму ###################### PUBLIC T1 := (DOY(DATE())-1)*86400+SECONDS() // Время предыдущей индикации процесса исполнения PUBLIC T2 := (DOY(DATE())-1)*86400+SECONDS()+1 // Текущее время (1-й раз оно заметно больше T1 чтобы было отображение) PUBLIC T1tp := T1 PUBLIC T2tp := T2 SELECT Rsp_ITk // №1, N_Obj+5 <<<############################################ *INDEX ON STR(99999999.9999999-Dost,19,7) TO Rsp_ITk // Один объект - много классов DBGOTOP() DO WHILE .NOT. EOF() * aSay[13]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(13, mMess, N_ALL, Regim) M_KodObj = Kod_obj IF M_KodObj > 0 M_NameObj = Name_obj M_KodClsA = KodC_MaxV M_KorrA = Max_Value M_KodClsB = KodC_MinV M_KorrB = Min_Value M_Dost = Dost IF M_KodClsA <= 2035 .AND. M_KodClsB <= 2035 SELECT Classes DBGOTO(M_KodClsA) M_NameClsA = Name_cls DBGOTO(M_KodClsB) M_NameClsB = Name_cls SELECT Rsp_ITf DBGOTO(M_KodObj) M_Fakt = FIELDGET(2+M_KodClsA) SELECT Rsp_it1k APPEND BLANK REPLACE Kod_obj WITH M_KodObj REPLACE Name_obj WITH M_NameObj REPLACE Kod_clsA WITH M_KodClsA REPLACE Name_clsA WITH M_NameClsA REPLACE KorrA WITH M_KorrA REPLACE Fakt WITH M_Fakt REPLACE Kod_clsB WITH M_KodClsB REPLACE Name_clsB WITH M_NameClsB REPLACE KorrB WITH M_KorrB REPLACE Dost WITH M_Dost REPLACE Date WITH DTOC(DATE()) REPLACE Time WITH TIME() ENDIF * IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF ENDIF SELECT Rsp_ITk DBSKIP(1) ENDDO IF Regim <> "3_7_9" IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF ENDIF IF Regim <> "3_7_9" aSay[13]:SetCaption(aSay[13]:caption+L(" - Готово ")) ENDIF IF Regim <> "3_7_9" aSay[14]:SetCaption(L('7/11: Создание итоговой наглядной формы: "Объект-класс". Инт.крит.-сумма инф.')) // Если задан 3.7.9, то рассчитывать только эту выходную форму ###################### ENDIF mNumPP = 0 // Для отображения стадии исполнения этапа N_ALL = N_Obj+5 + N_Obj + N_Obj * №1 №2 №3 mMess = L('7/11: Создание итоговой наглядной формы: "Объект-класс". Инт.крит.-сумма инф.:') PUBLIC T1 := (DOY(DATE())-1)*86400+SECONDS() // Время предыдущей индикации процесса исполнения PUBLIC T2 := (DOY(DATE())-1)*86400+SECONDS()+1 // Текущее время (1-й раз оно заметно больше T1 чтобы было отображение) PUBLIC T1tp := T1 PUBLIC T2tp := T2 SELECT Rsp_ITi // №1, N_Obj+5 <<<############################################ *INDEX ON STR(99999999.9999999-Dost,19,7) TO Rsp_ITi // Один объект - много классов ** 1234567890123456 DBGOTOP() DO WHILE .NOT. EOF() * aSay[14]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(14, mMess, N_ALL, Regim) M_KodObj = Kod_obj IF M_KodObj > 0 IF M_KodClsA <= 2035 .AND. M_KodClsB <= 2035 M_NameObj = Name_obj M_KodClsA = KodC_MaxV M_SumInfA = Max_Value M_KodClsB = KodC_MinV M_SumInfB = Min_Value M_Dost = Dost SELECT Classes DBGOTO(M_KodClsA) M_NameClsA = Name_cls DBGOTO(M_KodClsB) M_NameClsB = Name_cls SELECT Rsp_ITf DBGOTO(M_KodObj) M_Fakt = FIELDGET(2+M_KodClsA) M_Fakt = IF(VALTYPE(M_Fakt) = "C", M_Fakt, " ") SELECT Rsp_it1i APPEND BLANK REPLACE Kod_obj WITH M_KodObj REPLACE Name_obj WITH M_NameObj REPLACE Kod_clsA WITH M_KodClsA REPLACE Name_clsA WITH M_NameClsA REPLACE Sum_infA WITH M_SumInfA REPLACE Fakt WITH M_Fakt REPLACE Kod_clsB WITH M_KodClsB REPLACE Name_clsB WITH M_NameClsB REPLACE Sum_infB WITH M_SumInfB REPLACE Dost WITH M_Dost REPLACE Date WITH DTOC(DATE()) REPLACE Time WITH TIME() ENDIF * IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF ENDIF SELECT Rsp_ITi DBSKIP(1) ENDDO IF Regim <> "3_7_9" IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF ENDIF // Объединение итоговых наглядных форм "Объект-класс" для визуализации // Объединение БД Rsp_it1k + Rsp_it1i => Rsp_it1 для визуализации // Wsego = Wsego+N_Obj*2 SELECT Rsp_it1k // №2, N_Obj <<<############################################ DBGOTOP() DO WHILE .NOT. EOF() * aSay[14]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(14, mMess, N_ALL, Regim) Ar := {} FOR j=1 TO FCOUNT() AADD(Ar, FIELDGET(j)) NEXT SELECT Rsp_it1 APPEND BLANK FOR j=1 TO LEN(Ar) FIELDPUT(j,Ar[j]) NEXT REPLACE Int_krit WITH 1 // Инт.крит.-корреляция * IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF SELECT Rsp_it1k DBSKIP(1) ENDDO IF Regim <> "3_7_9" IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF ENDIF SELECT Rsp_it1i // №3, N_Obj <<<############################################ DBGOTOP() DO WHILE .NOT. EOF() * aSay[14]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(14, mMess, N_ALL, Regim) Ar := {} FOR j=1 TO FCOUNT() AADD(Ar, FIELDGET(j)) NEXT SELECT Rsp_it1 APPEND BLANK FOR j=1 TO LEN(Ar) FIELDPUT(j,Ar[j]) NEXT REPLACE Int_krit WITH 2 // Инт.крит.-сумма инф. * IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF SELECT Rsp_it1i DBSKIP(1) ENDDO IF Regim <> "3_7_9" IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF ENDIF IF Regim <> "3_7_9" aSay[14]:SetCaption(aSay[14]:caption+L(" - Готово ")) ENDIF ***** Создание подробных наглядных форм: "Класс-объекты" IF Regim <> "3_7_9" aSay[15]:SetCaption(L('8/11: Создание подробной наглядной формы: "Класс-объекты". Инт.крит.-корреляция')) ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rasp EXCLUSIVE NEW INDEX ON STR(Kod_cls,19)+STR(99999999.9999999-Korr ,19,7)+STR(Kod_Obj,19) TO RspK_cls // Один класс - много объектов INDEX ON STR(Kod_cls,19)+STR(99999999.9999999-Sum_inf,19,7)+STR(Kod_Obj,19) TO RspI_cls // Один класс - много объектов CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW ;N_Cls = RECCOUNT() // Кол-во классов USE Rso_Zag EXCLUSIVE NEW ;N_Obj = RECCOUNT() // Кол-во объектов расп.выборки USE Rasp INDEX RspK_cls, RspI_cls EXCLUSIVE NEW;N_Rasp = RECCOUNT() // Строк в БД asp.dbf mNumPP = 0 // Для отображения стадии исполнения этапа N_ALL = N_Rasp + N_Rasp + N_Rasp * №1 №2 №3 mMess = L('8/11: Создание подробной наглядной формы: "Класс-объекты". Инт.крит.-корреляция:') PUBLIC T1 := (DOY(DATE())-1)*86400+SECONDS() // Время предыдущей индикации процесса исполнения PUBLIC T2 := (DOY(DATE())-1)*86400+SECONDS()+1 // Текущее время (1-й раз оно заметно больше T1 чтобы было отображение) PUBLIC T1tp := T1 PUBLIC T2tp := T2 USE Rsp_ITk EXCLUSIVE NEW // Подробная сжатая форма, инт.крит.-корреляция USE Rsp_ITi EXCLUSIVE NEW // Подробная сжатая форма, инт.крит.-сумма инф. USE Rsp_ITf EXCLUSIVE NEW // Подробная сжатая форма, факт принадл.объекта к классу USE Rsp2k EXCLUSIVE NEW;ZAP // Подробная наглядная форма, инт.крит.-корреляция ("Один класс - много объектов") USE Rsp2i EXCLUSIVE NEW;ZAP // Подробная наглядная форма, инт.крит.-сумма инф. ("Один класс - много объектов") USE Rsp_it2k EXCLUSIVE NEW;ZAP // Итоговая наглядная форма, инт.крит.-корреляция ("Класс-объекты") USE Rsp_it2i EXCLUSIVE NEW;ZAP // Итоговая наглядная форма, инт.крит.-сумма инф. ("Класс-объекты") USE Rsp_it2 EXCLUSIVE NEW;ZAP // Итоговая наглядная форма, инт.крит.-сумма инф. ("Класс-объекты") для визуализации ****** Rsp2k: Один класс - много объектов, интегральный критерий - Семантический резонанс SELECT Rasp // №1, N_Rasp <<<############################################ SET ORDER TO 1 M_Num = 0 set printer to ("Rsp2k_"+Ar_Model[mNumModel]+".txt") ADDITIVE DBGOTOP() mKodClsRasp = Kod_cls DO WHILE .NOT. EOF() * aSay[15]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(15, mMess, N_ALL, Regim) mRecno = RECNO() M_KodObj = Kod_obj M_KodCls = Kod_cls M_Korr = Korr M_SumInf = Sum_inf M_Fakt = Fakt IF -100 <= M_Korr .AND. M_Korr <= +100 IF M_KodObj <= N_Obj .AND. M_KodCls <= N_Cls IF mKodClsRasp <> Kod_cls .AND. M_Num > 0 ?REPLICATE('~',LEN(mS1)) mKodClsRasp = Kod_cls ENDIF ?TABEXPAND(ALLTRIM(STR(M_KodObj)) +CHR(9)+' | ')+; ALLTRIM(aNameObj[M_KodObj])+SPACE(mLO-LEN(ALLTRIM(aNameObj[M_KodObj]))-2)+' | '+; TABEXPAND(ALLTRIM(STR(M_KodCls)) +CHR(9)+' | ')+; ALLTRIM(aNameCls[M_KodCls])+SPACE(mLC-LEN(ALLTRIM(aNameCls[M_KodCls])))+' | '+; TABEXPAND(ALLTRIM(STR(aKodClSc[M_KodCls])) +CHR(9)+' | ')+; TABEXPAND(ALLTRIM(STR(M_Korr,15,7)) +CHR(9)+' | ')+; TABEXPAND(ALLTRIM(STR(M_SumInf,15,7)) +CHR(9)+' | ')+; TABEXPAND(REPLICATE("■", 0.15*ABS(M_Korr)) +CHR(9)+' | ',16)+; M_Fakt+' | '+DTOC(DATE())+' | '+TIME()+' | '+; TABEXPAND(ALLTRIM(STR(++M_Num)) +CHR(9)+' | ') SELECT Rsp2k * IF RECCOUNT()*720 > 1501000000 // Если БД достигает очень большого размера, то оставить только наиболее значимые записи * FlagRsp := .F. // .T. - удалось полностью записать базу данных результатов (она меньше 2 Гб), .F. - не удалось (база больше 2 Гб) * INDEX ON STR(Kod_Obj,15)+STR(9999999.9999999-ABS(Korr),19,7) TO Rsp2kFltr * DBGOTOP() * N = 0 * mKodObj = Kod_obj * DO WHILE .NOT. EOF() * IF mKodObj = Kod_obj * IF N < 9 * REPLACE Filter9 WITH '#' * ++N * ENDIF * ELSE * N = 0 * mKodObj = Kod_obj * REPLACE Filter9 WITH '#' * ++N * ENDIF * DBSKIP(1) * ENDDO * DELETE FOR FILTER9 <> '#' * PACK * ENDIF SELECT Rsp2k APPEND BLANK REPLACE Kod_obj WITH M_KodObj REPLACE Name_obj WITH aNameObj[M_KodObj] REPLACE Kod_cls WITH M_KodCls REPLACE Kod_ClSc WITH aKodClSc[M_KodCls] REPLACE Name_cls WITH DelZeroNameGr(aNameCls[M_KodCls]) REPLACE Korr WITH M_Korr REPLACE Sum_inf WITH M_SumInf REPLACE Fakt WITH M_Fakt REPLACE Histogram WITH REPLICATE("|", ABS(M_Korr)) REPLACE Date WITH DTOC(DATE()) REPLACE Time WITH TIME() REPLACE Num WITH M_Num ENDIF ENDIF * IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF SELECT Rasp DBGOTO(mRecno) DBSKIP(1) ENDDO ?REPLICATE('=',LEN(mS1)) IF Regim <> "3_7_9" IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF ENDIF ****** Подготовка для отображения 9 записей с макс.модулем интегр.критерия сходства ****** и 2-х классов по каждой класс.шкале: с макс.и мин.уровнями сходства SELECT Rsp2k // №2, N_Rasp <<<############################################ INDEX ON STR(Kod_Obj,15)+STR(9999999.9999999-ABS(Korr),19,7) TO Rsp2kFltr DBGOTOP() N = 0 mKodObj = Kod_obj DO WHILE .NOT. EOF() * aSay[15]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(15, mMess, N_ALL, Regim) IF mKodObj = Kod_obj IF N < 9 REPLACE Filter9 WITH '#' ++N ENDIF ELSE N = 0 mKodObj = Kod_obj REPLACE Filter9 WITH '#' ++N ENDIF DBSKIP(1) ENDDO DBGOTOP() * IF RECCOUNT()*720 > 1501000000 // Если БД достигает очень большого размера, то оставить только наиболее значимые записи * FlagRsp := .F. // .T. - удалось полностью записать базу данных результатов (она меньше 2 Гб), .F. - не удалось (база больше 2 Гб) * oScr := DC_WaitOn(L('Немного подождите. Идет сжатие БД "Rsp2k"'),,,,,,,,,,,.F.) * SELECT Rsp2k * DELETE FOR FILTER9 <> '#' * PACK * DC_Impl(oScr) * ENDIF SELECT Rsp2k // №3, N_Rasp <<<############################################ INDEX ON STR(Kod_Obj,15)+STR(Kod_ClSc,15)+STR(9999999.9999999-Korr,19,7) TO Rsp2kFltr DBGOTOP() N = 0 mKodClSc = Kod_ClSc DO WHILE .NOT. EOF() * aSay[15]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(15, mMess, N_ALL, Regim) IF mKodClSc = Kod_ClSc IF N < 1 REPLACE FilterM WITH '#' ++N ENDIF ELSE DBSKIP(-1) mKodClSc = Kod_ClSc REPLACE FilterM WITH '#' DBSKIP(1) N = 0 mKodClSc = Kod_ClSc REPLACE FilterM WITH '#' ++N ENDIF DBSKIP(1) ENDDO DBGOBOTTOM();REPLACE FilterM WITH '#' DBGOTOP() IF Regim <> "3_7_9" aSay[15]:SetCaption(aSay[15]:caption+L(" - Готово ")) ENDIF ****** Rsp2i: Один класс - много объектов, интегральный критерий - суммарное количество информации IF Regim <> "3_7_9" aSay[16]:SetCaption(L('9/11: Создание подробной наглядной формы: "Класс-объекты". Инт.крит.-сумма инф.')) ENDIF mNumPP = 0 // Для отображения стадии исполнения этапа N_ALL = N_Rasp + N_Rasp + N_Rasp * №1 №2 №3 mMess = L('9/11: Создание подробной наглядной формы: "Класс-объекты". Инт.крит.-сумма инф.:') PUBLIC T1 := (DOY(DATE())-1)*86400+SECONDS() // Время предыдущей индикации процесса исполнения PUBLIC T2 := (DOY(DATE())-1)*86400+SECONDS()+1 // Текущее время (1-й раз оно заметно больше T1 чтобы было отображение) PUBLIC T1tp := T1 PUBLIC T2tp := T2 SELECT Rasp // №1, N_Rasp <<<############################################ SET ORDER TO 2 M_Num = 0 set printer to ("Rsp2i_"+Ar_Model[mNumModel]+".txt") ADDITIVE DBGOTOP() mKodClsRasp = Kod_cls DO WHILE .NOT. EOF() * aSay[16]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(16, mMess, N_ALL, Regim) mRecno = RECNO() M_KodObj = Kod_obj M_KodCls = Kod_cls M_Korr = Korr M_SumInf = Sum_inf M_Fakt = Fakt IF -100 <= M_Korr .AND. M_Korr <= +100 IF M_KodObj <= N_Obj .AND. M_KodCls <= N_Cls IF mKodClsRasp <> Kod_cls .AND. M_Num > 0 ?REPLICATE('~',LEN(mS1)) mKodClsRasp = Kod_cls ENDIF ?TABEXPAND(ALLTRIM(STR(M_KodObj)) +CHR(9)+' | ')+; ALLTRIM(aNameObj[M_KodObj])+SPACE(mLO-LEN(ALLTRIM(aNameObj[M_KodObj]))-2)+' | '+; TABEXPAND(ALLTRIM(STR(M_KodCls)) +CHR(9)+' | ')+; ALLTRIM(aNameCls[M_KodCls])+SPACE(mLC-LEN(ALLTRIM(aNameCls[M_KodCls])))+' | '+; TABEXPAND(ALLTRIM(STR(aKodClSc[M_KodCls])) +CHR(9)+' | ')+; TABEXPAND(ALLTRIM(STR(M_Korr,15,7)) +CHR(9)+' | ')+; TABEXPAND(ALLTRIM(STR(M_SumInf,15,7)) +CHR(9)+' | ')+; TABEXPAND(REPLICATE("■", 0.15*ABS(M_SumInf)) +CHR(9)+' | ',16)+; M_Fakt+' | '+DTOC(DATE())+' | '+TIME()+' | '+; TABEXPAND(ALLTRIM(STR(++M_Num)) +CHR(9)+' | ') SELECT Rsp2i * IF RECCOUNT()*720 > 1501000000 // Если БД достигает очень большого размера, то оставить только наиболее значимые записи * FlagRsp := .F. // .T. - удалось полностью записать базу данных результатов (она меньше 2 Гб), .F. - не удалось (база больше 2 Гб) * INDEX ON STR(Kod_Obj,15)+STR(9999999.9999999-ABS(Korr),19,7) TO Rsp2iFltr * DBGOTOP() * N = 0 * mKodObj = Kod_obj * DO WHILE .NOT. EOF() * IF mKodObj = Kod_obj * IF N < 9 * REPLACE Filter9 WITH '#' * ++N * ENDIF * ELSE * N = 0 * mKodObj = Kod_obj * REPLACE Filter9 WITH '#' * ++N * ENDIF * DBSKIP(1) * ENDDO * DELETE FOR FILTER9 <> '#' * PACK * SET ORDER TO * ENDIF SELECT Rsp2i APPEND BLANK REPLACE Kod_obj WITH M_KodObj REPLACE Name_obj WITH aNameObj[M_KodObj] REPLACE Kod_cls WITH M_KodCls REPLACE Kod_ClSc WITH aKodClSc[M_KodCls] REPLACE Name_cls WITH DelZeroNameGr(aNameCls[M_KodCls]) REPLACE Korr WITH M_Korr REPLACE Sum_inf WITH M_SumInf REPLACE Fakt WITH M_Fakt REPLACE Histogram WITH REPLICATE("|",ABS(M_SumInf)) REPLACE Date WITH DTOC(DATE()) REPLACE Time WITH TIME() REPLACE Num WITH M_Num ENDIF ENDIF * IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF SELECT Rasp DBGOTO(mRecno) DBSKIP(1) ENDDO ?REPLICATE('=',LEN(mS1)) IF Regim <> "3_7_9" IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF ENDIF ****** Подготовка для отображения 9 записей с макс.модулем интегр.критерия сходства ****** и 2-х классов по каждой класс.шкале: с макс.и мин.уровнями сходства SELECT Rsp2i // №2, N_Rasp <<<############################################ INDEX ON STR(Kod_Obj,15)+STR(9999999.9999999-ABS(Korr),19,7) TO Rsp2iFltr DBGOTOP() N = 0 mKodObj = Kod_obj DO WHILE .NOT. EOF() * aSay[16]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(16, mMess, N_ALL, Regim) IF mKodObj = Kod_obj IF N < 9 REPLACE Filter9 WITH '#' ++N ENDIF ELSE N = 0 mKodObj = Kod_obj REPLACE Filter9 WITH '#' ++N ENDIF DBSKIP(1) ENDDO DBGOTOP() * IF RECCOUNT()*720 > 1501000000 // Если БД достигает очень большого размера, то оставить только наиболее значимые записи * FlagRsp := .F. // .T. - удалось полностью записать базу данных результатов (она меньше 2 Гб), .F. - не удалось (база больше 2 Гб) * oScr := DC_WaitOn(L('Немного подождите. Идет сжатие БД "Rsp2i"'),,,,,,,,,,,.F.) * SELECT Rsp2i * DELETE FOR FILTER9 <> '#' * PACK * DC_Impl(oScr) * ENDIF SELECT Rsp2i // №3, N_Rasp <<<############################################ INDEX ON STR(Kod_Obj,15)+STR(Kod_ClSc,15)+STR(9999999.9999999-Korr,19,7) TO Rsp2iFltr DBGOTOP() N = 0 mKodClSc = Kod_ClSc DO WHILE .NOT. EOF() * aSay[16]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(16, mMess, N_ALL, Regim) IF mKodClSc = Kod_ClSc IF N < 1 REPLACE FilterM WITH '#' ++N ENDIF ELSE DBSKIP(-1) mKodClSc = Kod_ClSc REPLACE FilterM WITH '#' DBSKIP(1) N = 0 mKodClSc = Kod_ClSc REPLACE FilterM WITH '#' ++N ENDIF DBSKIP(1) ENDDO DBGOBOTTOM();REPLACE FilterM WITH '#' DBGOTOP() IF Regim <> "3_7_9" aSay[16]:SetCaption(aSay[16]:caption+L(" - Готово ")) ENDIF // Сделать БД наглядных итогов: "Класс-объекты" IF Regim <> "3_7_9" aSay[17]:SetCaption(L('10/11: Создание итоговой наглядной формы: "Класс-объекты". Инт.крит.-корреляция')) ENDIF mNumPP = 0 // Для отображения стадии исполнения этапа N_ALL = MIN(N_Cls,2035) * №1 mMess = L('10/11: Создание итоговой наглядной формы: "Класс-объекты". Инт.крит.-корреляция:') PUBLIC T1 := (DOY(DATE())-1)*86400+SECONDS() // Время предыдущей индикации процесса исполнения PUBLIC T2 := (DOY(DATE())-1)*86400+SECONDS()+1 // Текущее время (1-й раз оно заметно больше T1 чтобы было отображение) PUBLIC T1tp := T1 PUBLIC T2tp := T2 FOR M_KodCls=1 TO MIN(N_Cls,2035) // №1, MIN(N_Cls,2035) <<<############################################ * aSay[17]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(17, mMess, N_ALL, Regim) SELECT Classes DBGOTO(M_KodCls) M_NameCls = Name_cls SELECT Rsp_ITk DBGOTO(1+N_Obj);M_KorrA = FIELDGET(7+M_KodCls) DBGOTO(2+N_Obj);M_KodObjA = FIELDGET(7+M_KodCls) DBGOTO(3+N_Obj);M_KorrB = FIELDGET(7+M_KodCls) DBGOTO(4+N_Obj);M_KodObjB = FIELDGET(7+M_KodCls) DBGOTO(5+N_Obj);M_Dost = FIELDGET(7+M_KodCls) DBGOTO(M_KodObjA) M_NameObjA = Name_obj // Объект, с которым у данного класса макс.ур.сходства. Отображать красным DBGOTO(M_KodObjB) M_NameObjB = Name_obj // Объект, с которым у данного класса мин.ур.сходства. Отображать синим SELECT Rsp_ITf DBGOTO(M_KodObjA) M_Fakt = FIELDGET(2+M_KodCls) SELECT Rsp_it2k APPEND BLANK REPLACE Kod_cls WITH M_KodCls REPLACE Name_cls WITH M_NameCls REPLACE Kod_objA WITH M_KodObjA REPLACE Name_objA WITH M_NameObjA REPLACE KorrA WITH M_KorrA REPLACE Fakt WITH M_Fakt REPLACE Kod_objB WITH M_KodObjB REPLACE Name_objB WITH M_NameObjB REPLACE KorrB WITH M_KorrB REPLACE Dost WITH M_Dost REPLACE Date WITH DTOC(DATE()) REPLACE Time WITH TIME() * IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF NEXT IF Regim <> "3_7_9" IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF ENDIF IF Regim <> "3_7_9" aSay[17]:SetCaption(aSay[17]:caption+L(" - Готово ")) ENDIF IF Regim <> "3_7_9" aSay[18]:SetCaption(L('11/11: Создание итоговой наглядной формы: "Класс-объекты". Инт.крит.-сумма инф.')) ENDIF mNumPP = 0 // Для отображения стадии исполнения этапа N_ALL = MIN(N_Cls,2035) + N_Cls + N_Cls * №1 №2 №3 mMess = L('11/11: Создание итоговой наглядной формы: "Класс-объекты". Инт.крит.-сумма инф.:') PUBLIC T1 := (DOY(DATE())-1)*86400+SECONDS() // Время предыдущей индикации процесса исполнения PUBLIC T2 := (DOY(DATE())-1)*86400+SECONDS()+1 // Текущее время (1-й раз оно заметно больше T1 чтобы было отображение) PUBLIC T1tp := T1 PUBLIC T2tp := T2 FOR M_KodCls=1 TO MIN(N_Cls,2035) // №1, MIN(N_Cls,2035) <<<############################################ * aSay[18]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(18, mMess, N_ALL, Regim) SELECT Classes DBGOTO(M_KodCls) M_NameCls = Name_cls SELECT Rsp_ITi DBGOTO(1+N_Obj);M_SumInfA = FIELDGET(7+M_KodCls) DBGOTO(2+N_Obj);M_KodObjA = FIELDGET(7+M_KodCls) DBGOTO(3+N_Obj);M_SumInfB = FIELDGET(7+M_KodCls) DBGOTO(4+N_Obj);M_KodObjB = FIELDGET(7+M_KodCls) DBGOTO(5+N_Obj);M_Dost = FIELDGET(7+M_KodCls) DBGOTO(M_KodObjA) M_NameObjA = Name_obj // Объект, с которым у данного класса макс.ур.сходства. Отображать красным DBGOTO(M_KodObjB) M_NameObjB = Name_obj // Объект, с которым у данного класса мин.ур.сходства. Отображать синим SELECT Rsp_ITf DBGOTO(M_KodObjA) M_Fakt = FIELDGET(2+M_KodCls) SELECT Rsp_it2i APPEND BLANK REPLACE Kod_cls WITH M_KodCls REPLACE Name_cls WITH M_NameCls REPLACE Kod_objA WITH M_KodObjA REPLACE Name_objA WITH M_NameObjA REPLACE Sum_InfA WITH M_SumInfA REPLACE Fakt WITH M_Fakt REPLACE Kod_objB WITH M_KodObjB REPLACE Name_objB WITH M_NameObjB REPLACE Sum_InfB WITH M_SumInfB REPLACE Dost WITH M_Dost REPLACE Date WITH DTOC(DATE()) REPLACE Time WITH TIME() * IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF NEXT IF Regim <> "3_7_9" IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF ENDIF // Объединение итоговых наглядных форм "Класс-объект" для визуализации // Объединение БД SELECT Rsp_it2k + Rsp_it2i => Rsp_it2 для визуализации // Wsego = Wsego+N_Cls*2 SELECT Rsp_it2k // №2, N_Cls <<<############################################ DBGOTOP() DO WHILE .NOT. EOF() * aSay[18]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(18, mMess, N_ALL, Regim) Ar := {} FOR j=1 TO FCOUNT() AADD(Ar, FIELDGET(j)) NEXT SELECT Rsp_it2 APPEND BLANK FOR j=1 TO LEN(Ar) FIELDPUT(j,Ar[j]) NEXT REPLACE Int_krit WITH 1 // Инт.крит.-корреляция * IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF SELECT Rsp_it2k DBSKIP(1) ENDDO IF Regim <> "3_7_9" IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF ENDIF SELECT Rsp_it2i // №3, N_Cls <<<############################################ DBGOTOP() DO WHILE .NOT. EOF() * aSay[18]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(18, mMess, N_ALL, Regim) Ar := {} FOR j=1 TO FCOUNT() AADD(Ar, FIELDGET(j)) NEXT SELECT Rsp_it2 APPEND BLANK FOR j=1 TO LEN(Ar) FIELDPUT(j,Ar[j]) NEXT REPLACE Int_krit WITH 2 // Инт.крит.-сумма инф. * IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF SELECT Rsp_it2i DBSKIP(1) ENDDO IF Regim <> "3_7_9" IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF ENDIF IF Regim <> "3_7_9" aSay[18]:SetCaption(aSay[18]:caption+L(" - Готово ")) ENDIF *MsgBox('STOP') FlagRsp =.T. *** *** RECOVER // код обработки ошибки aMess := {} AADD(aMess, L("При распознавании была попытка превышения максимального допустимого объема БД 2 Гб.")) // НАПРИМЕР AADD(aMess, L("Необходимо уменьшить количество классов или/и объектов распознаваемой выборки !!! ")) AADD(aMess, L("Можно также исключить из результатов распознавания наименее достоверные (режим 3.5)")) LB_Warning(aMess, L("4.1.2. пакетное распознавание")) FlagRsp =.F. * EXIT ENDSEQUENCE ErrorBlock( bError ) // переустановить старый кодовый ****************************************** ********** Закрыть процесс печати выходной формы Set device to screen Set printer off Set printer to Set console on DC_ASave(M_CurrInf, "_RaspInf.arx") // Сохранение информации о модели, в которой было проведено распознавание Running(.T.) // Чтобы не могли запустить какой-нибудь режим пока висит окно окончания работы IF Dialog ************************************************************************************************** oSay97:SetCaption(L("ПАКЕТНОЕ РАСПОЗНАВАНИЕ ОБЪЕКТОВ РАСПОЗНАВАЕМОЙ ВЫБОРКИ ЗАВЕРШЕНО УСПЕШНО !")) oSay97:SetCaption(oSay97:caption) oButton:SetCaption(L('&Ok')) // Деструктурирование окна отображения графического Progress-bar oButton:activate := {||PostAppEvent(xbeP_Close,,,oDialog)} //<<<<<< Add This DC_AppEvent( @lOk ) oDialog:Destroy() ************************************************************************************************** ENDIF FClose( nHandle[M_CurrInf] ) // Закрытие dbf и txt баз данных ###################################### *IF Regim <> "3_5" * IF FlagRspView = .F. // .T. - Сообщение об этом уже отображалось, .F. - еще не отображалось * IF FlagRsp = .F. // .T. - удалось полностью записать базу данных результатов (она меньше 2Гб), .F. - не удалось (база больше 2Гб) * FlagRspView := .T. * aMess := {} * AADD(aMess, L('Не удалось полностью записать базы данных результатов распознавания: "Rsp##-XXX.dbf",' )) * AADD(aMess, L('так как они оказались больше 2 Гб. Поэтому в базах данных "Rsp##-XXX.txt" оставлены ' )) * AADD(aMess, L('только максимальные по подулю уровня сходства результаты, а полностью они будут в БД:')) * AADD(aMess, L('"Rsp##-XXX.txt", где: "##" - {1k, 1i, 2k, 2i}, "XXX" - {Abs, Prc1, Prc2, Inf1 - Inf7}.')) * LB_Warning(aMess, L("4.1.2. пакетное распознавание" )) * ENDIF * ENDIF *ENDIF // После расчета записать БД Rsp_it2k, Rsp_it2i с именами: Rsp_it2k_###, Rsp_it2i_###, где ### - наименование модели Ar_Model := {"Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций mName = 'Rsp2k_'+Ar_Model[mNumModel]+'.dbf' COPY FILE 'Rsp2k.dbf' TO (mName) mName = 'Rsp2i_'+Ar_Model[mNumModel]+'.dbf' COPY FILE 'Rsp2i.dbf' TO (mName) StrFile("412", "Rasp.txt") // Запись текстового файла с информацией о том, что был выполнен режим 4.1.2 IF Regim <> "3_7_9" ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** ENDIF Running(.F.) RETURN NIL *********************************************************************************************************** ******** Создание баз результатов распознавания для визуализации *********************************************************************************************************** *********************************************************************************************************** ******* С функцией выдачи результатов распознавания в форме, сходной с Inp_data ******* - в текущей модели ******* - с обоими интегральными критериями ******* - в кодах и наименованиях классов и признаков ****** - с указанием уровней сходства (идея Александра Петровича Трунева) *********************************************************************************************************** FUNCTION F4_1_3_12() LOCAL Time_progress, Wsego, oProgress, lOk LOCAL nEvery := 100 // Количество корректировок прогресс-бар Running(.T.) * MsgBox(mProcessor) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF ApplChange("4.1.2()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } IF FILE("_CurrInf.arx") // Файл с информацией о том, какая модель задана текущей M_CurrInf = DC_ARestore("_CurrInf.arx") mNumModel = M_CurrInf // Если модель задана некорректно - использовать текущую ELSE LB_Warning(L('Выходные формы "Inp_rasp" не могут быть получены, т.к. нет информации о том, какая модель является текущей !!! ')) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ***** Создать базы данных RecognResults_####_#_###.dbf ***************************************************************** ***** модель: {"Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7"} ***** интегральный критерий: {'i','k'} ***** коды классов и признаков, наименования, значения, сходство: {'Kod','Nam','Val','Sim'} ********************************************************************************* // Подготовка данных для отображения графического прогресс-бар // Определить значение Wsego CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rasp EXCLUSIVE NEW USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Class_Sc EXCLUSIVE NEW;N_ClSc = RECCOUNT() USE Attributes EXCLUSIVE NEW;N_Atr = RECCOUNT() USE Opis_Sc EXCLUSIVE NEW;N_OpSc = RECCOUNT() USE Rso_Zag EXCLUSIVE NEW;N_Obj = RECCOUNT() SELECT Rasp SET FILTER TO Korr > 0 DBGOTOP();DBGOBOTTOM();DBGOTOP() COUNT TO N_RaspKorr SET FILTER TO Sum_inf > 0 DBGOTOP();DBGOBOTTOM();DBGOTOP() COUNT TO N_RaspInf Wsego = N_Cls +; // 01 N_Cls +; // 02 N_ClSc +; // 03 N_Atr +; // 04 N_Atr +; // 05 N_OpSc +; // 06 N_Obj +; // 07 N_ClSc +; // 08 N_OpSc +; // 09 8 +; // 10 8 +; // 11 (N_RaspKorr+N_RaspInf)*4 // 12 Time_progress = 0 // Прошло секунд с начала процесса // Процесс может идти больше суток, поэтому для определения // во всех случаях вычисляется время, прошедшее с начала года T_Mess1 = L("Начало:")+" "+TIME() // Начало Sec_1 = (DOY(DATE())-1)*86400+SECONDS() PUBLIC T1 := (DOY(DATE())-1)*86400+SECONDS() // Время предыдущей индикации процесса исполнения PUBLIC T2 := (DOY(DATE())-1)*86400+SECONDS()+1 // Текущее время (1-й раз оно заметно больше T1 чтобы было отображение) PUBLIC T1tp := T1 PUBLIC T2tp := T2 * aSay[1]:SetCaption(L('1/2: Подготовка к запуску мастера подготовки исполнения мастера загрузки исходных данных')) * aSay[2]:SetCaption(L('2/2: Расчет восьми выходных форм вида: "RecognResults_####_#_###.dbf"')) ******************************************************************************************** // Отображение стадии исполнения. Будет написано прямо в окне Progress-bar @ 0,0 DCGROUP oGroup1 CAPTION L('Стадии исполнения процесса') FONT "6.Helv" SIZE 105, 3.5 PARENT oTabPage1 @ 5,0 DCGROUP oGroup2 CAPTION L('Прогноз времени исполнения') FONT "6.Helv" SIZE 105, 5.0 PARENT oTabPage2 s = 1 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 1] FONT "10.Helv" // 1 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 2] FONT "10.Helv" // 2 s++ @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay97 FONT "10.HelvBold" s++ @0.2+s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay98 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @1.5+s ,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay99 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @s ,1 DCPROGRESS oProgress ; SIZE 95,1.5 ; PERCENT ; EVERY 1 ; // Кол-во обновлений изображения (в функции самой регулируеся обновление изображений через 0,1 секунды) MAXCOUNT Wsego ; COLOR GRA_CLR_CYAN // Цвет полосы @s++,97 DCPUSHBUTTON CAPTION L('&Cancel') ; ACTION {||lCancelled:=.T.} OBJECT oButton ; SIZE 7,1.5 DCREAD GUI ; TITLE L('4.1.3.12.Вывод результатов распознавания в стиле: "Inp_data.xlsx" в модели: "')+UPPER(Ar_Model[M_CurrInf])+'"' ; PARENT @oDialog ; FIT ; EXIT ; MODAL oDialog:show() // Завершение подготовки данных для отображения графического прогресс-бар ********************************************************************************* aSay[1]:SetCaption(L('1/2: Подготовка к запуску мастера подготовки исполнения мастера загрузки исходных данных')) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Class_Sc EXCLUSIVE NEW;N_ClSc = RECCOUNT() USE Gr_ClSc EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW;N_Atr = RECCOUNT() USE Opis_Sc EXCLUSIVE NEW;N_OpSc = RECCOUNT() USE Gr_OpSc EXCLUSIVE NEW USE Rso_Zag EXCLUSIVE NEW;N_Obj = RECCOUNT() aKodClsKodClSc := {} SELECT Classes DBGOTOP() DO WHILE .NOT. EOF() AADD(aKodClsKodClSc, Kod_ClSc) lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // 1 N_Cls DBSKIP(1) ENDDO aNameCls := {} SELECT Gr_ClSc DBGOTOP() DO WHILE .NOT. EOF() AADD(aNameCls, ALLTRIM(Name_GrCS)) lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // 2 N_Cls DBSKIP(1) ENDDO aKodClSc := {} aNameClSc := {} SELECT Class_Sc DBGOTOP() DO WHILE .NOT. EOF() AADD(aKodClSc, Kod_ClSc) AADD(aNameClSc, ALLTRIM(Name_ClSc)) lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // 3 N_ClSc DBSKIP(1) ENDDO aKodAtrKodOpSc := {} SELECT Attributes DBGOTOP() DO WHILE .NOT. EOF() AADD(aKodAtrKodOpSc, Kod_OpSc) lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // 4 N_Atr DBSKIP(1) ENDDO aNameAtr := {} SELECT Gr_OpSc DBGOTOP() DO WHILE .NOT. EOF() AADD(aNameAtr, ALLTRIM(Name_GrOS)) lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // 5 N_Atr DBSKIP(1) ENDDO aKodOpSc := {} aNameOpSc := {} SELECT Opis_Sc DBGOTOP() DO WHILE .NOT. EOF() AADD(aKodOpSc, Kod_OpSc) AADD(aNameOpSc, ALLTRIM(Name_OpSc)) lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // 6 N_OpSc DBSKIP(1) ENDDO aObjName := {} mLenObjName = -999 SELECT Rso_Zag DBGOTOP() DO WHILE .NOT. EOF() mObjName = ALLTRIM(Name_obj) mLenObjName = MAX(mLenObjName, LEN(mObjName)) AADD(aObjName, mObjName) lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // 7 N_Obj DBSKIP(1) ENDDO aStructure := { { "ObjName", "C", mLenObjName, 0 } } // Наименование шкалы FOR j=1 TO LEN(aKodClSc) * AADD(aStructure, { aNameClSc[j], "C", 255, 0 } ) mFieldName = 'CS'+ALLTRIM(STR(aKodClSc[j])) AADD(aStructure, { mFieldName, "C", 255, 0 } ) lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // 8 N_ClSc NEXT FOR j=1 TO LEN(aKodOpSc) * AADD(aStructure, { aNameOpSc[j], "C", 255, 0 } ) mFieldName = 'OS'+ALLTRIM(STR(aKodOpSc[j])) AADD(aStructure, { mFieldName, "C", 255, 0 } ) lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // 9 N_OpSc NEXT * LB_Warning(aStructure) * DC_DebugQout( aStructure ) // Отладка ***** Создать базы данных RecognResults_####_#_###.dbf ***************************************************************** ***** модель: {"Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7"} ***** интегральный критерий: {'i','k'} ***** коды классов и признаков, наименования, значения, сходство: {'Kod','Nam','Val','Sim'} Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } aIntKrit := {'i','k'} aTypeRR := {'Kod','Nam','Val','Sim'} aDBname := {} AADD(aDBname, L('Базы данных результатов распознавания в стиле: "Inp_data.xlsx" успешно созданы!')) AADD(aDBname, L('Все они находятся по пути:')+' '+M_PathAppl+' '+L('и открываются в MS Excel.')) AADD(aDBname, '') m=mNumModel FOR k=1 TO 2 FOR n=1 TO 4 cFileName = 'RecognResults_'+Ar_Model[m]+'_'+aIntKrit[k]+'_'+aTypeRR[n] // База результатов распознавания AADD(aDBname, cFileName+'.dbf') DbCreate( cFileName, aStructure ) lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // 10 8 NEXT NEXT ***** Создать базы данных RecognResults_####_#_####.dbf ***************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rasp EXCLUSIVE NEW INDEX ON STR(Kod_Obj,19)+STR(99999999.9999999-Korr ,19,7)+STR(Kod_cls,19) TO RspK_obj // Один объект - много классов INDEX ON STR(Kod_Obj,19)+STR(99999999.9999999-Sum_inf,19,7)+STR(Kod_cls,19) TO RspI_obj // Один объект - много классов CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Class_Sc EXCLUSIVE NEW INDEX ON Kod_ClSc TO Class_Sc CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Gr_ClSc EXCLUSIVE NEW INDEX ON Kod_ClSc TO Gr_ClSc CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Opis_Sc EXCLUSIVE NEW INDEX ON Kod_OpSc TO Opis_Sc CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Gr_OpSc EXCLUSIVE NEW INDEX ON Kod_OpSc TO Gr_OpSc USE Rso_Kpr EXCLUSIVE NEW INDEX ON Kod_obj TO Rso_Kpr CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rasp INDEX RspK_obj, RspI_obj EXCLUSIVE NEW;N_Rasp = RECCOUNT() // Кол-во строк в БД Rasp.dbf USE Class_Sc INDEX Class_Sc EXCLUSIVE NEW USE Gr_ClSc INDEX Gr_ClSc EXCLUSIVE NEW USE Classes EXCLUSIVE NEW USE Opis_Sc INDEX Opis_Sc EXCLUSIVE NEW USE Gr_OpSc INDEX Gr_OpSc EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW USE Rso_Zag EXCLUSIVE NEW USE Rso_Kcl EXCLUSIVE NEW USE Rso_Kpr INDEX Rso_Kpr EXCLUSIVE NEW m=mNumModel FOR k=1 TO 2 FOR n=1 TO 4 cFileName = 'RecognResults_'+Ar_Model[m]+'_'+aIntKrit[k]+'_'+aTypeRR[n] // База результатов распознавания USE (cFileName) EXCLUSIVE NEW APPEND BLANK REPLACE ObjName WITH "Объект" FOR j=1 TO LEN(aKodClSc) mFieldName = 'CS'+ALLTRIM(STR(aKodClSc[j])) REPLACE &mFieldName WITH aNameClSc[j] NEXT FOR j=1 TO LEN(aKodOpSc) mFieldName = 'OS'+ALLTRIM(STR(aKodOpSc[j])) REPLACE &mFieldName WITH aNameOpSc[j] NEXT lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // 11 8 NEXT NEXT aSay[1]:SetCaption(aSay[1]:caption+L(' - Готово ')) aSay[2]:SetCaption(L('2/2: Расчет 8 выходных форм вида: "RecognResults_####_#_###.dbf"')) SELECT Rasp m=mNumModel FOR k=1 TO 2 DO CASE CASE k=1 SET FILTER TO Korr > 0 SET ORDER TO 1 CASE k=2 SET FILTER TO Sum_inf > 0 SET ORDER TO 2 ENDCASE FOR n=1 TO 4 ******************************************* * KOD_OBJ KOD_CLS KORR SUM_INF FAKT ******************************************* * OBJNAME A[1,1] A[1,2] A[1,3] A[1,5] A[1,6] A[1,7] A[1,8] A[2,1] A[2,2] A[2,3] A[2,5] A[2,6] A[2,7] A[2,8] A[3,1] A[3,2] A[3,3] A[3,5] A[3,6] A[3,7] A[3,8] A[5,1] A[5,2] A[5,3] A[5,5] A[5,6] A[5,7] A[5,8] A[6,1] A[6,2] A[6,3] A[6,5] A[6,6] A[6,7] A[6,8] A[7,1] A[7,2] A[7,3] A[7,5] A[7,6] A[7,7] A[7,8] B[1,1] B[1,2] B[1,3] B[1,5] B[1,6] B[1,7] B[2,1] B[2,2] B[2,3] B[2,5] B[2,6] B[2,7] B[3,1] B[3,2] B[3,3] B[3,5] B[3,6] B[3,7] B[5,1] B[5,2] B[5,3] B[5,5] B[5,6] B[5,7] B[6,1] B[6,2] B[6,3] B[6,5] B[6,6] B[6,7] B[7,1] B[7,2] B[7,3] B[7,5] B[7,6] B[7,7] B[8,1] B[8,2] B[8,3] B[8,5] B[8,6] B[8,7] PARAM aKodObj := {} aKodObjKodClSc := {} SELECT Rasp DBGOTOP() DO WHILE .NOT. EOF() mKodObj = Kod_obj mKodCls = Kod_cls mKorr = Korr mSumInf = Sum_inf IF ASCAN(aKodObj, mKodObj) = 0 // Добавлять запись в итоговую БД по каждому объекту распознаваемой выборки только 1 раз cFileName = 'RecognResults_'+Ar_Model[m]+'_'+aIntKrit[k]+'_'+aTypeRR[n] // База результатов распознавания SELECT(cFileName) AADD (aKodObj, mKodObj) APPEND BLANK REPLACE ObjName WITH aObjName[mKodObj] ****** Занести в БД RecognResults_####_#_####.dbf информацию о признаках объекта распознаваемой выборки (градациях описательных шкал) Ar_kpr := {} SELECT Rso_Kpr SET ORDER TO 1 T = DBSEEK(mKodObj) IF T DO WHILE mKodObj = Kod_obj .AND. .NOT. EOF() FOR j=2 TO 8 Fv = FIELDGET(j) IF Fv > 0 AADD(Ar_kpr, Fv) ENDIF NEXT DBSKIP(1) ENDDO ENDIF ASORT(Ar_kpr) ** коды классов и признаков, наименования, значения, сходство: {'Kod','Nam','Val','Sim'} IF LEN(Ar_kpr) > 0 cFileName = 'RecognResults_'+Ar_Model[m]+'_'+aIntKrit[k]+'_'+aTypeRR[n] // База результатов распознавания SELECT(cFileName) FOR j=1 TO LEN(Ar_kpr) mKodAtr = Ar_kpr[j] mKodOpSc = aKodAtrKodOpSc[mKodAtr] mNameOpSc = 'OS'+ALLTRIM(STR(mKodOpSc)) DO CASE CASE n=1 // Коды REPLACE &mNameOpSc WITH ALLTRIM(STR(mKodAtr)) CASE n=2 // Наименования REPLACE &mNameOpSc WITH aNameAtr[mKodAtr] CASE n=3 .OR. n=4 // Значения или сходство * 1/10-{1118577.5921037, 12024993.0180571} mPos = RAT('-{', aNameAtr[mKodAtr])+1 // Ищем справа на лево первую встречу '-{' mName = SUBSTR(aNameAtr[mKodAtr], mPos+1, LEN(aNameAtr[mKodAtr])-mPos) mName = STRTRAN(mName, '{','') mName = STRTRAN(mName, '}','') // Числовая шкала mMin = VAL(TOKEN(mName, ',', 1)) mMax = VAL(TOKEN(mName, ',', 2)) mAvrGrInt = mMin+(mMax-mMin)/2 // Текстовая шкала IF ABS(mMin) + ABS(mMax) + ABS(mAvrGrInt) = 0 mAvrGrInt = aNameAtr[mKodAtr] ELSE mAvrGrInt = STRTRAN(ALLTRIM(STR(mMin+(mMax-mMin)/2, 19, 7)),'.',',') ENDIF * MsgBox(aNameAtr[mKodAtr]+' '+STR(mMin,19,7)+' '+STR(mMax,19,7)+' '+mAvrGrInt) REPLACE &mNameOpSc WITH mAvrGrInt * CASE n=4 // Сходство * REPLACE &mNameOpSc WITH STRTRAN(IF(k=1, ALLTRIM(STR(mKorr,15,3)), ALLTRIM(STR(mSumInf,15,3))),'.',',') ENDCASE NEXT ENDIF ENDIF mKodClSc = aKodClsKodClSc[mKodCls] mNameClSc = 'CS'+ALLTRIM(STR(mKodClSc)) mKodObjKodClSc = STR(mKodObj)+STR(mKodClSc) IF ASCAN(aKodObjKodClSc, mKodObjKodClSc) = 0 // Записывать в БД только результат распознавания с самым высоким уровнем сходства, т.е. 1 раз AADD (aKodObjKodClSc, mKodObjKodClSc) cFileName = 'RecognResults_'+Ar_Model[m]+'_'+aIntKrit[k]+'_'+aTypeRR[n] // База результатов распознавания SELECT(cFileName) ** коды классов и признаков, наименования, значения, сходство: {'Kod','Nam','Val','Sim'} DO CASE CASE n=1 // Коды REPLACE &mNameClSc WITH ALLTRIM(STR(mKodCls)) CASE n=2 // Наименования REPLACE &mNameClSc WITH aNameCls[mKodCls] CASE n=3 // Значения * 1/10-{1118577.5921037, 12024993.0180571} mPos = RAT('-{', aNameCls[mKodCls])+1 // Ищем справа на лево первую встречу '-{' mName = SUBSTR(aNameCls[mKodCls], mPos+1, LEN(aNameCls[mKodCls])-mPos) mName = STRTRAN(mName, '{','') mName = STRTRAN(mName, '}','') // Числовая шкала mMin = VAL(TOKEN(mName, ',', 1)) mMax = VAL(TOKEN(mName, ',', 2)) mAvrGrInt = mMin+(mMax-mMin)/2 // Текстовая шкала IF ABS(mMin) + ABS(mMax) + ABS(mAvrGrInt) = 0 mAvrGrInt = aNameCls[mKodCls] ELSE mAvrGrInt = STRTRAN(ALLTRIM(STR(mMin+(mMax-mMin)/2, 19, 7)),'.',',') ENDIF * MsgBox(aNameCls[mKodCls]+' '+STR(mMin,19,7)+' '+STR(mMax,19,7)+' '+mAvrGrInt) REPLACE &mNameClSc WITH mAvrGrInt CASE n=4 // Сходство REPLACE &mNameClSc WITH STRTRAN(IF(k=1, ALLTRIM(STR(mKorr,15,3)), ALLTRIM(STR(mSumInf,15,3))),'.',',') ENDCASE ENDIF lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) // 12 (N_RaspKorr+N_RaspInf)*4, т.к. 8 БД SELECT Rasp DBSKIP(1) ENDDO NEXT NEXT aSay[2]:SetCaption(aSay[2]:caption+L(' - Готово ')) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** oSay97:SetCaption(L('Расчет восьми выходных форм вида: "RecognResults_####_#_###.dbf" успешно завершен !!!')) oSay97:SetCaption(oSay97:caption) oButton:SetCaption('&Ok') // Деструктурирование окна отображения графического Progress-bar oButton:activate := {||PostAppEvent(xbeP_Close,,,oDialog)} //<<<<<< Add This DC_AppEvent( @lOk ) * PostAppEvent(xbeP_Activate,,,DC_GetObject(GetList,'DCGUI_BUTTON_OK')) // Роджер oDialog:Destroy() LB_Warning(aDBname) Running(.F.) RETURN NIL **************************************************************************************** ******** 4.1.3.13.Частотное распределение наблюдений по самым похожим классам' ******** Частотное распределения объектов распознаваемой выборки по классам формируется ******** на основе выходной формы режима: 4.1.3.3. Итоги наглядно: "Объект - класс". ******** При расчетах учитываются по одному классу на наблюдение: к сумматору класса, ******** на который данное наблюдение наиболее похоже, суммируется 1. ******** Подробнее в статье: https://www.researchgate.net/publication/370402930 **************************************************************************************** FUNCTION F4_1_3_13() LOCAL GetList := {}, aPres, oBrowse, oToolBar, aColors, bColor, GetOptions, oEventsKO, bItems, n:=0 Local oHttp, oResponse, cColorm, bColorSize, bColorDate PUBLIC mNumbAppl := 0 Running(.T.) ******* Все ли условия запуска режима соблюдены? ******* CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF ApplChange("4.1.3.13()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF mFlagErr = .F. aMess := {} IF .NOT. FILE("Classes.dbf") // БД класс.шкал + градаций класс.шкал: Classes.dbf AADD(aMess, L('Отсутствует БД классификационных шкал и градаций: "Classes.dbf". Зайдите в режим 2.1')) AADD(aMess, L('')) mFlagErr = .T. ENDIF IF .NOT. FILE("Rsp_it1k.dbf") AADD(aMess, L('Отсутствует база данных Rsp1k.dbf !!! Для ее создания нужно')) AADD(aMess, L('запустить режим 3.5 с верификацией моделей или режим 4.1.2.')) mFlagErr = .T. ENDIF IF mFlagErr LB_Warning(aMess, L('(C) Система "Эйдос-Х++"' )) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) ReTURN nil ENDIF ********** Создать БД для частотного распределения наблюдений по классам CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW SELECT Classes mMaxLenNC = -99999999 DBGOTOP() DO WHILE .NOT. EOF() mMaxLenNC = MAX(mMaxLenNC, LEN(ALLTRIM(Name_cls))) DBSKIP(1) ENDDO aStructure := { { "Num_pp" , "N", 15, 0 }, ; // Номер по порядку при сортировке по числу наблюдений по убыванию { "Kod_cls" , "N", 15, 0 }, ; // Код класса, т.е. градации классификационной шкалы { "Name_cls" , "C",mMaxLenNC, 0 }, ; // Наименование класса, т.е. классификационной шкалы+"-"+градации классификационной шкалы { "Abs" , "N", 15, 0 }, ; { "Perc_fiz" , "N", 19, 7 }, ; { "Universal", "N", 19, 7 } } DbCreate( 'PieChartCls', aStructure ) ********** Дорасчет показателей ****************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Rsp_it1k EXCLUSIVE NEW;N_Obj = RECCOUNT() ********************************************************************************* Wsego = N_Obj + 2 * N_Cls // Отображение стадии исполнения. Будет написано прямо в окне Progress-bar d = 0 @0,0 DCGROUP oGroup1 CAPTION 'Стадии исполнения процесса' FONT "6.Helv" SIZE 105+d, 2.5 PARENT oTabPage1 @4,0 DCGROUP oGroup2 CAPTION 'Прогноз времени исполнения' FONT "6.Helv" SIZE 105+d, 5.0 PARENT oTabPage2 s = 1 @s++,1 DCSAY " " SAYSIZE 100 SAYOBJECT aSay[ 1] FONT "10.Helv" s++ @s++,1 DCSAY " " SAYSIZE 100 SAYOBJECT oSay97 FONT "10.HelvBold" s++ @0.2+s++,1 DCSAY " " SAYSIZE 100 SAYOBJECT oSay98 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @1.5+s ,1 DCSAY " " SAYSIZE 100 SAYOBJECT oSay99 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @s ,1 DCPROGRESS oProgress ; SIZE 95,1.5 ; PERCENT ; EVERY 1; // Кол-во обновлений изображения MAXCOUNT Wsego; COLOR GRA_CLR_CYAN // Цвет полосы @s++,97 DCPUSHBUTTON CAPTION '&Cancel' ; ACTION {||lOk:=.T.} OBJECT oButton ; SIZE 7,1.5 DCREAD GUI ; TITLE L('4.1.3.13. Частотное распределение')+' '+ALLTRIM(STR(N_Obj))+' '+L('наблюдений по классам') ; PARENT @oDialog ; FIT ; EXIT ; MODAL oDialog:alwaysOnTop = .T. // Окно открывается на переднем плане oDialog:show() // Начало отсчета времени для прогнозирования длительности исполнения Time_progress = 0 // Прошло секунд с начала процесса // Процесс может идти больше суток, поэтому для определения // во всех случаях вычисляется время, прошедшее с начала года T_Mess1 = "Начало:"+" "+TIME() // Начало Sec_1 = (DOY(DATE())-1)*86400+SECONDS() PUBLIC T1 := (DOY(DATE())-1)*86400+SECONDS() // Время предыдущей индикации процесса исполнения PUBLIC T2 := (DOY(DATE())-1)*86400+SECONDS()+1 // Текущее время (1-й раз оно заметно больше T1 чтобы было отображение) PUBLIC T1tp := T1 PUBLIC T2tp := T2 ********************************************************************************* aSay[ 1]:SetCaption('Расчет частотного распределения наблюдений по классам') SELECT Classes DBGOTOP() DO WHILE .NOT. EOF() REPLACE ABS WITH 0 REPLACE UNIVERSAL WITH 0 lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) DBSKIP(1) ENDDO SELECT Rsp_it1k DBGOTOP() DO WHILE .NOT. EOF() mKodCls = KOD_CLSA SELECT Classes DBGOTO(mKodCls) mAbs = ABS REPLACE Abs WITH mAbs + 1 lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) SELECT Rsp_it1k DBSKIP(1) ENDDO SELECT Classes DBGOTOP() DO WHILE .NOT. EOF() REPLACE PERC_FIZ WITH Abs / N_Obj * 100 lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) DBSKIP(1) ENDDO aSay[ 1]:SetCaption(aSay[ 1]:caption+L(" - Готово ")) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций oSay97:SetCaption(L("Расчет частотного распределения наблюдений по классам успешно завершен !")) oSay97:SetCaption(oSay97:caption) oButton:SetCaption(L('&Ok')) // Деструктурирование окна отображения графического Progress-bar oButton:activate := {||PostAppEvent(xbeP_Close,,,oDialog)} //<<<<<< Add This DC_AppEvent( @lOk ) MILLISEC(1000) oDialog:Destroy() ****** Отображение БД Classes ****************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW SELECT Classes INDEX ON STR(KOD_CLS, 15, 0) TO Cls_Kod INDEX ON STR(999.9999999-PERC_FIZ,11,7) TO Cls_PercFiz CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes INDEX Cls_Kod, Cls_PercFiz EXCLUSIVE NEW SELECT Classes SET ORDER TO 2 DBGOTOP() DO WHILE .NOT. EOF() REPLACE PERC_FIZ WITH Abs / N_Obj * 100 DBSKIP(1) ENDDO ********** Дорасчет нарастающего итога ****************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes INDEX Cls_Kod, Cls_PercFiz EXCLUSIVE NEW USE PieChartCls EXCLUSIVE NEW SELECT Classes SET ORDER TO 2 DBGOTOP() mMaxLenNC = -99999999 REPLACE UNIVERSAL WITH PERC_FIZ mUNIVERSAL = UNIVERSAL DBSKIP(1) DO WHILE .NOT. EOF() REPLACE UNIVERSAL WITH mUNIVERSAL + PERC_FIZ mUNIVERSAL = UNIVERSAL mMaxLenNC = MAX(mMaxLenNC, LEN(ALLTRIM(Name_cls))) DBSKIP(1) ENDDO ********** Физическая сортировка ************************ * aStructure := { { "Num_pp" , "N", 15, 0 }, ; // Номер по порядку при сортировке по числу наблюдений по убыванию * { "Kod_cls" , "N", 15, 0 }, ; // Код класса, т.е. градации классификационной шкалы * { "Name_cls" , "C",mMaxLenNC, 0 }, ; // Наименование класса, т.е. классификационной шкалы+"-"+градации классификационной шкалы * { "Abs" , "N", 15, 0 }, ; * { "Perc_fiz" , "N", 19, 7 }, ; * { "Universal", "N", 19, 7 } } * DbCreate( 'PieChartCls', aStructure ) SELECT Classes SET ORDER TO 2 DBGOTOP() DO WHILE .NOT. EOF() mKod_cls = Kod_cls mName_cls = Name_cls mAbs = Abs mPerc_fiz = Perc_fiz mUniversal = Universal SELECT PieChartCls APPEND BLANK REPLACE Num_pp WITH RECNO() REPLACE Kod_cls WITH mKod_cls REPLACE Name_cls WITH mName_cls REPLACE Abs WITH mAbs REPLACE Perc_fiz WITH mPerc_fiz REPLACE Universal WITH mUniversal SELECT Classes DBSKIP(1) ENDDO CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE PieChartCls EXCLUSIVE NEW SELECT PieChartCls INDEX ON STR(KOD_CLS, 15, 0) TO Cls_Kod INDEX ON STR(999.9999999-PERC_FIZ,11,7) TO Cls_PercFiz CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE PieChartCls INDEX Cls_Kod, Cls_PercFiz EXCLUSIVE NEW SELECT PieChartCls SET ORDER TO 2 DBGOTOP() /* ----- Create ToolBar ----- */ Name_DD = M_PathAppl + "PieChartCls.xls" mStr1 = L('Помощь' ) mStr2 = L('Сортировка по коду класса' ) mStr3 = L('Сортировка по числу наблюдений в классе' ) mStr4 = L('Круговая диаграмма числа наблюдений по классам' ) d = 20 @35+1.5, 0 DCPUSHBUTTON CAPTION mStr1 SIZE LEN(mStr1)+6, 1.5 ACTION {||Help41313(Name_DD), DC_GetRefresh(GetList)} @35+1.5, DCGUI_COL+d DCPUSHBUTTON CAPTION mStr2 SIZE LEN(mStr2)-0, 1.5 ACTION {||SortClasses(1), DC_GetRefresh(GetList)} @35+1.5, DCGUI_COL+d DCPUSHBUTTON CAPTION mStr3 SIZE LEN(mStr3)-0, 1.5 ACTION {||SortClasses(2), DC_GetRefresh(GetList)} * @35+1.5, DCGUI_COL+d DCPUSHBUTTON CAPTION mStr4 SIZE LEN(mStr4)-0, 1.5 ACTION {||PieChartCls(), DC_GetRefresh(GetList)} SELECT PieChartCls DBGOTOP() DCSETPARENT TO @ 1, 0 DCBROWSE PieChartCls ALIAS 'PieChartCls' SIZE mMaxLenNC+92, 35 ; HEADLINES 4 ; // Кол-во строк в заголовке (перенос строки - ";") COLOR {||IIF(PieChartCls->UNIVERSAL<=25,{nil,aColor[107]},IIF(PieChartCls->UNIVERSAL<=50,{nil,aColor[33]},IIF(STR(PieChartCls->UNIVERSAL,7,3)="100.000",{nil,aColor[153]},{nil,GRA_CLR_WHITE,})))} DCSETPARENT PieChartCls DCBROWSECOL FIELD PieChartCls->Num_pp HEADER L("№") PARENT Classes FONT "9.Courier" WIDTH 15 DCBROWSECOL FIELD PieChartCls->Kod_cls HEADER L("Код;класса") PARENT Classes FONT "9.Courier" WIDTH 15 DCBROWSECOL FIELD PieChartCls->Name_cls HEADER L("Наименование;класса") PARENT Classes FONT "9.Courier" WIDTH mMaxLenNC DCBROWSECOL FIELD PieChartCls->Abs HEADER L("Количество;наблюдений;в классе;(шт.)") PARENT Classes FONT "9.Courier" WIDTH 15 DCBROWSECOL FIELD PieChartCls->PERC_FIZ HEADER L("Количество;наблюдений;в классе;(%)") PARENT Classes FONT "9.Courier" WIDTH 18 DCBROWSECOL FIELD PieChartCls->UNIVERSAL HEADER L("Количество;наблюдений;в классе;(% кумулятивно)") PARENT Classes FONT "9.Courier" WIDTH 18 DCGETOPTIONS SAYFONT '10.Helv Bold' TABSTOP AUTORESIZE DCREAD GUI; TO lExit ; FIT; ADDBUTTONS; MODAL; TITLE L('4.1.3.13. Частотное распределение')+' '+ALLTRIM(STR(N_Obj))+' '+L('наблюдений по классам') IF lExit ** Button Ok ELSE QUIT ENDIF ******************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций Name_SS = M_PathAppl + "PieChartCls.dbf" Name_DD = M_PathAppl + "PieChartCls.xls" * LB_Warning(L("Источник: "+Name_SS+", приемник: "+Name_DD) COPY FILE (Name_SS) TO (Name_DD) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW Running(.F.) RETURN NIL ************************************************************************************ ******** Визуализация частотного распределения наблюдений в форме круговой диаграммы ************************************************************************************ FUNCTION PieChartCls() LOCAL oClipBoard, cTitle, aSize, aData, aColor, aLegend, ; oPrinter, oBitmap, aData1, aData2, nColor1, nColor2, ; aLabel, aAxisLabel IF !LoadRMChartControl() RETURN .f. ENDIF DCPRINT ON TO oPrinter IF Valtype(oPrinter) # 'O' .OR. !oPrinter:lActive RETURN .f. ENDIF N_Obj = 8405 cTitle := '4.1.3.13. Частотное распределение'+' '+ALLTRIM(STR(N_Obj))+' '+'наблюдений по классам' @ 1,5 DCPRINT SAY cTitle FONT '14.Arial Bold' * --- Create and Print Pie Chart --- * <<<===####################################### ************************************************************************ * aStructure := { { "Num_pp" , "N", 15, 0 }, ; // Номер по порядку при сортировке по числу наблюдений по убыванию * { "Kod_cls" , "N", 15, 0 }, ; // Код класса, т.е. градации классификационной шкалы * { "Name_cls" , "C",mMaxLenNC, 0 }, ; // Наименование класса, т.е. классификационной шкалы+"-"+градации классификационной шкалы * { "Abs" , "N", 15, 0 }, ; * { "Perc_fiz" , "N", 19, 7 }, ; * { "Universal", "N", 19, 7 } } * DbCreate( 'PieChartCls', aStructure ) aSize := { 2048, 2048 } // <<<===################ aData := {} aLegend := {} CLOSE ALL USE PieChartCls EXCLUSIVE NEW SELECT PieChartCls DBGOTOP() DO WHILE .NOT. EOF() IF RECNO() <= 100 AADD(aData , Perc_fiz) AADD(aLegend, ALLTRIM(STR(Kod_cls))+'-'+ALLTRIM(Name_cls) ) ELSE EXIT ENDIF DBSKIP(1) ENDDO DBGOTOP() ************************************************************************ PieChartToClipBoard( cTitle, aSize, aData, aColor, aLegend ) oBitmap := GetBitmapFromClipBoard() @ 3,5,20,40 DCPRINT BITMAP oBitmap DCPRINT OFF RETURN nil **************************************************************************************************** * ------------ FUNCTION PieChartToClipBoard( cTitle, aSize, aData, aColor, aLegend ) LOCAL GetList[0], GetOptions, oRmChart, aPie[0], oRegion, oDlg * --- RMChart ActiveX Control -- @ 0,0 DCRMCHART oRmChart SIZE aSize[1], aSize[2] PIXEL * --- Pie --- DcAddGridlessGroup TO aPie DATA aData ; COLOR aColor STYLE RMC_PIE_3D @ 0,0 DcChartRegion oRegion ; PARENT oRMChart ; SIZE aSize[1], aSize[2] PIXEL ; CAPTION TITLE cTitle ; LEGEND TEXT aLegend ; GRIDLESSGROUP aPie DCGETOPTIONS HIDE DCREAD GUI FIT TITLE 'Pie Chart' ; EXIT ; OPTIONS GetOptions ; PARENT @oDlg ; EVAL {||oRMChart:draw(), ; oRMChart:draw2ClipBoard()} oDlg:destroy() RETURN nil * ----------- FUNCTION BarChartToClipBoard( cTitle, aSize, aData1, aData2, nColor1, nColor2, ; aLabel, aAxisLabel, aLegend ) LOCAL GetList[0], GetOptions, oRmChart, oRegion1, oRegion2, aBarGroup[0], ; aDataAxis[0], oDlg * --- RMChart ActiveX Control -- @ 0,0 DCRMCHART oRmChart SIZE aSize[1], aSize[2] PIXEL * --- Bar Group --- DcAddBarGroup TO aBarGroup DATA aData1 TYPE RMC_BARGROUP COLOR nColor1 DcAddBarGroup TO aBarGroup DATA aData2 TYPE RMC_BARGROUP COLOR nColor2 DcAddDataAxis TO aDataAxis LABELTEXT aAxisLabel @ 5,5 DcChartRegion oRegion1 ; PARENT oRMChart ; ;// FOOTER "(c) Copyright - Donnay Software Designs (2008)" ; SIZE aSize[1], aSize[2] PIXEL ; CAPTION TITLE cTitle ; GRID ; LEGEND TEXT aLegend ; DATAAXIS aDataAxis ; LABELAXIS LABELARRAY aLabel ; BARGROUP aBarGroup DCGETOPTIONS HIDE DCREAD GUI FIT TITLE 'Bar Chart' ; EXIT ; OPTIONS GetOptions ; PARENT @oDlg ; EVAL {||oRMChart:draw(), ; oRMChart:draw2ClipBoard()} oDlg:destroy() RETURN nil * ----------- *PROC appsys ; return * ----------- STATIC FUNCTION GetBitmapFromClipBoard() LOCAL oClipBoard, oBitmap oClipBoard := XbpClipBoard():new():create() oClipBoard:open() oBitMap := oClipBoard:getBuffer( XBPCLPBRD_BITMAP ) oClipBoard:close() RETURN oBitmap * ----------- STATIC FUNCTION LoadRMChartControl() LOCAL cRegSvr, cClsId, cRegQuery, lStatus := .t. cRegSvr := 'regsvr32.exe' cClsId := '\CLSID\{4D814D0F-7D71-4E7E-B51E-2885AD0ED9D7}' // RMChart Version 4.xx cRegQuery := DC_RegQuery(HKEY_CLASSES_ROOT,cClsId,'') IF Valtype(cRegQuery) # 'C' .OR. Empty(cRegQuery) RunShell('rmchart.ocx /s',cRegSvr) cRegQuery := DC_RegQuery(HKEY_CLASSES_ROOT,cClsId,'') IF Valtype(cRegQuery) # 'C' .OR. Empty(cRegQuery) DC_WinAlert('Could not register RMChart OCX') lStatus := .f. ENDIF ENDIF RETURN lStatus **************************************************************************************** ******** 4.1.3.14.Распределение уровней сходства наблюдений по всем классам. ******** Распределение уровней сходства объектов распознаваемой выборки по классам ******** формируется на основе выходной формы режима: 4.1.3.1. Подробно наглядно: ******** "Объект - классы". При расчетах учитываются все классы, на которые данное ******** наблюдение похоже: к сумматору каждого класса суммируется сходство данного ******** наблюдения с этим классом. ******** Подробнее в статье: https://www.researchgate.net/publication/370402930 **************************************************************************************** FUNCTION F4_1_3_14() LOCAL GetList := {}, aPres, oBrowse, oToolBar, aColors, bColor, GetOptions, oEventsKO, bItems, n:=0 Local oHttp, oResponse, cColorm, bColorSize, bColorDate PUBLIC mNumbAppl := 0 Running(.T.) ******* Все ли условия запуска режима соблюдены? ******* CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF ApplChange("4.1.3.13()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF mFlagErr = .F. aMess := {} IF .NOT. FILE("Classes.dbf") // БД класс.шкал + градаций класс.шкал: Classes.dbf AADD(aMess, L('Отсутствует БД классификационных шкал и градаций: "Classes.dbf". Зайдите в режим 2.1')) AADD(aMess, L('')) mFlagErr = .T. ENDIF IF .NOT. FILE("Rsp1i.dbf") AADD(aMess, L("Нет баз данных результатов распознавания! Небходимо выполнить режим 3.5 или 4.1.2!")) mFlagErr = .T. ENDIF IF mFlagErr LB_Warning(aMess, L('(C) Система "Эйдос-Х++"' )) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) ReTURN nil ENDIF ********** Создать БД для распределения уровней сходства наблюдений по классам CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW SELECT Classes * mMaxLenNC = 86 * DBGOTOP() * DO WHILE .NOT. EOF() * mMaxLenNC = MAX(mMaxLenNC, LEN(ALLTRIM(Name_cls))) * DBSKIP(1) * ENDDO aStructure := { { "Num_pp" , "C", 9, 0 }, ; // Номер по порядку при сортировке по числу наблюдений по убыванию { "Kod_cls" , "C", 9, 0 }, ; // Код класса, т.е. градации классификационной шкалы { "Name_cls" , "C",103, 0 }, ; // Наименование класса, т.е. классификационной шкалы+"-"+градации классификационной шкалы { "Perc_fiz" , "C", 19, 3 }, ; { "Universal", "C", 19, 3 } } DbCreate( 'SumUrSxCls', aStructure ) ********** Дорасчет показателей ****************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Rsp1i EXCLUSIVE NEW;N_Obj = RECCOUNT() SELECT Rsp1i ****** Задание параметров текущей модели mIntKrit = 2 mValIntKrit = 1 @ 0,0 DCGROUP oGroup1 CAPTION L('Какой интегр.критерий сходства использовать?') SIZE 82, 3.5 @ 1,3 DCRADIO mIntKrit VALUE 1 PROMPT L('1. "Резонанс знаний" ') PARENT oGroup1 @ 2,3 DCRADIO mIntKrit VALUE 2 PROMPT L('2. "Сумма знаний" ') PARENT oGroup1 @ 4,0 DCGROUP oGroup2 CAPTION L('Какие значения интегр.критерия учитывать? ') SIZE 82, 3.5 @ 1,3 DCRADIO mValIntKrit VALUE 1 PROMPT L('1. Только сходство ') PARENT oGroup2 @ 2,3 DCRADIO mValIntKrit VALUE 2 PROMPT L('2. Только различие ') PARENT oGroup2 DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; OPTIONS GetOptions ; ADDBUTTONS; MODAL ; TITLE L('4.1.3.14.Распределение уровней сходства')+' '+ALLTRIM(STR(N_Obj))+' '+L('фактов наблюдений по классам') ******************************************************************** IF lExit ** Button Ok ELSE ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ******************************************************************** CalculatDistribut() // Расчет распределения /* ----- Create ToolBar ----- */ * mIntKrit = 2 * mValIntKrit = 1 * @ 0,0 DCGROUP oGroup1 CAPTION L('Какой интегральный критерий сходства использовать?') SIZE 82, 3.5 * @ 1,3 DCRADIO mIntKrit VALUE 1 PROMPT L('1. "Резонанс знаний" ') PARENT oGroup1 * @ 2,3 DCRADIO mIntKrit VALUE 2 PROMPT L('2. "Сумма знаний" ') PARENT oGroup1 * @ 4,0 DCGROUP oGroup2 CAPTION L('Какие значения интегрального критерия учитывать? ') SIZE 82, 3.5 * @ 1,3 DCRADIO mValIntKrit VALUE 1 PROMPT L('1. Только сходство ') PARENT oGroup2 * @ 2,3 DCRADIO mValIntKrit VALUE 2 PROMPT L('2. Только различие ') PARENT oGroup2 Name_DD = M_PathAppl + "SumUrSxCls.xls" mStr1 = L('Помощь' ) mStr2 = L('По коду класса' ) mStr3 = L('По сумм.сход.набл.с классом' ) d = 5 @31.5 , 0 DCGROUP oGroup1 CAPTION '' SIZE LEN(mStr1)+7, 3.0 @32.35, 2 DCPUSHBUTTON CAPTION mStr1 SIZE LEN(mStr1)+3, 1.5 ACTION {||Help41314(Name_DD), DC_GetRefresh(GetList)} @31.5 , LEN(mStr1)+ 8 DCGROUP oGroup2 CAPTION L('Сортировка:') SIZE 44, 3.0 @32.35, LEN(mStr1)+10 DCPUSHBUTTON CAPTION mStr2 SIZE LEN(mStr2)-0, 1.5 ACTION {||SortCls41314(1) , DC_GetRefresh(GetList)} @32.35, DCGUI_COL+d+0 DCPUSHBUTTON CAPTION mStr3 SIZE LEN(mStr3)-2, 1.5 ACTION {||SortCls41314(2) , DC_GetRefresh(GetList)} @31.5, LEN(mStr1)+LEN(mStr2)+LEN(mStr3)+12 DCGROUP oGroup3 CAPTION L('Задайте интегральный критерий:') SIZE 34, 3.0 @ 1 , 2 DCRADIO mIntKrit VALUE 1 PROMPT L('Резонанс знаний') PARENT oGroup3 @ 1 , DCGUI_COL+d DCRADIO mIntKrit VALUE 2 PROMPT L('Сумма знаний') PARENT oGroup3 @31.5, LEN(mStr1)+LEN(mStr2)+LEN(mStr3)+47 DCGROUP oGroup4 CAPTION L('Какие значения интегрального критерия учитывать?') SIZE 44, 3.0 @ 1 , 2 DCRADIO mValIntKrit VALUE 1 PROMPT L('Только сходство ') PARENT oGroup4 @ 1 , DCGUI_COL+d DCRADIO mValIntKrit VALUE 2 PROMPT L('Только различие ') PARENT oGroup4 @32.35,LEN(mStr1)+LEN(mStr2)+LEN(mStr3)+92 DCPUSHBUTTON CAPTION "Пересчет" SIZE LEN("Пересчет")+4, 1.5 ACTION {||CalculatDistribut(), DC_GetRefresh(GetList)} FONT "9.Helv Bold" SELECT SumUrSxCls DBGOTOP() DCSETPARENT TO @ 1, 0 DCBROWSE SumUrSxCls ALIAS 'SumUrSxCls' SIZE 151, 30 ; HEADLINES 5 ; // Кол-во строк в заголовке (перенос строки - ";") COLOR {||IIF(VAL(UNIVERSAL)<=25,{nil,aColor[107]},IIF(VAL(UNIVERSAL)<=50,{nil,aColor[33]},IIF(VAL(PERC_FIZ)<=0.007,{nil,aColor[153]},{nil,GRA_CLR_WHITE,})))} DCSETPARENT SumUrSxCls DCBROWSECOL FIELD Num_pp HEADER L("№") PARENT Classes FONT "9.Courier" WIDTH 9 DCBROWSECOL FIELD Kod_cls HEADER L("Код;класса") PARENT Classes FONT "9.Courier" WIDTH 9 DCBROWSECOL FIELD Name_cls HEADER L("Наименование;класса") PARENT Classes FONT "9.Courier" WIDTH 103 DCBROWSECOL FIELD PERC_FIZ HEADER L("Суммарное;сходство;наблюдений;с классом;(%)") PARENT Classes FONT "9.Courier" WIDTH 10 DCBROWSECOL FIELD UNIVERSAL HEADER L("Суммарное;сходство;наблюдений;с классом;(% кумулятивно)") PARENT Classes FONT "9.Courier" WIDTH 10 DCGETOPTIONS SAYFONT '10.Helv Bold' TABSTOP AUTORESIZE DCREAD GUI; FIT; MODAL; TITLE L('4.1.3.14.Распределение уровней сходства')+' '+ALLTRIM(STR(N_Obj))+' '+L('фактов наблюдений по классам') ******************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций Name_SS = M_PathAppl + "SumUrSxCls.dbf" Name_DD = M_PathAppl + "SumUrSxCls.xls" * LB_Warning(L("Источник: "+Name_SS+", приемник: "+Name_DD) COPY FILE (Name_SS) TO (Name_DD) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW Running(.F.) RETURN NIL *********************************************************************************************** FUNCTION Help41313(Name_DD) DCSETFONT TO '10.Helv' s=0 @ s++,1 DCSAY L('В данном режиме 4.1.3.13 рассчитывается частотное распределение количества наблюдений, т.е.') SAYSIZE 0 @ s++,1 DCSAY L('объектов распознаваемой выборки, по классам. Это частотное распределение формируется ') SAYSIZE 0 @ s++,1 DCSAY L('на основе обобщенных результатов распознавания (режим: 4.1.3.3, файл: "Rsp_it1.dbf"). ') SAYSIZE 0 @ s++,1 DCSAY L('Вывод в табличной форме, в которой кроме количества объектов по классам выводится какой ') SAYSIZE 0 @ s++,1 DCSAY L('процент от общего количества объектов обучающей выборки, равного')+' '+ALLTRIM(STR(N_Obj))+', '+L('приходится') SAYSIZE 0 @ s++,1 DCSAY L('на каждый класс, а также этот процент расчитывается кумулятивно, т.е. нарастающим итогом. ') SAYSIZE 0 @ s++,1 DCSAY L('') SAYSIZE 0 @ s++,1 DCSAY L('Строки с кумулятивным % числа набюдений по классам <= 25% отображаются зеленом фоне. ') SAYSIZE 0 @ s++,1 DCSAY L('Строки с кумулятивным % числа набюдений по классам <= 50% отображаются голубом фоне. ') SAYSIZE 0 @ s++,1 DCSAY L('Строки без набюдений по классам отображаются желтом фоне. ') SAYSIZE 0 @ s++,1 DCSAY L('') SAYSIZE 0 @ s++,1 DCSAY L('В режиме возможна сортировка таблицы:')+' '+Name_DD SAYSIZE 0 @ s++,1 DCSAY L('по количеству наблюдений в классах (в порядке убывания) и по коду класса (по возрастанию). ') SAYSIZE 0 @ s++,1 DCSAY L('') SAYSIZE 0 @ s++,1 DCSAY L('Различные диаграммы по таблице частотного распределения наблюдений по классам можно ') SAYSIZE 0 @ s++,1 DCSAY L('построить средствами MS Excel. Для этого удобно использовать указанный выше файл. ') SAYSIZE 0 @ s++,1 DCSAY L('') SAYSIZE 0 @ s++,1 DCSAY L('Подробнее о том, что делает данный режим, можно почитать в статье на русском языке: ') SAYSIZE 0 @ s++,1 DCSAY L('Lutsenko E.V. Automated system-cognitive analysis and classification of all articles of the scientific') SAYSIZE 0 @ s++,1 DCSAY L('journal KubSAU for 20 years in the specialties of the higher attestation commission of the Russian ') SAYSIZE 0 @ s++,1 DCSAY L('federation of the new nomenclature // April 2023, DOI: 10.13140/RG.2.2.18565.42726, License CC BY 4.0,') SAYSIZE 0 @ s++,1 DCSAY L('https://www.researchgate.net/publication/370402930') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'https://www.researchgate.net/publication/370402930', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} @ s++,1 DCSAY L('') SAYSIZE 0 @ s++,1 DCSAY L('Подробнее о том, что делает данный режим, можно почитать в статье на английском языке: ') SAYSIZE 0 @ s++,1 DCSAY L('Lutsenko E.V. Automated system-cognitive analysis and classification of all articles of the scientific') SAYSIZE 0 @ s++,1 DCSAY L('journal KubSAU for 20 years in the specialties of the higher attestation commission of the Russian ') SAYSIZE 0 @ s++,1 DCSAY L('federation of the new nomenclature // April 2023, DOI: 10.13140/RG.2.2.18565.42726, License CC BY 4.0,') SAYSIZE 0 @ s++,1 DCSAY L('https://www.researchgate.net/publication/370402853') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'https://www.researchgate.net/publication/370402853', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} DCREAD GUI FIT TITLE L('4.1.3.13. Частотное распределение')+' '+ALLTRIM(STR(N_Obj))+' '+L('наблюдений по классам') RETURN NIL *********************************************************************************************** FUNCTION SortClasses(mNumInd) * USE PieChartCls INDEX Cls_Kod, Cls_PercFiz EXCLUSIVE NEW DO CASE CASE mNumInd = 1 SET ORDER TO 1 DBGOTOP() CASE mNumInd = 2 SET ORDER TO 2 DBGOTOP() ENDCASE RETURN NIL *********************************************************************************************** FUNCTION Help41314(Name_DD) DCSETFONT TO '10.Helv' s=0 @ s++,1 DCSAY L('В этом режиме 4.1.3.14 рассчитывается распределение суммарного сходства фактов наблюдений, ') SAYSIZE 0 @ s++,1 DCSAY L('(объектов распознаваемой выборки) по классам. Это распределение формируется на основе ') SAYSIZE 0 @ s++,1 DCSAY L('результатов распознавания (режим: 4.1.3.1, файл: "Rsp1i.dbf"). Вывод в форме таблицы, в которой') SAYSIZE 0 @ s++,1 DCSAY L('кроме суммарного сходства объектов с классами выводится какой процент от суммарного сходства ') SAYSIZE 0 @ s++,1 DCSAY L('приходится на каждый класс, а также этот % расчитывается кумулятивно, т.е. нарастающим итогом.') SAYSIZE 0 @ s++,1 DCSAY L('') SAYSIZE 0 @ s++,1 DCSAY L('Строки с кумулятивным % числа набюдений по классам <= 25% отображаются зеленом фоне. ') SAYSIZE 0 @ s++,1 DCSAY L('Строки с кумулятивным % числа набюдений по классам <= 50% отображаются голубом фоне. ') SAYSIZE 0 @ s++,1 DCSAY L('Строки без набюдений по классам отображаются желтом фоне. ') SAYSIZE 0 @ s++,1 DCSAY L('') SAYSIZE 0 @ s++,1 DCSAY L('В режиме возможна сортировка таблицы:')+' '+Name_DD SAYSIZE 0 @ s++,1 DCSAY L('по суммарному сходству наблюдений с классами по убыванию и по коду класса по возрастанию. ') SAYSIZE 0 @ s++,1 DCSAY L('') SAYSIZE 0 @ s++,1 DCSAY L('Различные диаграммы по таблице частотного распределения наблюдений по классам можно ') SAYSIZE 0 @ s++,1 DCSAY L('построить средствами MS Excel. Для этого удобно использовать указанный выше файл. ') SAYSIZE 0 @ s++,1 DCSAY L('') SAYSIZE 0 @ s++,1 DCSAY L('Подробнее о том, что делает данный режим, можно почитать в статье на русском языке: ') SAYSIZE 0 @ s++,1 DCSAY L("Lutsenko E.V. Automated system-cognitive analysis of the frequency distribution of the author's") SAYSIZE 0 // <<<===#################### @ s++,1 DCSAY L('publications on scientific specialties of the higher attestation commission of the Russian federation') SAYSIZE 0 @ s++,1 DCSAY L('of the new nomenclature // May 2023, DOI: 10.13140/RG.2.2.17726.87369, License CC BY 4.0,') SAYSIZE 0 @ s++,1 DCSAY L('https://www.researchgate.net/publication/370961056') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'https://www.researchgate.net/publication/370961056', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} @ s++,1 DCSAY L('') SAYSIZE 0 @ s++,1 DCSAY L('Подробнее о том, что делает данный режим, можно почитать в статье на английском языке: ') SAYSIZE 0 @ s++,1 DCSAY L("Lutsenko E.V. Automated system-cognitive analysis of the frequency distribution of the author's") SAYSIZE 0 // <<<===#################### @ s++,1 DCSAY L('publications on scientific specialties of the higher attestation commission of the russian federation') SAYSIZE 0 @ s++,1 DCSAY L('of the new nomenclature (in English) // May 2023, DOI: 10.13140/RG.2.2.14371.43049, License CC BY 4.0,') SAYSIZE 0 @ s++,1 DCSAY L('https://www.researchgate.net/publication/370961244') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'https://www.researchgate.net/publication/370961244', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} DCREAD GUI FIT TITLE L('4.1.3.14.Распределение уровней сходства')+' '+ALLTRIM(STR(N_Obj))+' '+L('фактов наблюдений по классам') RETURN NIL *********************************************************************************************** FUNCTION SortCls41314(mNumInd) * USE SumUrSxCls INDEX Cls_Kod, Cls_PercFiz EXCLUSIVE NEW DO CASE CASE mNumInd = 1 SET ORDER TO 1 DBGOTOP() CASE mNumInd = 2 SET ORDER TO 2 DBGOTOP() ENDCASE RETURN NIL ************************************************************************************ FUNCTION CalculatDistribut() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций aStructure := { { "Num_pp" , "C", 9, 0 }, ; // Номер по порядку при сортировке по числу наблюдений по убыванию { "Kod_cls" , "C", 9, 0 }, ; // Код класса, т.е. градации классификационной шкалы { "Name_cls" , "C",103, 0 }, ; // Наименование класса, т.е. классификационной шкалы+"-"+градации классификационной шкалы { "Perc_fiz" , "C", 19, 3 }, ; { "Universal", "C", 19, 3 } } DbCreate( 'SumUrSxCls', aStructure ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Rsp1i EXCLUSIVE NEW;N_Obj = RECCOUNT() SELECT Rsp1i ************************************************ Начало расчета ************************************ Wsego = N_Obj + N_Cls // Отображение стадии исполнения. Будет написано прямо в окне Progress-bar d = 0 @0,0 DCGROUP oGroup1 CAPTION 'Стадии исполнения процесса' FONT "6.Helv" SIZE 105+d, 2.5 PARENT oTabPage1 @4,0 DCGROUP oGroup2 CAPTION 'Прогноз времени исполнения' FONT "6.Helv" SIZE 105+d, 5.0 PARENT oTabPage2 s = 1 @s++,1 DCSAY " " SAYSIZE 100 SAYOBJECT aSay[ 1] FONT "10.Helv" s++ @s++,1 DCSAY " " SAYSIZE 100 SAYOBJECT oSay97 FONT "10.HelvBold" s++ @0.2+s++,1 DCSAY " " SAYSIZE 100 SAYOBJECT oSay98 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @1.5+s ,1 DCSAY " " SAYSIZE 100 SAYOBJECT oSay99 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @s ,1 DCPROGRESS oProgress ; SIZE 95,1.5 ; PERCENT ; EVERY 1; // Кол-во обновлений изображения MAXCOUNT Wsego; COLOR GRA_CLR_CYAN // Цвет полосы @s++,97 DCPUSHBUTTON CAPTION '&Cancel' ; ACTION {||lOk:=.T.} OBJECT oButton ; SIZE 7,1.5 DCREAD GUI ; TITLE L('4.1.3.14.Распределение уровней сходства')+' '+ALLTRIM(STR(N_Obj))+' '+L('фактов наблюдений по классам') ; PARENT @oDialog ; FIT ; EXIT ; MODAL oDialog:alwaysOnTop = .T. // Окно открывается на переднем плане oDialog:show() // Начало отсчета времени для прогнозирования длительности исполнения Time_progress = 0 // Прошло секунд с начала процесса // Процесс может идти больше суток, поэтому для определения // во всех случаях вычисляется время, прошедшее с начала года T_Mess1 = "Начало:"+" "+TIME() // Начало Sec_1 = (DOY(DATE())-1)*86400+SECONDS() PUBLIC T1 := (DOY(DATE())-1)*86400+SECONDS() // Время предыдущей индикации процесса исполнения PUBLIC T2 := (DOY(DATE())-1)*86400+SECONDS()+1 // Текущее время (1-й раз оно заметно больше T1 чтобы было отображение) PUBLIC T1tp := T1 PUBLIC T2tp := T2 ********************************************************************************* aSay[ 1]:SetCaption('Расчет распределения уровней сходства наблюдений по классам') PRIVATE aUniversal[N_Cls] AFILL(aUniversal, 0) mUniverSumma = 0 DBGOTOP() DO WHILE .NOT. EOF() DO CASE CASE mIntKrit=1 // 1. "Резонанс знаний" DO CASE CASE mValIntKrit=1 // 1. Только сходство IF KORR > 0 aUniversal[KOD_CLS] = aUniversal[KOD_CLS] + KORR*0.01 mUniverSumma = mUniverSumma + KORR*0.01 ENDIF CASE mValIntKrit=2 // 2. Только различие IF KORR < 0 aUniversal[KOD_CLS] = aUniversal[KOD_CLS] + KORR*0.01 mUniverSumma = mUniverSumma + KORR*0.01 ENDIF ENDCASE CASE mIntKrit=2 // 2. "Сумма знаний" DO CASE CASE mValIntKrit=1 // 1. Только сходство IF SUM_INF > 0 aUniversal[KOD_CLS] = aUniversal[KOD_CLS] + SUM_INF*0.01 mUniverSumma = mUniverSumma + SUM_INF*0.01 ENDIF CASE mValIntKrit=2 // 2. Только различие IF SUM_INF < 0 aUniversal[KOD_CLS] = aUniversal[KOD_CLS] + SUM_INF*0.01 mUniverSumma = mUniverSumma + SUM_INF*0.01 ENDIF ENDCASE ENDCASE lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) DBSKIP(1) ENDDO SELECT Classes DBGOTOP() DO WHILE .NOT. EOF() REPLACE PERC_FIZ WITH aUniversal[KOD_CLS] / mUniverSumma * 100 lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) DBSKIP(1) ENDDO aSay[ 1]:SetCaption(aSay[ 1]:caption+L(" - Готово ")) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций oSay97:SetCaption(L('Расчет распределения уровней сходства')+' '+ALLTRIM(STR(N_Obj))+' '+L('наблюдений по классам успешно завершен !!!')) oSay97:SetCaption(oSay97:caption) oButton:SetCaption(L('&Ok')) // Деструктурирование окна отображения графического Progress-bar oButton:activate := {||PostAppEvent(xbeP_Close,,,oDialog)} //<<<<<< Add This DC_AppEvent( @lOk ) MILLISEC(1000) oDialog:Destroy() ****** Отображение БД Classes ****************** oScr := DC_WaitOn('Формирование базы данных SumUrSxCls.xls для визуализации. Немного подождите!',,,,,,,,,,,.F.) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW SELECT Classes INDEX ON STR(KOD_CLS, 15, 0) TO Cls_Kod INDEX ON STR(999999.9999999-PERC_FIZ,15,7) TO Cls_PercFiz ********** Дорасчет нарастающего итога ****************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes INDEX Cls_Kod, Cls_PercFiz EXCLUSIVE NEW USE SumUrSxCls EXCLUSIVE NEW SELECT Classes SET ORDER TO 2 DBGOTOP() REPLACE UNIVERSAL WITH PERC_FIZ mUNIVERSAL = UNIVERSAL DBSKIP(1) DO WHILE .NOT. EOF() REPLACE UNIVERSAL WITH mUNIVERSAL + PERC_FIZ mUNIVERSAL = UNIVERSAL DBSKIP(1) ENDDO ********** Физическая сортировка ************************ SELECT Classes SET ORDER TO 2 DBGOTOP() DO WHILE .NOT. EOF() mNum_pp = ALLTRIM(STR(RECNO() ,9)) ;mNum_pp = SPACE(( 9-LEN(mNum_pp)) /2) + mNum_pp mKod_cls = ALLTRIM(STR(Kod_cls ,9)) ;mKod_cls = SPACE(( 9-LEN(mKod_cls)) /2) + mKod_cls mName_cls = ALLTRIM(SUBSTR(Name_cls,1,103)) mPerc_fiz = ALLTRIM(STR(Perc_fiz ,11,3));mPerc_fiz = SPACE((11-LEN(mPerc_fiz)) /2) + mPerc_fiz mUniversal = ALLTRIM(STR(Universal,11,3));mUniversal = SPACE((11-LEN(mUniversal))/2) + mUniversal SELECT SumUrSxCls APPEND BLANK REPLACE Num_pp WITH mNum_pp REPLACE Kod_cls WITH mKod_cls REPLACE Name_cls WITH mName_cls REPLACE Perc_fiz WITH mPerc_fiz REPLACE Universal WITH mUniversal SELECT Classes DBSKIP(1) ENDDO CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE SumUrSxCls EXCLUSIVE NEW SELECT SumUrSxCls INDEX ON KOD_CLS TO Cls_Kod INDEX ON 999999.999-VAL(PERC_FIZ) TO Cls_PercFiz CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE SumUrSxCls INDEX Cls_Kod, Cls_PercFiz EXCLUSIVE NEW SELECT SumUrSxCls SET ORDER TO 2 DBGOTOP() DC_Impl(oScr) ************************************************ Конец расчета ************************************* RETURN NIL******************************************************************************* ******** Создание БД Inp_data.dbf из файлов: t1.xlsx, t2.xlsx, t3.xlsx, t4.xlsx ******** Чемпионат RAIF-Challenge 2017-API-bank ******************************************************************************* FUNCTION F2_3_2_13() aMess := {} AADD(aMess, 'Данный режим создан для участия в открытом чемпионате России') AADD(aMess, 'по искусственному интеллекту: "RAIF-Challenge 2017-API-bank".') AADD(aMess, 'В настоящее время он не спользуется и заблокирован.') LB_Warning(aMess, L('(C) Система "Эйдос"')) RETURN NIL *Running(.T.) ** 1. Преобразовать t1.xlsx, t2.xlsx, t3.xlsx, t4.xlsx в t1.dbf, t2.dbf, t3.dbf, t4.dbf * mNameInpData = Disk_dir+"\AID_DATA\Inp_data\" * DIRCHANGE(mNameInpData) // Перейти в папку Inp_data * cFile='t1.xlsx';IF .NOT. FILE(cFile);LB_Warning(L('В папке: ')+mNameInpData+L(' нет файла: ')+cFile );RETURN NIL;ENDIF * IF .NOT. FILE('t1.dbf');LC_Excel2WorkArea( cFile, mNameInpData );ENDIF * COPY FILE ("Inp_name.txt") TO ("Inp_name_t1.txt") * COPY FILE ("Inp_nameAll.txt") TO ("Inp_nameAll_t1.txt") * cFile='t2.xlsx';IF .NOT. FILE(cFile);LB_Warning(L('В папке: ')+mNameInpData+L(' нет файла: ')+cFile );RETURN NIL;ENDIF * IF .NOT. FILE('t2.dbf');LC_Excel2WorkArea( cFile, mNameInpData );ENDIF * COPY FILE ("Inp_name.txt") TO ("Inp_name_t2.txt") * COPY FILE ("Inp_nameAll.txt") TO ("Inp_nameAll_t2.txt") * cFile='t3.xlsx';IF .NOT. FILE(cFile);LB_Warning(L('В папке: ')+mNameInpData+L(' нет файла: ')+cFile );RETURN NIL;ENDIF * IF .NOT. FILE('t3.dbf');LC_Excel2WorkArea( cFile, mNameInpData );ENDIF * COPY FILE ("Inp_name.txt") TO ("Inp_name_t3.txt") * COPY FILE ("Inp_nameAll.txt") TO ("Inp_nameAll_t3.txt") * cFile='t4.xlsx';IF .NOT. FILE(cFile);LB_Warning(L('В папке: ')+mNameInpData+L(' нет файла: ')+cFile );RETURN NIL;ENDIF * IF .NOT. FILE('t4.dbf');LC_Excel2WorkArea( cFile, mNameInpData );ENDIF * COPY FILE ("Inp_name.txt") TO ("Inp_name_t4.txt") * COPY FILE ("Inp_nameAll.txt") TO ("Inp_nameAll_t4.txt") ** 2. Создать БД Inp_data.dbf * oScrn := DC_WaitOn( L('Создание БД Inp_data.dbf' ),,,,,,,,,,,.F.) * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций;USE t1 EXCLUSIVE NEW;at1 := DbStruct() * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций;USE t2 EXCLUSIVE NEW;at2 := DbStruct() * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций;USE t3 EXCLUSIVE NEW;at3 := DbStruct() * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций;USE t4 EXCLUSIVE NEW;at4 := DbStruct() * *** Уменьшить размер полей (на сколько это возможно) * *** Наверное надо сделать что-то подобное в конвертере xls => dbf * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * USE t1 EXCLUSIVE NEW * FOR j=1 TO FCOUNT() * mVal = FIELDGET(j) * DO CASE * CASE VALTYPE(mVal) = 'N' * INDEX ON LEN(ALLTRIM(STR(FIELDGET(j)))) TO tmp * DBGOBOTTOM();at1[j,3] = LEN(ALLTRIM(STR(FIELDGET(j)))) * CASE VALTYPE(mVal) = 'C' * INDEX ON LEN(ALLTRIM(FIELDGET(j))) TO tmp * DBGOBOTTOM();at1[j,3] = LEN(ALLTRIM(FIELDGET(j))) * CASE VALTYPE(mVal) = 'D' * DBGOBOTTOM();at1[j,3] = 8 * ENDCASE * NEXT * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * USE t2 EXCLUSIVE NEW * FOR j=1 TO FCOUNT() * mVal = FIELDGET(j) * DO CASE * CASE VALTYPE(mVal) = 'N' * INDEX ON LEN(ALLTRIM(STR(FIELDGET(j)))) TO tmp * DBGOBOTTOM();at2[j,3] = LEN(ALLTRIM(STR(FIELDGET(j)))) * CASE VALTYPE(mVal) = 'C' * INDEX ON LEN(ALLTRIM(FIELDGET(j))) TO tmp * DBGOBOTTOM();at2[j,3] = LEN(ALLTRIM(FIELDGET(j))) * CASE VALTYPE(mVal) = 'D' * DBGOBOTTOM();at2[j,3] = 8 * ENDCASE * NEXT * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * USE t3 EXCLUSIVE NEW * FOR j=1 TO FCOUNT() * mVal = FIELDGET(j) * DO CASE * CASE VALTYPE(mVal) = 'N' * INDEX ON LEN(ALLTRIM(STR(FIELDGET(j)))) TO tmp * DBGOBOTTOM();at3[j,3] = LEN(ALLTRIM(STR(FIELDGET(j)))) * CASE VALTYPE(mVal) = 'C' * INDEX ON LEN(ALLTRIM(FIELDGET(j))) TO tmp * DBGOBOTTOM();at3[j,3] = LEN(ALLTRIM(FIELDGET(j))) * CASE VALTYPE(mVal) = 'D' * DBGOBOTTOM();at3[j,3] = 8 * ENDCASE * NEXT * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * USE t4 EXCLUSIVE NEW * FOR j=1 TO FCOUNT() * mVal = FIELDGET(j) * DO CASE * CASE VALTYPE(mVal) = 'N' * INDEX ON LEN(ALLTRIM(STR(FIELDGET(j)))) TO tmp * DBGOBOTTOM();at4[j,3] = LEN(ALLTRIM(STR(FIELDGET(j)))) * CASE VALTYPE(mVal) = 'C' * INDEX ON LEN(ALLTRIM(FIELDGET(j))) TO tmp * DBGOBOTTOM();at4[j,3] = LEN(ALLTRIM(FIELDGET(j))) * CASE VALTYPE(mVal) = 'D' * DBGOBOTTOM();at4[j,3] = 8 * ENDCASE * NEXT * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * aStructure := {} ** | N | Имя поля | Тип | Ширина | Дес. | * AADD(aStructure, { 'Object', 'C', 60, 0 }) // Объект * **** Классы **** * AADD(aStructure, { 'Exp_tim_card', 'N', 8, 0 }) // Срок экспирации карты * AADD(aStructure, { 'Act_dur_card', 'N', 8, 0 }) // Фактическая длительность действия карты * AADD(aStructure, { 'Pla_dur_cont', 'N', 8, 0 }) // Планируемая длительность действия договора * AADD(aStructure, { 'Act_dur_cont', 'N', 8, 0 }) // Фактическая длительность действия договора * **** Массив имен полей из t1, t2, t3, t4, не включаемых в Inp_data.dbf ** aDF := {'tn2', 'tn9', 'tn10', 'tn11', 'tn12', 'tn13', 'tn14', 't3n3', t3n7', t3n8', 't3n9', 't3n11', 't3n12', 't4n2' } // ############## * FOR j=3 TO LEN(at1);AADD(aStructure, { 't1'+at1[j,1], at1[j,2], at1[j,3], 0 });NEXT * FOR j=2 TO LEN(at2);AADD(aStructure, { 't2'+at2[j,1], at2[j,2], at2[j,3], 0 });NEXT * FOR j=2 TO LEN(at3);AADD(aStructure, { 't3'+at3[j,1], at3[j,2], at3[j,3], 0 });NEXT * FOR j=2 TO LEN(at4);AADD(aStructure, { 't4'+at4[j,1], at4[j,2], at4[j,3], 0 });NEXT * DbCreate( 'Inp_data.dbf', aStructure ) * DC_Impl(oScrn) ** 3. Заполнить БД Inp_data.dbf данными из БД: t1.dbf, t2.dbf, t3.dbf, t4.dbf * oScrn := DC_WaitOn( L('Заполнение БД Inp_data.dbf данными из БД: t1.dbf, t2.dbf, t3.dbf, t4.dbf' ),,,,,,,,,,,.F.) * ***** Индексация БД t1.dbf, t2.dbf, t3.dbf, t4.dbf * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций;USE t1 EXCLUSIVE NEW;INDEX ON N2 TO t1 * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций;USE t2 EXCLUSIVE NEW;INDEX ON N1 TO t2 * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций;USE t3 EXCLUSIVE NEW;INDEX ON N1 TO t3 * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций;USE t4 EXCLUSIVE NEW;INDEX ON N1 TO t4 * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * USE Inp_data EXCLUSIVE NEW * USE t1 INDEX t1 EXCLUSIVE NEW * USE t2 INDEX t2 EXCLUSIVE NEW * USE t3 INDEX t3 EXCLUSIVE NEW * USE t4 INDEX t4 EXCLUSIVE NEW * SELECT t1 * SET ORDER TO 1 * DBGOTOP() * DO WHILE .NOT. EOF() * SELECT t1 * aRt1 := {} * FOR j=1 TO FCOUNT() * AADD(aRt1, FIELDGET(j)) * NEXT * SELECT t2;SET ORDER TO 1;fT2=DBSEEK(aRt1[2]) * IF fT2 * aRt2 := {} * FOR j=1 TO FCOUNT() * AADD(aRt2, FIELDGET(j)) * NEXT * ENDIF * SELECT t3;SET ORDER TO 1;fT3=DBSEEK(aRt1[2]) * IF fT3 * aRt3 := {} * FOR j=1 TO FCOUNT() * AADD(aRt3, FIELDGET(j)) * NEXT * ENDIF * SELECT t4;SET ORDER TO 1;fT4=DBSEEK(aRt1[2]) * IF fT4 * aRt4 := {} * FOR j=1 TO FCOUNT() * AADD(aRt4, FIELDGET(j)) * NEXT * ENDIF * mFlagErr = .F. * mN_Error = 0 * IF fT2 .AND. fT3 .AND. fT4 * mPos = 1 * SELECT Inp_data * APPEND BLANK * FIELDPUT(mPos++, aRt1[1]+', ID='+aRt1[2]) // Отчётный месяц и ID клиента (ОБЪЕКТ) * ********************************************* * ******* КЛАССЫ ****************************** * ********************************************* * ******* Таблица 2: Карты ******************** * IF VALTYPE(CTOD(aRt2[11])) = 'D' .AND. VALTYPE(CTOD(aRt2[10])) = 'D' * mLong = CTOD(aRt2[11]) - CTOD(aRt2[10]);FIELDPUT(mPos++, IF(mLong>0,mLong,0)) // Срок экспирации карты = Дата экспирации карты - Дата открытия карты * mLong = CTOD(aRt2[12]) - CTOD(aRt2[10]);FIELDPUT(mPos++, IF(mLong>0,mLong,0)) // Фактическая длительность действия карты = Фактическая дата закрытия - Дата открытия карты * ELSE * FIELDPUT(mPos++, 0) // Срок экспирации карты = Дата экспирации карты - Дата открытия карты * FIELDPUT(mPos++, 0) // Фактическая длительность действия карты = Фактическая дата закрытия - Дата открытия карты * ENDIF * ******* Таблица 3: Договоры ***************** * IF VALTYPE(CTOD(aRt3[8])) = 'D' .AND. VALTYPE(CTOD(aRt3[9])) = 'D' * mLong = CTOD(aRt3[8]) - CTOD(aRt3[7]);FIELDPUT(mPos++, IF(mLong>0,mLong,0)) // Планируемая длительность действия договора = Планируемая дата закрытия договора - Дата открытия договора * mLong = CTOD(aRt3[9]) - CTOD(aRt3[7]);FIELDPUT(mPos++, IF(mLong>0,mLong,0)) // Фактическая длительность действия договора = Фактическая дата закрытия договора - Дата открытия договора * ELSE * FIELDPUT(mPos++, 0) // Срок экспирации карты = Дата экспирации карты - Дата открытия карты * FIELDPUT(mPos++, 0) // Фактическая длительность действия карты = Фактическая дата закрытия - Дата открытия карты * ENDIF * ********************************************* * ******* ФАКТОРЫ ***************************** * ********************************************* * FOR j=3 TO LEN(aRt1) * FIELDPUT(mPos++, aRt1[j]) * NEXT * FOR j=2 TO LEN(aRt2) * FIELDPUT(mPos++, aRt2[j]) * NEXT * FOR j=2 TO LEN(aRt3) * FIELDPUT(mPos++, aRt3[j]) * NEXT * FOR j=2 TO LEN(aRt4) * FIELDPUT(mPos++, aRt4[j]) * NEXT * ELSE * mFlagErr = .T. * mN_Error++ * ENDIF * SELECT t1 * SET ORDER TO 1 * DBSKIP(1) * ENDDO * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * DC_Impl(oScrn) * IF mFlagErr * LB_Warning(L('Создание БД Inp_data.dbf из файлов: t1.xlsx, t2.xlsx, t3.xlsx, t4.xlsx завершено. Обнаружено ')+ALLTRIM(STR(mN_Error))+L(' ошибок')) * ELSE * LB_Warning(L('Создание БД Inp_data.dbf из файлов: t1.xlsx, t2.xlsx, t3.xlsx, t4.xlsx завершено успешно!')) * ENDIF *Running(.F.) *RETURN NIL *********************************************************************************************************** ******** Создание БД Inp_data.dbf и файла: Inp_name.txt из файлов:jet_raif_challenge.csv и description.csv' *********************************************************************************************************** FUNCTION F2_3_2_14() aMess := {} AADD(aMess, 'Данный режим создан для участия в открытом чемпионате России') AADD(aMess, 'по искусственному интеллекту: "Чемпионат RAIF-Challenge 2017-API-retail".') AADD(aMess, 'В настоящее время он не спользуется и заблокирован.') LB_Warning(aMess, L('(C) Система "Эйдос"')) RETURN NIL *Running(.T.) * mNameInpData = "C:\AIDOS-X\AID_DATA\Inp_data\" * DIRCHANGE(mNameInpData) // Перейти в папку Inp_data * cFile='description.csv' ;IF .NOT. FILE(cFile);LB_Warning(L('В папке: ')+mNameInpData+L(' нет файла: ')+cFile );RETURN NIL;ENDIF * cFile='jet_raif_challenge.csv';IF .NOT. FILE(cFile);LB_Warning(L('В папке: ')+mNameInpData+L(' нет файла: ')+cFile );RETURN NIL;ENDIF * oScrn := DC_WaitOn( L('Определение минимальных достаточных размеров полей БД "Inp_data.dbf"' ),,,,,,,,,,,.F.) ****** Можно это сделать на сравнительно небольшом файле ****** Создать и записать БД InpDat.dbf * aStr := { { "Numb" , "C", 255, 0 }, ; // 1 Numb * { "tstamp" , "C", 255, 0 }, ; // 2 tstamp;Временной слепок 1 <=== Наименование объекта: 1=1+2+3+4 * { "session_i" , "C", 255, 0 }, ; // 3 session_id;ID сессии * { "calday" , "C", 255, 0 }, ; // 4 calday;Дата конкретного действия клиента * { "cnt" , "C", 255, 0 }, ; // 5 cnt;Количество 4 * { "platform" , "C", 255, 0 }, ; // 6 platform;Платформа 5 * { "os" , "C", 255, 0 }, ; // 7 os;Операционная система 6 * { "cookie" , "C", 255, 0 }, ; // 8 cookie;Cookie пользователя 7 * { "action" , "C", 255, 0 }, ; // 9 action;Действие на сайте <====== Классы 2 * { "target" , "C", 255, 0 }, ; // 10 target;Цель действия <====== 3 * { "material" , "C", 255, 0 }, ; // 11 material;ID товара 8 * { "txtlg" , "C", 255, 0 }, ; // 12 txtlg;Описание товара 9 * { "category1" , "C", 255, 0 }, ; // 13 category1;Категория 10 * { "category2" , "C", 255, 0 }, ; // 14 category2;Подкатегория 11 * { "brand" , "C", 255, 0 }, ; // 15 brand;Брэнд 12 * { "promo" , "C", 255, 0 }, ; // 16 promo;Флаг промо 13 * { "page_type" , "C", 255, 0 } } // 17 page_type;Тип страницы 14 **DC_DebugQout( aStr ) **LB_Warning(aStr) // Отладка * DbCreate( 'InpDat1', aStr ) * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * USE InpDat1 EXCLUSIVE NEW * SELECT InpDat1 **APPEND FROM jet_raif_challenge.csv DELIMITED RECORD 1000 * APPEND FROM jet_raif_100.csv DELIMITED * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций **MsgBox('STOP') ************************************************************************************* * 1 Numb * 2 tstamp;Временной слепок 1 <=== Наименование объекта: 1=1+2+3+4 * 3 session_id;ID сессии * 4 calday;Дата конкретного действия клиента * ---------------------------------------------- * 5 cnt;Количество 4 * 6 platform;Платформа 5 * 7 os;Операционная система 6 * 8 cookie;Cookie пользователя 7 * ---------------------------------------------- * 9 action;Действие на сайте <====== Классы 2 * 10 target;Цель действия <====== 3 * ---------------------------------------------- * 11 material;ID товара 8 * 12 txtlg;Описание товара 9 * 13 category1;Категория 10 * 14 category2;Подкатегория 11 * 15 brand;Брэнд 12 * 16 promo;Флаг промо 13 * 17 page_type;Тип страницы 14 ************************************************************************************* *** Цикл по записям БД InpDat * USE InpDat1 EXCLUSIVE NEW * SELECT InpDat1 * PRIVATE aLenField[FCOUNT()] * AFILL(aLenField, 15) * DBGOTOP() * DELETE FOR RECNO()=1 * PACK * DBGOTOP() * FOR j=1 TO FCOUNT() * INDEX ON FIELDNAME(j) TO InpDat * DBGOBOTTOM() * aLenField[j] = MAX(aLenField[j], LEN(ALLTRIM(FIELDGET(j)))) * NEXT * DC_Impl(oScrn) * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций **LB_Warning(aLenField) // Отладка * oScrn := DC_WaitOn( L('Преобразование файла: "jet_raif_challenge.csv" в БД "InpDat.dbf"' ),,,,,,,,,,,.F.) ***** Создать и записать БД InpDat.dbf *aLenField[ 1] = 8 *aLenField[13] = 8 * aStr := { { "Numb" , "C", aLenField[ 1], 0 }, ; // 1 Numb * { "tstamp" , "C", aLenField[ 2], 0 }, ; // 2 tstamp;Временной слепок 1 <=== Наименование объекта: 1=1+2+3+4 * { "session_i" , "C", aLenField[ 3], 0 }, ; // 3 session_id;ID сессии * { "calday" , "C", aLenField[ 4], 0 }, ; // 4 calday;Дата конкретного действия клиента * { "cnt" , "C", aLenField[ 5], 0 }, ; // 5 cnt;Количество 4 * { "platform" , "C", aLenField[ 6], 0 }, ; // 6 platform;Платформа 5 * { "os" , "C", aLenField[ 7], 0 }, ; // 7 os;Операционная система 6 * { "cookie" , "C", aLenField[ 8], 0 }, ; // 8 cookie;Cookie пользователя 7 * { "action" , "C", aLenField[ 9], 0 }, ; // 9 action;Действие на сайте <====== Классы 2 * { "target" , "C", aLenField[10], 0 }, ; // 10 target;Цель действия <====== 3 * { "material" , "C", aLenField[11], 0 }, ; // 11 material;ID товара 8 * { "txtlg" , "C", aLenField[12], 0 }, ; // 12 txtlg;Описание товара 9 * { "category1" , "C", aLenField[13], 0 }, ; // 13 category1;Категория 10 * { "category2" , "C", aLenField[14], 0 }, ; // 14 category2;Подкатегория 11 * { "brand" , "C", aLenField[15], 0 }, ; // 15 brand;Брэнд 12 * { "promo" , "C", aLenField[16], 0 }, ; // 16 promo;Флаг промо 13 * { "page_type" , "C", aLenField[17], 0 } } // 17 page_type;Тип страницы 14 **DC_DebugQout( aStr ) **LB_Warning(aStr) // Отладка * DbCreate( 'InpDat2', aStr ) * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * USE InpDat2 EXCLUSIVE NEW * SELECT InpDat2 **APPEND FROM jet_raif_challenge.csv DELIMITED RECORD 1000 // Отладка **APPEND FROM jet_raif_100.csv DELIMITED * APPEND FROM jet_raif_challenge.csv DELIMITED * DC_Impl(oScrn) * oScrn := DC_WaitOn( L('Преобразование БД: "InpDat.dbf" в БД "Inp_data.dbf"' ),,,,,,,,,,,.F.) * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций ***** Создать и записать БД Inp_data.dbf *LenCol1234 = aLenField[1]+aLenField[2]+aLenField[3]+aLenField[4]+6 *aLenField[13] = 8 * aStr := { { "Col1234 " , "C", LenCol1234 , 0 }, ; // 1 (1+2+3+4) Номер объекта, слепок, ID сессии, дата * { "action " , "C", aLenField[ 9], 0 }, ; // 2 (9) Действие на сайте (класс) * { "target " , "C", aLenField[10], 0 }, ; // 3 (10) Цель посещения сайта (класс) * { "cnt " , "C", aLenField[ 4], 0 }, ; // 4 (5) <==== * { "platform " , "C", aLenField[ 5], 0 }, ; // 5 (6) * { "os " , "C", aLenField[ 6], 0 }, ; // 6 (7) * { "cookie " , "C", aLenField[ 7], 0 }, ; // 7 (8) <==== * { "material " , "C", aLenField[11], 0 }, ; // 8 (11) <==== * { "txtlg " , "C", aLenField[12], 0 }, ; // 9 (12) * { "category1 " , "C", aLenField[13], 0 }, ; // 10 (13) * { "category2 " , "C", aLenField[14], 0 }, ; // 11 (14) * { "brand " , "C", aLenField[15], 0 }, ; // 12 (15) * { "promo " , "C", aLenField[16], 0 }, ; // 13 (16) * { "page_type " , "C", aLenField[17], 0 } } // 14 (17) <==== ** LB_Warning(aStr) // Отладка * DbCreate( 'Inp_data.dbf', aStr ) * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * USE InpDat2 EXCLUSIVE NEW * USE Inp_data EXCLUSIVE NEW * SELECT InpDat2 * DBGOTOP() * DBSKIP(1) * DO WHILE .NOT. EOF() * aR := {} * FOR j=1 TO FCOUNT() * AADD(aR, ALLTRIM(FIELDGET(j))) * NEXT * SELECT Inp_data * APPEND BLANK * FIELDPUT(1, aR[1]+'--'+aR[2]+'--'+aR[3]+'--'+aR[4]) // Номер объекта, слепок, ID сессии, дата * FIELDPUT(2, aR[9]) // Класс (действие на сайте) * FIELDPUT(3, aR[10]) // Класс (цель) * FOR j=5 TO 7 * FIELDPUT(j-1, aR[j] ) * NEXT * FOR j=11 TO 17 * IF j <> 12 * FIELDPUT(j-3, aR[j] ) * ENDIF * NEXT * SELECT InpDat2 * DBSKIP(1) * ENDDO * DC_Impl(oScrn) * oScrn := DC_WaitOn( L('Преобразование файла: "description.csv" в "Inp_name.txt"' ),,,,,,,,,,,.F.) * CrLf = CHR(13)+CHR(10) // Конец строки (записи) HEX(0D)+HEX(0A) * aInp_name := {} * nHandle := DC_txtOpen( 'description.csv' ) * DO WHILE !DC_TxtEOF( nHandle ) // Начало цикла по строкам * mLine = DC_TxtLine( nHandle ) // Выделить строку из текстового файла * mPos = AT(';',mLine) * AADD(aInp_name, SUBSTR(mLine,mPos+1,LEN(mLine)-mPos+1)) * DC_TxtSkip( nHandle, 1 ) * ENDDO * DC_TxtClose( nHandle ) ************************************************************************************* * 1 Numb * 2 tstamp;Временной слепок 1 <=== Наименование объекта: 1=1+2+3+4 * 3 session_id;ID сессии * 4 calday;Дата конкретного действия клиента * ---------------------------------------------- * 5 cnt;Количество 4 * 6 platform;Платформа 5 * 7 os;Операционная система 6 * 8 cookie;Cookie пользователя 7 * ---------------------------------------------- * 9 action;Действие на сайте <====== Классы 2 * 10 target;Цель действия <====== 3 * ---------------------------------------------- * 11 material;ID товара 8 * 12 txtlg;Описание товара 9 * 13 category1;Категория 10 * 14 category2;Подкатегория 11 * 15 brand;Брэнд 12 * 16 promo;Флаг промо 13 * 17 page_type;Тип страницы 14 ************************************************************************************* * mInp_name = '' **mInp_name = mInp_name + aInp_name[1]+'-'+aInp_name[2] + CrLf // Номер объекта и ID сессии * mInp_name = mInp_name + aInp_name[ 9] + CrLf // Класс (действие на сайте) * mInp_name = mInp_name + aInp_name[10] + CrLf // Класс (цель) * FOR j=5 TO 8 * mInp_name = mInp_name + aInp_name[j] + CrLf * NEXT * FOR j=11 TO 17 * mInp_name = mInp_name + aInp_name[j] + CrLf * NEXT * mInp_name = mInp_name + CrLf * StrFile(mInp_name, 'Inp_name.txt') // Запись текстового файла: Inp_name.txt * DC_Impl(oScrn) * LB_Warning(L('Создание БД Inp_data.dbf и файла: Inp_name.txt из файлов: jet_raif_challenge.csv и description.csv завершено успешно!')) *Running(.F.) *RETURN NIL ******************************************************************************************************************* ******** 6.9. География пользователей системы "Эйдос-Х++" ******** Когда кто-либо в мире запускает систему "Эйдос-Х++" на исполнение на компьютере, подключенном к Internet, ******** то на она программно обращается к специально созданному сайту, на котором размещен PHP-код, определяющий ******** дату и время обращения, а также IP-адрес компьютера, с которого произошло это обращение, и по нему опреде- ******** ляет страну, регион и город пользователя ******************************************************************************************************************* #include "inkey.ch" #include "dcdir.ch" #include "appevent.ch" #include "xbp.ch" #include "dll.ch" #include "dccursor.ch" #Include "thread.ch" #include "class.ch" #include "dmlb.ch" #include "fileio.ch" #include "dctree.ch" *#include "SystemMetrics.ch" *#include "axcdxcmx.ch" // Графика ActiveX #include "collat.ch" #include "common.ch" #include "dbedit.ch" #include "Dbfdbe.ch" #include "dcapp.ch" #include "dcbitmap.ch" #include "dccargo.ch" #include "dcdialog.ch" #include "dcdir.ch" #include "dcfiles.ch" #include "dcgra.ch" #include "dcgraph.ch" // графика #include "BdColors.Ch" // графика #include "dccolors.ch" // графика #include "dcprint.ch" // графика #include "Dcicon.ch" #include "dcmsg.ch" #include "dcpick.ch" #include "deldbe.ch" #include "directry.ch" #include "dmlb.ch" #include "express.ch" #include "fileio.ch" #include "font.ch" #include "gra.ch" #include "inkey.ch" #include "memvar.ch" #include "natmsg.ch" #include "prompt.ch" #include '_dcdbfil.ch' #include "set.ch" #include "std.ch" #include "xbp.ch" #include '_dcappe.ch' #include 'dcscope.ch' #include '_dcstru.ch' #include 'dcfields.ch' #include 'dccolor.ch' *#include "Fileio.ch" // Max_DB *#include "rmchart.ch" // Графика ActiveX #include "dcads.ch" #pragma Library( "ASINet10.lib" ) // 2.0 // Для альтернативного и неальтернативного выбора в просмотре таблиц *#define BMP_CHECKED "check1.bmp" *#define BMP_UNCHECKED "check2.bmp" *#define BMP_RACHECKED "radio1.bmp" *#define BMP_RAUNCHECKED "radio2.bmp" *#include "test.ch" #define BMP_CHECKED 10002 #define BMP_UNCHECKED 10003 #define BMP_RACHECKED 10004 #define BMP_RAUNCHECKED 10005 #pragma library( "ascom10.lib" ) #pragma library( "dclip1.lib" ) #pragma library( "dclip2.lib" ) #pragma library( "dclipx.lib" ) #pragma library( "xbtbase1.lib" ) #pragma library( "xbtbase2.lib" ) #pragma library( "xppui2.lib" ) #pragma library( "XPPRT0.LIB" ) #Pragma Library("Taskbar.lib") #include "simpleio.ch" #include "asxml.ch" #INCLUDE "dcdialog.CH" *#INCLUDE "dcads.CH" #DEFINE CRLF Chr(13)+Chr(10) #pragma library("asxml10.lib") #pragma library( "XPPRT0.LIB" ) #xtranslate NTrim() => LTrim(Str()) #define USE_HTTPCLIENT // comment out to try Method2 //#include "Imgview.ch" /* * We use user defined events */ #define xbeDS_DirChanged xbeP_User + 100 #define xbeFS_FileMarked xbeP_User + 101 #define xbeFS_FileSelected xbeP_User + 102 #define DCAREAMSG_1 'Invalid Expression in Index Key:' /* * This directive calculates a centered position */ #xtrans CenterPos( , ) => ; { Int( (\[1] - \[1]) / 2 ) ; , Int( (\[2] - \[2]) / 2 ) } #define DC_RDDMSG_1 'Invalid RDD selection - '+cSuperRdd #define DC_RDDMSG_2 'DBE Name Description' #define DC_RDDMSG_3 'Select a Database Driver' *#define ADSDBE_MEMOFILE_EXT (DBE_USER+1) // RO *#define ADSDBE_INDEX_EXT (DBE_USER+2) // RW *#define ADSDBE_TBL_MODE (DBE_USER+3) // RW *#define ADSDBE_LOCK_MODE (DBE_USER+4) // RW *#define ADSDBE_RIGHTS_MODE (DBE_USER+5) // RW *#define ADSDBE_MEMOBLOCKSIZE (DBE_USER+6) // RW *#define ADSDBE_PASSWORD (DBE_USER+7) // RW // Return types of ADSDBE_TBL_MODE *#define ADSDBE_NTX 1 *#define ADSDBE_CDX 2 *#define ADSDBE_ADT 3 // Для опредедения разрешения монитора от Джимми #define DESKTOPVERTRES 117 #define DESKTOPHORZRES 118 // Excel Orientation #DEFINE xlLandscape 2 #DEFINE xlPortrait 1 #DEFINE xlWorkbookNormal -4143 #DEFINE xlCellTypeLastCell 11 #DEFINE SRCCOPY 0xCC0020 // Для быстрой графики Роджера #define KEYEVENTF_KEYUP 0x02 #define VK_MENU 0x12 #define VK_SNAPSHOT 0x2C #DEFINE VK_LBUTTON 0x01 #DEFINE VK_RBUTTON 0x02 * Для CSV=>DBF конвертера *#include "ot4xb.ch" // => ot4xb.dll => www.xbwin.com #ifndef CRLF #define CRLF chr(13)+chr(10) #endif * Klasse zum sequentiellen Einlesen groбer Dateien *#IF .t. // zum Einbinden in eigenes Projekt, .f. setzen ! STATIC snHdll ******************************************************************************************************************** FUNCTION F6_9() LOCAL GetList := {}, aPres, oBrowse, oToolBar, aColors, bColor, GetOptions, oEventsKO, bItems, n:=0 Local oHttp, oResponse, cColor PUBLIC mSortVisit := 0 Running(.T.) n=0 IF InternetGetConnectedState( @n, 0 ) == 0 LB_Warning(L('Нет соединения с Internet, что необходимо для данного режима!'), L('(C) Система "Эйдос-Х++"' )) Running(.F.) RETURN NIL ENDIF * Вариант с отображением базы данных 'test_strings.txt' в браузере * ShellOpenFile( 'http://lc.kubagro.ru/test_strings.txt', .T., .T. ) * cFile := LoadFromURL('http://lc.kubagro.ru/test_strings.txt') // Считывает страницу сайта в текстовую переменную * MsgBox(cFile) * * Вариант со скачиванием базы данных: 'test_strings.txt' с сайта: 'http://lc.kubagro.ru' * * и отображением ее в окне в текстовом виде (как в 2.3.2.2) и в виде базы данных, а также на карте * ***** Получить файл "test_strings.txt", используя только HTTP (GetWeb.prg, Boris Borzic) * oScrn := DC_WaitOn( L('Загрузка с FTP-сервера БД: "test_strings.txt" с информацией о запусках системы "Эйдос-Х++"' ),,,,,,,,,,,.F.) * oHttp := xbHTTPClient():new() * oHttp:Transport := VIA_WININET * oResponse := oHttp:Execute( 'http://lc.kubagro.ru/test_strings.txt' ) * if oResponse == NIL * MsgBox("Error:" + str(oHttp:ErrorCode) + chr(10) + oHttp:ErrorMessage + chr(10) + oHttp:ErrorSource) * Return .f. * endif * mABC = oResponse:Content * StrFile(mABC,'test_strings.txt') * DC_Impl(oScrn) * ***** Получить файл "test_strings.txt", используя FTP (GetWeb.prg, Boris Borzic) * ***** Это прекрасно работает, но нужно разобраться с FTP, а он не работает, обращается непонятно к какому сайту <<<===####################### * cFile := LoadFromURL('http://lc.kubagro.ru/test_strings.txt') // Считывает страницу сайта в текстовую переменную * DC_Impl(oScrn) * StrFile(cFile, 'test_strings.txt') // Запись текстового файла параметров визитов на локальный компьтер * MsgBox(cFile) ********************************************************************************************************** Xb2NetKey() *oScr := DC_WaitOn('Идет проверка наличия интернета и FTP доступа к Эйдос-облаку. Немного подождите!!!',,,,,,,,,,,.F.) cFtpServer:="94.25.18.114" // Это везде одинаково <<<===############ oFtp := FTPClient():new( cFtpServer, Ftp_User, Ftp_Passw ) // Соединение с моим сайтом и авторизация IF oFtp:connect() // Есть соединение с моим сайтом и авторизация? ********************************************************************************************************** **** Сделать текущей папку: ftp://94.25.18.114/public_html/ **** Восстанавливать ли базу данных запусков системы Эйдос, если это необходимо? mPar = "N" @0, 2 DCSAY L('Восстанавливать базу данных запусков системы Эйдос, если это необходимо?') @0,61 DCSAY '' GET mPar PICTURE 'X' DCREAD GUI; TO lExit ; FIT; ADDBUTTONS; MODAL; TITLE L('6.9. География пользователей системы "Эйдос-Х++" в мире') ******************************************************************** IF lExit ** Button Ok ELSE Running(.F.) RETURN NIL ENDIF ******************************************************************** oScrn := DC_WaitOn( L('Загрузка с FTP-сервера БД: "test_strings.txt" с информацией о запусках системы "Эйдос-Х++"' ),,,,,,,,,,,.F.) // <<<===############## * MsgBox(oFtp:curDir()) oFtp:CurDir("/") oFtp:curDir("public_html") * MsgBox(oFtp:curDir()) * ******************************************************************************* <<<===######################## * **** Просмотр массива директории с FTP-сервера от Роджера ******** * aDir := oFtp:Directory() // Борис Борзик, для этого нужен только FTP, т.к. под HTTP не работает oHttp:Directory() ** wtf oFtp:Directory() ** LB_Warning(oFtp:Directory()) * IF LEN(aDir) > 0 // Если папка в облаке не пустая, т.е. кроме . и .. есть хотя бы один файл * DC_Impl(oScrn) * PRIVATE aDirShow[Len(aDir)+1,6] * mSummaSize = 0 * mFlag50Mb = .F. * mFlagErrName = .F. ** AADD(aClsName, ConvToAnsiCP(mV)) ** AADD(aClsName, ConvToOemCP (mV)) ** AADD(aClsName, Str2Unicode (mV)) * FOR j := 1 TO Len(aDir) * aDirShow[j,1] = ALLTRIM(STR(j)) // File Num * aDirShow[j,2] = aDir[j,1] // File Name ** aDirShow[j,2] = ConvToOemCP(aDir[j,1]) // File Name * aDirShow[j,3] = aDir[j,2] // File Size * aDirShow[j,4] = DTOC(aDir[j,3]) // File Date * aDirShow[j,5] = aDir[j,4] // File Time * mSummaSize = mSummaSize + aDir[j,2] * IF aDir[j,2] >= 50*1024^2 // 50 Мб * mFlag50Mb = .T. * ENDIF * NEXT * aDirShow[Len(aDir)+1,2] = L('Суммарный объем (байт)') * aDirShow[Len(aDir)+1,3] = mSummaSize * @ 0,0 DCBROWSE oBrowse DATA aDirShow SIZE 136,45 COLOR {||RowColor(oBrowse, aDirShow)} // Управление фоном отображения строки от Роджера * DCBROWSECOL ELEMENT 1 HEADER 'File Num ' WIDTH 5 PARENT oBrowse * DCBROWSECOL ELEMENT 2 HEADER 'File Name' WIDTH 50 PARENT oBrowse * DCBROWSECOL ELEMENT 3 HEADER 'File Size' WIDTH 10 PARENT oBrowse * DCBROWSECOL ELEMENT 4 HEADER 'File Date' WIDTH 8 PARENT oBrowse * DCBROWSECOL ELEMENT 5 HEADER 'File Time' WIDTH 8 PARENT oBrowse * DCREAD GUI FIT TITLE L('Файлы главной директории сайта: http://lc.kubagro.ru') * ENDIF * ******************************************************************************** <<<===######################## IF oFtp:CurDir() <> "\public_html" DC_Impl(oScrn) // <<<===############## LB_Warning(L('Не удалось сделать текущей директорию: "\public_html"'), L('(C) Система "Эйдос-Х++"' )) Running(.F.) RETURN NIL ENDIF mFTP = 'OFF' * StrFile(mFTP, '_FTP.txt') mFTP = FileStr('_FTP.txt') IF mFTP = 'OFF' DC_Impl(oScrn) // <<<===############## LB_Warning(L('Не удалось скачать базу данных: "test_strings.txt" с FTP-сервера'), L('(C) Система "Эйдос-Х++"' )) Running(.F.) RETURN NIL ELSE IF oFtp:GetFile("test_strings.txt") DC_Impl(oScrn) // <<<===############## * LB_Warning(L('Скачивание базы данных: "test_strings.txt" с FTP-сервера завершено успешно'), L('(C) Система "Эйдос-Х++"' )) ELSE DC_Impl(oScrn) // <<<===############## LB_Warning(L('Не удалось скачать базу данных: "test_strings.txt" с FTP-сервера'), L('(C) Система "Эйдос-Х++"' )) Running(.F.) RETURN NIL ENDIF ENDIF ELSE DC_Impl(oScrn) LB_Warning(L('Нет соединения с FTP-сервером'), L('(C) Система "Эйдос-Х++"')) Running(.F.) RETURN NIL ENDIF DC_Impl(oScrn) // <<<===############## * QUIT * **************************************************************************************** * Отображение базы данных: "test_strings.txt" как текстового файла как в режиме адаптивных интервалов в 2.3.2.2. * mABC = FileStr('test_strings.txt') // Загрузка текстового файла параметров визитов с локального компьтера * @ 1,1 DCMULTILINE mABC FONT '12.Courier New' SIZE 180.0,27.0 EDITPROTECT {||.T.} * DCREAD GUI ; * TITLE L('6.9. География пользователей системы "Эйдос-Х++"') ; * FIT CrLf = CHR(13)+CHR(10) // Конец строки (записи) **** Замена неименованных неизвестных параметров вида: 06.12.16,20:41:32,93.91.80.6,US,United States,,,,,,37.75,-97.82,0 **** на поименованные неизвестные параметры: 06.12.16,20:41:32,93.91.80.6,US,United States,Unknown,Unknown,Unknown,Unknown,Unknown,37.75,-97.82,0 mABC = FileStr('test_strings.txt') // Загрузка текстового файла параметров визитов в переменную IF LEN(ALLTRIM(mABC)) = 0 DC_Impl(oScrn) LB_Warning(L('База данных: "test_strings.txt" ПУСТА'), L('(C) Система "Эйдос-Х++"')) Running(.F.) RETURN NIL ENDIF FOR j=1 TO 12 * mABC = STRTRAN(mABC,',,',',Unknown,') mABC = STRTRAN(mABC,',,',',') NEXT StrFile(mABC,'test_strings.txt') // Запись текстового файла параметров визитов из переменной mABCerr = mABC ***** Преобразование базы данных: "test_strings.txt" в DBF-базу данных и отображение, ***** с возможностями фильтрации и сортировки по полям и HELPом, в т.ч. картографическое ***** 06.12.16,10:30:37,37.146.34.226,RU,Russia,KDA,Krasnodarskiy Kray,Krasnodar,350000,Europe/Moscow,45.0300,38.98,0 ***** ############# ***** находить IP-адрес и оставлять перед ним только дату и время, а все остальное игнорировать ** С 08.02.2019 стали появляться строки вида: *08.02.2019,16:43:44,Unknown,e,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Sub,e,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Sub,se,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subs,se,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subs,ss":false,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subscriptio,ess":false,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subscription,Unknown,:false,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subscript,false,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subscrip,alse,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subscri *08.02.2019,16:52:29,Unknown,e,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Sub,e,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Sub,se,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subs,se,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subs,ss":false,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subscriptio,ess":false,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subscription,Unknown,:false,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subscript,false,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subscrip,alse,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subscri *08.02.2019,19:51:05,Unknown,e,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Sub,e,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Sub,se,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subs,se,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subs,ss":false,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subscriptio,ess":false,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subscription,Unknown,:false,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subscript,false,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subscrip,alse,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subscri *08.02.2019,23:10:54,Unknown,e,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Sub,e,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Sub,se,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subs,se,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subs,ss":false,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subscriptio,ess":false,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subscription,Unknown,:false,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subscript,false,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subscrip,alse,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subscri ** ИХ НАДО ИГНОРИРОВАТЬ!!! ******* Определение максимальных длин полей для БД Visitors.dbf oScrn := DC_WaitOn( L('Преобразование базы данных: "test_strings.txt" в "Visitors.dbf"' ),,,,,,,,,,,.F.) // Переделать на Питоне <<<===################################ PRIVATE aLenF[13] // Максимальные размеры полей в БД Visitors.dbf AFILL(aLenF,-999) PRIVATE aStringOut[13] // Выходная строка, возможно исправленная nHandle := DC_txtOpen( 'test_strings.txt' ) DO WHILE !DC_TxtEOF( nHandle ) // Начало цикла по строкам mLine = DC_TxtLine( nHandle ) // Выделить строку из текстового файла IF AT("usage_limit_reached", mLine) = 0 aStringInp := {} // Входная строка "как есть" FOR w=1 TO NUMTOKEN(mLine,",") // Разделитель между показателями - запятая mWord = ALLTRIM(TOKEN(mLine, ",", w)) AADD(aStringInp, mWord) NEXT * DC_DebugQout( aStringInp ) * MsgBox(STR(NUMTOKEN(mLine,","))) S = 1 // Индекс для выходного массива AFILL(aStringOut,' ') FOR w=1 TO LEN(aStringInp) // Цикл по элементам входной строки mWord = ALLTRIM(aStringInp[w]) mNumberPoints=0;FOR j=1 TO LEN(mWord);IF SUBSTR(mWord,j,1)='.';mNumberPoints++;ENDIF;NEXT // Количество '.' в слове - признак даты или IP mNumberColons=0;FOR j=1 TO LEN(mWord);IF SUBSTR(mWord,j,1)=':';mNumberColons++;ENDIF;NEXT // Число ':' в слове DO CASE CASE mNumberPoints = 2 // две точки, похоже это дата IF LEN(ALLTRIM(aStringOut[1])) = 0;aStringOut[1] = mWord;S++;ENDIF CASE mNumberColons = 2 // два двоеточия, похоже это время IF LEN(ALLTRIM(aStringOut[2])) = 0;aStringOut[2] = mWord;S++;ENDIF CASE mNumberPoints = 3 // три точки, похоже это IP-адрес IF LEN(ALLTRIM(aStringOut[3])) = 0;aStringOut[3] = mWord;S++;ENDIF OTHERWISE IF 3 < S .AND. S < 14 // Первые 3 элемента записаны в массив, значит записывать и остальные, если они еще не записаны IF LEN(ALLTRIM(aStringOut[S])) = 0 aStringOut[S] = mWord S++ ENDIF ENDIF ENDCASE NEXT * DC_DebugQout( aStringOut ) // Отладка ########## * MsgBox(STR(LEN(aStringInp))) // Отладка ########## * LB_Warning(aStringInp, L('(C) Система "Эйдос"')) // Отладка ########## * LB_Warning(aStringOut, L('(C) Система "Эйдос"')) // Отладка ########## ***** Определить максимальные размеры полей выходной строки. FOR w=1 TO 10 // Цикл по элементам выходной строки * MsgBox(STR(w)) aLenF[w] = MAX(aLenF[w], LEN(ALLTRIM(aStringOut[w]))+2) NEXT * DC_DebugQout( aLenF ) ENDIF DC_TxtSkip( nHandle, 1 ) ENDDO DC_TxtClose( nHandle ) ***** Создать и записать БД Visitors.DBF aStructure := { { "Num" , "N", 7 , 0 }, ; // 0 { "Date" , "C", aLenF[ 1], 0 }, ; // 1 { "Time" , "C", aLenF[ 2], 0 }, ; // 2 { "IP_address", "C", aLenF[ 3], 0 }, ; // 3 { "Domain" , "C", aLenF[ 4], 0 }, ; // 4 { "Country" , "C", aLenF[ 5], 0 }, ; // 5 { "Okrug" , "C", aLenF[ 6], 0 }, ; // 6 { "Region" , "C", aLenF[ 7], 0 }, ; // 7 { "City" , "C", aLenF[ 8], 0 }, ; // 8 { "Postcode" , "C", aLenF[ 9], 0 }, ; // 9 // Надо обработать, чтобы в Visitors не было смещения полей <<<===################ { "Timezone" , "C", aLenF[10], 0 }, ; // 10 // В новой строке его нет. Вернее он не всегда есть. Надо обработать, чтобы в Visitors не было смещения полей { "Latitude" , "N", 12, 4 }, ; // 11 { "Longitude" , "N", 12, 4 }, ; // 12 { "GeonameId" , "N", 12, 0 }, ; // 13 { "NIPaddress", "N", 12, 0 } } // 14 // Число встреч IP-адреса при сортировке по IP DbCreate( 'Visitors', aStructure ) *** Открыть и проиндексировать БД координат крупнейших городов мира по странам CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE WorldCities EXCLUSIVE NEW *INDEX ON SUBSTR(country,1,aLenF[ 5])+SUBSTR(city,1,aLenF[ 8]) TO WorldCities INDEX ON SUBSTR(city,1,aLenF[ 8]) TO WorldCities CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE WorldCities INDEX WorldCities EXCLUSIVE NEW USE Visitors EXCLUSIVE NEW PRIVATE aStringOut[13] // Выходная строка, возможно исправленная PRIVATE aFIELDSIZE[13] // Размеры полей БД Visitors FOR j=1 TO 13 aFIELDSIZE[j] = FIELDSIZE(j+1) NEXT mFlagErr = .F. // .F. - все нормально, .T. - были повторные даты и времена, значит надо преобразовать БД Visitors.DBF в текст и записать на WEB-сервер по FTP nHandle := DC_txtOpen( 'test_strings.txt' ) nRec = 0 DO WHILE !DC_TxtEOF( nHandle ) // Начало цикла по строкам mLine = DC_TxtLine( nHandle ) // Выделить строку из текстового файла mLine = STRTRAN(mLine, '"', '') // Убрать кавычки IF AT("usage_limit_reached", mLine) > 0 mFlagErr =.T. // Есть строки с информацией об ошибках ELSE nRec++ ***** Начало цикла по показателям посетителя ***************************************************************************************************************************************** ***** Сделать исправление ошибок БД 'test_strings.txt': <==########################################################### ***** 1. Сначала преобразовывать во входную строку запись БД 'test_strings.txt'. ***** 2. Потом определять типы данных всех элементов входной строки и сформировать выходную строку, записывая в каждое поле только первый ***** случай соотвествующего ему значения: первую дату, первое время, первый IP, если он есть, и далее все подряд. Если были повторы ***** значений одного типа - запомнить это, чтобы потом записать исправленную БД 'test_strings.txt' на WEB-сервер по FTP. ***** 3. Если IP отсутствует - всю строку игнорировать. ***** 4. Определить максимальные размеры полей выходной строки. ***** 5. Создать и записать БД Visitors.DBF ***** 6. Если были повторы даты или времени, или не было IP, то преобразовать БД Visitors.DBF в текст и записать на WEB-сервер по FTP ***************************************************************************************************************************************** ***** 1. Сначала преобразовывать во входную строку запись БД 'test_strings.txt'. aStringInp := {} // Входная строка "как есть" (после распаковки и форматирования в php) FOR w=1 TO NUMTOKEN(mLine,",") // Разделитель между показателями - запятая mWord = ALLTRIM(TOKEN(mLine, ",", w)) AADD(aStringInp, mWord) NEXT * IF nRec = 1 * MsgBox(STR(LEN(aStringInp))) // Отладка ########## * ENDIF ***** 2. Потом определять типы данных всех элементов входной строки и сформировать выходную строку, записывая в каждое поле только первый ***** случай соотвествующего ему значения: первую дату, первое время, первый IP, если он есть, и далее все подряд. Если были повторы ***** значений одного типа - запомнить это, чтобы потом записать исправленную БД 'test_strings.txt' на WEB-сервер по FTP. ***** Правильный вид строки из БД 'test_strings.txt': ***** 06.12.16,10:30:37,37.146.34.226,RU,Russia,KDA,Krasnodarskiy Kray,Krasnodar,350000,Europe/Moscow,45.0300,38.98,123456 S = 0 // Индекс для выходного массива AFILL(aStringOut,' ') * IF LEN(aStringInp) = 13 // Если IP отсутствует - всю строку игнорировать. FOR w=1 TO LEN(aStringInp) // Цикл по элементам входной строки ******************************************************************************* mWord = ALLTRIM(aStringInp[w]) mNumberPoints=0;FOR j=1 TO LEN(mWord);IF SUBSTR(mWord,j,1)='.';mNumberPoints++;ENDIF;NEXT // Количество '.' в слове - признак даты или IP mNumberColons=0;FOR j=1 TO LEN(mWord);IF SUBSTR(mWord,j,1)=':';mNumberColons++;ENDIF;NEXT // Число ':' в слове // Проверка, является ли элемент датой или временем, если является, записывать только 1-й раз // Проверка, является ли элемент IP-адресом, если является, записывать только 1-й раз. DO CASE CASE mNumberPoints = 2 // две точки, похоже это дата IF LEN(ALLTRIM(aStringOut[1])) = 0 ++S aStringOut[1] = mWord ELSE mFlagErr = .T. // .F. - все нормально, .T. - были повторные даты и времена, значит надо преобразовать БД Visitors.DBF в текст и записать на WEB-сервер по FTP ENDIF CASE mNumberColons = 2 // два двоеточия, похоже это время IF LEN(ALLTRIM(aStringOut[2])) = 0 ++S aStringOut[2] = mWord ELSE mFlagErr = .T. // .F. - все нормально, .T. - были повторные даты и времена, значит надо преобразовать БД Visitors.DBF в текст и записать на WEB-сервер по FTP ENDIF CASE mNumberPoints = 3 // три точки, похоже это IP-адрес IF LEN(ALLTRIM(aStringOut[3])) = 0 ++S aStringOut[3] = mWord ELSE mFlagErr = .T. // .F. - все нормально, .T. - были повторные даты и времена, значит надо преобразовать БД Visitors.DBF в текст и записать на WEB-сервер по FTP ENDIF OTHERWISE ++S IF 3 < S .AND. S <= LEN(aStringOut) // Первые 3 элемента записаны в массив, значит записывать и остальные, если они еще не записаны IF LEN(ALLTRIM(aStringOut[S])) = 0 IF S=9 IF VAL(ALLTRIM(mWord)) = 0 // Иногда вместо индекса сюда попадает временная зона и все смещается. Это учитывает эту ситуацию <<<===################# IF mWord <> 'unknown' aStringOut[S] = 'unknown' S++ ENDIF ENDIF ENDIF aStringOut[S] = mWord ENDIF ENDIF ENDCASE NEXT * ENDIF ***** 6. Если были повторы даты или времени, или не было IP, то преобразовать БД Visitors.DBF в текст и записать на WEB-сервер по FTP. ПОСЛЕ 07.07.2018 этого делать не надо ############ SELECT Visitors * IF LEN(ALLTRIM(aStringOut[3])) > 0 .AND. LEN(aStringOut) = 14 // Если IP отсутствует - всю строку игнорировать. * IF VAL(SUBSTR(aStringOut[12],1,aFIELDSIZE[12])) = 0 // <===##################### * LB_Warning(aStringOut) * MsgBox(aStringOut[j]) * ENDIF ****** Если Вашингтон или Лондон, то формат записи другой, поэтому они просто не учитываются APPEND BLANK FOR j=1 TO LEN(aStringOut) IF j <= 10 FIELDPUT(j+1, SUBSTR(aStringOut[j],1,aFIELDSIZE[j])) ELSE FIELDPUT(j+1, VAL(SUBSTR(aStringOut[j],1,aFIELDSIZE[j]))) // Ошибка размера поля <===##################### ENDIF NEXT * ENDIF IF AT(":", Time) = 2 REPLACE Time WITH ' '+Time ENDIF ENDIF DC_TxtSkip( nHandle, 1 ) ENDDO DC_TxtClose( nHandle ) SELECT Visitors N_Rec1 = RECCOUNT() DELETE FOR LATITUDE = 0 .OR. LONGITUDE = 0 .OR.; LATITUDE < -90 .OR. LATITUDE > +90 .OR.; LONGITUDE < -180 .OR. LONGITUDE > +180 .OR.; LEN(ALLTRIM(IP_ADDRESS)) = 0 PACK N_Rec2 = RECCOUNT() *MsgBox(STR(N_Rec1)+STR(N_Rec2)) *CLOSE ALL *QUIT mFlag = .T. *** ПОСЛЕ 07.07.2018 этого делать не надо, поэтому: ############ все же надо, сделать вопрос IF mPar = "N" mFlagErr = .F. N_Rec1 = N_Rec2 ENDIF *** С 08.02.2019 опять надо это делать, т.к. стали появляться строки вида: *08.02.2019,16:43:44,Unknown,e,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Sub,e,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Sub,se,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subs,se,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subs,ss":false,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subscriptio,ess":false,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subscription,Unknown,:false,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subscript,false,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subscrip,alse,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subscri *08.02.2019,16:52:29,Unknown,e,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Sub,e,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Sub,se,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subs,se,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subs,ss":false,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subscriptio,ess":false,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subscription,Unknown,:false,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subscript,false,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subscrip,alse,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subscri *08.02.2019,19:51:05,Unknown,e,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Sub,e,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Sub,se,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subs,se,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subs,ss":false,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subscriptio,ess":false,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subscription,Unknown,:false,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subscript,false,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subscrip,alse,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subscri *08.02.2019,23:10:54,Unknown,e,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Sub,e,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Sub,se,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subs,se,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subs,ss":false,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subscriptio,ess":false,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subscription,Unknown,:false,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subscript,false,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subscrip,alse,"error":{"code":104,"type":"usage_limit_reached","info":"Your monthly usage limit has been reached. Please upgrade your Subscri *mFlagErr = .T. // <<<===############## Отладка IF mFlagErr .OR. N_Rec1 <> N_Rec2 // .T. - были повторные даты и времена или нулевые координаты, значит надо преобразовать БД Visitors.DBF в текст и записать на WEB-сервер по FTP mFlag = .F. DC_Impl(oScrn) * oScrn2 := DC_WaitOn( L('Запись на FTP-сервер исправленной БД: "test_strings.txt" с информацией о запусках системы "Эйдос-Х++"' ),,,,,,,,,,,.F.) **** Формирование текстового файла для WEB-сервера и запись его на WEB-сервер по FTP SELECT Visitors ************************************************************************************* *** Отображение стадии и прогноза времени исполнения ******************************** ************************************************************************************* Wsego = RECCOUNT() + 1 mTitleName = L('Запись в Эйдос-облако исправленной БД с информацией о запусках системы "Эйдос-Х++"') // Отображение стадии исполнения. Будет написано прямо в окне Progress-bar d = 0 @0,0 DCGROUP oGroup1 CAPTION L('Стадии исполнения процесса') FONT "6.Helv" SIZE 105+d, 2.5 PARENT oTabPage1 @4,0 DCGROUP oGroup2 CAPTION L('Прогноз времени исполнения') FONT "6.Helv" SIZE 105+d, 5.0 PARENT oTabPage2 s = 1 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 1] FONT "10.Helv" s++ @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay97 FONT "10.HelvBold" s++ @0.2+s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay98 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @1.5+s ,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay99 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @s ,1 DCPROGRESS oProgress ; SIZE 95,1.5 ; PERCENT ; EVERY 1+INT(Wsego/100) ; // Кол-во обновлений изображения MAXCOUNT Wsego ; COLOR GRA_CLR_CYAN // Цвет полосы @s++,97 DCPUSHBUTTON CAPTION L('&Cancel') ; ACTION {||lOk:=.T.} OBJECT oButton ; SIZE 7,1.5 DCREAD GUI ; TITLE mTitleName ; PARENT @oDialog ; FIT ; EXIT ; MODAL oDialog:alwaysOnTop = .T. // Окно открывается на переднем плане oDialog:show() // Начало отсчета времени для прогнозирования длительности исполнения Time_progress = 0 // Прошло секунд с начала процесса // Процесс может идти больше суток, поэтому для определения // во всех случаях вычисляется время, прошедшее с начала года T_Mess1 = L("Начало:")+" "+TIME() // Начало Sec_1 = (DOY(DATE())-1)*86400+SECONDS() PUBLIC T1 := (DOY(DATE())-1)*86400+SECONDS() // Время предыдущей индикации процесса исполнения PUBLIC T2 := (DOY(DATE())-1)*86400+SECONDS()+1 // Текущее время (1-й раз оно заметно больше T1 чтобы было отображение) PUBLIC T1tp := T1 PUBLIC T2tp := T2 ********************************************************************************* mABC = '' DBGOTOP() DO WHILE .NOT. EOF() mLine = '' FOR j=2 TO 14 mVal = FIELDGET(j) DO CASE CASE VALTYPE(mVal) = 'C' mABC = mABC + mVal + IF(j<14,',','') mLine = mLine + mVal + IF(j<14,',','') CASE VALTYPE(mVal) = 'N' mABC = mABC + STR(mVal,12,IF(j<14,4,0)) + IF(j<14,',','') mLine = mLine + STR(mVal,12,IF(j<14,4,0)) + IF(j<14,',','') ENDCASE NEXT mABC = mABC + CrLf aSay[ 1]:SetCaption(L('Подготовка БД:'+' '+ALLTRIM(mLine))) *** Отображение стадии и прогноза времени исполнения **************** lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) DBSKIP(1) ENDDO aSay[ 1]:SetCaption(L('Запись исправленной БД: "test_strings.txt" в Эйдос-облако')) StrFile(mABC, 'test_strings.txt') // Запись текстового файла для картографической визуализации в папку с системой mDateTime = DTOC(DATE())+"-"+TIME() mDateTime = STRTRAN(mDateTime, ":", "_") mDBtmp = 'test_strings_'+mDateTime+".txt" StrFile(mABCerr, mDBtmp) // Запись исходного текстового файла для картографической визуализации в папку с системой ******* Записать БД 'map_strings.txt' по FTP на сайт: http://lc.kubagro.ru ********************************************************************************************************** Xb2NetKey() cFtpServer:="94.25.18.114" // Это везде одинаково <<<===############ oFtp := FTPClient():new( cFtpServer, Ftp_User, Ftp_Passw ) // Соединение с моим сайтом и авторизация IF oFtp:connect() // Есть соединение с моим сайтом и авторизация? ********************************************************************************************************** **** Сделать текущей папку: ftp://94.25.18.114/public_html/ * MsgBox(oFtp:curDir()) oFtp:curDir("/") oFtp:curDir("public_html") * MsgBox(oFtp:curDir()) IF oFtp:CurDir() <> "\public_html" * DC_Impl(oScrn2) LB_Warning(L('Не удалось сделать текущей директорию: "\public_html"'), L('(C) Система "Эйдос-Х++"' )) RETURN NIL ENDIF IF oFtp:PutFile("test_strings.txt", "test_strings.txt") * LB_Warning(L('Запись исправленной базы данных: "test_strings.txt" на FTP-сервер завершена успешно'), L('(C) Система "Эйдос-Х++"' )) ENDIF IF oFtp:PutFile(mDBtmp, mDBtmp) * LB_Warning(L('Запись исходной базы данных: "')+mDBtmp+L('" на FTP-сервер завершена успешно'), L('(C) Система "Эйдос-Х++"' )) ENDIF ERASE(mDBtmp) ELSE * DC_Impl(oScrn2) LB_Warning(L('Нет соединения с FTP-сервером'), L('(C) Система "Эйдос-Х++"')) RETURN NIL ENDIF * DC_Impl(oScrn2) *** Отображение стадии и прогноза времени исполнения **************** lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) oSay97:SetCaption(L("Запись в Эйдос-облако исправленной БД посещений успешно завершено !!!")) MILLISEC(2000) oSay97:SetCaption(oSay97:caption) oButton:SetCaption(L('&Ok')) // Деструктурирование окна отображения графического Progress-bar oButton:activate := {||PostAppEvent(xbeP_Close,,,oDialog)} //<<<<<< Add This DC_AppEvent( @lOk ) PostAppEvent(xbeP_Activate,,,DC_GetObject(GetList,'DCGUI_BUTTON_OK')) // Роджер oDialog:Destroy() ENDIF IF mFlag DC_Impl(oScrn) ENDIF ******* Отображение БД ******* * PUBLIC mDate1, mDate2 * DBGOTOP() ;mDate1 = Date * DBGOBOTTOM();mDate2 = Date * SET FILTER TO CTOD(mDate1) <= CTOD(Date) .AND. CTOD(Date) <= CTOD(mDate2) *SET FILTER TO LATITUDE * LONGITUDE = 0 // VPN скрывает координаты (обнуляет), из-за чего возникает ошибка в Яндекс-картах *IF RECCOUNT() > 0 * aMess := {} * AADD(aMess, L('Некоторые пользователи системы "Эйдос" использовали VPN,')) * AADD(aMess, L('из-за которого геолокация возвращает нулевые координаты,')) * AADD(aMess, L('что приводит к ошибке картографической визуализации в Яндекс-картах.')) * AADD(aMess, L('Эти пользователи не будут визуализироваться на Яндекс-картах,')) * AADD(aMess, L('но в базе данных они будут отображаться.')) * LB_Warning( aMess, L('(C) Система "Эйдос-Х++"')) *ENDIF SET FILTER TO DBGOTOP() sLenF = 33 FOR j=1 TO 10 sLenF = sLenF + aLenF[j] NEXT *MsgBox(STR(sLenF)) /* ----- Create ToolBar ----- */ @35.3,0 DCGROUP oGroup1 CAPTION L(' ') SIZE sLenF+40, 4.0 @ 0.5, 2 DCGROUP oGroup2 CAPTION L(' ') SIZE LEN(L('Помощь') ) +5, 3.0 PARENT oGroup1 @ 1 , 1 DCPUSHBUTTON CAPTION L('Помощь') SIZE LEN(L('Помощь') ) +2, 1.5 ACTION {||Help69(), DC_GetRefresh(GetList)} PARENT oGroup2 d = 5 n = 0.5 @ 0.5, 15 DCGROUP oGroup3 CAPTION L('СОРТИРОВКА:' ) SIZE 85, 3.0 PARENT oGroup1 @ 1 , 1 DCPUSHBUTTON CAPTION L('Без сортировки' ) SIZE LEN(L('Без сортировки') )-0+n, 1.5 ACTION {||Sorting69(0), DC_GetRefresh(GetList)} PARENT oGroup3 // 0 @ 1 ,DCGUI_COL+d DCPUSHBUTTON CAPTION L('По дате' ) SIZE LEN(L('По дате') )+0+n, 1.5 ACTION {||Sorting69(1), DC_GetRefresh(GetList)} PARENT oGroup3 // 1 @ 1 ,DCGUI_COL+d DCPUSHBUTTON CAPTION L('По IP' ) SIZE LEN(L('По IP') )+0+n, 1.5 ACTION {||Sorting69(2), DC_GetRefresh(GetList)} PARENT oGroup3 // 2 @ 1 ,DCGUI_COL+d DCPUSHBUTTON CAPTION L('По IP-unique' ) SIZE LEN(L('По IP-unique') )-2+n, 1.5 ACTION {||Sorting69(3), DC_GetRefresh(GetList)} PARENT oGroup3 // 3 @ 1 ,DCGUI_COL+d DCPUSHBUTTON CAPTION L('По N запусков с IP-unique' ) SIZE LEN(L('По N запусков с IP-unique') )-4+n, 1.5 ACTION {||Sorting69(6), DC_GetRefresh(GetList)} PARENT oGroup3 // 6 @ 1 ,DCGUI_COL+d DCPUSHBUTTON CAPTION L('По стране' ) SIZE LEN(L('По стране') )+0+n, 1.5 ACTION {||Sorting69(4), DC_GetRefresh(GetList)} PARENT oGroup3 // 4 @ 1 ,DCGUI_COL+d DCPUSHBUTTON CAPTION L('По городу' ) SIZE LEN(L('По городу') )+0+n, 1.5 ACTION {||Sorting69(5), DC_GetRefresh(GetList)} PARENT oGroup3 // 5 @ 0.5, 102 DCGROUP oGroup4 CAPTION L('Карта мира (необходим FTP-доступ):') SIZE 56, 3.0 PARENT oGroup1 @ 1 , 1 DCPUSHBUTTON CAPTION L('Все за период') SIZE LEN(L('Все за период')) +0, 1.5 ACTION {||Visual69(2), DC_GetRefresh(GetList)} PARENT oGroup4 @ 1 ,DCGUI_COL+d DCPUSHBUTTON CAPTION L('Unique IP без надписей') SIZE LEN(L('Unique IP без надписей')) -2, 1.5 ACTION {||Visual69(3), DC_GetRefresh(GetList)} PARENT oGroup4 @ 1 ,DCGUI_COL+d DCPUSHBUTTON CAPTION L('Unique IP с надписями') SIZE LEN(L('Unique IP с надписями')) -2, 1.5 ACTION {||Visual69(4), DC_GetRefresh(GetList)} PARENT oGroup4 @ 0.5, 160 DCGROUP oGroup5 CAPTION L('Карта, достаточно http') SIZE 20, 3.0 PARENT oGroup1 @ 1 , 1 DCPUSHBUTTON CAPTION L('Все IP кластеры') SIZE LEN(L('Все IP кластеры')) +2, 1.5 ACTION {||Visual69(5), DC_GetRefresh(GetList)} PARENT oGroup5 *@ 0.5, 182 DCGROUP oGroup6 CAPTION L(' ') SIZE LEN(L('Facebook-группа по АСК-анализу и системе "Эйдос"')) -1, 3.0 PARENT oGroup1 *@ 1 , 1 DCPUSHBUTTON CAPTION L('Facebook-группа по АСК-анализу и системе "Эйдос"') SIZE LEN(L('Facebook-группа по АСК-анализу и системе "Эйдос"')) -4, 1.5 ACTION {||LC_RunUrl("https://www.facebook.com/groups/558866657885969/")} PARENT oGroup6 @ 0.5, 182 DCGROUP oGroup6 CAPTION L(' ') SIZE LEN(L('Пересоздать базу запусков системы "Эйдос"')) -1, 3.0 PARENT oGroup1 @ 1 , 1 DCPUSHBUTTON CAPTION L('Пересоздать базу запусков системы "Эйдос"') SIZE LEN(L('Пересоздать базу запусков системы "Эйдос"')) -4, 1.5 ACTION {||RecreateDB(), DC_GetRefresh(GetList)} PARENT oGroup6 ****** Отображение таблицы *************** SELECT Visitors mNumPP = 0 DBGOTOP() DO WHILE .NOT. EOF() REPLACE Num WITH ++mNumPP // Нумерация всех обращений по порядку DBSKIP(1) ENDDO DBGOBOTTOM();mDate2 = Date DBGOTOP() ;mDate1 = Date DCSETPARENT TO @ 5, 0 DCBROWSE Visitors ALIAS 'Visitors' SIZE sLenF+39,30 ; PRESENTATION LC_BrowPres() ; // Только просмотр БД NOSOFTTRACK ; HEADLINES 2 ; // Кол-во строк в заголовке (перенос строки - ";") SCOPE ; ITEMMARKED bItems DCSETPARENT Visitors *** Подарок от Роджера *** Цветом выделять колонку, по которой сортировка <<<===############## *@ 1 , 1 DCPUSHBUTTON CAPTION L('Без сортировки' ) SIZE LEN(L('Без сортировки') )-0+n, 1.5 ACTION {||Sorting69(0), DC_GetRefresh(GetList)} PARENT oGroup3 // 0 *@ 1 ,DCGUI_COL+d DCPUSHBUTTON CAPTION L('По дате' ) SIZE LEN(L('По дате') )+0+n, 1.5 ACTION {||Sorting69(1), DC_GetRefresh(GetList)} PARENT oGroup3 // 1 *@ 1 ,DCGUI_COL+d DCPUSHBUTTON CAPTION L('По IP' ) SIZE LEN(L('По IP') )+0+n, 1.5 ACTION {||Sorting69(2), DC_GetRefresh(GetList)} PARENT oGroup3 // 2 *@ 1 ,DCGUI_COL+d DCPUSHBUTTON CAPTION L('По IP-unique' ) SIZE LEN(L('По IP-unique') )-2+n, 1.5 ACTION {||Sorting69(3), DC_GetRefresh(GetList)} PARENT oGroup3 // 3 *@ 1 ,DCGUI_COL+d DCPUSHBUTTON CAPTION L('По N запусков с IP-unique' ) SIZE LEN(L('По N запусков с IP-unique') )-4+n, 1.5 ACTION {||Sorting69(6), DC_GetRefresh(GetList)} PARENT oGroup3 // 6 *@ 1 ,DCGUI_COL+d DCPUSHBUTTON CAPTION L('По стране' ) SIZE LEN(L('По стране') )+0+n, 1.5 ACTION {||Sorting69(4), DC_GetRefresh(GetList)} PARENT oGroup3 // 4 *@ 1 ,DCGUI_COL+d DCPUSHBUTTON CAPTION L('По городу' ) SIZE LEN(L('По городу') )+0+n, 1.5 ACTION {||Sorting69(5), DC_GetRefresh(GetList)} PARENT oGroup3 // 5 DCBROWSECOL FIELD Visitors->Num HEADER L("№;п/п" ) PARENT Visitors WIDTH 7 FONT "9.Courier" COLOR {||IIF(mSortVisit=0, {nil,aColor[100]},{nil,GRA_CLR_WHITE})} // 0 DCBROWSECOL FIELD Visitors->Date HEADER L("Дата;ДД.ММ.ГГ" ) PARENT Visitors WIDTH aLenF[ 1]+1 FONT "9.Courier" COLOR {||IIF(mSortVisit=1, {nil,aColor[100]},{nil,GRA_CLR_WHITE})} // 1 DCBROWSECOL FIELD Visitors->Time HEADER L("Время;ЧЧ:ММ:СС" ) PARENT Visitors WIDTH aLenF[ 2]+1 FONT "9.Courier" COLOR {||IIF(mSortVisit=1, {nil,aColor[100]},{nil,GRA_CLR_WHITE})} // 1 DCBROWSECOL FIELD Visitors->IP_address HEADER L("IP-адрес" ) PARENT Visitors WIDTH aLenF[ 3]+1 FONT "9.Courier" COLOR {||IIF(mSortVisit=2 .OR. mSortVisit=3, {nil,aColor[100]},{nil,GRA_CLR_WHITE})} // 2, 3 DCBROWSECOL FIELD Visitors->Domain HEADER L("Домен" ) PARENT Visitors WIDTH aLenF[ 4]+4 FONT "9.Courier" DCBROWSECOL FIELD Visitors->Country HEADER L("Страна" ) PARENT Visitors WIDTH aLenF[ 5]+1 FONT "9.Courier" COLOR {||IIF(mSortVisit=4, {nil,aColor[100]},{nil,GRA_CLR_WHITE})} // 4 DCBROWSECOL FIELD Visitors->Okrug HEADER L("Округ" ) PARENT Visitors WIDTH aLenF[ 6]+1 FONT "9.Courier" DCBROWSECOL FIELD Visitors->Region HEADER L("Регион" ) PARENT Visitors WIDTH aLenF[ 7]+1 FONT "9.Courier" DCBROWSECOL FIELD Visitors->City HEADER L("Город" ) PARENT Visitors WIDTH aLenF[ 8]+1 FONT "9.Courier" COLOR {||IIF(mSortVisit=5, {nil,aColor[100]},{nil,GRA_CLR_WHITE})} // 5 DCBROWSECOL FIELD Visitors->Postcode HEADER L("Почтовый;индекс") PARENT Visitors WIDTH aLenF[ 9]+1 FONT "9.Courier" DCBROWSECOL FIELD Visitors->Timezone HEADER L("Временной;пояс" ) PARENT Visitors WIDTH aLenF[10]+1 FONT "9.Courier" DCBROWSECOL FIELD Visitors->Latitude HEADER L("Широта" ) PARENT Visitors WIDTH 12 +1 FONT "9.Courier" DCBROWSECOL FIELD Visitors->Longitude HEADER L("Долгота" ) PARENT Visitors WIDTH 12 +1 FONT "9.Courier" DCBROWSECOL FIELD Visitors->GeoNameId HEADER L("GeoNameId" ) PARENT Visitors WIDTH 12 +1 FONT "9.Courier" DCBROWSECOL FIELD Visitors->NIPaddress HEADER L("Число;запусков" ) PARENT Visitors WIDTH 12 +1 FONT "9.Courier" COLOR {||IIF(mSortVisit=6, {nil,aColor[100]},{nil,GRA_CLR_WHITE})} // 6 DCGETOPTIONS SAYFONT '10.Helv Bold' TABSTOP AUTORESIZE DCREAD GUI ; FIT ; OPTIONS GetOptions ; MODAL ; TITLE L('6.9. География пользователей системы "Эйдос-Х++"') ; EVAL {|o|SetAppFocus(Visitors:GetColumn(1))} ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ************************************************************************************************** ************************************************************************************************** FUNCTION Help69() aHelp := {} AADD(aHelp, L('Режим: 6.9. География пользователей системы "Эйдос-Х++". ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Когда кто-либо в мире запускает систему "Эйдос-Х++" на исполнение на компьютере, подключенном к Internet, то на она программно ')) AADD(aHelp, L('обращается к специально созданному сайту: "http://lc.kubagro.ru/index_aidos.php", на котором как index.php размещен следующий PHP-код: ')) AADD(aHelp, L(' ')) AADD(aHelp, L('"; // Редирект на основной сайт ')) AADD(aHelp, L('?> ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Этот код определяет дату и время обращения, а также IP-адрес компьютера, с которого произошло это обращение, а затем по нему определяет страну, регион, ')) AADD(aHelp, L('город пользователя, а также его географические координаты и почтовый индекс. Всю эту информацию данный срипт заносит в базу данных: "test_strings.txt", ')) AADD(aHelp, L('расположенную на сайте, а затем выполняет переход (редирект) на основной сайт разработчика: http://lc.kubagro.ru. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Режим 6.9. считывает по FTP базу данных "test_strings.txt" с сайта: http://lc.kubagro.ru и преобразует ее в DBF-файл: "Visitors.DBF", который ')) AADD(aHelp, L('и отображается в данном режиме в виде таблицы с различными сортировками или просто текста. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Если на компьютере есть FTP-доступ, то пользователь может получить картографическую визуализацию на масштабируемой карте мира как всех посещений, ')) AADD(aHelp, L('так и только тех, которые были в заданный диапазон дат. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Если на компьютере нет FTP-доступа (обычно это бывает в случаях, когда он заблокирован политиками безопасности), то можно воспользоваться упрощенным ')) AADD(aHelp, L('вариантом демонстрации карты посетителей, доступным, когда есть только HTTP-доступ. В этом случае пользователь лишен возможности сделать выборку ')) AADD(aHelp, L('по диапазону дат. В остальном возможности те же самые. PHP-скрипт картографической визуализации БД: "test_strings.txt" приведен в файле: ')) AADD(aHelp, L('../Aidos-X/Sheet_changes.doc за 11.12.2016. ')) mHelpMax = -999;FOR h=1 TO LEN(aHelp);mHelpMax = MAX(mHelpMax, LEN(ALLTRIM(aHelp[h])));NEXT s=1;d=0.7;@0,0 DCGROUP oGroup1 CAPTION L(' ') SIZE mHelpMax+7, LEN(aHelp)*d+1.5 FOR h=1 TO LEN(aHelp);@s,2 DCSAY aHelp[h] SIZE 0 PARENT ogroup1 FONT "9.Courier";s=s+d;NEXT DCREAD GUI TO lExit FIT TITLE L('Помощь по режиму: 6.9. География пользователей системы "Эйдос-Х++"') RETURN NIL ************************************************************************************************** FUNCTION Sorting69(Par) *SET FILTER TO LATITUDE * LONGITUDE <> 0 // VPN скрывает координаты (обнуляет), из-за чего возникает ошибка в Яндекс-картах * Без сортировки') // 0 * По дате') // 1 * По IP') // 2 * По IP-unique') // 3 * По N запусков с IP-unique') // 6 * По стране') // 4 * По городу') // 5 DO CASE CASE Par = 0 SET ORDER TO // Без сортировки mSortVisit = 0 CASE Par = 1 // По дате и времени INDEX ON DTOS(CTOD(Date))+Time+IP_ADDRESS+DOMAIN+COUNTRY+OKRUG+REGION+CITY+POSTCODE+TIMEZONE+STR(LATITUDE,12,4)+STR(LONGITUDE,12,4)+STR(GEONAMEID,12,0) TO Sort69 mSortVisit = 1 CASE Par = 2 // По IP-адресу INDEX ON IP_ADDRESS+DOMAIN+COUNTRY+OKRUG+REGION+CITY+POSTCODE+TIMEZONE+STR(LATITUDE,12,4)+STR(LONGITUDE,12,4)+STR(GEONAMEID,12,0) TO Sort69 mSortVisit = 2 CASE Par = 3 // По числу запусков и IP-адресу (unique) INDEX ON STR(999999999-NIPaddress,10,0)+IP_ADDRESS+DOMAIN+COUNTRY+OKRUG+REGION+CITY+POSTCODE+TIMEZONE+STR(LATITUDE,12,2)+STR(LONGITUDE,12,4)+STR(GEONAMEID,12,0) TO Sort69 UNIQUE mSortVisit = 3 CASE Par = 4 // По стране INDEX ON Country+IP_ADDRESS+DOMAIN+COUNTRY+OKRUG+REGION+CITY+POSTCODE+TIMEZONE+STR(LATITUDE,12,4)+STR(LONGITUDE,12,4)+STR(GEONAMEID,12,0) TO Sort69 mSortVisit = 4 CASE Par = 5 // По городу INDEX ON City+IP_ADDRESS+DOMAIN+COUNTRY+OKRUG+REGION+CITY+POSTCODE+TIMEZONE+STR(LATITUDE,12,4)+STR(LONGITUDE,12,4)+STR(GEONAMEID,12,0) TO Sort69 mSortVisit = 5 CASE Par = 6 // По N запусков с IP-unique' oScrn2 := DC_WaitOn( L('Поиск уникальных IP-адресов, c которых запускалась система "Эйдос" и подсчет количества запусков'),,,,,,,,,,,.F.) SELECT Visitors SET ORDER TO // Без сортировки ***** Посчитать сколько раз в БД Visitors встречается каждый IP-адрес aIP := {} // Массив уникальных IP-адресов для отображения aNIP := {} // Массив числа встреч IP-адресов DBGOTOP() DO WHILE .NOT. EOF() REPLACE NIPaddress WITH 0 // Число встреч IP-адреса при сортировке по IP mIP = IP_ADDRESS+DOMAIN+COUNTRY+OKRUG+REGION+CITY+POSTCODE+TIMEZONE+STR(LATITUDE,12,4)+STR(LONGITUDE,12,4)+STR(GEONAMEID,12,0) IF ASCAN(aIP, mIP) = 0 // Обеспечивает чтобы каждый IP-адрес встречался в массиве только 1 раз AADD( aIP, mIP) AADD(aNIP, 0) ENDIF DBSKIP(1) ENDDO SET ORDER TO // Без сортировки DBGOTOP() DO WHILE .NOT. EOF() mIP = IP_ADDRESS+DOMAIN+COUNTRY+OKRUG+REGION+CITY+POSTCODE+TIMEZONE+STR(LATITUDE,12,4)+STR(LONGITUDE,12,4)+STR(GEONAMEID,12,0) mPos = ASCAN(aIP, mIP) IF mPos > 0 aNIP[mPos] = aNIP[mPos] + 1 ENDIF DBSKIP(1) ENDDO DBGOTOP() DO WHILE .NOT. EOF() mIP = IP_ADDRESS+DOMAIN+COUNTRY+OKRUG+REGION+CITY+POSTCODE+TIMEZONE+STR(LATITUDE,12,4)+STR(LONGITUDE,12,4)+STR(GEONAMEID,12,0) mPos = ASCAN(aIP, mIP) IF mPos > 0 REPLACE NIPaddress WITH aNIP[mPos] // Число встреч IP-адреса в БД посещений ENDIF DBSKIP(1) ENDDO INDEX ON STR(999999999-NIPaddress,10,0)+IP_ADDRESS+DOMAIN+COUNTRY+OKRUG+REGION+CITY+POSTCODE+TIMEZONE+STR(LATITUDE,12,2)+STR(LONGITUDE,12,4)+STR(GEONAMEID,12,0) TO Sort69 UNIQUE DC_Impl(oScrn2) mSortVisit = 6 ENDCASE DBGOTOP() ReTURN nil ***************************************************************************************** FUNCTION Visual69(Par) LOCAL GetList := {}, mN_Visits := 0 ******* Из 'Visitors.DBF' сформировать базу данных: 'map_strings.txt' для отображения, ******* записать ее по FTP на сайт и запустить само картографическое отображение http://lc.kubagro.ru/map2.php * Задается период и число посещений Visual69(2) * Unique IP без надписей, задается число посещений Visual69(3) * Unique IP с надписями, задается число посещений Visual69(4) * Все IP кластеры все за все время Visual69(5) IF Par = 3 .OR. Par = 4 // Unique IP без надписей, Unique IP с надписями, задается число посещений mN_Visits = 10 @0, 0 DCGROUP oGroup1 CAPTION L('Отображать только IP-адреса' ) SIZE 50, 2.5 @1, 2 DCSAY L("с числом посещений не менее, чем:") PARENT oGroup1 @1,30 DCGET mN_Visits PICTURE "######" PARENT oGroup1 DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; OPTIONS GetOptions ; ADDBUTTONS ; MODAL ; TITLE L('6.9. Просмотр запусков системы "Эйдос"') **************************************************** IF lExit ** Button Ok ELSE RETURN NIL ENDIF **************************************************** IF mN_Visits > 0 // Отображать все уникальные IP, если с них запускали систему не менее, чем mN_Visits раз ***** Создать и записать БД Visitors.DBF *aStructure := { { "Num" , "N", 7 , 0 }, ; // 0 * { "Date" , "C", aLenF[ 1], 0 }, ; // 1 * { "Time" , "C", aLenF[ 2], 0 }, ; // 2 * { "IP_address", "C", aLenF[ 3], 0 }, ; // 3 * { "Domain" , "C", aLenF[ 4], 0 }, ; // 4 * { "Country" , "C", aLenF[ 5], 0 }, ; // 5 * { "Okrug" , "C", aLenF[ 6], 0 }, ; // 6 * { "Region" , "C", aLenF[ 7], 0 }, ; // 7 * { "City" , "C", aLenF[ 8], 0 }, ; // 8 * { "Postcode" , "C", aLenF[ 9], 0 }, ; // 9 * { "Timezone" , "C", aLenF[10], 0 }, ; // 10 // В новой строке его нет * { "Latitude" , "N", 12, 4 }, ; // 11 * { "Longitude" , "N", 12, 4 }, ; // 12 * { "GeonameId" , "N", 12, 0 }, ; // 13 * { "NIPaddress", "N", 12, 0 } } // 14 // Число встреч IP-адреса при сортировке по IP *DbCreate( 'Visitors', aStructure ) SELECT Visitors * SET FILTER TO LATITUDE * LONGITUDE <> 0 // VPN скрывает координаты (обнуляет), из-за чего возникает ошибка в Яндекс-картах SET ORDER TO // Без сортировки IF mN_Visits > 0 // Отображать все уникальные IP, независимо от числа посещений oScrn2 := DC_WaitOn( L('Поиск уникальных IP-адресов с которых было не менее:')+' '+ALLTRIM(STR(mN_Visits))+' '+L('запусков системы "Эйдос"'),,,,,,,,,,,.F.) ELSE oScrn2 := DC_WaitOn( L('Поиск уникальных IP-адресов, c которых запускалась система "Эйдос"'),,,,,,,,,,,.F.) ENDIF ***** Посчитать сколько раз в БД Visitors встречается каждый IP-адрес aIP := {} // Массив уникальных IP-адресов для отображения aNIP := {} // Массив числа встреч IP-адресов DBGOTOP() DO WHILE .NOT. EOF() REPLACE NIPaddress WITH 0 // Число встреч IP-адреса при сортировке по IP mIP = IP_ADDRESS+DOMAIN+COUNTRY+OKRUG+REGION+CITY+POSTCODE+TIMEZONE+STR(LATITUDE,12,4)+STR(LONGITUDE,12,4)+STR(GEONAMEID,12,0) IF ASCAN(aIP, mIP) = 0 // Обеспечивает чтобы каждый IP-адрес встречался в массиве только 1 раз AADD( aIP, mIP) AADD(aNIP, 0) ENDIF DBSKIP(1) ENDDO SET ORDER TO // Без сортировки DBGOTOP() DO WHILE .NOT. EOF() mIP = IP_ADDRESS+DOMAIN+COUNTRY+OKRUG+REGION+CITY+POSTCODE+TIMEZONE+STR(LATITUDE,12,4)+STR(LONGITUDE,12,4)+STR(GEONAMEID,12,0) mPos = ASCAN(aIP, mIP) IF mPos > 0 aNIP[mPos] = aNIP[mPos] + 1 ENDIF DBSKIP(1) ENDDO DBGOTOP() DO WHILE .NOT. EOF() mIP = IP_ADDRESS+DOMAIN+COUNTRY+OKRUG+REGION+CITY+POSTCODE+TIMEZONE+STR(LATITUDE,12,4)+STR(LONGITUDE,12,4)+STR(GEONAMEID,12,0) mPos = ASCAN(aIP, mIP) IF mPos > 0 REPLACE NIPaddress WITH aNIP[mPos] // Число встреч IP-адреса в БД посещений ENDIF DBSKIP(1) ENDDO DC_Impl(oScrn2) ENDIF ENDIF ************************************************************************************************************** * Задается период и число посещений Visual69(2) * Unique IP без надписей, задается число посещений Visual69(3) * Unique IP с надписями, задается число посещений Visual69(4) * Все IP кластеры все за все время Visual69(5) IF Par = 2 // Задается период и число посещений Visual69(2) *** Задать диапазон дат ******************************************** SELECT Visitors SET ORDER TO // Без сортировки * SET FILTER TO LATITUDE * LONGITUDE <> 0 // VPN скрывает координаты (обнуляет), из-за чего возникает ошибка в Яндекс-картах *** Задать период и число посещений nRadio1 = 2 @ 0, 0 DCGROUP oGroup1 CAPTION L('Задайте период:' ) SIZE 50, 4.5 @ 1, 1 DCRADIO nRadio1 VALUE 1 PROMPT L('день ') PARENT oGroup1 @ 2, 1 DCRADIO nRadio1 VALUE 2 PROMPT L('неделя (7 дней) ') PARENT oGroup1 @ 3, 1 DCRADIO nRadio1 VALUE 3 PROMPT L('1 месяц (30 дней) ') PARENT oGroup1 @ 1,30 DCRADIO nRadio1 VALUE 4 PROMPT L('2 месяца (60 дней) ') PARENT oGroup1 @ 2,30 DCRADIO nRadio1 VALUE 5 PROMPT L('3 месяца (90 дней) ') PARENT oGroup1 @ 3,30 DCRADIO nRadio1 VALUE 6 PROMPT L('задается вручную ') PARENT oGroup1 mN_Visits = 1 @ 5, 0 DCGROUP oGroup2 CAPTION L('Отображать только IP-адреса' ) SIZE 50, 2.5 @ 1, 2 DCSAY L("с числом посещений не менее, чем:") PARENT oGroup2 @ 1,30 DCGET mN_Visits PICTURE "######" PARENT oGroup2 DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; OPTIONS GetOptions ; ADDBUTTONS ; MODAL ; TITLE L('6.9. Просмотр запусков системы "Эйдос"') ************************************************************************************************** *************************************************** IF lExit ** Button Ok ELSE RETURN NIL ENDIF *************************************************** DO CASE CASE nRadio1 = 1 // день DBGOBOTTOM();mDate2 = Date mDate1 = DTOC(CTOD(mDate2) - 1) CASE nRadio1 = 2 // неделю (7 дней) DBGOBOTTOM();mDate2 = Date mDate1 = DTOC(CTOD(mDate2) - 7) CASE nRadio1 = 3 // 1 месяц (30 дней) DBGOBOTTOM();mDate2 = Date mDate1 = DTOC(CTOD(mDate2) - 30) CASE nRadio1 = 4 // 2 месяца (60 дней) DBGOBOTTOM();mDate2 = Date mDate1 = DTOC(CTOD(mDate2) - 60) CASE nRadio1 = 5 // 3 месяца (90 дней) DBGOBOTTOM();mDate2 = Date mDate1 = DTOC(CTOD(mDate2) - 90) CASE nRadio1 = 6 // задать даты вручную DBGOTOP() ;mDate1 = Date DBGOBOTTOM();mDate2 = Date ENDCASE * MsgBox(mDate1) mDate1 = SUBSTR(mDate1, 1, 6)+'20'+SUBSTR(mDate1, 9, 2) @0,0 DCGROUP oGroup69 CAPTION L('Задайте диапазон дат:') SIZE 37.0, 3.5 @1,2 DCSAY L("Начальная дата:") GET mDate1 PICTURE "##.##.####" PARENT oGroup69 @2,2 DCSAY L("Конечная дата:") GET mDate2 PICTURE "##.##.####" PARENT oGroup69 DCREAD GUI; TO lExit ; FIT; ADDBUTTONS; MODAL; TITLE L('6.9. Просмотр запусков системы "Эйдос"') IF lExit ** Button Ok ELSE * ADS_SERVER_QUIT() QUIT ENDIF ******************************************************************** IF mN_Visits > 0 // Отображать все уникальные IP, если с них запускали систему не менее, чем mN_Visits раз oScrn2 := DC_WaitOn( L('Подсчет количества запусков системы "Эйдос" с разных IP-адресов за период:')+' '+mDate1+'-'+mDate2,,,,,,,,,,,.F.) ***** Создать и записать БД Visitors.DBF *aaStructure := { { "Num" , "N", 7 , 0 }, ; // 0 * { "Date" , "C", aLenF[ 1], 0 }, ; // 1 * { "Time" , "C", aLenF[ 2], 0 }, ; // 2 * { "IP_address", "C", aLenF[ 3], 0 }, ; // 3 * { "Domain" , "C", aLenF[ 4], 0 }, ; // 4 * { "Country" , "C", aLenF[ 5], 0 }, ; // 5 * { "Okrug" , "C", aLenF[ 6], 0 }, ; // 6 * { "Region" , "C", aLenF[ 7], 0 }, ; // 7 * { "City" , "C", aLenF[ 8], 0 }, ; // 8 * { "Postcode" , "C", aLenF[ 9], 0 }, ; // 9 * { "Timezone" , "C", aLenF[10], 0 }, ; // 10 // В новой строке его нет * { "Latitude" , "N", 12, 4 }, ; // 11 * { "Longitude" , "N", 12, 4 }, ; // 12 * { "GeonameId" , "N", 12, 0 }, ; // 13 * { "NIPaddress", "N", 12, 0 } } // 14 // Число встреч IP-адреса при сортировке по IP *DbCreate( 'Visitors', aStructure ) SELECT Visitors * SET FILTER TO CTOD(mDate1) <= CTOD(Date) .AND. CTOD(Date) <= CTOD(mDate2) .AND. LATITUDE * LONGITUDE <> 0 // VPN скрывает координаты (обнуляет), из-за чего возникает ошибка в Яндекс-картах SET FILTER TO CTOD(mDate1) <= CTOD(Date) .AND. CTOD(Date) <= CTOD(mDate2) // VPN скрывает координаты (обнуляет), из-за чего возникает ошибка в Яндекс-картах SET ORDER TO // Без сортировки ***** Посчитать сколько раз в БД Visitors встречается каждый IP-адрес aIP := {} // Массив уникальных IP-адресов для отображения aNIP := {} // Массив числа встреч IP-адресов DBGOTOP() DO WHILE .NOT. EOF() REPLACE NIPaddress WITH 0 // Число встреч IP-адреса при сортировке по IP mIP = IP_ADDRESS+DOMAIN+COUNTRY+OKRUG+REGION+CITY+POSTCODE+TIMEZONE+STR(LATITUDE,12,4)+STR(LONGITUDE,12,4)+STR(GEONAMEID,12,0) IF ASCAN(aIP, mIP) = 0 // Обеспечивает чтобы каждый IP-адрес встречался в массиве только 1 раз AADD( aIP, mIP) AADD(aNIP, 0) ENDIF DBSKIP(1) ENDDO SET ORDER TO // Без сортировки DBGOTOP() DO WHILE .NOT. EOF() mIP = IP_ADDRESS+DOMAIN+COUNTRY+OKRUG+REGION+CITY+POSTCODE+TIMEZONE+STR(LATITUDE,12,4)+STR(LONGITUDE,12,4)+STR(GEONAMEID,12,0) mPos = ASCAN(aIP, mIP) IF mPos > 0 aNIP[mPos] = aNIP[mPos] + 1 ENDIF DBSKIP(1) ENDDO DBGOTOP() DO WHILE .NOT. EOF() mIP = IP_ADDRESS+DOMAIN+COUNTRY+OKRUG+REGION+CITY+POSTCODE+TIMEZONE+STR(LATITUDE,12,4)+STR(LONGITUDE,12,4)+STR(GEONAMEID,12,0) mPos = ASCAN(aIP, mIP) IF mPos > 0 REPLACE NIPaddress WITH aNIP[mPos] // Число встреч IP-адреса в БД посещений ENDIF DBSKIP(1) ENDDO DC_Impl(oScrn2) ENDIF *** Если в заданном диапазоне дат есть посещения, то из 'Visitors.DBF' *** сформировать базу данных: 'map#_strings.txt' для отображения и записать ее на сайт по FTP *** Аналогично сделать и по картам с метками без надписей и с надписями ПО УНИКАЛЬНЫМ IP-АДРЕСАМ ############################# SELECT Visitors * SET FILTER TO NIPADDRESS >= mN_Visits .AND. (CTOD(mDate1) <= CTOD(Date) .AND. CTOD(Date) <= CTOD(mDate2)) .AND. LATITUDE * LONGITUDE <> 0 // VPN скрывает координаты (обнуляет), из-за чего возникает ошибка в Яндекс-картах SET FILTER TO NIPADDRESS >= mN_Visits .AND. (CTOD(mDate1) <= CTOD(Date) .AND. CTOD(Date) <= CTOD(mDate2)) // VPN скрывает координаты (обнуляет), из-за чего возникает ошибка в Яндекс-картах COUNT TO N_Visits IF N_Visits = 0 aMess := {} AADD(aMess, L('За период с:')+' '+mDate1+' '+L('по:')+' '+mDate2+' '+L('не было запусков системы "Эйдос-Х"')) AADD(aMess, L('на компьютерах, с разными IP-адресами, более чем:')+' '+ALLTRIM(STR(mN_Visits))+' '+L('раз')) LB_Warning(aMess, L('(C) Система "Эйдос-Х++"')) SET FILTER TO * SET FILTER TO LATITUDE * LONGITUDE <> 0 // VPN скрывает координаты (обнуляет), из-за чего возникает ошибка в Яндекс-картах SET ORDER TO DBGOTOP() RETURN NIL ENDIF **** Формирование текстового файла с заданными параметрами для WEB-сервера и запись его на WEB-сервер по FTP с нужным именем oScrn2 := DC_WaitOn( L('Подготовка БД: "map2_strings.txt" с информацией о запусках системы "Эйдос-Х++" для записи на FTP-сервер'),,,,,,,,,,,.F.) mABC = '' DBGOTOP() DO WHILE .NOT. EOF() FOR j=2 TO 14 mVal = FIELDGET(j) DO CASE CASE VALTYPE(mVal) = 'C' mABC = mABC + mVal + IF(j<14,',','') CASE VALTYPE(mVal) = 'N' mABC = mABC + STR(mVal,12,IF(j<14,4,0)) + IF(j<14,',','') ENDCASE NEXT mABC = mABC + CrLf DBSKIP(1) ENDDO DC_Impl(oScrn2) ENDIF * Unique IP без надписей, задается число посещений Visual69(3) * Unique IP с надписями, задается число посещений Visual69(4) IF Par = 3 .OR. Par = 4 // Unique IP без надписей, Unique IP с надписями, задается число посещений IF mN_Visits > 0 // Отображать все уникальные IP, независимо от числа посещений oScrn2 := DC_WaitOn( L('Поиск уникальных IP-адресов с которых было не менее:')+' '+ALLTRIM(STR(mN_Visits))+' '+L('запусков системы "Эйдос"'),,,,,,,,,,,.F.) * SET FILTER TO NIPADDRESS >= mN_Visits .AND. LATITUDE * LONGITUDE <> 0 // VPN скрывает координаты (обнуляет), из-за чего возникает ошибка в Яндекс-картах SET FILTER TO NIPADDRESS >= mN_Visits // VPN скрывает координаты (обнуляет), из-за чего возникает ошибка в Яндекс-картах DBGOTOP();DBGOBOTTOM();DBGOTOP() ELSE oScrn2 := DC_WaitOn( L('Поиск уникальных IP-адресов, c которых запускалась система "Эйдос"'),,,,,,,,,,,.F.) SET FILTER TO * SET FILTER TO LATITUDE * LONGITUDE <> 0 // VPN скрывает координаты (обнуляет), из-за чего возникает ошибка в Яндекс-картах DBGOTOP();DBGOBOTTOM();DBGOTOP() ENDIF INDEX ON IP_ADDRESS+DOMAIN+COUNTRY+OKRUG+REGION+CITY+POSTCODE+TIMEZONE+STR(LATITUDE,12,4)+STR(LONGITUDE,12,4)+STR(GEONAMEID,12,0) TO Sort69 UNIQUE // Сортировка по уникальным IP-адресам mABC = '' DBGOTOP() DO WHILE .NOT. EOF() FOR j=2 TO 14 mVal = FIELDGET(j) DO CASE CASE VALTYPE(mVal) = 'C' mABC = mABC + mVal + IF(j<14,',','') CASE VALTYPE(mVal) = 'N' mABC = mABC + STR(mVal,12,IF(j<14,4,0)) + IF(j<14,',','') ENDCASE NEXT mABC = mABC + CrLf DBSKIP(1) ENDDO DC_Impl(oScrn2) ENDIF DO CASE CASE Par = 2 // Метки без надписей IF LEN(mABC) = 0 aMess := {} AADD(aMess, L('не было запусков системы "Эйдос-Х" на компьютерах,')) AADD(aMess, L('с разными IP-адресами, более чем:')+' '+ALLTRIM(STR(mN_Visits))+' '+L('раз')) LB_Warning(aMess, L('(C) Система "Эйдос-Х++"')) SELECT Visitors SET ORDER TO // Без сортировки SET FILTER TO * SET FILTER TO LATITUDE * LONGITUDE <> 0 // VPN скрывает координаты (обнуляет), из-за чего возникает ошибка в Яндекс-картах DBGOTOP() RETURN NIL ENDIF StrFile(mABC, 'map2_strings.txt') // Запись текстового файла для картографической визуализации в папку с системой CASE Par = 3 // Метки без надписей IF LEN(mABC) = 0 aMess := {} AADD(aMess, L('не было запусков системы "Эйдос-Х" на компьютерах,')) AADD(aMess, L('с разными IP-адресами, более чем:')+' '+ALLTRIM(STR(mN_Visits))+' '+L('раз')) LB_Warning(aMess, L('(C) Система "Эйдос-Х++"')) SELECT Visitors SET ORDER TO SET FILTER TO // Без сортировки * SET FILTER TO LATITUDE * LONGITUDE <> 0 // VPN скрывает координаты (обнуляет), из-за чего возникает ошибка в Яндекс-картах DBGOTOP() RETURN NIL ENDIF StrFile(mABC, 'map3_strings.txt') // Запись текстового файла для картографической визуализации в папку с системой CASE Par = 4 // Метки с надписями IF LEN(mABC) = 0 aMess := {} AADD(aMess, L('не было запусков системы "Эйдос-Х" на компьютерах,')) AADD(aMess, L('с разными IP-адресами, более чем:')+' '+ALLTRIM(STR(mN_Visits))+' '+L('раз')) LB_Warning(aMess, L('(C) Система "Эйдос-Х++"')) SELECT Visitors SET ORDER TO // Без сортировки SET FILTER TO * SET FILTER TO LATITUDE * LONGITUDE <> 0 // VPN скрывает координаты (обнуляет), из-за чего возникает ошибка в Яндекс-картах DBGOTOP() RETURN NIL ENDIF StrFile(mABC, 'map4_strings.txt') // Запись текстового файла для картографической визуализации в папку с системой ENDCASE ******* Записать БД 'map_strings.txt' по FTP на сайт: http://lc.kubagro.ru ********************************************************************************************************** Xb2NetKey() cFtpServer:="94.25.18.114" // Это везде одинаково <<<===############ oFtp := FTPClient():new( cFtpServer, Ftp_User, Ftp_Passw ) // Соединение с моим сайтом и авторизация IF oFtp:connect() // Есть соединение с моим сайтом и авторизация? ********************************************************************************************************** **** Сделать текущей папку: ftp://lc.kubagro.ru/public_html * MsgBox(oFtp:curDir()) oFtp:curDir("/") oFtp:curDir("public_html") * MsgBox(oFtp:curDir()) IF oFtp:CurDir() <> "\public_html" DC_Impl(oScrn2) LB_Warning(L('Не удалось сделать текущей директорию: "\public_html"'), L('(C) Система "Эйдос-Х++"' )) RETURN NIL ENDIF DO CASE CASE Par = 2 // Метки без надписей oScrn := DC_WaitOn( L('Запись на FTP-сервер БД: "map2_strings.txt" с информацией о запусках системы "Эйдос-Х++"' ),,,,,,,,,,,.F.) IF oFtp:PutFile("map2_strings.txt", "map2_strings.txt") DC_Impl(oScrn) * LB_Warning(L('Запись базы данных: "map2_strings.txt" на FTP-сервер завершена успешно', '(C) Система "Эйдос-Х++"' )) ENDIF CASE Par = 3 // Метки без надписей oScrn := DC_WaitOn( L('Запись на FTP-сервер БД: "map3_strings.txt" с информацией о запусках системы "Эйдос-Х++"' ),,,,,,,,,,,.F.) IF oFtp:PutFile("map3_strings.txt", "map3_strings.txt") DC_Impl(oScrn) * LB_Warning(L('Запись базы данных: "map3_strings.txt" на FTP-сервер завершена успешно', '(C) Система "Эйдос-Х++"' )) ENDIF CASE Par = 4 // Метки с надписями oScrn := DC_WaitOn( L('Запись на FTP-сервер БД: "map4_strings.txt" с информацией о запусках системы "Эйдос-Х++"' ),,,,,,,,,,,.F.) IF oFtp:PutFile("map4_strings.txt", "map4_strings.txt") DC_Impl(oScrn) * LB_Warning(L('Запись базы данных: "map4_strings.txt" на FTP-сервер завершена успешно', '(C) Система "Эйдос-Х++"' )) ENDIF ENDCASE ELSE DC_Impl(oScrn) LB_Warning(L('Нет соединения с FTP-сервером'), L('(C) Система "Эйдос-Х++"')) RETURN NIL ENDIF ******* Запустить само картографическое отображение http://lc.kubagro.ru/map#.php mAddress = '' * LC_RunUrl(mUrl) DO CASE CASE Par = 2 // Диапазон дат с текстовыми метками * LC_RunUrl( 'http://lc.kubagro.ru/map2.php' ) LC_RunUrl( 'http://lc.kubagro.ru/map2cl.php' ) mAddress = 'http://lc.kubagro.ru/map2cl.php' CASE Par = 3 // Метки без надписей LC_RunUrl( 'http://lc.kubagro.ru/map3.php' ) mAddress = 'http://lc.kubagro.ru/map3.php' CASE Par = 4 // Метки с надписями LC_RunUrl( 'http://lc.kubagro.ru/map4.php' ) mAddress = 'http://lc.kubagro.ru/map4.php' CASE Par = 5 // Метки с надписями LC_RunUrl( 'http://lc.kubagro.ru/map5.php' ) mAddress = 'http://lc.kubagro.ru/map5.php' ENDCASE **************** Определение и отображение числа запусков системы по IP-адресам, доменам, странам, округам, регионам и городам oScrn := DC_WaitOn( L('Определение числа запусков системы "Эйдос" по IP-адресам, доменам, странам, округам, регионам и городам' ),,,,,,,,,,,.F.) *aStructure := { { "Num" , "N", 7 , 0 }, ; // 0 * { "Date" , "C", aLenF[ 1], 0 }, ; // 1 * { "Time" , "C", aLenF[ 2], 0 }, ; // 2 * { "IP_address", "C", aLenF[ 3], 0 }, ; // 3 * { "Domain" , "C", aLenF[ 4], 0 }, ; // 4 * { "Country" , "C", aLenF[ 5], 0 }, ; // 5 * { "Okrug" , "C", aLenF[ 6], 0 }, ; // 6 * { "Region" , "C", aLenF[ 7], 0 }, ; // 7 * { "City" , "C", aLenF[ 8], 0 }, ; // 8 * { "Postcode" , "C", aLenF[ 9], 0 }, ; // 9 * { "Timezone" , "C", aLenF[10], 0 }, ; // 10 // В новой строке его нет * { "Latitude" , "N", 12, 4 }, ; // 11 * { "Longitude" , "N", 12, 4 }, ; // 12 * { "GeonameId" , "N", 12, 0 }, ; // 13 * { "NIPaddress", "N", 12, 0 } } // 14 // Число встреч IP-адреса при сортировке по IP *DbCreate( 'Visitors', aStructure ) DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE WorldCities INDEX WorldCities EXCLUSIVE NEW USE Visitors EXCLUSIVE NEW SELECT Visitors * SET ORDER TO // Без сортировки SET FILTER TO SET FILTER TO NIPADDRESS >= mN_Visits .AND. (CTOD(mDate1) <= CTOD(Date) .AND. CTOD(Date) <= CTOD(mDate2)) DBGOTOP();DBGOBOTTOM();DBGOTOP() aNVisits := {} aIPaddress := {} aDomain := {} aCountry := {} aOkrug := {} aRegion := {} aCity := {} DBGOTOP() DO WHILE .NOT. EOF() IF ASCAN(aNVisits , Num ) = 0;AADD(aNVisits , Num );ENDIF IF ASCAN(aIPaddress, IP_ADDRESS) = 0;AADD(aIPaddress, IP_ADDRESS);ENDIF IF ASCAN(aDomain , DOMAIN ) = 0;AADD(aDomain , DOMAIN );ENDIF IF ASCAN(aCountry , COUNTRY ) = 0;AADD(aCountry , COUNTRY );ENDIF IF ASCAN(aOkrug , OKRUG ) = 0;AADD(aOkrug , OKRUG );ENDIF IF ASCAN(aRegion , REGION ) = 0;AADD(aRegion , REGION );ENDIF IF ASCAN(aCity , CITY ) = 0;AADD(aCity , CITY );ENDIF DBSKIP(1) ENDDO mN_Visits = IF(mN_Visits=0,1,mN_Visits) aMess := {} AADD(aMess, L('За период с:')+' '+mDate1+' '+L('по:')+' '+mDate2) AADD(aMess, L('система "Эйдос-Х" запускалась не менее:')+' '+ALLTRIM(STR(mN_Visits))+' '+L('раз')) AADD(aMess, L('на каждом из:')+' '+ALLTRIM(STR(LEN(aNVisits)))+' '+L('компьютеров, подключенных к Internet')) AADD(aMess, L('В том числе:')) AADD(aMess, L('- с разных IP-адресов:_')+'___'+ALLTRIM(STR(LEN(aIPaddress)))) AADD(aMess, L('- с разных доменов:____')+'___'+ALLTRIM(STR(LEN(aDomain )))) AADD(aMess, L('- из разных стран: ____')+'____'+ALLTRIM(STR(LEN(aCountry )))) AADD(aMess, L('- из разных округов:___')+'___'+ALLTRIM(STR(LEN(aOkrug )))) AADD(aMess, L('- из разных регионов:__')+'___'+ALLTRIM(STR(LEN(aRegion )))) AADD(aMess, L('- из разных городов:___')+'___'+ALLTRIM(STR(LEN(aCity )))) AADD(aMess, L('')) AADD(aMess, L('Если картографическая визуализация не появилась,')) AADD(aMess, L('то поставьте курсор в строку адреса браузера ')) AADD(aMess, L('и нажмите Ctrl+V или вручную наберите адрес: ')) AADD(aMess, mAddress) ***** Поместить адрес запуска картографической визуализации в буфер обмена cText := mAddress oClipBoard := XbpClipboard():new():create() oClipBoard:open() oClipboard:clear() oClipBoard:setBuffer(cText,XBPCLPBRD_TEXT) oClipBoard:close() oClipBoard:destroy() DC_Impl(oScrn) LB_Warning(aMess, L('(C) Система "Эйдос-Х++"')) SELECT Visitors SET ORDER TO // Без сортировки SET FILTER TO DBGOTOP() ReTURN nil ******************************************************************************************** ******************************************************************************************** ******** Загрузить приложение из облака (сходно с ЛР 3-го типа, но Inp_data.xls, 2_3_2_2.arx ******** Тип приложения: 2.3.2.1, 2.3.2.2 или 2.3.2.3 (в т.ч. графика, 2.3.2.5) ******************************************************************************************** FUNCTION LoadAppCloud() LOCAL GetList := {}, aPres, oBrowse, oToolBar, aColors, bColor, GetOptions, oEventsKO, bItems, n:=0 Local oHttp, oResponse, cColorm, bColorSize, bColorDate PUBLIC mNumbAppl := 0 *** АЛГОРИТМ: ************************************************************************** *** 1. Проверить, есть ли на компьютере Internet (http-доступ), и выдать сообщение, если его нет, о том, что он необходим для работы режима, и выйти *** 2. Если на моем FTP-сервере есть каталог WEB-приложений, то скачать его и записать в виде файла в папку с системой, иначе - сообщение и выход *** 3. Выбрать приложение, поставив курсор на нужную строку и кликнув по кнопке: "Загрузить приложение" *** 4. Определить тип приложения: 2.3.2.1, 2.3.2.2 или 2.3.2.3 (в т.ч. графика, 2.3.2.5) *** Скачать файл Inp_data в папку Inp_data, а 2_3_2_#.arx в папку с системой запустить режим 2.3.2.#. *** РЕАЛИЗАЦИЯ АЛГОРИТМА *************************************************************** *** 1. Проверить, есть ли на компьютере Internet (ftp-доступ), и выдать сообщение, если его нет, о том, что он необходим для работы режима, и выйти n=0 IF InternetGetConnectedState( @n, 0 ) == 0 LB_Warning(L('Нет соединения с Internet, что необходимо для данного режима!'), L('Загрузка приложения системы "Эйдос-Х++" из облака' )) RETURN NIL ENDIF DIRCHANGE(Disk_dir) // Перейти в папку с системой *** 2. Если на моем web-сервере есть каталог WEB-приложений, то скачать его и записать в виде файла в папку с системой, * ***** Получить файл "WebAppls.dbf", используя только HTTP (GetWeb.prg, Boris Borzic) * oHttp := xbHTTPClient():new() * oHttp:Transport := VIA_WININET * oResponse := oHttp:Execute( 'http://lc.kubagro.ru/Source_data_applications/WebAppls.dbf' ) * mABC = oResponse:Content oScrn := DC_WaitOn( L('Загрузка каталога WEB-приложений "WebAppls.dbf" с FTP-сервера системы "Эйдос-Х++"' ),,,,,,,,,,,.F.) mFlagLoad = .F. // .F. - база WebAppls.dbf не скачалась ********************************************************************************************************** Xb2NetKey() cFtpServer:="94.25.18.114" // Это везде одинаково <<<===############ oFtp := FTPClient():new( cFtpServer, Ftp_User, Ftp_Passw ) // Соединение с моим сайтом и авторизация IF oFtp:connect() // Есть соединение с моим сайтом и авторизация? ********************************************************************************************************** **** Создать папку: ftp://94.25.18.114/Source_data_applications (если ее еще нет) **** Сделать текущей папку: ftp://94.25.18.114/public_htmlSource_data_applications * MsgBox(oFtp:curDir()) //<<<===############### oFtp:CurDir("/") oFtp:curDir("public_html") oFtp:curDir("Source_data_applications") * aDirSite := oFtp:Directory("*.*","D") //<<<===############### * DC_DebugQout( aDirSite ) //<<<===############### * MsgBox(oFtp:curDir()) //<<<===############### IF oFtp:curDir() <> "\public_html\Source_data_applications" DC_Impl(oScrn) LB_Warning(L('Не удалось сделать текущей директорию: "\public_html\Source_data_applications"'), L('(C) Система "Эйдос-Х++"' )) RETURN NIL ENDIF IF oFtp:GetFile("WebAppls.dbf") DC_Impl(oScrn) * LB_Warning(L('Загрузка каталога WEB-приложений: "WebAppls.dbf" с FTP-сервера завершена успешно', '(C) Система "Эйдос-Х++"' )) mFlagLoad = .T. // .T. - база WebAppls.dbf скачалась ENDIF ELSE DC_Impl(oScrn) LB_Warning(L('Нет соединения с FTP-сервером'), L('(C) Система "Эйдос-Х++"')) oFtp:disconnect() RETURN NIL ENDIF DC_Impl(oScrn) * MsgBox('STOP') * QUIT ** Если БД "WebAppls.dbf" нет на WEB-сервере, то ** - если в директории Source_data_applications ЕСТЬ файлы вида: WebAppls_30.05.2017-22_17_43.DBF, ** то каталог занят, надо повторить попытку через несколько минут ** - если в директории Source_data_applications НЕТ файлов вида: WebAppls_30.05.2017-22_17_43.DBF, ** то каталог надо создать, записав в облако хотя бы одно приложение IF .NOT. mFlagLoad // БД "WebAppls.dbf" нет на WEB-сервере ****** Определить, если в папке Source_data_applications файлы вида: WebAppls_30.05.2017-22_17_43.DBF ****** Просмотр массива директории с FTP-сервера от Роджера PUBLIC aDir := oFtp:Directory() // Борис Борзик, для этого нужен только FTP, т.к. под HTTP не работает oHttp:Directory() mFlagBe = .F. FOR i := 1 TO Len(aDir) IF AT("_", aDir[i]) > 0 mFlagBe = .T. EXIT ENDIF NEXT aMess := {} IF mFlagBe // в директории Source_data_applications есть файлы вида: WebAppls_30.05.2017-22_17_43.DBF, // каталог занят, надо повторить попытку через несколько минут AADD(aMess, L('В данный момент каталог WEB-приложений на FTP-сервере системы "Эйдос" занят.')) AADD(aMess, L('Немного подождите и повторите попытку загрузки приложения из облака еще раз.')) ELSE // в директории Source_data_applications нет файлов вида: WebAppls_30.05.2017-22_17_43.DBF, // каталог надо создать, записав в облако хотя бы одно приложение AADD(aMess, L('WEB-приложения на FTP-сервере системы "Эйдос" отсутствуют.')) AADD(aMess, L('Чтобы они там появились надо записать в облако приложение.')) ENDIF LB_Warning(aMess, L('(c) Система "ЭЙДОС-X++"')) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) ReTURN nil ENDIF oFtp:disconnect() ******* Отображение БД ******* * StrFile(mABC,'WebAppls.dbf') // Записать WebAppls.dbf в виде файла на диск в папку с системой CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций IF .NOT. FILE("WebAppls.dbf") aMess := {} AADD(aMess, L('Не удалось скачать с FTP-сервера системы "Эйдос" каталог')) AADD(aMess, L('интеллектуальных облачных Эйдос-приложений: "WebAppls.dbf"')) LB_Warning(aMess, L('(C) Система "Эйдос-Х++"' )) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) ReTURN nil ENDIF IF FILESIZE("WebAppls.dbf") = 0 aMess := {} AADD(aMess, L('Размер скачанного с FTP-сервера системы "Эйдос" каталога')) AADD(aMess, L('интеллектуальных облачных Эйдос-приложений: "WebAppls.dbf"')) AADD(aMess, L('равен 0. Обратитесь к автору и разработчику системы "Эйдос"')) LB_Warning(aMess, L('(C) Система "Эйдос-Х++"' )) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) ReTURN nil ENDIF USE WebAppls EXCLUSIVE NEW SELECT WebAppls DBGOTO(RECCOUNT()-15) /* ----- Create ToolBar ----- */ mStr1 = L('Помощь' ) mStr2 = L('Сайт проф.Е.В.Луценко' ) mStr3 = L('Группа по АСК-анализу и системе "Эйдос"' ) mStr4 = L('Сообщество разработчиков Эйдоc-приложений') mStr5 = L('Форум Роджера Доннея' ) mStr6 = L('Немецкий форум' ) mStr7 = L('Установка Эйдос-приложения' ) mStr8 = L('Каталог обсуждений' ) mStr9 = L('Обсуждение Эйдос-приложения' ) d = 2 @36.5, 0 DCPUSHBUTTON CAPTION mStr1 SIZE LEN(mStr1)+3, 1.5 ACTION {||Help13web(), DC_GetRefresh(GetList)} @36.5, DCGUI_COL+d DCPUSHBUTTON CAPTION mStr2 SIZE LEN(mStr2)-1, 1.5 ACTION {||LC_RunUrl("http://lc.kubagro.ru/")} @36.5, DCGUI_COL+d DCPUSHBUTTON CAPTION mStr3 SIZE LEN(mStr3)-5, 1.5 ACTION {||LC_RunUrl("https://www.researchgate.net/profile/Eugene_Lutsenko")} @36.5, DCGUI_COL+d DCPUSHBUTTON CAPTION mStr4 SIZE LEN(mStr4)-3, 1.5 ACTION {||LC_RunUrl('http://lc.kubagro.ru/map5.php')} @36.5, DCGUI_COL+d DCPUSHBUTTON CAPTION mStr5 SIZE LEN(mStr5)+1, 1.5 ACTION {||LC_RunUrl('http://bb.donnay-software.com/donnay/viewforum.php?f=2')} @36.5, DCGUI_COL+d DCPUSHBUTTON CAPTION mStr6 SIZE LEN(mStr6)+1, 1.5 ACTION {||LC_RunUrl('https://www.xbaseforum.de')} @36.5, DCGUI_COL+d DCPUSHBUTTON CAPTION mStr7 SIZE LEN(mStr7)+3, 1.5 ACTION {||InstallWebAppl(VAL(ALLTRIM(WebAppls->Num_Appl)), ALLTRIM(WebAppls->Appl_Name)), DC_GetRefresh(GetList)} FONT '9.Arial Bold' @36.5, DCGUI_COL+d DCPUSHBUTTON CAPTION mStr8 SIZE LEN(mStr8)+1, 1.5 ACTION {||DiscCatalog(0,'',''), DC_GetRefresh(GetList)} @36.5, DCGUI_COL+d DCPUSHBUTTON CAPTION mStr9 SIZE LEN(mStr9)+0, 1.5 ACTION {||DiscAppl (VAL(ALLTRIM(WebAppls->Num_Appl)), ALLTRIM(WebAppls->Appl_Name)), DC_GetRefresh(GetList)} // <<<===################### ****** Отображение таблицы *************** SELECT WebAppls DBGOTO(RECCOUNT()-15) DCSETPARENT TO @ 1, 0 DCBROWSE WebAppls ALIAS 'WebAppls' SIZE 215,35 ; EDIT xbeBRW_ItemSelected MODE DCGUI_BROWSE_EDITDOWN ; // Редактирование БД NOSOFTTRACK ; HEADLINES 2 ; // Кол-во строк в заголовке (перенос строки - ";") SCOPE ; ITEMSELECTED {|| LC_RunUrl(WebAppls->E_mail) } * ITEMMARKED bItems * COLOR {||IIF(VAL(Num_Appl)=10,{nil,aColor[107]},{nil,GRA_CLR_WHITE})} * EVAL {||WebAppls:setRowHeight(35)} DCSETPARENT WebAppls *** Подарок от Роджера * aStructure := { { "Num_Appl" , "C", 5, 0 }, ; // 1 * { "Appl_Type" , "C", 30, 0 }, ; // 2 * { "Appl_Name" , "C",250, 0 }, ; // 3 * { "Authors" , "C",120, 0 }, ; // 4 * { "Country" , "C", 30, 0 }, ; // 5 * { "Region" , "C", 50, 0 }, ; // 6 * { "City" , "C", 30, 0 }, ; // 7 * { "Firm" , "C", 30, 0 }, ; // 8 * { "E_mail" , "C",130, 0 }, ; // 9 * { "Date" , "C", 10, 0 }, ; // 10 * { "Time" , "C", 8, 0 } } // 11 DCBROWSECOL FIELD WebAppls->Num_Appl HEADER L("Номер;приложения" ) PARENT WebAppls FONT "9.Courier" WIDTH 8 PROTECT {|| .T. } DCBROWSECOL FIELD WebAppls->Appl_Type HEADER L("Тип приложения" ) PARENT WebAppls FONT "9.Courier" WIDTH 14 PROTECT {|| .T. } DCBROWSECOL FIELD WebAppls->Appl_Name HEADER L("Наименование приложения") PARENT WebAppls FONT "9.Courier" WIDTH 150 PROTECT {|| .T. } COLOR {||{nil,aColor[153]}} DCBROWSECOL FIELD WebAppls->Authors HEADER L("Авторы приложения" ) PARENT WebAppls FONT "9.Courier" WIDTH 45 PROTECT {|| .T. } DCBROWSECOL FIELD WebAppls->Country HEADER L("Страна" ) PARENT WebAppls FONT "9.Courier" WIDTH 15 PROTECT {|| .T. } DCBROWSECOL FIELD WebAppls->Region HEADER L("Регион" ) PARENT WebAppls FONT "9.Courier" WIDTH 20 PROTECT {|| .T. } DCBROWSECOL FIELD WebAppls->City HEADER L("Город" ) PARENT WebAppls FONT "9.Courier" WIDTH 15 PROTECT {|| .T. } DCBROWSECOL FIELD WebAppls->Firm HEADER L("Фирма" ) PARENT WebAppls FONT "9.Courier" WIDTH 20 PROTECT {|| .T. } DCBROWSECOL FIELD WebAppls->E_mail HEADER L("Гиперссылка;E-mail" ) PARENT WebAppls FONT "9.Courier" WIDTH 20 PROTECT {|| .T. } COLOR {||{nil,aColor[33]}} DCBROWSECOL FIELD WebAppls->Date HEADER L("Дата;ДД.ММ.ГГГГ" ) PARENT WebAppls FONT "9.Courier" WIDTH 11 PROTECT {|| .T. } DCBROWSECOL FIELD WebAppls->Time HEADER L("Время;ЧЧ:ММ:СС" ) PARENT WebAppls FONT "9.Courier" WIDTH 8 PROTECT {|| .T. } DCGETOPTIONS SAYFONT '10.Helv Bold' TABSTOP AUTORESIZE DCREAD GUI ; FIT ; OPTIONS GetOptions ; MODAL ; TITLE L('Скачивание Эйдос-приложения с WEB-сервера системы "Эйдос-Х++"') ; EVAL {|o|SetAppFocus(WebAppls:GetColumn(1))} ***** Возврат в 1.3 ******** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE USERS INDEX ON Kod_AdmApp TO USERS CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Appls EXCLUSIVE NEW INDEX ON Kod_AdmApp TO APPLS USE USERS INDEX USERS EXCLUSIVE SELECT Users DO CASE CASE Flag_SysAdmin = .T. SET FILTER TO // Сисадмин видит все CASE Flag_AdmAppl = .T. SET FILTER TO Kod_AdmApp = M_KodAdmAppls // Адм.прил. и пользователь CASE Flag_User = .T. // Видят только свои приложения SET FILTER TO Kod_AdmApp = M_KodAdmAppls OTHERWISE LB_Warning(L("Этот режим доступен только после авторизации в режиме 1.1 !!!")) RETURN NIL ENDCASE *DBGOTOP();DBGOBOTTOM();DBGOTOP() USE APPLS INDEX APPLS EXCLUSIVE NEW SELECT Appls DO CASE CASE Flag_SysAdmin = .T. SET FILTER TO // Сисадмин видит и может все CASE Flag_AdmAppl = .T. SET FILTER TO Kod_AdmApp = M_KodAdmAppls // Адм.приложения и пользователь CASE Flag_User = .T. // Видят только свои приложения SET FILTER TO Kod_AdmApp = M_KodAdmAppls OTHERWISE LB_Warning(L("Этот режим доступен только после авторизации в режиме 1.1 !!!")) RETURN NIL ENDCASE *DBGOTOP();DBGOBOTTOM();DBGOTOP() RETURN NIL ************************************************************************************************ ******** Просмотр каталога обсуждений ************************************************************************************************ FUNCTION DiscCatalog(mNumAppl, mNameAppl, mPar) LOCAL cText, GetList[0], GetOptions, nWidth, cFont, cOutString, oMemo, oButton ***** 1. Скачать файл обсуждения 'DiscAppl.txt' по FTP с облака, если он там есть, ***** 2. а если нет - то создать локально здесь и показать без возможности редактирования, ***** 3. Если каталог обсуждений был создан - то записать его в облако в папку приложений ***** cOutString = Disk_dir+'\AID_DATA\Inp_data\DiscCatalog.txt' ***** 4. Если mNumAppl = 0, то не менять каталог обсуждений, ***** Если mNumAppl > 0, то дополнить каталог обсуждений строкой с датой и временем обсуждения данного приложения CrLf = CHR(13)+CHR(10) // Конец строки (записи) mFlagError = .F. ***** 1. Скачать файл каталога обсуждений 'DiscCatalog.txt' по FTP с облака, если он там есть, oScrn := DC_WaitOn( L('Скачать из облака файл каталога обсуждений Эйдос-приложений: "DiscCatalog"' ),,,,,,,,,,,.F.) ********************************************************************************************************** Xb2NetKey() cFtpServer:="94.25.18.114" // Это везде одинаково <<<===############ oFtp := FTPClient():new( cFtpServer, Ftp_User, Ftp_Passw ) // Соединение с моим сайтом и авторизация IF oFtp:connect() // Есть соединение с моим сайтом и авторизация? ********************************************************************************************************** **** Сделать текущей папку приложений: ftp://lc.kubagro.ru/public_html/Source_data_applications/' * MsgBox(oFtp:curDir()) oFtp:curDir("public_html") oFtp:curDir("Source_data_applications") * MsgBox(oFtp:curDir()) IF oFtp:curDir() <> "\public_html\Source_data_applications" DC_Impl(oScrn) LB_Warning(L('Не удалось сделать текущей директорию: "\public_html\Source_data_applications"'), L('(C) Система "Эйдос-Х++"' )) RETURN NIL ENDIF DIRCHANGE(Disk_dir+"\AID_DATA\Inp_data\") // Перейти в папку Inp_data IF ! oFtp:GetFile('DiscCatalog.txt', 'DiscCatalog.txt' ) LB_Warning(L('Файл каталога обсуждений: "DiscCatalog.txt" в облаке отсутствует и будет создан!'), L('(C) Система "Эйдос-Х++"' )) mFlagError = .T. ENDIF ENDIF DC_Impl(oScrn) ***** 2. а если же его там нет - то создать локально здесь и предоставить для редактирования, а потом записать в облако отредактированный IF mFlagError cOutString = REPLICATE('=',120) + CrLf +; L('Это файл каталога обсуждений Эйдос-приложений: "DiscCatalog.txt"' ) + CrLf +; L('Дата и время создания файла каталога обсуждений: '+DTOC(DATE())+"-"+TIME() ) + CrLf +; L('Чтобы вступить в обсуждение надо в каталоге WEB-приложений поставить курсор') + CrLf +; L('на нужное приложение и кликнуть по кнопке: "Обсуждение Эйдос-приложения"' ) + CrLf +; REPLICATE('=',120) + CrLf StrFile(cOutString, 'DiscCatalog.txt') // Запись файла обсуждения в папку Inp_data ELSE cOutString = ALLTRIM(FILESTR('DiscCatalog.txt')) // Считывание файла обсуждения для просмотра из папки Inp_data ENDIF cFont = Pad('10.Courier',40) nWidth = 900 @2.7, 0 DCMULTILINE cOutString SIZE 150,28 FONT Alltrim(cFont) OBJECT oMemo EDITPROTECT {||.T.} @1.0,50 DCPUSHBUTTON CAPTION L('Форматировать текст') SIZE 25,1.2 ; OBJECT oButton ; ACTION {||cOutString := DC_FormatMemoToWidth(cOutString,nWidth,cFont), ; DC_GetRefresh(GetList), ; oMemo:setFontCompoundName(Alltrim(cFont))} @1.0,115 DCPUSHBUTTON CAPTION L('Помощь по режиму') SIZE 20, 1.2 OBJECT oButton ; ACTION {|| DiscApplHelp() } DCGETOPTIONS SAYWIDTH 180 SAYRIGHTBOTTOM IF mNumAppl = 0 DCREAD GUI ; TITLE L("Каталог обсуждения облачных Эйдос-приложений:"); FIT ; BUTTONS DCGUI_BUTTON_EXIT ENDIF IF mFlagError .OR. mNumAppl > 0 IF mNumAppl > 0 cOutString = cOutString + DTOC(DATE())+"-"+TIME()+' '+mPar+': "'+ALLTRIM(STR(mNumAppl))+'-'+ALLTRIM(mNameAppl)+'"' + CrLf ENDIF * cOutString = ALLTRIM(FILESTR('DiscCatalog.txt')) // Считывание файла обсуждения для просмотра STRFILE(cOutString, 'DiscCatalog.txt') // Запись файла каталога обсуждения на WEB-сервер ***** 3. Если каталог обсуждений был создан или изменен - то записать его в облако в папку приложений, ***** но перед записью нового измененного каталога переименовать старый каталог с тем же именем, но датой и временем изменения oScrn := DC_WaitOn( L('Записать каталог обсуждений Эйдос-приложений: "DiscCatalog.txt" на WEB-сервер системы "Эйдос-Х++"'),,,,,,,,,,,.F.) ********************************************************************************************************** Xb2NetKey() cFtpServer:="94.25.18.114" // Это везде одинаково <<<===############ oFtp := FTPClient():new( cFtpServer, Ftp_User, Ftp_Passw ) // Соединение с моим сайтом и авторизация IF oFtp:connect() // Есть соединение с моим сайтом и авторизация? ********************************************************************************************************** **** Сделать текущей папку приложений: ftp://lc.kubagro.ru/public_html/Source_data_applications/' * MsgBox(oFtp:curDir()) oFtp:curDir("public_html") oFtp:curDir("Source_data_applications") * MsgBox(oFtp:curDir()) IF oFtp:curDir() <> "\public_html\Source_data_applications" DC_Impl(oScrn) LB_Warning(L('Не удалось сделать текущей директорию: "\public_html\Source_data_applications"'), L('(C) Система "Эйдос-Х++"' )) RETURN NIL ENDIF DIRCHANGE(Disk_dir+"\AID_DATA\Inp_data\") // Перейти в папку Inp_data mDateTime = DTOC(DATE())+"-"+TIME() mDateTime = STRTRAN(mDateTime, ":", "_") IF ! oFtp:putFile("DiscCatalog.txt", "DiscCatalog_"+mDateTime+".txt") DC_Impl(oScrn) LB_Warning(L('*** ERROR: Unable to rename file!'), L('(C) Система "Эйдос-Х++"' )) ENDIF IF ! oFtp:PutFile('DiscCatalog.txt', 'DiscCatalog.txt' ) DC_Impl(oScrn) LB_Warning(L('Файл каталога обсуждений: "DiscCatalog.txt" не записан в облако!'), L('(C) Система "Эйдос-Х++"' ) ) mFlagError = .T. ENDIF ENDIF DC_Impl(oScrn) ENDIF DIRCHANGE(Disk_dir) // Перейти в папку Inp_data RETURN NIL ************************************************************************************************ ******** Установка интеллектуального облачного Эйдос-приложения ************************************************************************************************ FUNCTION RowColor(oBrowse,aDirShow) // Цвет фона строки в зависимости от размера и имени файла LOCAL aCol aCol := { nil, nil } // Белый IF aDirShow[oBrowse:arrayElement,3] > 50*1024^2 // File size greater than 50 Mb aCol := { aColor[222], aColor[153] } // Золотой ENDIF IF aDirShow[oBrowse:arrayElement,6] = "BadName" aCol := { aColor[222], aColor[186] } // Розовый ENDIF IF aDirShow[oBrowse:arrayElement,2] = "Суммарный объем (байт)" aCol := { aColor[222], aColor[196] } // Серый ENDIF RETURN aCol ************************************************************************************************ FUNCTION InstallWebAppl(mNumAppl, mNameAppl) LOCAL GetList[0], oBrowse, i, aPres, oToolBar, aColors, bColor, GetOptions * MsgBox(mNameAppl) * IF mNumbAppl > 0 // Когда выходишь из выбора WEB-приложения по Esc, то здесь возникает ошибка ###### нет переменной * oScrn := DC_WaitOn( L('Загрузка приложения: "'+ALLTRIM(WebAppls->Appl_Name)+'" с FTP-сервера' ,,,,,,,,,,,.F.) // <########### + написать загружаемые файлы * mLW = ALLTRIM(WebAppls->Appl_Name) * mRecno = VAL(ALLTRIM(WebAppls->Num_Appl)) * DIRCHANGE(Disk_dir+"\AID_DATA\Inp_data\") // Перейти в папку Inp_data <############### удалить все файлы в папке Inp_data * mApplName = "Applications-"+STRTRAN(STR(VAL(ALLTRIM(WebAppls->Num_Appl)),6),' ','0') * oHttp := xbHTTPClient():new() // Загрузка файлов по HTTP, но это требует знать имена файлов конкретно до загрузки * oHttp:Transport := VIA_WININET // а если использовать FTP, то их можно узнать, какие они есть на WEB-сервере * oResponse := oHttp:Execute( 'http://lc.kubagro.ru/Source_data_applications/'+mApplName+'/Inp_data.xls' ) * mABC = oResponse:Content * IF AT('was not found on this server', mABC) = 0 * StrFile(mABC,'Inp_data.xls') // Записать "Inp_data.xls" в виде файла на диск в папку Inp_data * mDataSource = 'Inp_data.xls' * ELSE * LB_Warning(L('На WEB-сервере системы "Эйдос" нет файла: "Inp_data.xls"', '(c) Система "ЭЙДОС-X++"') * oResponse := oHttp:Execute( 'http://lc.kubagro.ru/Source_data_applications/'+mApplName+'/Inp_data.xlsx' ) * mABC = oResponse:Content * IF AT('was not found on this server', mABC) = 0 * StrFile(mABC,'Inp_data.xlsx') // Записать "Inp_data.xlsx" в виде файла на диск в папку Inp_data * mDataSource = 'Inp_data.xlsx' * ELSE * DC_Impl(oScrn) ** LB_Warning(L('На WEB-сервере системы "Эйдос" нет файла: "Inp_data.xls" (xlsx)', '(c) Система "ЭЙДОС-X++"') * ENDIF * ENDIF * DIRCHANGE(Disk_dir) // Перейти в папку с системой * oResponse := oHttp:Execute( 'http://lc.kubagro.ru/Source_data_applications/'+mApplName+'/_2_3_2_2.arx' ) * mABC = oResponse:Content * IF AT('was not found on this server', mABC) = 0 * StrFile(mABC,'_2_3_2_2.arx') // Записать WebAppls.dbf в виде файла на диск в папку с системой ** LB_Warning(L('Загрузка файла: "_2_3_2_2.arx" с FTP-сервера завершена успешно', '(C) Система "Эйдос-Х++"' ) * ENDIF * DC_Impl(oScrn) ******* Загрузить все файлы из папки приложения с сайта: http://lc.kubagro.ru в папку Inp_data по FTP ************* ***** Узнать, какие файлы есть в папке приложения на FTP-сервере и все их скачать и записать в папку Inp_data * oScrn := DC_WaitOn( L('Загрузка приложения: "'+ALLTRIM(WebAppls->Appl_Name)+'" с FTP-сервера' ,,,,,,,,,,,.F.) // <########### + написать загружаемые файлы mLW = ALLTRIM(WebAppls->Appl_Name) mRecno = VAL(ALLTRIM(WebAppls->Num_Appl)) DIRCHANGE(Disk_dir+"\AID_DATA\Inp_data\") // Перейти в папку Inp_data Zap_InpData() // Удалить все файлы из папки Inp_data mApplName = "Applications-"+STRTRAN(STR(mNumAppl,6),' ','0') ********************************************************************************************************** Xb2NetKey() cFtpServer:="94.25.18.114" // Это везде одинаково <<<===############ oFtp := FTPClient():new( cFtpServer, Ftp_User, Ftp_Passw ) // Соединение с моим сайтом и авторизация IF oFtp:connect() // Есть соединение с моим сайтом и авторизация? ********************************************************************************************************** **** Создать папку: ftp://94.25.18.114/public_html/Source_data_applications (если ее еще нет) **** Сделать текущей папку: ftp://94.25.18.114/public_html/Source_data_applications * MsgBox(oFtp:curDir()) //<<<===############### oFtp:CurDir("/") oFtp:curDir("public_html") oFtp:curDir("Source_data_applications") * aDirSite := oFtp:Directory("*.*","D") //<<<===############### * DC_DebugQout( aDirSite ) //<<<===############### * MsgBox(oFtp:curDir()) //<<<===############### IF oFtp:curDir() <> "\public_html\Source_data_applications" DC_Impl(oScrn) LB_Warning(L('Не удалось сделать текущей директорию: "\public_html\Source_data_applications"'), L('(C) Система "Эйдос-Х++"' )) RETURN NIL ENDIF **** Сделать текущей папку нового приложения: ftp://lc.kubagro.ru/public_html/Source_data_applications/'+mApplName * MsgBox('3. Исходная директория: '+oFtp:curDir()) oFtp:curDir("\public_html\Source_data_applications") oFtp:curDir(mApplName) * MsgBox('3. Должна быть директория: \public_html\Source_data_applications'+mApplName+', а фактически: '+oFtp:curDir()) IF oFtp:curDir() <> '\public_html\Source_data_applications\'+mApplName DC_Impl(oScrn) LB_Warning(L('Не удалось сделать текущей директорию: "\public_html\Source_data_applications\')+mApplName+'"', '(C) Система "Эйдос-Х++"' ) RETURN NIL ENDIF * aFileUpd := oFtp:Directory("Downloads.exe") * DC_DebugQout( aFileUpd[1] ) // Отладка Имя Размер Дата Время * wtf oFtp:Directory("Downloads.exe") // VALUE: {{"Downloads.exe", 10242016, 20201202, "07:57:00", "N", 0, , "00:00:00", , "00:00:00"}} * DC_MsgBox(10,10,aFileUpd[1]) * MsgBox('Имя файла: '+aFileUpd[1,F_NAME]+', размер: '+STR(aFileUpd[1,F_SIZE])+' байт, дата создания: '+DTOC(aFileUpd[1,F_WRITE_DATE])+', время создания: '+aFileUpd[1,F_WRITE_TIME]) * mSizeUpd = aFileUpd[1,F_SIZE] / (1024^2) // Мб * mDateUpd = aFileUpd[1,F_WRITE_DATE] * mTimeUpd = aFileUpd[1,F_WRITE_TIME] PUBLIC aDir := oFtp:Directory() // Борис Борзик, для этого нужен только FTP, т.к. под HTTP не работает oHttp:Directory() * wtf oFtp:Directory() // VALUE: {{"Downloads.exe", 10242016, 20201202, "07:57:00", "N", 0, , "00:00:00", , "00:00:00"}} IF LEN(aDir) > 0 // Если папка в облаке не пустая, т.е. кроме . и .. есть хотя бы один файл **** Просмотр массива директории с FTP-сервера от Роджера mLenMax = LEN(L('Файлы приложения N:')+ALLTRIM(STR(mRecno))+'-"'+ALLTRIM(WebAppls->Appl_Name)+'"') **** Просмотр массива директории от Роджера PRIVATE aDirShow[Len(aDir)+1,6] mSummaSize = 0 mFlag50Mb = .F. mFlagErrName = .F. FOR j := 1 TO Len(aDir) aDirShow[j,1] = ALLTRIM(STR(j)) // File Num * aDirShow[j,2] = aDir[j,1] // File Name aDirShow[j,2] = ConvToOemCP(aDir[j,1]) // File Name aDirShow[j,3] = aDir[j,2] // File Size aDirShow[j,4] = DTOC(aDir[j,3]) // File Date aDirShow[j,5] = aDir[j,4] // File Time mSummaSize = mSummaSize + aDir[j,2] IF aDir[j,2] >= 50*1024^2 // 50 Мб mFlag50Mb = .T. ENDIF NEXT aDirShow[Len(aDir)+1,2] = L('Суммарный объем (байт)') aDirShow[Len(aDir)+1,3] = mSummaSize @ 0,0 DCBROWSE oBrowse DATA aDirShow SIZE 88.5,25 COLOR {||RowColor(oBrowse, aDirShow)} // Управление фоном отображения строки от Роджера DCBROWSECOL ELEMENT 1 HEADER 'File Num ' WIDTH 5 PARENT oBrowse DCBROWSECOL ELEMENT 2 HEADER 'File Name' WIDTH 20 PARENT oBrowse DCBROWSECOL ELEMENT 3 HEADER 'File Size' WIDTH 10 PARENT oBrowse DCBROWSECOL ELEMENT 4 HEADER 'File Date' WIDTH 8 PARENT oBrowse DCBROWSECOL ELEMENT 5 HEADER 'File Time' WIDTH 8 PARENT oBrowse mMess = '' IF mFlag50Mb mMess = mMess + L('Есть файлы >= 50 Мб!') ENDIF IF mFlagErrName mMess = mMess + ' ' + L('Есть файлы с некорректными именами!') ENDIF IF LEN(mMess) > 0 @25.5,2 DCPUSHBUTTON CAPTION mMess SIZE 84, 1.5 ACTION {||Help13f(mFlag50Mb, mFlagErrName)} FONT '10.Helv Bold' ENDIF DCREAD GUI FIT TITLE L('Файлы приложения') *** Имя файла всегда последнее в строке, искать его справа налево до ":" *** Отличать имена файлов от имен папок, использовать только имена файлов * oScrn := DC_WaitOn( L('Загрузка файлов приложения с FTP-сервера'),,,,,,,,,,,.F.) ************************************************************************************* *** Отображение стадии и прогноза времени исполнения ******************************** ************************************************************************************* Wsego = LEN(aDir) mTitleName = L('Загрузка приложения:"')+' №'+ALLTRIM(WebAppls->Num_appl)+'-'+SUBSTR(ALLTRIM(WebAppls->Appl_Name),1,47)+'"'+L('из Эйдос-облака') // Отображение стадии исполнения. Будет написано прямо в окне Progress-bar d = 0 @0,0 DCGROUP oGroup1 CAPTION L('Стадии исполнения процесса') FONT "6.Helv" SIZE 105+d, 2.5 PARENT oTabPage1 @4,0 DCGROUP oGroup2 CAPTION L('Прогноз времени исполнения') FONT "6.Helv" SIZE 105+d, 5.0 PARENT oTabPage2 s = 1 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 1] FONT "10.Helv" s++ @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay97 FONT "10.HelvBold" s++ @0.2+s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay98 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @1.5+s ,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay99 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @s ,1 DCPROGRESS oProgress ; SIZE 95,1.5 ; PERCENT ; EVERY 1+INT(Wsego/nEvery) ; // Кол-во обновлений изображения MAXCOUNT Wsego ; COLOR GRA_CLR_CYAN // Цвет полосы @s++,97 DCPUSHBUTTON CAPTION L('&Cancel') ; ACTION {||lOk:=.T.} OBJECT oButton ; SIZE 7,1.5 DCREAD GUI ; TITLE mTitleName ; PARENT @oDialog ; FIT ; EXIT ; MODAL oDialog:alwaysOnTop = .T. // Окно открывается на переднем плане oDialog:show() // Начало отсчета времени для прогнозирования длительности исполнения Time_progress = 0 // Прошло секунд с начала процесса // Процесс может идти больше суток, поэтому для определения // во всех случаях вычисляется время, прошедшее с начала года T_Mess1 = L("Начало:")+" "+TIME() // Начало Sec_1 = (DOY(DATE())-1)*86400+SECONDS() PUBLIC T1 := (DOY(DATE())-1)*86400+SECONDS() // Время предыдущей индикации процесса исполнения PUBLIC T2 := (DOY(DATE())-1)*86400+SECONDS()+1 // Текущее время (1-й раз оно заметно больше T1 чтобы было отображение) PUBLIC T1tp := T1 PUBLIC T2tp := T2 ********************************************************************************* aFileName := {} FOR j=1 TO LEN(aDir) mFileName = aDir[j,F_NAME] * oScrn := DC_WaitOn( L('Загрузка приложения: "')+'['+ALLTRIM(STR(Num_appl))+']-'+ALLTRIM(WebAppls->Appl_Name)+L('" с FTP-сервера. Файл: ')+ALLTRIM(STR(j))+'/'+ALLTRIM(STR(LEN(aDir)))+'-"'+ConvToOemCP(mFileName)+'"' ,,,,,,,,,,,.F.) aSay[ 1]:SetCaption(L('Обрабатывается файл:')+' '+ALLTRIM(STR(j))+'/'+ALLTRIM(STR(LEN(aDir)))+'-"'+ConvToOemCP(mFileName)+'"') IF oFtp:GetFile(mFileName, mFileName) AADD(aFileName, mFileName) * LB_Warning(L('Загрузка файла: ')+ALLTRIM(STR(j))+'/'+ALLTRIM(STR(LEN(aDir)))+'-"'+ConvToOemCP(mFileName)+L('" с FTP-сервера системы "Эйдос" завершена успешно'), L('(C) Система "Эйдос-Х++"' )) ENDIF * DC_Impl(oScrn) *** Отображение стадии и прогноза времени исполнения **************** lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) NEXT oSay97:SetCaption(L("Загрузка файлов приложения с ftp-сервера успешно завершена !!!")) MILLISEC(5000) oSay97:SetCaption(oSay97:caption) oButton:SetCaption(L('&Ok')) // Деструктурирование окна отображения графического Progress-bar oButton:activate := {||PostAppEvent(xbeP_Close,,,oDialog)} //<<<<<< Add This DC_AppEvent( @lOk ) PostAppEvent(xbeP_Activate,,,DC_GetObject(GetList,'DCGUI_BUTTON_OK')) // Роджер oDialog:Destroy() * DC_Impl(oScrn) ENDIF ELSE * DC_Impl(oScrn) LB_Warning(L('Нет соединения с FTP-сервером'), L('(C) Система "Эйдос-Х++"')) RETURN NIL ENDIF * DC_Impl(oScrn) ************************************************************************************************ mLW = ALLTRIM(WebAppls->Appl_Name) mRecno = VAL(ALLTRIM(WebAppls->Num_Appl)) DiscCatalog(mRecno, mLW, L('скачивание приложения')) // Дополнить каталог обсуждений информацией о скачивании приложения ************************************************************************************************ *** Перенос файлов приложения из папки с исполнимым модулем системы "Эйдос" в папку Inp_data DIRCHANGE(Disk_dir) // Перейти в папку с системой * LB_Warning(aDirectory, '(C) Универсальная когнитивная аналитическая система "Эйдос-Х++"') // ############################ * LB_Warning(aFileName , '(C) Универсальная когнитивная аналитическая система "Эйдос-Х++"') // ############################ IF LEN(aFileName) = 0 aMess := {} AADD(aMess, L('Приложение: "'+mNameAppl+'" не установлено,')) AADD(aMess, L('т.к. в папке облачного Эйдос-приложения нет файлов!')) AADD(aMess, L('Обращайтесь к разработчику: http://lc.kubagro.ru/index.htm')) LB_Warning(aMess, L('(C) Универсальная когнитивная аналитическая система "Эйдос-Х++"')) ELSE FOR j=1 TO LEN(aFileName) Name_SS = aFileName[j] Name_DD = Disk_dir+"\AID_DATA\Inp_data\"+aFileName[j] COPY FILE (Name_SS) TO (Name_DD) IF aFileName[j] = '_2_3_2_1.arx' .OR.; aFileName[j] = '_2_3_2_2.arx' .OR.; aFileName[j] = '_2_3_2_3.arx' ELSE ERASE(Name_SS) ENDIF NEXT ********* Определение типов файлов, скачанных из облака и определение типа приложения и типа API DIRCHANGE(Disk_dir+"\AID_DATA\Inp_data\") // Перейти в папку Inp_data mFlag2321 = .F. mFlag2322 = .F. mFlag2323 = .F. mFlagInpData = .F. mFlagJpg = .F. mFlagBmp = .F. mFlagDoc = .F. mFlagTxt = .F. mFlagPdf = .F. mFlagRar = .F. mFlagZip = .F. mFlagDiscAppl = .F. mFlagDialog = .F. mFlagAPItype = .F. API_type = '' FOR j=1 TO LEN(aFileName) IF 'API_type.txt' = aFileName[j] mFlagAPItype = .T. API_type = FileStr('API_type.txt') ENDIF IF AT('rar',aFileName[j]) > 0 mFlagRar = .T. ENDIF IF AT('zip',aFileName[j]) > 0 mFlagZip = .T. ENDIF IF AT('doc',aFileName[j]) > 0 mFlagDoc = .T. ENDIF IF AT('txt',aFileName[j]) > 0 mFlagTxt = .T. ENDIF IF AT('pdf',aFileName[j]) > 0 mFlagPdf = .T. ENDIF IF 'DiscAppl.txt' = aFileName[j] mFlagDiscAppl = .T. ENDIF IF AT('jpg',aFileName[j]) > 0 mFlagJpg = .T. ENDIF IF AT('bmp',aFileName[j]) > 0 mFlagBmp = .T. ENDIF IF aFileName[j] = '_2_3_2_1.arx' // <<<===############## mFlag2321 = .T. ENDIF IF aFileName[j] = '_2_3_2_2.arx' mFlag2322 = .T. ENDIF IF aFileName[j] = '_2_3_2_3.arx' // <<<===############## mFlag2323 = .T. ENDIF IF aFileName[j] = 'Inp_data.xls' mFlagInpData = .T. mDataSource = 'Inp_data.xls' ENDIF IF aFileName[j] = 'Inp_data.xlsx' mFlagInpData = .T. mDataSource = 'Inp_data.xlsx' ENDIF NEXT aMess := {} IF mFlagAPItype AADD(aMess, L('В папку: "')+Disk_dir+L('\AID_DATA\Inp_data\ скачан файл "API_type.txt"')) AADD(aMess, L('с информацией о типе автоматизированного программного интерфейса (API),')) AADD(aMess, L('при помощи которого были введены исходные данные при создании приложения.')) ENDIF IF mFlagDiscAppl AADD(aMess, L('В папку: "')+Disk_dir+L('\AID_DATA\Inp_data\" скачан файл "DiscAppl.txt" с обсуждением приложения.')) ENDIF IF mFlagDoc AADD(aMess, L('Среди файлов, скачанных в папку: "')+Disk_dir+L('\AID_DATA\Inp_data\" есть doc-файлы.')) ENDIF IF mFlagTxt AADD(aMess, L('Среди файлов, скачанных в папку: "')+Disk_dir+L('\AID_DATA\Inp_data\" есть txt-файлы.')) ENDIF IF mFlagPdf AADD(aMess, L('Среди файлов, скачанных в папку: "')+Disk_dir+L('\AID_DATA\Inp_data\" есть pdf-файлы.')) ENDIF IF mFlagDoc .OR. mFlagTxt .OR. mFlagDiscAppl .OR. mFlagPdf AADD(aMess, L(' ')) AADD(aMess, L('Вероятно они содержат описание исходных данных и созданного на их основе приложения.')) mFlagDialog = .T. ENDIF IF mFlagRar AADD(aMess, L(' ')) AADD(aMess, L('Среди файлов, скачанных в папку: "')+Disk_dir+L('\AID_DATA\Inp_data\" есть rar-архивы.')) ENDIF IF mFlagZip AADD(aMess, L('Среди файлов, скачанных в папку: "')+Disk_dir+L('\AID_DATA\Inp_data\" есть zip-архивы.')) ENDIF IF mFlagRar .OR. mFlagZip AADD(aMess, L(' ')) AADD(aMess, L('Вероятно они содержат полные исходные данные для данного приложения. ')) AADD(aMess, L('Возможно архивы содержат файлы, в именах которых есть пробелы и кириллица.')) AADD(aMess, L('Есть смысл развернуть эти архивы и посмотреть, а, возможно, и создать')) AADD(aMess, L('полные модели с теми же параметрами API, что и на сокращенном примере')) mFlagDialog = .T. ENDIF IF mFlagJpg AADD(aMess, L(' ')) AADD(aMess, L('Среди файлов, скачанных в папку: "')+Disk_dir+L('\AID_DATA\Inp_data\" есть jpg-файлы.')) ENDIF IF mFlagBmp AADD(aMess, L(' ')) AADD(aMess, L('Среди файлов, скачанных в папку: "')+Disk_dir+L('\AID_DATA\Inp_data\" есть bmp-файлы.')) ENDIF IF mFlagDialog LB_Warning(aMess, L('(C) Универсальная когнитивная аналитическая система "Эйдос-Х++"')) ENDIF ******************************************************************************************************************************************************************************* ** Определение типа программного интерфейса приложения: *********************************************************************************************************************** ******************************************************************************************************************************************************************************* mFlagAPItypeERR = .F. * MsgBox(API_type) IF mFlagAPItype // В переменной API_type есть верная информация о типе использованного API ********************************************* DO CASE CASE API_type = 'API_type=2.3.2.1.' // 2.3.2.1. Импорт данных из текстовых файлов ************************************************************************** F2_3_2_1() // Запуск универсального программного интерфейса с внешними текстовыми файлами mDataSource = "текстовые файлы" IF .NOT. FILE("_2_3_2_1.arx") PUBLIC aPar[10] aPar[ 1] = 1 // Формат текстовых файлов: 1 = TXT, 2 = DOC, 3 = Internet aPar[ 2] = 2 // Кодировка исходных файлов: 1 = ANSI (Windows), 2 = OEM (DOS) ### aPar[ 3] = 1 // В качестве признаков рассматривать: 1 = слова, 2 = сочетания слов aPar[10] = 3 // Количество символов в словах >: aPar[ 4] = 1 // Количество слов в сочетаниях слов (мемах) aPar[ 5] = 1 // 1-форм.кл.и оп.шк.и град.и обуч.выборки, 2-форм.расп.выборки aPar[ 6] =.F. // .T. - проводить лемматизацию, .F. не проводить лемматизацию ### // Удалять ковычки, апострофы, знаки препинания и спец.символы ### // Не учитывать слова, короче 4 символов ### // Не различать верхний и нижний регистр (переводить все символы в нижний регистр) ### aPar[ 7] =.F. // .T. - Создавать БД Inp_data.dbf для создания моделей (2.3.2.2) прогнозирования последующих слов на основе предшествующих, .F. - не создавать aPar[ 8] = 1 // 1 - работать в папке обучающей выборки: "..AID_DATA/Inp_data/"', 2 - работать в папке распознаваемой выборки: "..AID_DATA/Inp_rasp/" aPar[ 9] = 2 // 1 - имена файлов формировать в стандарте "Эйдос": "id, Class name" брать из номера и имени файла, 2 - в стандарте "http://kaggle.com/": "id, Class name" брать из текста файла DC_ASave(aPar, "_2_3_2_1.arx") ELSE aPar = DC_ARestore("_2_3_2_1.arx") ENDIF DC_ASave(aPar, Disk_dir+"\AID_DATA\Inp_data\"+"_2_3_2_1.arx") CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Appls EXCLUSIVE NEW SELECT Appls DBGOBOTTOM() REPLACE Name_Appl WITH ALLTRIM(mNameAppl) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций CASE API_type = 'API_type=2.3.2.2.' // 2.3.2.2. Универсальный программный интерфейс импорта данных в систему *********************************************** M_NewAppl = ADD_ZAPPL(mNameAppl) // Путь на БД нового приложения в папке приложений и наименование приложения в БД приложений // Создание пустых баз данных нового приложения DIRCHANGE(M_NewAppl) // Перейти в папку с новым приложением и создать БД формализации предметной области: GenDbfClSc(.F.) // Классификационные шкалы ######### GenDbfGrClSc(.F.) // Градации классификационных шкал ######### GenDbfClass(.F.) // Классификационные шкалы и градации GenDbfOpSc(.F.) // Описательные шкалы GenDbfGrOpSc(.F.) // Градации описательных шкал GenDbfAttr(.F.) // Описательные шкалы и градации ######### GenDbfObiZag() // Заголовки объектов обучающей выборки GenDbfObiKcl() // Коды классов объектов обучающей выборки GenDbfObiKpr() // Коды признаков объектов обучающей выборки GenDbfRsoZag() // Заголовки объектов распознаваемой выборки GenDbfRsoKcl() // Коды классов объектов распознаваемой выборки GenDbfRsoKpr() // Коды признаков объектов распознаваемой выборки DIRCHANGE(Disk_dir) // Перейти в папку с системой * MsgBox(IF(mFlag2322,'T','F')) // ############################################# IF mFlag2322 F2_3_2_2(mNameAppl,"1.3()") // Запуск универсального программного интерфейса с внешними базами данных ENDIF CASE API_type = 'API_type=2.3.2.3.' // 2.3.2.3. Импорт данных из транспонированных внешних баз данных ****************************************************** F2_3_2_3() CASE API_type = 'API_type=2.3.2.4.' // 2.3.2.4. Оцифровка изображений по внешним контурам ****************************************************************** F2324ok() CASE API_type = 'API_type=2.3.2.5.' // 2.3.2.5. Оцифровка изображений по всем пикселям и спектру *********************************************************** mFlagDialog = .T. F2_3_2_5() mDataSource = "графические файлы" ***** Записать наименование установленного облачного приложения в БД приложений CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Appls EXCLUSIVE NEW SELECT Appls DBGOBOTTOM() REPLACE Name_Appl WITH ALLTRIM(mNameAppl) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций CASE API_type = 'API_type=2.3.2.6.' // 2.3.2.6. Сценарный АСК-анализ символьных и числовых рядов *********************************************************** mDataSource = "текстовый файл" F2_3_2_6() OTHERWISE mFlagAPItypeERR = .T. // В переменной API_type нет верной информации о типе использованного API ********************************************** ENDCASE aMess := {} AADD(aMess, L('Приложение: "'+mNameAppl+'" успешно установлено!')) AADD(aMess, L(" ")) AADD(aMess, L("Для дальнейшего его изучения и выполнения необходимо:")) AADD(aMess, L(" ")) AADD(aMess, L("1. Выполнить режимы: 2.1, 2.2, 2.3, 3.5, 4.1.3.6, 4.1.3.1 и другие")) AADD(aMess, L(" в соответствии со схемой преобразования данных в информацию,")) AADD(aMess, L(" а ее в знания, приведенной в режиме 6.4.")) AADD(aMess, L(" ")) AADD(aMess, L("2. Файл(ы) исходных данных приложения: ")+Disk_dir+"\AID_DATA\Inp_data\"+mDataSource+".") AADD(aMess, L(" ")) AADD(aMess, L("3. Для завершения установки облачного Эйдос-приложения необходимо")) AADD(aMess, L("последовательно закрыть все окна и выйти в главное окно режима 1.3.")) IF API_type = 'API_type=2.3.2.5.' AADD(aMess, L(" ")) AADD(aMess, L("Затем в режиме 4.7 можно создать и записать спектры конкретных")) AADD(aMess, L("изображений и спектры обобщенных образов классов.")) ENDIF LB_Warning(aMess, L('(C) Универсальная когнитивная аналитическая система "Эйдос-Х++"')) ENDIF IF .NOT. mFlagAPItype .OR. mFlagAPItypeERR ** Если среди скачанных файлов нет файла "API_type.txt" с информацией о типе API, использованного при создании приложения. ** - если в папке Inp_data много txt-файлов, а jpg(bmp) файлов мало, то 2.3.2.1 ** - если в папке Inp_data много jpg(bmp)-файлов, то 2.3.2.5 ** - еслиmFlag2322, а txt и jpg(bmp) файлов мало, иначе 2.3.2.2. N_txt = ADIR("*.txt") N_jpg = ADIR("*.jpg") N_bmp = ADIR("*.bmp") DIRCHANGE(Disk_dir) // Перейти в папку с системой ** Запуск интерфейса 2.3.2.1 для обработки текстовых файлов IF mFlag2321 .AND. N_txt > 2 IF N_jpg + N_bmp <= 2 // <<<===####################### F2_3_2_1() // Запуск универсального программного интерфейса с внешними текстовыми файлами IF .NOT. FILE("_2_3_2_1.arx") PUBLIC aPar[10] aPar[ 1] = 1 // Формат текстовых файлов: 1 = TXT, 2 = DOC, 3 = Internet aPar[ 2] = 2 // Кодировка исходных файлов: 1 = ANSI (Windows), 2 = OEM (DOS) ### aPar[ 3] = 1 // В качестве признаков рассматривать: 1 = слова, 2 = сочетания слов aPar[10] = 3 // Количество символов в словах >: aPar[ 4] = 1 // Количество слов в сочетаниях слов (мемах) aPar[ 5] = 1 // 1-форм.кл.и оп.шк.и град.и обуч.выборки, 2-форм.расп.выборки aPar[ 6] =.F. // .T. - проводить лемматизацию, .F. не проводить лемматизацию ### // Удалять ковычки, апострофы, знаки препинания и спец.символы ### // Не учитывать слова, короче 4 символов ### // Не различать верхний и нижний регистр (переводить все символы в нижний регистр) ### aPar[ 7] =.F. // .T. - Создавать БД Inp_data.dbf для создания моделей (2.3.2.2) прогнозирования последующих слов на основе предшествующих, .F. - не создавать aPar[ 8] = 1 // 1 - работать в папке обучающей выборки: "..AID_DATA/Inp_data/"', 2 - работать в папке распознаваемой выборки: "..AID_DATA/Inp_rasp/" aPar[ 9] = 2 // 1 - имена файлов формировать в стандарте "Эйдос": "id, Class name" брать из номера и имени файла, 2 - в стандарте "http://kaggle.com/": "id, Class name" брать из текста файла DC_ASave(aPar, "_2_3_2_1.arx") ELSE aPar = DC_ARestore("_2_3_2_1.arx") ENDIF DC_ASave(aPar, Disk_dir+"\AID_DATA\Inp_data\"+"_2_3_2_1.arx") CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Appls EXCLUSIVE NEW SELECT Appls DBGOBOTTOM() REPLACE Name_Appl WITH ALLTRIM(mNameAppl) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций aMess := {} AADD(aMess, L('Приложение: "'+mNameAppl+'" успешно установлено!')) AADD(aMess, L(" ")) AADD(aMess, L("Для дальнейшего его изучения и выполнения необходимо:")) AADD(aMess, L(" ")) AADD(aMess, L("1. Выполнить режимы: 2.1, 2.2, 2.3, 3.5, 4.1.3.6, 4.1.3.1 и другие")) AADD(aMess, L(" в соответствии со схемой преобразования данных в информацию,")) AADD(aMess, L(" а ее в знания, приведенной в режиме 6.4.")) AADD(aMess, L(" ")) AADD(aMess, L("2. Файл исходных данных приложения: ")+Disk_dir+"\AID_DATA\Inp_data\"+mDataSource+".") AADD(aMess, L(" ")) AADD(aMess, L("3. Для завершения установки облачного Эйдос-приложения необходимо")) AADD(aMess, L("последовательно закрыть все окна и выйти в главное окно режима 1.3.")) LB_Warning(aMess, L('(C) Универсальная когнитивная аналитическая система "Эйдос-Х++"')) ENDIF ENDIF ** Запуск интерфейса 2.3.2.2 для обработки табличных файлов с числовой и тестовой информацией IF mFlag2322 IF N_jpg + N_bmp < 2 .AND. N_txt <= 5 // <<<===####################### IF mFlagInpData M_NewAppl = ADD_ZAPPL(mNameAppl) // Путь на БД нового приложения в папке приложений и наименование приложения в БД приложений // Создание пустых баз данных нового приложения DIRCHANGE(M_NewAppl) // Перейти в папку с новым приложением и создать БД формализации предметной области: GenDbfClSc(.F.) // Классификационные шкалы ######### GenDbfGrClSc(.F.) // Градации классификационных шкал ######### GenDbfClass(.F.) // Классификационные шкалы и градации GenDbfOpSc(.F.) // Описательные шкалы GenDbfGrOpSc(.F.) // Градации описательных шкал GenDbfAttr(.F.) // Описательные шкалы и градации ######### GenDbfObiZag() // Заголовки объектов обучающей выборки GenDbfObiKcl() // Коды классов объектов обучающей выборки GenDbfObiKpr() // Коды признаков объектов обучающей выборки GenDbfRsoZag() // Заголовки объектов распознаваемой выборки GenDbfRsoKcl() // Коды классов объектов распознаваемой выборки GenDbfRsoKpr() // Коды признаков объектов распознаваемой выборки DIRCHANGE(Disk_dir) // Перейти в папку с системой * MsgBox(IF(mFlag2322,'T','F')) // ############################################# IF mFlag2322 F2_3_2_2(mNameAppl,"1.3()") // Запуск универсального программного интерфейса с внешними базами данных ENDIF aMess := {} AADD(aMess, L('Приложение: "'+mNameAppl+'" успешно установлено!')) AADD(aMess, L(" ")) AADD(aMess, L("Для дальнейшего его изучения и выполнения необходимо:")) AADD(aMess, L(" ")) AADD(aMess, L("1. Выполнить режимы: 2.1, 2.2, 2.3, 3.5, 4.1.3.6, 4.1.3.1 и другие")) AADD(aMess, L(" в соответствии со схемой преобразования данных в информацию,")) AADD(aMess, L(" а ее в знания, приведенной в режиме 6.4.")) AADD(aMess, L(" ")) AADD(aMess, L("2. Файл исходных данных приложения: ")+Disk_dir+"\AID_DATA\Inp_data\"+mDataSource+".") AADD(aMess, L(" ")) AADD(aMess, L("3. Для завершения установки облачного Эйдос-приложения необходимо")) AADD(aMess, L("последовательно закрыть все окна и выйти в главное окно режима 1.3.")) LB_Warning(aMess, L('(C) Универсальная когнитивная аналитическая система "Эйдос-Х++"')) ENDIF ENDIF ENDIF ** Приложение спектрального АСК-анализа изображений ****************** IF mFlag2322 .AND. N_txt <= 2 IF ( mFlagJpg .AND. N_jpg > 2 ) .OR. ( mFlagBmp .AND. N_bmp > 2 ) // <<<===####################### mFlagDialog = .T. F2_3_2_5() ***** Записать наименование установленного облачного приложения в БД приложений CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Appls EXCLUSIVE NEW SELECT Appls DBGOBOTTOM() REPLACE Name_Appl WITH ALLTRIM(mNameAppl) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций aMess := {} AADD(aMess, L('Приложение: "'+mNameAppl+'" успешно установлено!')) AADD(aMess, L(" ")) AADD(aMess, L("Для дальнейшего его изучения и выполнения необходимо:")) AADD(aMess, L(" ")) AADD(aMess, L("1. Выполнить режимы: 2.1, 2.2, 2.3, 3.5, 4.1.3.6, 4.1.3.1 и другие")) AADD(aMess, L(" в соответствии со схемой преобразования данных в информацию,")) AADD(aMess, L(" а ее в знания, приведенной в режиме 6.4.")) AADD(aMess, L(" ")) AADD(aMess, L("Затем в режиме 4.7 можно создать и записать спектры конкретных")) AADD(aMess, L("изображений и спектры обобщенных образов классов")) AADD(aMess, L(" ")) AADD(aMess, L("2. Файлы исходных данных приложения: ")+Disk_dir+"\AID_DATA\Inp_data\...") // <<<===################### AADD(aMess, L(" ")) AADD(aMess, L("3. Для завершения установки облачного Эйдос-приложения необходимо")) AADD(aMess, L("последовательно закрыть все окна и выйти в главное окно режима 1.3.")) LB_Warning(aMess, L('(C) Универсальная когнитивная аналитическая система "Эйдос-Х++"')) ENDIF ENDIF ENDIF ENDIF * ENDIF DIRCHANGE(Disk_dir) // Перейти в папку с системой CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE WebAppls EXCLUSIVE NEW SELECT WebAppls DBGOBOTTOM() ReTURN nil ********************************************************************************************* ****** Простой текстовый редактор для обсуждения облачного интеллектуального Эйдос-приложения ********************************************************************************************* STATIC FUNCTION DiscAppl(mNumAppl, mNameAppl) // XSample_186() /* This example uses DC_FormatMemoToWidth() to perfectly fit memo text into an object based on its font */ LOCAL cText, GetList[0], GetOptions, nWidth, cFont, cOutString, oMemo, oButton ***** 1. Скачать файл обсуждения 'DiscAppl.txt' по FTP с облака, если он там есть, ***** 2. а если нет - то создать локально здесь и предоставить для редактирования, ***** 3. Записать отредактированную строку в облако в то же приложение, откуда он скачивался ***** cOutString = Disk_dir+'\AID_DATA\Inp_data\DiscAppl.txt' CrLf = CHR(13)+CHR(10) // Конец строки (записи) mFlagError = .F. ***** 1. Скачать файл обсуждения 'DiscAppl.txt' по FTP с облака, если он там есть, oScrn := DC_WaitOn( L('Скачивание из облака файла обсуждения Эйдос-приложения: ')+ALLTRIM(STR(mNumAppl))+'-'+mNameAppl+'"',,,,,,,,,,,.F. ) mApplName = "Applications-"+STRTRAN(STR(mNumAppl,6),' ','0') mRecno = ALLTRIM(FIELDGET(1)) ********************************************************************************************************** Xb2NetKey() cFtpServer:="94.25.18.114" // Это везде одинаково <<<===############ oFtp := FTPClient():new( cFtpServer, Ftp_User, Ftp_Passw ) // Соединение с моим сайтом и авторизация IF oFtp:connect() // Есть соединение с моим сайтом и авторизация? ********************************************************************************************************** **** Сделать текущей папку приложения: ftp://lc.kubagro.ru/public_html/Source_data_applications/'+mApplName **** Сделать текущей папку: ftp://lc.kubagro.ru/public_html/Source_data_applications * MsgBox('2. Исходная директория: '+oFtp:curDir()) oFtp:curDir("public_html") oFtp:curDir("Source_data_applications") * MsgBox('2. Должна быть директория: "\public_html\Source_data_applications", а фактически: '+oFtp:curDir()) IF oFtp:curDir() <> "\public_html\Source_data_applications" DC_Impl(oScrn) LB_Warning(L('Не удалось сделать текущей директорию: "\public_html\Source_data_applications"'), L('(C) Система "Эйдос-Х++"' )) RETURN NIL ENDIF **** Сделать текущей папку нового приложения: ftp://aidos.kubagro.ru/public_html/Source_data_applications/'+mApplName * MsgBox('3. Исходная директория: '+oFtp:curDir()) oFtp:curDir("\public_html\Source_data_applications") oFtp:curDir(mApplName) * MsgBox('3. Должна быть директория: \public_html\Source_data_applications\'+mApplName+', а фактически: '+oFtp:curDir()) IF oFtp:curDir() <> '\public_html\Source_data_applications\'+mApplName DC_Impl(oScrn) LB_Warning(L('Не удалось сделать текущей директорию: "public_html/Source_data_applications/')+mApplName+'"', '(C) Система "Эйдос-Х++"' ) RETURN NIL ENDIF PUBLIC aDir := oFtp:Directory() // Борис Борзик, для этого нужен только FTP, т.к. под HTTP не работает oHttp:Directory() * wtf oFtp:Directory() // VALUE: {{"Downloads.exe", 10242016, 20201202, "07:57:00", "N", 0, , "00:00:00", , "00:00:00"}} IF LEN(aDir) > 0 // Если папка в облаке не пустая, т.е. кроме . и .. есть хотя бы один файл **** Просмотр массива директории с FTP-сервера от Роджера mLenMax = LEN(L('Файлы приложения N:')+' '+mRecno+'-"'+ALLTRIM(WebAppls->Appl_Name)+'"') PRIVATE aDirShow[Len(aDir)+1,6] mSummaSize = 0 FOR i := 1 TO Len(aDir) aDirShow[i,1] = ALLTRIM(STR(i)) aDirShow[i,2] = aDir[i,F_NAME] aDirShow[i,3] = aDir[i,F_SIZE] aDirShow[i,4] = DTOC(aDir[i,F_WRITE_DATE]) aDirShow[i,5] = aDir[i,F_WRITE_TIME] mSummaSize = mSummaSize + aDir[i,F_SIZE] NEXT ENDIF DIRCHANGE(Disk_dir+"\AID_DATA\Inp_data\") // Перейти в папку Inp_data IF ! oFtp:GetFile('DiscAppl.txt', 'DiscAppl.txt' ) * LB_Warning(L('Файл обсуждений: "DiscAppl.txt" в облаке отсутствует и будет создан!', '(C) Система "Эйдос-Х++"' ) mFlagError = .T. ENDIF ENDIF DC_Impl(oScrn) ***** 2. а если же его там нет - то создать локально здесь и предоставить для редактирования, а потом записать в облако отредактированный IF mFlagError cOutString = REPLICATE('=',170) + CrLf +; 'Это файл обсуждения Эйдос-приложения: '+ALLTRIM(STR(mNumAppl))+'-'+UPPER(mNameAppl)+'".' + CrLf +; 'Здесь можно обсудить данное приложение, задать вопросы и получить ответы.' + CrLf +; 'Дата и время создания файла обсуждения: '+DTOC(DATE())+"-"+TIME() + CrLf +; REPLICATE('=',170) + CrLf StrFile(cOutString, 'DiscAppl.txt') // Запись файла обсуждения в папку Inp_data ELSE cOutString = ALLTRIM(FILESTR('DiscAppl.txt')) // Считывание файла обсуждения для редактирования cOutString = cOutString + CrLf + CrLf + REPLICATE('-',25)+DTOC(DATE())+"-"+TIME()+REPLICATE('-',126) + CrLf ENDIF cFont = Pad('10.Courier',40) nWidth = 1000 @0, 0 DCMULTILINE cOutString SIZE 200,35 FONT Alltrim(cFont) NOHORIZSCROLL OBJECT oMemo d = 97 S = 35.5 @S, 0 DCPUSHBUTTON CAPTION L('Записать сообщение в облако') SIZE LEN(L('Записать сообщение в облако')), 1.2 OBJECT oButton ; ACTION {|| MemoWrit(Disk_dir+'\AID_DATA\Inp_data\DiscAppl.txt', cOutString) } // Запись отредактированного сообщения на диск @S, DCGUI_COL+d DCPUSHBUTTON CAPTION L('Форматировать текст') SIZE LEN(L('Форматировать текст')), 1.2 OBJECT oButton ; ACTION {||cOutString := DC_FormatMemoToWidth(cOutString,nWidth,cFont), DC_GetRefresh(GetList), ; oMemo:setFontCompoundName(Alltrim(cFont))} @S, DCGUI_COL+d DCPUSHBUTTON CAPTION L('Получить гиперссылки на файлы приложения') SIZE LEN(L('Получить гиперссылки на файлы приложения')), 1.2 OBJECT oButton ; ACTION {|| cOutString := HyperlinksApplFiles(mNumAppl, mNameAppl, cOutString), DC_GetRefresh(GetList) } @S, DCGUI_COL+d DCPUSHBUTTON CAPTION 'Помощь по режиму' SIZE LEN('Помощь по режиму')+4, 1.2 OBJECT oButton ; ACTION {|| DiscApplHelp(), DC_GetRefresh(GetList) } @S, 0 DCPUSHBUTTON CAPTION L('Записать сообщение в облако') SIZE LEN(L('Записать сообщение в облако')), 1.2 OBJECT oButton ; ACTION {|| MemoWrit(Disk_dir+'\AID_DATA\Inp_data\DiscAppl.txt', cOutString) } // Запись отредактированного сообщения на диск DCGETOPTIONS SAYWIDTH 230 SAYRIGHTBOTTOM DCREAD GUI FIT TITLE L('Обсуждение облачного Эйдос-приложения: "')+ALLTRIM(STR(mNumAppl))+'-'+mNameAppl+'"' ; OPTIONS GetOptions ; EVAL {||PostAppEvent(xbeP_Activate,,,oButton)} ***** 3. Записать файл обсуждений (отредактированную строку) в облако в то же приложение, откуда он скачивался mFlagError = .F. oScrn := DC_WaitOn( L('Запись в облако отредактированного файла обсуждения Эйдос-приложения: ')+ALLTRIM(STR(mNumAppl))+'-'+mNameAppl+'"',,,,,,,,,,,.F. ) ********************************************************************************************************** Xb2NetKey() cFtpServer:="94.25.18.114" // Это везде одинаково <<<===############ oFtp := FTPClient():new( cFtpServer, Ftp_User, Ftp_Passw ) // Соединение с моим сайтом и авторизация IF oFtp:connect() // Есть соединение с моим сайтом и авторизация? ********************************************************************************************************** mApplName = "Applications-"+STRTRAN(STR(mNumAppl,6),' ','0') **** Сделать текущей папку приложения: ftp://lc.kubagro.ru/public_html/Source_data_applications/'+mApplName **** Сделать текущей папку: ftp://lc.kubagro.ru/public_html/Source_data_applications * MsgBox('2. Исходная директория: '+oFtp:curDir()) oFtp:curDir("public_html") oFtp:curDir("Source_data_applications") * MsgBox('2. Должна быть директория: "\public_html\Source_data_applications", а фактически: '+oFtp:curDir()) IF oFtp:curDir() <> "\public_html\Source_data_applications" DC_Impl(oScrn) LB_Warning(L('Не удалось сделать текущей директорию: "\public_html\Source_data_applications"'), L('(C) Система "Эйдос-Х++"' )) RETURN NIL ENDIF **** Сделать текущей папку нового приложения: ftp://lc.kubagro.ru/public_html/Source_data_applications/'+mApplName * MsgBox('3. Исходная директория: '+oFtp:curDir()) oFtp:curDir("\public_html\Source_data_applications") oFtp:curDir(mApplName) * MsgBox('3. Должна быть директория: \public_html\Source_data_applications\'+mApplName+', а фактически: '+oFtp:curDir()) IF oFtp:curDir() <> '\public_html\Source_data_applications\'+mApplName DC_Impl(oScrn) LB_Warning(L('Не удалось сделать текущей директорию: "\public_html\Source_data_applications\')+mApplName+'"', '(C) Система "Эйдос-Х++"' ) RETURN NIL ENDIF DIRCHANGE(Disk_dir+"\AID_DATA\Inp_data\") // Перейти в папку Inp_data IF ! oFtp:PutFile('DiscAppl.txt', 'DiscAppl.txt' ) * LB_Warning(L('*** ERROR: Файл: "DiscAppl.txt" в облако не записан'), L('(C) Система "Эйдос-Х++"' )) mFlagError = .T. ENDIF DIRCHANGE(Disk_dir) // Перейти в папку с системой ENDIF DC_Impl(oScrn) DiscCatalog(mNumAppl, mNameAppl, L('новое сообщение')) // Дополнить каталог обсуждений информацией о добавлении сообщения в файл обсуждения IF ! mFlagError aMess := {} AADD(aMess, L('Файл обсуждения Эйдос-приложения:')) AADD(aMess, L('"')+ALLTRIM(STR(mNumAppl))+'-'+mNameAppl+'"') AADD(aMess, L('записан в облако успешно !')) LB_Warning(aMess, L('(C) Система "Эйдос-Х++"' )) ENDIF RETURN nil **************************************************************************************************************** ******** Узнать, какие файлы есть в папке приложения на FTP-сервере и вставить в файл диалога гиперссылки на них **************************************************************************************************************** FUNCTION HyperlinksApplFiles(mNumAppl, mNameAppl, cOutString) LOCAL GetList := {}, aPres, oBrowse, oToolBar, aColors, bColor, GetOptions ***** Узнать, какие файлы есть в папке приложения на FTP-сервере и вставить в файл диалога гиперссылки на них mLW = ALLTRIM(WebAppls->Appl_Name) mRecno = VAL(ALLTRIM(WebAppls->Num_Appl)) DIRCHANGE(Disk_dir+"\AID_DATA\Inp_data\") // Перейти в папку Inp_data mApplName = "Applications-"+STRTRAN(STR(mNumAppl,6),' ','0') ********************************************************************************************************** Xb2NetKey() cFtpServer:="94.25.18.114" // Это везде одинаково <<<===############ oFtp := FTPClient():new( cFtpServer, Ftp_User, Ftp_Passw ) // Соединение с моим сайтом и авторизация IF oFtp:connect() // Есть соединение с моим сайтом и авторизация? ********************************************************************************************************** mApplName = "Applications-"+STRTRAN(STR(mNumAppl,6),' ','0') **** Сделать текущей папку приложения: ftp://lc.kubagro.ru/public_html/Source_data_applications/'+mApplName **** Сделать текущей папку: ftp://lc.kubagro.ru/public_html/Source_data_applications * MsgBox('2. Исходная директория: '+oFtp:curDir()) oFtp:curDir("public_html") oFtp:curDir("Source_data_applications") * MsgBox('2. Должна быть директория: "\public_html\Source_data_applications", а фактически: '+oFtp:curDir()) IF oFtp:curDir() <> "\public_html\Source_data_applications" DC_Impl(oScrn) LB_Warning(L('Не удалось сделать текущей директорию: "\public_html\Source_data_applications"'), L('(C) Система "Эйдос-Х++"' )) RETURN NIL ENDIF **** Сделать текущей папку нового приложения: ftp://aidos.kubagro.ru/public_html/Source_data_applications/'+mApplName * MsgBox('3. Исходная директория: '+oFtp:curDir()) oFtp:curDir("\public_html\Source_data_applications") oFtp:curDir(mApplName) * MsgBox('3. Должна быть директория: \public_html\Source_data_applications\'+mApplName+', а фактически: '+oFtp:curDir()) IF oFtp:curDir() <> '\public_html\Source_data_applications\'+mApplName DC_Impl(oScrn) LB_Warning(L('Не удалось сделать текущей директорию: "\public_html\Source_data_applications\')+mApplName+'"', '(C) Система "Эйдос-Х++"' ) RETURN NIL ENDIF * cOutString = ALLTRIM(FILESTR('DiscAppl.txt')) // Считывание файла обсуждения для редактирования cOutString = cOutString + CrLf + CrLf + REPLICATE('-',25)+DTOC(DATE())+"-"+TIME()+REPLICATE('-',126) + CrLf +; 'Гиперссылки на файлы интеллектуального облачного Эйдос-приложения: '+ALLTRIM(STR(mNumAppl))+'-'+UPPER(mNameAppl)+'"' + CrLf +; REPLICATE('-',170) + CrLf *** Имя файла всегда последнее в строке PUBLIC aDir := oFtp:Directory() // Борис Борзик, для этого нужен только FTP, т.к. под HTTP не работает oHttp:Directory() * wtf oFtp:Directory() // VALUE: {{"Downloads.exe", 10242016, 20201202, "07:57:00", "N", 0, , "00:00:00", , "00:00:00"}} IF LEN(aDir) > 0 // Если папка в облаке не пустая, т.е. кроме . и .. есть хотя бы один файл **** Просмотр массива директории с FTP-сервера от Роджера mLenMax = LEN(L('Файлы приложения N:')+ALLTRIM(STR(mRecno))+'-"'+ALLTRIM(WebAppls->Appl_Name)+'"') PRIVATE aDirShow[Len(aDir)+1,6] mSummaSize = 0 mFNLenMax = -99999 FOR j := 1 TO Len(aDir) aDirShow[j,1] = ALLTRIM(STR(j)) aDirShow[j,2] = aDir[j,F_NAME] aDirShow[j,3] = aDir[j,F_SIZE] aDirShow[j,4] = DTOC(aDir[j,F_WRITE_DATE]) aDirShow[j,5] = aDir[j,F_WRITE_TIME] mFNLenMax = MAX(mFNLenMax, LEN(ALLTRIM(aDir[j,F_NAME]))) mSummaSize = mSummaSize + aDir[j,F_SIZE] NEXT aDirShow[Len(aDir)+1,2] = L('Суммарный объем (байт)') aDirShow[Len(aDir)+1,3] = mSummaSize ENDIF mPdf = '' FOR j=1 TO LEN(aDir) cOutString = cOutString + 'http://lc.kubagro.ru/Source_data_applications/'+mApplName+'/'+ALLTRIM(aDir[j,F_NAME])+; REPLICATE(' ',1+mFNLenMax-LEN(ALLTRIM(aDir[j,F_NAME]))) + STR(aDir[j,F_SIZE]) + ' ' + DTOC(aDir[j,F_WRITE_DATE]) + ' '+ aDir[j,F_WRITE_TIME] + CrLf // Вставка гиперссылки на файл в файл диалога IF AT('.PDF',UPPER(aDir[j,F_NAME])) > 0 mPdf = 'http://lc.kubagro.ru/Source_data_applications/'+mApplName+'/'+ALLTRIM(aDir[j,F_NAME]) ENDIF NEXT cOutString = cOutString + REPLICATE('-',170) + CrLf cOutString = cOutString + L('Суммарный объем файлов:')+REPLICATE(' ',12+LEN('http://lc.kubagro.ru/Source_data_applications/')+LEN(mApplName)-LEN(L('Суммарный объем файлов:'))+mFNLenMax-LEN(ALLTRIM(STR(mSummaSize))))+ALLTRIM(STR(mSummaSize)+' '+L('байтов'))+CrLf cOutString = cOutString + REPLICATE('=',170) + CrLf StrFile(cOutString, 'DiscAppl.txt') // Запись файла обсуждения в папку Inp_data ELSE DC_Impl(oScrn) LB_Warning(L('Нет соединения с FTP-сервером'), L('(C) Система "Эйдос-Х++"')) RETURN NIL ENDIF DC_Impl(oScrn) DIRCHANGE(Disk_dir) // Перейти в папку с системой ** Вставить гиперссылку на PDF-файл, если он есть, в каталог приложений * MsgBox(mPdf) IF LEN(mPdf) > 0 SELECT WebAppls DBGOTO(mNumAppl) REPLACE E_MAIL WITH mPdf SaveCatWebAppls(.T.) ENDIF RETURN(cOutString) *********************************************************************************************** FUNCTION DiscApplHelp() LOCAL GetList[0], cText TEXT INTO cText WRAP "\n" TRIMMED ПОМОЩЬ ПО РЕЖИМУ: "Обсуждение облачного Эйдос-приложения" 1. Данный режим предназначен для обсуждения того облачного Эйдос-приложения, на котором стоял курсор в момент клика по кнопке "Обсуждение...". 2. Вы можете задавать здесь вопросы и другие пользователи или разработчики Эйдос-приложений или разработчик АСК-анализа и системы "Эйдос" проф.Е.В.Луценко смогут помочь Вам советом. 3. Когда Вы кликаете на кнопке "Обсуждение..." с FTP-сервера системы "Эйдос" из папки с тем приложением, на котором был курсор, по считывается файл: "DiscAppl.txt", который есть в каждом приложении. Если его там не было, то создается новый файл для обсуждений. 4. Вы можете корректировать файл, пользуясь простым редактором. 5. Чтобы записать отредактированный файл в облако в папку его приложения, и тем самым сделать его доступным всем пользователям и разработчикам Эйдос-приложений во всем мире, надо просто кликнуть по кнопке: "Записать файл сообщений в облако" и выйти из редактора, закрыв его окно. Если Вы выйдете из редактора не кликнув по кнопке: "Записать файл сообщений в облако", то файл "DiscAppl.txt" на FTP-сервере останется без изменений. 6. Если среди файлов приложения в папке: ../Aidos-X/AID_DATA/Inp_data/ есть PDF-файл, то предполагается, что этот файл содержит описание приложения. Гиперссылка на него вставляется в каталог Web-приложений, если пользователь кликнет по кнопке: "Получить гиперссылки на файлы приложения". Русские символы в имени этого файла не допускаются, т.к. иначе гиперссылка не будет работать. Информация о дате и времени добавления сообщений в файлы обсуждения облачных Эйдос-приложений автоматически добавляются в каталог обсуждений, который хранится на WEB-сервере системы "Эйдос". Этот каталог можно просмотреть, если кликнуть по кнопке: "Каталог обсуждений" или в файле: ../Aidos-X/AID_DATA/Inp_data/DiscCatalog.txt. Записи в этом каталоге находятся в хронологическом порядке, т.е. самые новые записи в конце каталога. Используя этот каталог обсуждений всегда можно узнать по каким приложениям были добавлены сообщения в последнее время и какие облачные Эйдос-приложения были скачаны и установлены. Каталог обсуждений ведется автоматически и пользователю не предоставлена возможность его корректировки. Русские символы в именах файлов приложения являются нежелательными, т.к. гиперссылки с ними не работают. ENDTEXT @ 0,0 DCSTATIC TYPE XBPSTATIC_TYPE_TEXT SIZE 0 ; CAPTION cText FORMATTED ; FONT '10.Lucida Console' ; COLOR GRA_CLR_BLACK, GRA_CLR_WHITE DCREAD GUI FIT TITLE L('Помощь по режиму обсуждения облачного Эйдос-приложения') ReTURN nil *********************************************************************************************** ******** Отображение массива с данными о файлах директории на FTP-сервере в виде таблицы Browse *********************************************************************************************** FUNCTION GuiBrowse(aDirectory) LOCAL GetList[0], oBrowse, bColorSize, bColorDate * bColorSize := {|n|n:=DC_GetColArray(2,oBrowse),IIF(n>10000 ,{nil,GRA_CLR_GREEN},{nil,GRA_CLR_YELLOW})} * bColorDate := {|d|d:=DC_GetColArray(7,oBrowse),IIF(d=Date(),{nil,GRA_CLR_BROWN},{nil,GRA_CLR_PINK})} * @ 0,0 DCBROWSE oBrowse DATA aDirectory ; * PRESENTATION LC_BrowPres() ; * SIZE 100, 20 FIT ; * HEADLINES 2 ; * FONT '8.Lucida Console' ** COLOR {||IIF(oBrowse:arrayElement%2==0,nil,{nil,GraMakeRGBColor({230,252,213})})} // Вывод поля цветом RGB @ 0,0 DCBROWSE oBrowse DATA aDirectory SIZE 88.5,25 COLOR {||RowColor(oBrowse, aDirShow)} // Управление фоном отображения строки от Роджера DCBROWSECOL ELEMENT 1 HEADER L('F1') WIDTH 13 PARENT oBrowse * DCBROWSECOL ELEMENT 2 HEADER L('F2') WIDTH 10 PARENT oBrowse COLOR bColorSize DCBROWSECOL ELEMENT 2 HEADER L('F2') WIDTH 10 PARENT oBrowse DCBROWSECOL ELEMENT 3 HEADER L('F3') WIDTH 10 PARENT oBrowse DCBROWSECOL ELEMENT 4 HEADER L('F4') WIDTH 10 PARENT oBrowse DCBROWSECOL ELEMENT 5 HEADER L('F5') WIDTH 3 PARENT oBrowse DCBROWSECOL ELEMENT 6 HEADER L('F6') WIDTH 3 PARENT oBrowse * DCBROWSECOL ELEMENT 7 HEADER L('F7') WIDTH 10 PARENT oBrowse COLOR bColorDate DCBROWSECOL ELEMENT 7 HEADER L('F7') WIDTH 10 PARENT oBrowse DCBROWSECOL ELEMENT 8 HEADER L('F8') WIDTH 10 PARENT oBrowse DCBROWSECOL ELEMENT 9 HEADER L('F9') WIDTH 10 PARENT oBrowse DCBROWSECOL ELEMENT 10 HEADER L('F10') WIDTH 10 PARENT oBrowse DCREAD GUI FIT TITLE L('Browse Test') ReTURN nil ******************************************************************************************** ******** Сохранить приложение в облаке (сходно с ЛР 3-го типа, но Inp_data.xls, 2_3_2_2.arx ******** и наименование работы загружать из облака с моего сайта) ******************************************************************************************** FUNCTION SaveAppCloud() LOCAL GetList := {}, aPres, oBrowse, oToolBar, aColors, bColor, GetOptions, oEventsKO, bItems, n:=0 Local oHttp, oResponse, cColor *** АЛГОРИТМ: *************************************************************************************************************************************** *** Сделать авторизацию имя и пароль и делать доступными для корректировки только те записи, в которых они совпадают *** или заданы имя и пароль: admin, aidos *** Сделать кнопку: "Запись на WEB-сервер каталога приложений" *** 0. Проверить, есть ли в Appl хоть одно приложение. Если нет, то ОБЯЗАТЕЛЬНО создать его. *** 1. Проверить, есть ли на компьютере Internet (ftp-доступ), и выдать сообщение, если его нет, о том, что он необходим для работы режима, и выйти *** 2. Проверить, есть ли файл Inp_data.xls в папке: c:\1\Aidos-X\AID_DATA\Inp_data\, и выдать сообщение, если его нет, о том, что он необходим, и выйти *** 3. Если на моем web-сервере есть каталог WEB-приложений, то скачать его и записать в папку с системой, *** а на сервере переименовать с датой и временем (чтобы не было конфликта обращений) (для этого и нужен FTP) *** 4. Если БД WEB-приложений не скачалась с моего WEB-сервера, создать пустую БД WEB-приложений. *** 5. Добавить в БД WEB-приложений запись о текущем приложении, созданном путем ввода данных в интерфейсе 2.3.2.2 из файла Inp_data.xls (xlsx) *** и отобразить в окне с возможностью корректировки наименования приложения и указания сведений об авторе. *** 6. Проверить, есть ли на компьютере FTP-доступ, и выдать сообщение, если его нет, о том, что он необходим для работы режима, и выйти *** 7. Создать на WEB-сервере папку исходных данных приложений: "Source_data_applications", *** а в ней папку данных нового приложения: "Applications-######" и записать в нее: *** все файлы из папки Inp_data, в т.ч.: c:\1\Aidos-X\AID_DATA\Inp_data\Inp_data.xls (xlsx), c:\1\Aidos-X\_2_3_2_2.arx *** 8. Записать каталог WEB-приложений WebAppls.dbf на сайт по FTP в папку "Source_data_applications" *** 9. Конвертировать каталог WEB-приложений WebAppls.dbf в WebAppls.html (моя программа на Питоне: dbf_to_html_py.exe) и записать его ********************************************************************************************************************************************************* *** РЕАЛИЗАЦИЯ АЛГОРИТМА *************************************************************** *** 0. Проверить, есть ли в Appl хоть одно приложение и создано ли оно при помощи одного из программных интерфейсов (API) mFlagAppl = .F. SELECT Appls DBGOTOP() DO WHILE .NOT. EOF() IF LEN(ALLTRIM(By_default)) > 0 mFlagAppl = .T. REPLACE By_default WITH "W" M_PathAppl = ALLTRIM(Path_Appl) // Путь на текущее приложение M_NameAppl = ALLTRIM(Name_Appl) EXIT ENDIF DBSKIP(1) ENDDO mFlagAPI = .F. IF FILE(Disk_dir+'\AID_DATA\Inp_data\API_type.txt') // Создано ли текущее приложение путем применения API mFlagAPI = .T. ENDIF IF .NOT. mFlagAppl .OR. .NOT. mFlagAPI // Если вообще нет приложения или оно создано без использования API, то выдать сообщение об этом aMess := {} AADD(aMess, L('В папке:')+' '+Disk_dir+'\Aid_data\Inp_data\Inp_data.xls(x)'+' '+L('нет файла: "API_type.txt"')+' '+L('с информацией об автоматизированном программном интерфейсе (API),')) AADD(aMess, L('использованном для ввода исходных данных из внешних источников данных табличного, текстового или графического типа. Необходимо установить')) AADD(aMess, L(' хотя бы одно приложение путем ввода исходных данных из файла:')+' '+Disk_dir+'\Aid_data\Inp_data\Inp_data.xls(x)'+' '+L('в API-2.3.2.2 или из других файлов из папки:')) AADD(aMess, Disk_dir+'\Aid_data\Inp_data\'+' '+L('в других программных интерфейсах (API) системы "Эйдос" (см. режим 2.3.2).')) LB_Warning(aMess, L('(c) Система "ЭЙДОС-X++"')) RETURN NIL ENDIF *** 1. Проверить, есть ли на компьютере Internet (ftp-доступ), и выдать сообщение, если его нет, о том, что он необходим для работы режима, и выйти n=0 IF InternetGetConnectedState( @n, 0 ) == 0 LB_Warning(L('Нет соединения с Internet, что необходимо для данного режима!'), L('(C) Система "Эйдос-Х++"' )) RETURN NIL ENDIF *** 2. Проверить, есть ли файл Inp_data.xls в папке: c:\1\Aidos-X\AID_DATA\Inp_data\, и выдать сообщение, если его нет, о том, что он необходим, и выйти mFlag2322 = .F. // .T. - Есть файл: _2_3_2_2.arx mFlagInpData = .F. // .T. - Есть файл: Inp_data.xls(x) DIRCHANGE(Disk_dir+"\AID_DATA\Inp_data\") // Перейти в папку Inp_data IF FILE('Inp_data.xls') .OR. FILE('Inp_data.xlsx') ELSE aMess := {} AADD(aMess, L('В папке: ')+Disk_dir+'\AID_DATA\Inp_data\') AADD(aMess, L('нет файла: "Inp_data.xls" или "Inp_data.xlsx"')) * mFlag2322 = .F. // .T. - Есть файл: _2_3_2_2.arx mFlagInpData = .F. // .T. - Есть файл: Inp_data.xls(x) * LB_Warning(aMess, L('(c) Система "ЭЙДОС-X++"') * RETURN NIL ENDIF IF .NOT. FILE('readme.pdf') aMess := {} AADD(aMess, L('В папке: ')+Disk_dir+'\AID_DATA\Inp_data\') AADD(aMess, L('отсутствует файл: "readme.pdf" с описанием сохраня- ')) AADD(aMess, L('емого интеллектуального облачного Эйдос-приложения. ')) AADD(aMess, L('Этот файл является ОБЯЗАТЕЛЬНЫМ !!! Сделайте это ')) AADD(aMess, L('описание, как описано в п.6 задания для обучающихся:')) AADD(aMess, L('https://www.researchgate.net/publication/345682484 ')) AADD(aMess, L('и повторите сохранение Эйдос-приложения в облаке. ')) LB_Warning(aMess, L('(c) Система "ЭЙДОС-X++"')) RETURN NIL ENDIF ****** Показать все файлы в папке ..\AID_DATA\Inp_data\ и отметить файлы размером > 50 Мб. ****** Если такие есть, то выдать сообщение о том, что они не будут записаны на FTP-сервер из-за ограничений хостинга. ****** Тоже самое сделать по файлам с некорретными именами PUBLIC aDir := Directory() *wtf oFtp:Directory() // VALUE: {{"Downloads.exe", 10242016, 20201202, "07:57:00", "N", 0, , "00:00:00", , "00:00:00"}} *wtf Directory() // VALUE: {{"Downloads.exe", 10242016, 20201202, "07:57:00", "N", 0, , "00:00:00", , "00:00:00"}} IF LEN(aDir) > 0 // Если папка в облаке не пустая, т.е. кроме . и .. есть хотя бы один файл **** Просмотр массива директории от Роджера PRIVATE aDirShow[Len(aDir)+1,6] mSummaSize = 0 mFlag50Mb = .F. mFlagErrName = .F. FOR j := 1 TO Len(aDir) aDirShow[j,1] = ALLTRIM(STR(j)) // File Num aDirShow[j,2] = ConvToOemCP(aDir[j,1]) // File Name aDirShow[j,3] = aDir[j,2] // File Size aDirShow[j,4] = DTOC(aDir[j,3]) // File Date aDirShow[j,5] = aDir[j,4] // File Time mSummaSize = mSummaSize + aDir[j,2] IF aDir[j,2] >= 50*1024^2 // > 50 Мб ? mFlag50Mb = .T. ENDIF *** Проверка корректности имени файла mFlagErrName = .F. IF AT(CHR(32), ConvToOemCP(aDir[j,1])) > 0 mFlagErrName = .T. ENDIF FOR i=128 TO 175 IF AT(CHR(i), ConvToOemCP(aDir[j,1])) > 0 mFlagErrName = .T. EXIT ENDIF NEXT FOR i=224 TO 240 IF AT(CHR(i), ConvToOemCP(aDir[j,1])) > 0 mFlagErrName = .T. EXIT ENDIF NEXT IF mFlagErrName * MsgBox(ConvToOemCP(aDir[j,1])) aDirShow[j,6] = 'BadName' // File BadName mFlagErrName = .T. ENDIF NEXT aDirShow[Len(aDir)+1,2] = L('Суммарный объем (байт)') aDirShow[Len(aDir)+1,3] = mSummaSize @ 0,0 DCBROWSE oBrowse DATA aDirShow SIZE 88.5,25 COLOR {||RowColor(oBrowse, aDirShow)} // Управление фоном отображения строки от Роджера DCBROWSECOL ELEMENT 1 HEADER 'File Num ' WIDTH 5 PARENT oBrowse DCBROWSECOL ELEMENT 2 HEADER 'File Name' WIDTH 20 PARENT oBrowse DCBROWSECOL ELEMENT 3 HEADER 'File Size' WIDTH 10 PARENT oBrowse DCBROWSECOL ELEMENT 4 HEADER 'File Date' WIDTH 8 PARENT oBrowse DCBROWSECOL ELEMENT 5 HEADER 'File Time' WIDTH 8 PARENT oBrowse * DCBROWSECOL ELEMENT 6 HEADER 'BadName' WIDTH 10 PARENT oBrowse // <<<===############## mMess = '' IF mFlag50Mb mMess = mMess + L('Есть файлы >= 50 Мб!') ENDIF IF mFlagErrName mMess = mMess + ' ' + L('Есть файлы с некорректными именами!') ENDIF IF LEN(mMess) > 0 @25.5,2 DCPUSHBUTTON CAPTION mMess SIZE 84, 1.5 ACTION {||Help13f(mFlag50Mb, mFlagErrName)} FONT '10.Helv Bold' ENDIF DCREAD GUI FIT TITLE L('Файлы приложения') *** Имя файла всегда последнее в строке, искать его справа налево до ":" *** Отличать имена файлов от имен папок, использовать только имена файлов ENDIF ***** Скопировать все файлы с корректными именами и размером <= 10Mb из папки ..\AID_DATA\Inp_data\ в облако N_All = ADIR("*.*") PRIVATE aFileNameAll[N_All] ADIR("*.*",aFileNameAll) // Имена ВСЕХ файлов в папке Inp_data DIRCHANGE(Disk_dir) // Перейти в папку с системой IF N_All = 0 aMess := {} AADD(aMess, L('В папке: ')+Disk_dir+L('"\AID_DATA\Inp_data\" нет файлов.')) AADD(aMess, L('Записывать нечего!')) mFlag2322 = .F. // .T. - Есть файл: _2_3_2_2.arx * mFlagInpData = .F. // .T. - Есть файл: Inp_data.xls(x) LB_Warning(aMess, L('(c) Система "ЭЙДОС-X++"')) RETURN NIL ENDIF *** 3. Если на моем web-сервере есть TXT-БД приложений, то скачать ее и записать в виде файла в папку с системой, *** а на сервере переименовать (чтобы не было конфликта обращений, но для этого нужно FTP) * ***** Получить файл "WebAppls.dbf", используя только HTTP (GetWeb.prg, Boris Borzic) * oHttp := xbHTTPClient():new() * oHttp:Transport := VIA_WININET * oResponse := oHttp:Execute( 'http://lc.kubagro.ru/WebAppls.dbf' ) * mFlagConvert = .T. // .T. - преобразовывать в DBF (есть что) * mABC = oResponse:Content * IF AT('was not found on this server', mABC) = 0 * StrFile(mABC,'WebAppls.dbf') // Записать WebAppls.dbf в виде файла на диск в папку с системой * ELSE ** LB_Warning(L('На web-сервере системы "Эйдос" нет файла: "WebAppls.dbf"'), L('(c) Система "ЭЙДОС-X++"')) * mFlagConvert = .F. // .F. - не преобразовывать в DBF (нечего преобразовывать) * ENDIF *** 3. Если на моем FTP-сервере есть каталог WEB-приложений, то скачать его и записать в папку с системой, *** а на сервере переименовать с датой и временем (чтобы не было конфликта обращений) (для этого и нужен FTP) oScrn := DC_WaitOn( L('Загрузка каталога WEB-приложений "WebAppls.dbf" с FTP-сервера системы "Эйдос-Х++"' ),,,,,,,,,,,.F.) mFlagLoad = .F. // .F. - база WebAppls.dbf не скачалась ********************************************************************************************************** Xb2NetKey() cFtpServer:="94.25.18.114" // Это везде одинаково <<<===############ oFtp := FTPClient():new( cFtpServer, Ftp_User, Ftp_Passw ) // Соединение с моим сайтом и авторизация IF oFtp:connect() // Есть соединение с моим сайтом и авторизация? ********************************************************************************************************** **** Создать папку: ftp://lc.kubagro.ru/public_html/Source_data_applications (если ее еще нет) * MsgBox(oFtp:curDir()) oFtp:curDir("/") oFtp:curDir("public_html") * MsgBox(oFtp:curDir()) IF oFtp:CurDir() <> "\public_html" DC_Impl(oScrn) LB_Warning(L('Не удалось сделать текущей директорию: "\public_html"'), L('(C) Система "Эйдос-Х++"' )) ENDIF **** Сделать текущей папку: ftp://94.25.18.114/public_html/Source_data_applications * MsgBox(oFtp:curDir()) oFtp:curDir("Source_data_applications") * MsgBox(oFtp:curDir()) IF oFtp:curDir() <> "\public_html\Source_data_applications" DC_Impl(oScrn) LB_Warning(L('Не удалось сделать текущей директорию: "\public_html\Source_data_applications"'), L('(C) Система "Эйдос-Х++"' )) RETURN NIL ENDIF IF oFtp:GetFile("WebAppls.dbf") DC_Impl(oScrn) * LB_Warning(L('Загрузка каталога WEB-приложений: "WebAppls.dbf" с FTP-сервера завершена успешно'), L('(C) Система "Эйдос-Х++"' )) mFlagLoad = .T. // .T. - база WebAppls.dbf скачалась mDateTime = DTOC(DATE())+"-"+TIME() mDateTime = STRTRAN(mDateTime, ":", "_") IF ! oFtp:PutFile("WebAppls.dbf", "WebAppls_"+mDateTime+".DBF") DC_Impl(oScrn) LB_Warning(L('*** ERROR: Unable to rename file!'), L('(C) Система "Эйдос-Х++"' )) ENDIF ELSE * DC_Impl(oScrn) * LB_Warning(L('На FTP-сервере в данный момент нет базы данных: "WebAppls.dbf"'), L('(C) Система "Эйдос-Х++"' )) ENDIF ELSE DC_Impl(oScrn) LB_Warning(L('Нет соединения с FTP-сервером'), L('(C) Система "Эйдос-Х++"')) oFtp:disconnect() RETURN NIL ENDIF DC_Impl(oScrn) *** 4. Если БД WEB-приложений не скачалась с моего WEB-сервера *** - и ее там и не было, т.е. там нет файлов вида: "WebAppls_30.05.2017-22_17_43.DBF" (это определить), *** то создать пустую БД WEB-приложений, *** - а если была, т.е. есть файлы вида: "WebAppls_30.05.2017-22_17_43.DBF", *** то выдать сообщение о том, чтобы подождали и попробовали еще раз через несколько минут IF .NOT. mFlagLoad ****** Определить, если в папке файлы вида: WebAppls_30.05.2017-22_17_43.DBF ****** Просмотр массива директории с FTP-сервера от Роджера PUBLIC aDir := oFtp:Directory() // Борис Борзик, для этого нужен только FTP, т.к. под HTTP не работает oHttp:Directory() mFlagBe = .F. FOR i := 1 TO Len(aDir) IF AT("_", aDir[i]) > 0 mFlagBe = .T. EXIT ENDIF NEXT IF mFlagBe aMess := {} AADD(aMess, L('В данный момент каталог WEB-приложений "WebAppls.dbf" на FTP-сервере занят другими')) AADD(aMess, L('пользователями. Попробуйте повторить попытку записи приложения через несколько минут.')) LB_Warning(aMess, L('(C) Система "Эйдос-Х++"' )) RETURN NIL ELSE aStructure := { { "Num_Appl" , "C", 5, 0 }, ; // 1 { "Appl_Type" , "C", 30, 0 }, ; // 2 { "Appl_Name" , "C",250, 0 }, ; // 3 { "Authors" , "C",120, 0 }, ; // 4 { "Country" , "C", 30, 0 }, ; // 5 { "Region" , "C", 50, 0 }, ; // 6 { "City" , "C", 30, 0 }, ; // 7 { "Firm" , "C", 30, 0 }, ; // 8 { "E_mail" , "C",250, 0 }, ; // 9 { "Date" , "C", 10, 0 }, ; // 10 { "Time" , "C", 8, 0 } } // 11 DbCreate( 'WebAppls', aStructure ) ENDIF ENDIF oFtp:disconnect() ******* Отображение БД ******* /* ----- Create ToolBar ----- */ mStr1 = 'Помощь' mStr2 = 'Форум по АСК-анализу и системе "Эйдос"' mStr3 = '1.Добавить приложение в каталог WEB-приложений' mStr4 = '2.Копировать информацию о приложении из пред.записи' * mStr5 = 'Сохранить каталог WEB-приложений в облаке' mStr6 = '3.Сохранить приложение в облаке' mStr7 = 'Каталог обсуждений' mStr8 = 'Обсуждение Эйдос-приложения' d = 7 @36.5, 0 DCPUSHBUTTON CAPTION mStr1 SIZE LEN(mStr1)+3, 1.5 ACTION {||Help13web() , DC_GetRefresh(GetList)} @36.5, DCGUI_COL+d DCPUSHBUTTON CAPTION mStr2 SIZE LEN(mStr2)-4, 1.5 ACTION {||LC_RunUrl("https://www.reddit.com/user/prof_E_V_Lutsenko")} @36.5, DCGUI_COL+d DCPUSHBUTTON CAPTION mStr3 SIZE LEN(mStr3)-0, 1.5 ACTION {||AddRecCatWebAppls() , DC_GetRefresh(GetList)} FONT '9.Arial Bold' @36.5, DCGUI_COL+d DCPUSHBUTTON CAPTION mStr4 SIZE LEN(mStr4)-1, 1.5 ACTION {||CopyInfAuthors() , DC_GetRefresh(GetList)} FONT '9.Arial Bold' * @36.5, DCGUI_COL+d DCPUSHBUTTON CAPTION mStr5 SIZE LEN(mStr5)-4, 1.5 ACTION {||SaveCatWebAppls(.T.) , DC_GetRefresh(GetList)} @36.5, DCGUI_COL+d DCPUSHBUTTON CAPTION mStr6 SIZE LEN(mStr6)+1, 1.5 ACTION {||SaveWebApplCloud() , DC_GetRefresh(GetList)} FONT '9.Arial Bold' @36.5, DCGUI_COL+d DCPUSHBUTTON CAPTION mStr7 SIZE LEN(mStr7)+0, 1.5 ACTION {||DiscCatalog(0,'','') , DC_GetRefresh(GetList)} @36.5, DCGUI_COL+d DCPUSHBUTTON CAPTION mStr8 SIZE LEN(mStr8)-1, 1.5 ACTION {||DiscAppl(VAL(ALLTRIM(WebAppls->Num_Appl)), ALLTRIM(WebAppls->Appl_Name)), DC_GetRefresh(GetList)} ****** Отображение таблицы *************** DIRCHANGE(Disk_dir) // Перейти в папку с системой CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций IF .NOT. FILE("WebAppls.dbf") aMess := {} AADD(aMess, L('Не удалось скачать с FTP-сервера системы "Эйдос" каталог')) AADD(aMess, L('интеллектуальных облачных Эйдос-приложений: "WebAppls.dbf"')) LB_Warning(aMess, L('(C) Система "Эйдос-Х++"' )) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) ReTURN nil ENDIF IF FILESIZE("WebAppls.dbf") = 0 aMess := {} AADD(aMess, L('Размер скачанного с FTP-сервера системы "Эйдос" каталога')) AADD(aMess, L('интеллектуальных облачных Эйдос-приложений: "WebAppls.dbf"')) AADD(aMess, L('равен 0. Обратитесь к автору и разработчику системы "Эйдос"')) LB_Warning(aMess, L('(C) Система "Эйдос-Х++"' )) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) ReTURN nil ENDIF USE WebAppls EXCLUSIVE NEW USE Appls EXCLUSIVE NEW SELECT WebAppls N_Appls = RECCOUNT() *DBGOBOTTOM() DBGOTO(RECCOUNT()-15) DCSETPARENT TO @ 1, 0 DCBROWSE WebAppls ALIAS 'WebAppls' SIZE 221,35 ; EDIT xbeBRW_ItemSelected MODE DCGUI_BROWSE_EDITDOWN ; // Редактирование БД NOSOFTTRACK ; HEADLINES 2 ; // Кол-во строк в заголовке (перенос строки - ";") SCOPE ; ITEMMARKED bItems * ITEMSELECTED {|| LC_RunUrl(WebAppls->E_mail) } // При записи каталога клик должен приводить к редактированию, а не скачиваю описания * COLOR {||IIF(mLogin=Login .AND. mPassw=Password, {nil,GRA_CLR_GREEN},{nil,GRA_CLR_WHITE})} // Управление фоном отображения строки от Роджера DCSETPARENT WebAppls *** Подарок от Роджера * aStructure := { { "Num_Appl" , "C", 5, 0 }, ; // 1 * { "Appl_Type" , "C", 30, 0 }, ; // 2 * { "Appl_Name" , "C",250, 0 }, ; // 3 * { "Authors" , "C",120, 0 }, ; // 4 * { "Country" , "C", 30, 0 }, ; // 5 * { "Region" , "C", 50, 0 }, ; // 6 * { "City" , "C", 30, 0 }, ; // 7 * { "Firm" , "C", 30, 0 }, ; // 8 * { "E_mail" , "C",130, 0 }, ; // 9 * { "Date" , "C", 10, 0 }, ; // 10 * { "Time" , "C", 8, 0 }, ; // 11 ** Если другие пользователи, то проверять имя и пароль в базе на совпадение с заданными в диалоге, ** отмечать строки с совпадением светло-зеленым цветом и разрешать ее редактирование d=3 DCBROWSECOL FIELD WebAppls->Num_Appl HEADER L("Номер;приложения" ) PARENT WebAppls FONT "9.Courier" WIDTH 5+d PROTECT {|| .T. } COLOR {||IIF(RECNO()=N_Appls+1, {nil,aColor[38]},{nil,aColor[100]})} DCBROWSECOL FIELD WebAppls->Appl_Type HEADER L("Тип приложения" ) PARENT WebAppls FONT "9.Courier" WIDTH 10+d PROTECT {|| IIF(RECNO()=N_Appls+1,.F.,.T.) } COLOR {||IIF(RECNO()=N_Appls+1, {nil,aColor[38]},{nil,aColor[100]})} DCBROWSECOL FIELD WebAppls->Appl_Name HEADER L("Наименование приложения") PARENT WebAppls FONT "9.Courier" WIDTH 65+d PROTECT {|| IIF(RECNO()=N_Appls+1,.F.,.T.) } COLOR {||IIF(RECNO()=N_Appls+1, {nil,aColor[38]},{nil,aColor[100]})} DCBROWSECOL FIELD WebAppls->Authors HEADER L("Авторы приложения" ) PARENT WebAppls FONT "9.Courier" WIDTH 30+d PROTECT {|| IIF(RECNO()=N_Appls+1,.F.,.T.) } COLOR {||IIF(RECNO()=N_Appls+1, {nil,aColor[38]},{nil,aColor[100]})} DCBROWSECOL FIELD WebAppls->Country HEADER L("Страна" ) PARENT WebAppls FONT "9.Courier" WIDTH 15+d PROTECT {|| IIF(RECNO()=N_Appls+1,.F.,.T.) } COLOR {||IIF(RECNO()=N_Appls+1, {nil,aColor[38]},{nil,aColor[100]})} DCBROWSECOL FIELD WebAppls->Region HEADER L("Регион" ) PARENT WebAppls FONT "9.Courier" WIDTH 20+d PROTECT {|| IIF(RECNO()=N_Appls+1,.F.,.T.) } COLOR {||IIF(RECNO()=N_Appls+1, {nil,aColor[38]},{nil,aColor[100]})} DCBROWSECOL FIELD WebAppls->City HEADER L("Город" ) PARENT WebAppls FONT "9.Courier" WIDTH 15+d PROTECT {|| IIF(RECNO()=N_Appls+1,.F.,.T.) } COLOR {||IIF(RECNO()=N_Appls+1, {nil,aColor[38]},{nil,aColor[100]})} DCBROWSECOL FIELD WebAppls->Firm HEADER L("Фирма" ) PARENT WebAppls FONT "9.Courier" WIDTH 20+d PROTECT {|| IIF(RECNO()=N_Appls+1,.F.,.T.) } COLOR {||IIF(RECNO()=N_Appls+1, {nil,aColor[38]},{nil,aColor[100]})} DCBROWSECOL FIELD WebAppls->E_mail HEADER L("Гиперссылка;E-mail" ) PARENT WebAppls FONT "9.Courier" WIDTH 20+d PROTECT {|| IIF(RECNO()=N_Appls+1,.F.,.T.) } COLOR {||IIF(RECNO()=N_Appls+1, {nil,aColor[38]},{nil,aColor[100]})} DCBROWSECOL FIELD WebAppls->Date HEADER L("Дата;ДД.ММ.ГГГГ" ) PARENT WebAppls FONT "9.Courier" WIDTH 11+d PROTECT {|| .T. } COLOR {||IIF(RECNO()=N_Appls+1, {nil,aColor[38]},{nil,aColor[100]})} DCBROWSECOL FIELD WebAppls->Time HEADER L("Время;ЧЧ:ММ:СС" ) PARENT WebAppls FONT "9.Courier" WIDTH 8+d PROTECT {|| .T. } COLOR {||IIF(RECNO()=N_Appls+1, {nil,aColor[38]},{nil,aColor[100]})} DCGETOPTIONS SAYFONT '10.Helv Bold' TABSTOP AUTORESIZE DCREAD GUI ; FIT ; OPTIONS GetOptions ; MODAL ; TITLE L('Запись приложения на WEB-сервер системы "Эйдос-Х++"') ; EVAL {|o|SetAppFocus(WebAppls:GetColumn(1))} ******* Записать БД 'WebAppls.dbf' по FTP на сайт: http://lc.kubagro.ru SaveCatWebAppls(.F.) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) ReTURN nil *********************************************************************************************************** ******** Сообщение о том, что файлы размером больше 50 мегабайт не могут быть записаны на FTP-сервер *********************************************************************************************************** FUNCTION Help13f() * https://www.splitapdf.com/ru/pdfsplitform // Разбить файлы на части меньше заданного размера IF mFlag50Mb DCSETFONT TO '10.Helv' s=0 @ s++,1 DCSAY L('Файлы приложения размером больше 50 Мб (выделены золотистым фоном) ') SAYSIZE 0 @ s++,1 DCSAY L('не будут записаны на FTP-сервер системы "Эйдос" из-за ограничений ') SAYSIZE 0 @ s++,1 DCSAY L('хостинга, т.к. сразу после загрузки они автоматически удаляются. ') SAYSIZE 0 @ s++,1 DCSAY L('') SAYSIZE 0 @ s++,1 DCSAY L('Такие файлы можно заархивировать rar,zip. Даже если сжатие не очень ') SAYSIZE 0 @ s++,1 DCSAY L('велико, все равно архив может оказаться < 50 Мб (см. приложение № 277)') SAYSIZE 0 @ s++,1 DCSAY L('') SAYSIZE 0 @ s++,1 DCSAY L('Если больше 50 Мб pdf-файл описания приложения "readme.pdf", то можно ') SAYSIZE 0 @ s++,1 DCSAY L('либо при сохранении в ворде задать: Минимальный размер (публикация в ') SAYSIZE 0 @ s++,1 DCSAY L(' Internet), либо бесплтано сжать pdf онлайн: ') SAYSIZE 0 @ s++,1 DCSAY L('https://www.ilovepdf.com/ru/compress_pdf') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'https://www.ilovepdf.com/ru/compress_pdf', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} @ s++,1 DCSAY L('') SAYSIZE 0 @ s++,1 DCSAY L('Если > 50 Мб pdf-файл описания приложения "readme.pdf", то можно также') SAYSIZE 0 @ s++,1 DCSAY L('раздробить его на файлы размером менее 50 Мб на на онлайн сервисе: ') SAYSIZE 0 @ s++,1 DCSAY L('https://www.splitapdf.com/ru/pdfsplitform') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'https://www.splitapdf.com/ru/pdfsplitform', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} @ s++,1 DCSAY L('') SAYSIZE 0 @ s++,1 DCSAY L('При этом 1-й файл ОБЯЗАТЕЛЬНО должен иметь имя: "readme.pdf" ') SAYSIZE 0 ENDIF IF mFlagErrName @ 5,1 DCSAY L('') SAYSIZE 0 @ 6,1 DCSAY L('Розовым фоном выделены файлы, в наименованиях которых есть пробелы ') SAYSIZE 0 @ 7,1 DCSAY L('и/или кириллица. Эти файлы также не будут записаны на FTP-сервер, т.к.') SAYSIZE 0 @ 8,1 DCSAY L('хостинг не поддерживает никаких операций с такими файлами, даже Del. ') SAYSIZE 0 @ 9,1 DCSAY L('Файлы с русскими именами можно разместить в rar(zip)-архиве, который ') SAYSIZE 0 @10,1 DCSAY L('разместить в Эйдос-облаке. ') SAYSIZE 0 ENDIF DCREAD GUI FIT TITLE L('Об ограничениях на размер и имена файлов на FTP-сервере') RETURN nil ******** Добавить приложение в каталог WEB-приложений FUNCTION AddRecCatWebAppls() *** 5. Добавить в БД WEB-приложений запись о текущем приложении, созданном путем ввода данных в интерфейсе 2.3.2.2 из файла Inp_data.xls (xlsx) *** и отобразить в окне с возможностью корректировки информации только в записи о добавленном приложении DIRCHANGE(Disk_dir) // Перейти в папку с системой CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE WebAppls EXCLUSIVE NEW USE Appls EXCLUSIVE NEW SELECT Appls DBGOTOP() DO WHILE .NOT. EOF() IF LEN(ALLTRIM(By_default)) > 0 REPLACE By_default WITH "W" M_PathAppl = ALLTRIM(Path_Appl) // Путь на текущее приложение M_NameAppl = ALLTRIM(Name_Appl) EXIT ENDIF DBSKIP(1) ENDDO ****** Добавить запись о новом приложении SELECT WebAppls APPEND BLANK REPLACE Num_Appl WITH ALLTRIM(STR(RECNO())) REPLACE Appl_Name WITH ALLTRIM(M_NameAppl) REPLACE Date WITH DTOC(DATE()) REPLACE Time WITH TIME() ******* Проверить, есть ли в файлах приложения PDF-файл, и, если есть, то сфорировать ******* гиперссылку на него и записать ее в поле E_MAIL каталога WEB-приложений mAN = ALLTRIM(WebAppls->Appl_Name) mApplName = "Applications-"+STRTRAN(STR(VAL(ALLTRIM(Num_Appl)),6),' ','0') // Сформировать имя папки приложения mPdf = '' FOR j=1 TO LEN(aFileNameAll) IF AT('.PDF',UPPER(aFileNameAll[j])) > 0 mPdf = 'http://lc.kubagro.ru/Source_data_applications/'+mApplName+'/'+aFileNameAll[j] ENDIF NEXT ****** Вставить гиперссылку на PDF-файл, если он есть, в каталог приложений IF LEN(mPdf) > 0 REPLACE E_MAIL WITH mPdf ENDIF *DBGOBOTTOM() DBGOTO(RECCOUNT()-15) ReTURN nil ************************************** ******** Сохранить приложение в облаке ************************************** FUNCTION SaveWebApplCloud() *** 6. Проверить, есть ли на компьютере FTP-доступ, и выдать сообщение, если его нет, о том, что он необходим для работы режима, и выйти *** 7. Записать каталог WEB-приложений на сайт по FTP *** 8. Создать на WEB-сервере папку исходных данных приложений: "Source_data_applications", *** а в ней папку данных нового приложения: "Applications-######" и записать в нее (все файлы из папки Inp_data): *** - c:\1\Aidos-X\AID_DATA\Inp_data\Inp_data.xls (xlsx) и т.д., и т.д., ВСЕ *** - c:\1\Aidos-X\_2_3_2_2.arx ****** Если WEB-база исходных данных приложений не пуста, то записать информацию о последнем приложении на WEB-сервер CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE WebAppls EXCLUSIVE NEW SELECT WebAppls aBigFileName := {} IF RECCOUNT() > 0 DBGOBOTTOM() mAN = ALLTRIM(WebAppls->Appl_Name) mApplName = "Applications-"+STRTRAN(STR(VAL(ALLTRIM(Num_Appl)),6),' ','0') ********************************************************************************************************** Xb2NetKey() cFtpServer:="94.25.18.114" // Это везде одинаково <<<===############ oFtp := FTPClient():new( cFtpServer, Ftp_User, Ftp_Passw ) // Соединение с моим сайтом и авторизация IF oFtp:connect() // Есть соединение с моим сайтом и авторизация? ********************************************************************************************************** **** Сделать текущей папку: ftp://94.25.18.114/public_html/Source_data_applications * MsgBox(oFtp:curDir()) //<<<===############### oFtp:CurDir("/") oFtp:curDir("public_html") oFtp:curDir("Source_data_applications") * aDirSite := oFtp:Directory("*.*","D") //<<<===############### * DC_DebugQout( aDirSite ) //<<<===############### * MsgBox(oFtp:curDir()) //<<<===############### IF oFtp:curDir() <> "\public_html\Source_data_applications" DC_Impl(oScrn) LB_Warning(L('Не удалось сделать текущей директорию: "\public_html\Source_data_applications"'), L('(C) Система "Эйдос-Х++"' )) RETURN NIL ENDIF **** Создать папку нового приложения: ftp://lc.kubagro.ru/public_html/Source_data_applications/'+mApplName IF !oFtp:createDir(mApplName) DC_Impl(oScrn) LB_Warning(L('Не удалось создать директорию: \public_html\Source_data_applications\"'+mApplName+'"'), L('(C) Система "Эйдос-Х++"' )) RETURN NIL ENDIF **** Сделать текущей папку нового приложения: ftp://lc.kubagro.ru/public_html/Source_data_applications/'+mApplName * MsgBox('3. Исходная директория: '+oFtp:curDir()) oFtp:curDir("\public_html\Source_data_applications") oFtp:curDir(mApplName) * MsgBox('3. Должна быть директория: \public_html\Source_data_applications'+mApplName+', а фактически: '+oFtp:curDir()) * oScrn := DC_WaitOn( L('Запись на FTP-сервер системы "Эйдос-Х++" исходных данных приложения: '+mApplName ),,,,,,,,,,,.F.) DIRCHANGE(Disk_dir+"\AID_DATA\Inp_data\") // Перейти в папку Inp_data aBigFileName := {} // Файлы больше 50 Мб aBadFileName := {} // Файлы, в именах которых есть пробелы и кириллица *** Запись всех корректных файлов из папки Inp_data на FTP-сервер системы "Эйдос-Х++" IF LEN(aFileNameAll) > 0 *** Проверка корректности размеров и имен файлов FOR j=1 TO LEN(aFileNameAll) *** Проверка корректности имени файла mFlagErrName = .F. IF AT(CHR(32), ConvToOemCP(aFileNameAll[j])) > 0 mFlagErrName = .T. ENDIF FOR i=128 TO 175 IF AT(CHR(i), ConvToOemCP(aFileNameAll[j])) > 0 mFlagErrName = .T. EXIT ENDIF NEXT FOR i=224 TO 240 IF AT(CHR(i), ConvToOemCP(aFileNameAll[j])) > 0 mFlagErrName = .T. EXIT ENDIF NEXT IF mFlagErrName // На FTP-сервер записывать только файлы с корректными именами <<<===#################### AADD(aBadFileName, aFileNameAll[j]) ENDIF IF FILESIZE(aFileNameAll[j]) >= 50*1024^2 // На FTP-сервер записывать только файлы размером < 50 Mb <<<===#################### AADD(aBigFileName, aFileNameAll[j]) ENDIF NEXT *** Запись всех корректных файлов из папки Inp_data на FTP-сервер системы "Эйдос-Х++" ************************************************************************************* *** Отображение стадии и прогноза времени исполнения ******************************** ************************************************************************************* Wsego = LEN(aFileNameAll) mTitleName = L('Запись в Эйдос-облако приложения:')+' №'+ALLTRIM(WebAppls->Num_Appl)+'-'+SUBSTR(ALLTRIM(ALLTRIM(WebAppls->Appl_Name)),1,47) // Отображение стадии исполнения. Будет написано прямо в окне Progress-bar d = 0 @0,0 DCGROUP oGroup1 CAPTION L('Стадии исполнения процесса') FONT "6.Helv" SIZE 105+d, 2.5 PARENT oTabPage1 @4,0 DCGROUP oGroup2 CAPTION L('Прогноз времени исполнения') FONT "6.Helv" SIZE 105+d, 5.0 PARENT oTabPage2 s = 1 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 1] FONT "10.Helv" s++ @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay97 FONT "10.HelvBold" s++ @0.2+s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay98 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @1.5+s ,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay99 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @s ,1 DCPROGRESS oProgress ; SIZE 95,1.5 ; PERCENT ; EVERY 1+INT(Wsego/nEvery) ; // Кол-во обновлений изображения MAXCOUNT Wsego ; COLOR GRA_CLR_CYAN // Цвет полосы @s++,97 DCPUSHBUTTON CAPTION L('&Cancel') ; ACTION {||lOk:=.T.} OBJECT oButton ; SIZE 7,1.5 DCREAD GUI ; TITLE mTitleName ; PARENT @oDialog ; FIT ; EXIT ; MODAL oDialog:alwaysOnTop = .T. // Окно открывается на переднем плане oDialog:show() // Начало отсчета времени для прогнозирования длительности исполнения Time_progress = 0 // Прошло секунд с начала процесса // Процесс может идти больше суток, поэтому для определения // во всех случаях вычисляется время, прошедшее с начала года T_Mess1 = L("Начало:")+" "+TIME() // Начало Sec_1 = (DOY(DATE())-1)*86400+SECONDS() PUBLIC T1 := (DOY(DATE())-1)*86400+SECONDS() // Время предыдущей индикации процесса исполнения PUBLIC T2 := (DOY(DATE())-1)*86400+SECONDS()+1 // Текущее время (1-й раз оно заметно больше T1 чтобы было отображение) PUBLIC T1tp := T1 PUBLIC T2tp := T2 ********************************************************************************* FOR j=1 TO LEN(aFileNameAll) IF ASCAN(aBigFileName, aFileNameAll[j]) + ASCAN(aBadFileName, aFileNameAll[j]) = 0 * oScrn := DC_WaitOn( L('Запись на FTP-сервер системы "Эйдос-Х++" исходных данных приложения:')+' '+mApplName+L('. Записан файл:')+' '+ALLTRIM(STR(j))+'/'+ALLTRIM(STR(LEN(aFileNameAll)))+'-"'+ALLTRIM(ConvToOemCP(aFileNameAll[j]))+'"',,,,,,,,,,,.F. ) aSay[ 1]:SetCaption(L('Обрабатывается файл:')+' '+' '+mApplName+L('. Записан файл:')+' '+ALLTRIM(STR(j))+'/'+ALLTRIM(STR(LEN(aFileNameAll)))+'-"'+ALLTRIM(ConvToOemCP(aFileNameAll[j]))+'"') IF oFtp:PutFile(aFileNameAll[j], ConvToOemCP(aFileNameAll[j]) ) * IF oFtp:PutFile(aFileNameAll[j], ConvToAnsiCP(aFileNameAll[j]) ) * IF oFtp:PutFile(aFileNameAll[j], Str2Unicode(aFileNameAll[j]) ) * MsgBox('STOP') * DC_Impl(oScrn) * LB_Warning(L('Запись файла: "')+ConvToOemCP(aFileNameAll[j])+L('" на FTP-сервер завершена успешно'), L('(C) Система "Эйдос-Х++"' )) ENDIF * DC_Impl(oScrn) ENDIF *** Отображение стадии и прогноза времени исполнения **************** lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) NEXT ELSE DC_Impl(oScrn) LB_Warning(L('В папке: ')+Disk_dir+L('"\AID_DATA\Inp_data\" нет файлов. Записывать нечего!'), L('(C) Система "Эйдос-Х++"' )) ENDIF DIRCHANGE(Disk_dir) // Перейти в папку с системой ENDIF ENDIF * DC_Impl(oScrn) oFtp:disconnect() oSay97:SetCaption(L("Загрузка файлов приложения с ftp-сервера успешно завершена !!!")) MILLISEC(5000) oSay97:SetCaption(oSay97:caption) oButton:SetCaption(L('&Ok')) // Деструктурирование окна отображения графического Progress-bar oButton:activate := {||PostAppEvent(xbeP_Close,,,oDialog)} //<<<<<< Add This DC_AppEvent( @lOk ) PostAppEvent(xbeP_Activate,,,DC_GetObject(GetList,'DCGUI_BUTTON_OK')) // Роджер oDialog:Destroy() aMess := {} AADD(aMess, L('Запись на FTP-сервер системы "Эйдос-Х++" исходных данных приложения:')) AADD(aMess, L('"')+ALLTRIM(WebAppls->Appl_Name)+'"') AADD(aMess, L('из папки: ')+Disk_dir+L('\AID_DATA\Inp_data\ завершена успешно!')) IF mFlagInpData // .T. - Есть файл: Inp_data.xls(x) AADD(aMess, L(' ')) AADD(aMess, L('Cреди записанных файлов не было файла: "Inp_data.xls(x)"')) ENDIF IF LEN(aBigFileName) > 0 AADD(aMess, L(' ')) AADD(aMess, L('Файлы больше 50 Мб на FTP-сервер не записывались, т.к. они ')) AADD(aMess, L('сразу же после записи были бы автоматичеси удалены хостингом.')) AADD(aMess, L('Список файлов размером => 50 Мб, незаписанных на FTP-сервер: ')) FOR j=1 TO LEN(aBigFileName) AADD(aMess, ConvToOemCP(aBigFileName[j])) NEXT ENDIF IF LEN(aBadFileName) > 0 AADD(aMess, L(' ')) AADD(aMess, L('Файлы, в именах которых есть пробелы и кириллица на FTP-сервер не записывались, так как он не поддерживает никаких')) AADD(aMess, L('операций с такими файлами, даже удаления. Рекомендуем заархивировать все такие файлы в один архив в имени которого')) AADD(aMess, L('не должно быть пробелов и кириллицы. При скачивании приложения из облака система обнаружит архив и рекомендует его')) AADD(aMess, L('развернуть. Список файлов, в именах которых есть пробелы и кириллица, незаписанных на FTP-сервер, приведен ниже: ')) FOR j=1 TO LEN(aBadFileName) AADD(aMess, ConvToOemCP(aBadFileName[j])) NEXT ENDIF AADD(aMess, L(' ')) AADD(aMess, L("Для завершения записи Эйдос-приложения в облако необходимо")) AADD(aMess, L("последовательно закрыть все окна и выйти в главное окно режима 1.3.")) LB_Warning(aMess, L('(C) Система "Эйдос-Х++"' )) DBGOBOTTOM() ReTURN nil ******** Сохранить каталог WEB-приложений в облаке FUNCTION SaveCatWebAppls(mPar) CloseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы * LC_RunShell("dbf_to_html_py.exe",200368259) // dbf_to_html, написанный на # Питоне # и откомпилированный auto-py-to-exe * LC_RunShellAidosPy(717400306, "dbf_to_html_py") LC_RunShell("__AIDOS-PY.exe", 717400306, "dbf_to_html_py") // Мой вариант на Питоне в системе __AIDOS-PY.exe mRecno = RECNO() ******* Записать БД 'WebAppls.dbf' по FTP на сайт: http://lc.kubagro.ru CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций ********************************************************************************************************** Xb2NetKey() cFtpServer:="94.25.18.114" // Это везде одинаково <<<===############ oFtp := FTPClient():new( cFtpServer, Ftp_User, Ftp_Passw ) // Соединение с моим сайтом и авторизация IF oFtp:connect() // Есть соединение с моим сайтом и авторизация? ********************************************************************************************************** **** Сделать текущей папку: ftp://94.25.18.114/public_html/Source_data_applications * MsgBox(oFtp:curDir()) //<<<===############### oFtp:CurDir("/") oFtp:curDir("public_html") oFtp:curDir("Source_data_applications") * aDirSite := oFtp:Directory("*.*","D") //<<<===############### * DC_DebugQout( aDirSite ) //<<<===############### * MsgBox(oFtp:curDir()) //<<<===############### IF oFtp:curDir() <> "\public_html\Source_data_applications" DC_Impl(oScrn) LB_Warning(L('Не удалось сделать текущей директорию: "\public_html\Source_data_applications"'), L('(C) Система "Эйдос-Х++"' )) RETURN NIL ENDIF oScrn := DC_WaitOn( L('Запись каталога WEB-приложений "WebAppls.dbf" на FTP-сервер системы "Эйдос-Х++"' ),,,,,,,,,,,.F.) IF oFtp:PutFile("WebAppls.dbf", "WebAppls.dbf") DC_Impl(oScrn) IF mPar LB_Warning(L('Запись базы данных: "WebAppls.dbf" на FTP-сервер завершена успешно'), L('(C) Система "Эйдос-Х++"' )) ENDIF ENDIF oScrn := DC_WaitOn( L('Запись каталога WEB-приложений "WebAppls.html" на FTP-сервер системы "Эйдос-Х++"' ),,,,,,,,,,,.F.) IF oFtp:PutFile("WebAppls.html", "WebAppls.html") DC_Impl(oScrn) IF mPar LB_Warning(L('Запись базы данных: "WebAppls.html" на FTP-сервер завершена успешно'), L('(C) Система "Эйдос-Х++"' )) ENDIF ENDIF oScrn := DC_WaitOn( L('Запись каталога WEB-приложений "WebAppls.htm" на FTP-сервер системы "Эйдос-Х++"' ),,,,,,,,,,,.F.) IF oFtp:PutFile("WebAppls.html", "WebAppls.htm") DC_Impl(oScrn) IF mPar LB_Warning(L('Запись базы данных: "WebAppls.htm" на FTP-сервер завершена успешно'), L('(C) Система "Эйдос-Х++"' )) ENDIF ENDIF ELSE DC_Impl(oScrn) LB_Warning(L('Нет соединения с FTP-сервером'), L('(C) Система "Эйдос-Х++"')) RETURN NIL ENDIF CloseAll() // Закрытие всех баз данных с ожиданием завершения операций USE WebAppls EXCLUSIVE NEW SELECT WebAppls DBGOBOTTOM() ReTURN nil ******** Копировать информацию о новом приложении и авторах (т.е. в последнюю запись) из предпоследней записи FUNCTION CopyInfAuthors() LOCAL GetList := {}, aPres, oBrowse, oToolBar, aColors, bColor, GetOptions, mNumAppl := SPACE(12) IF RECNO() > 1 ******* Задать номер приложения, из которого копировать информацию DBGOTO(RECCOUNT()-1) mNumAppl = NUM_APPL @0.0,0 DCGROUP oGroup1 CAPTION L('Задайте № приложения, из которого копировать информацию:') SIZE 50.0, 2.5 @1,2 DCSAY L("№ приложения:") PARENT oGroup1 @1,15 DCGET mNumAppl PICTURE "XXXXXXXXXXXX" PARENT oGroup1 DCREAD GUI; TO lExit ; FIT; ADDBUTTONS; MODAL; TITLE L('(c) Задание № облачного Эйдос-приложения') ******************************************************************** IF lExit ** Button Ok ELSE * ADS_SERVER_QUIT() QUIT ENDIF ******************************************************************** * MsgBox(mNumAppl) mFlagNumAppl = .F. DBGOTOP() DO WHILE .NOT. EOF() IF ALLTRIM(mNumAppl) = ALLTRIM(NUM_APPL) mRecno = RECNO() mFlagNumAppl = .T. // Приложение с заданным номером найдено EXIT ENDIF DBSKIP(1) ENDDO IF mFlagNumAppl DBGOTO(mRecno) ELSE LB_Warning(L('Приложение с заданным номером:')+' '+ALLTRIM(mNumAppl)+' '+L('не найдено'), L('(C) Система "Эйдос-Х++"')) DBGOTO(RECCOUNT()-1) ENDIF PRIVATE aR[8] aR[2] = ALLTRIM(FIELDGET(2)) FOR j=4 TO 8 aR[j] = ALLTRIM(FIELDGET(j)) NEXT DBGOBOTTOM() FIELDPUT(2, aR[2]) FOR j=4 TO 8 FIELDPUT(j, aR[j]) NEXT ENDIF ReTURN nil ************************************************************************************************** ************************************************************************************************** FUNCTION Help13web() aHelp := {} AADD(aHelp, L('Помощь по режиму работы с приложениями на WEB-сервере системы "Эйдос-Х++". ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Данный режим позволяет средствами самой системы "Эйдос" легко обмениваться исходными данными приложений между пользователями ')) AADD(aHelp, L('системы "Эйдос" во всем мире и организовать сообщество разработчиков интеллектуальных приложений и пользователей системы "Эйдос". ')) AADD(aHelp, L('Это существенно повышает ее ценность за счет системного эффекта, образующегося в таком сообществе за счет взаимосвязей между его ')) AADD(aHelp, L('участниками и обмена между ними опытом решения задач в различных предметных областях. Для работы режима необходим FTP-доступ, ')) AADD(aHelp, L('не заблокированный политиками безопасности, брандмауэрами, антивирусными программами и т.п. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Любой пользователь системы "Эйдос-Х++" имеет возможность в диспетчере приложений (режим 1.3) устанавливать не только встроенные ')) AADD(aHelp, L('лабораторные работы с локального компьютера, но и приложения с WEB-сервера системы (кнопка: "Скачать приложение из облака"), ')) AADD(aHelp, L('а также загружать приложения на WEB-сервер системы (кнопка: "Записать приложение в облако"): ')) AADD(aHelp, L(' ')) AADD(aHelp, L('1. Сохранять исходные данные по текущему приложению на WEB-сервер системы "Эйдос". В текущей версии системы есть три типа облачных ')) AADD(aHelp, L('Эйдос-приложений: 1) с числовыми и текстовыми исходными данными в Excel-файле вида: "Inp_data.xls(xlsx); 2) с графическими данными ')) AADD(aHelp, L('в файлах jpg или bmp; 3) в текстовых файлах стандарта DOS TXT. Текстовые файлы должны бытьс именами без пробелов и кириллицы. ')) AADD(aHelp, L('Чтобы привести в корректное состояние метаданные графических файлов рекомендуется преобразовать их в bmp, а затем в jpg. ')) AADD(aHelp, L('2. Просматривать приложения, по которым на WEB-сервере системы "Эйдос" есть исходные данные и читать пояснения по ним, если они ')) AADD(aHelp, L('размещены в Internet. Также doc, pdf и txt-файлы с описаниями приложений могут быть размещены в папке Inp_data с исходными данными. ')) AADD(aHelp, L('3. Выбирать приложение на WEB-сервере системы "Эйдос", скачивать исходные данные по нему на свой компьютер и устанавливать это ')) AADD(aHelp, L('приложение. Для выбора и скачивания приложения нужно поставить курсор на нужную строку и кликнуть по кнопке: "Скачать приложение". ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Для сохранения исходных данных приложения на WEB-сервере с локального компьютера с системой "Эйдос" и для выбора приложений на ')) AADD(aHelp, L('WEB-сервере и скачивания их исходных данных на этом компьютере должен быть Internet с незаблокированным FTP-доступом. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Для записи исходных данных и файла параметров по текущему приложению на WEB-сервер системы "Эйдос" необходимо: ')) AADD(aHelp, L('- записать в папку: ../Aid_data/Inp_data/ файл исходных данных: "Inp_data.xls" ("Inp_data.xlsx") или графические файлы (jpg, bmp); ')) AADD(aHelp, L('- записать в папку: ../Aid_data/Inp_data/ файлы: README.DOC и README.PDF с описанием приложения; ')) AADD(aHelp, L('- перейти в диспетчер приложений (режим 1.3) и кликнуть по кнопке: "Сохранить приложение в облаке"; ')) AADD(aHelp, L('- внести в каталог WEB-приложений необходимую информацию об авторах приложения. Все поля являются обязательными для заполнения; ')) AADD(aHelp, L('- записать приложение на WEB-сервер (сохранение), кликнув по соответствующей кнопке. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Важно отметить, что работа в режиме сохранения приложения в облаке возможна одновременно только для одного пользователя, ')) AADD(aHelp, L('т.е. другие смогут воспользоваться данным режимом только после нормального выхода из него предыдущего пользователя. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Если среди файлов приложения в папке: ../Aidos-X/AID_DATA/Inp_data/ есть PDF-файл, то предполагается, что этот файл содержит ')) AADD(aHelp, L('описание приложения. Гиперссылка на него автоматически вставляется в каталог Web-приложений при записи приложения. Русские символы ')) AADD(aHelp, L('в имени этого файла не допускаются, т.к. иначе гиперссылка не будет работать. PDF-файл в этой папке должен быть один. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Приложения необходимо записывать на WEB-сервер СРАЗУ после их установки на локальном компьютере, т.к. именно тогда гарантируется, ')) AADD(aHelp, L('что файлы: "Inp_data.xls" (xlsx) и "_2_3_2_2.arx" ("_2_3_2_3.arx") соответствуют друг другу и текущему приложению. Если же после ')) AADD(aHelp, L('установки приложения из "Inp_data.xls" в режиме 2.3.2.2 установить еще какие-то приложения другим способом, т.е. без использования ')) AADD(aHelp, L('этих файлов, то уже эти приложения будут текущими и в файлах исходных данных будут данные, не соответствующие текущему приложению. ')) AADD(aHelp, L('Поэтому ответственность за соответствие информации в папке Inp_data и WEB-базе несет автор приложения. В облако всегда записывается ')) AADD(aHelp, L('именно текущее приложение и его имя берется из диспетчера приложений 1.3. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Луценко Е.В. Открытая масштабируемая интерактивная интеллектуальная on-line среда для обучения и научных исследований на базе АСК- ')) AADD(aHelp, L('анализа и системы "Эйдос" / Е.В. Луценко // Политематический сетевой электронный научный журнал Кубанского государственного аграрно-')) AADD(aHelp, L('го университета (Научный журнал КубГАУ) [Электронный ресурс]. - Краснодар: КубГАУ, 2017. - №06(130). С. 1 - 55. - IDA [article ID]: ')) AADD(aHelp, L('1301706001. - Режим доступа: http://ej.kubagro.ru/2017/06/pdf/01.pdf, 3,438 у.п.л. http://dx.doi.org/10.21515/1990-4665-130-001 ')) mHelpMax = -999;FOR h=1 TO LEN(aHelp);mHelpMax = MAX(mHelpMax, LEN(ALLTRIM(aHelp[h])));NEXT s=1;d=0.8;@0,0 DCGROUP oGroup1 CAPTION L(' ') SIZE mHelpMax-20, LEN(aHelp)*d+1.5 FOR h=1 TO LEN(aHelp);@s,2 DCSAY aHelp[h] SIZE 0 PARENT ogroup1;s=s+d;NEXT DCREAD GUI TO lExit FIT TITLE L('Помощь по режиму работы с приложениями на WEB-сервере системы "Эйдос-Х++"') RETURN NIL ************************************************************************************************** **** ################################################################################################################################# **** Л Е М М А Т И З А Ц И Я . Если задана лемматизация, то лемматизировать те колонки Inp_data.dbf, которые рассматриваются как слова **** ################################################################################################################################# FUNCTION Lemma2322(mPar, mRegim) DIRCHANGE(Disk_dir) // Перейти в папку с системой IF .NOT. FILE("_2_3_2_2.arx") LB_Warning(L('Необходимо выполнить режим: 2.3.2.2.')) ReTURN nil ELSE aSoftInt = DC_ARestore("_2_3_2_2.arx") // Если параметры были заданы ранее, то использовать их * Regim = aSoftInt[ 1] // Формализация предметной области (1) или ввод распознаваемой выборки (2) * MsgBox(STR(Regim)) Regim = mRegim // Формализация предметной области (1) или ввод распознаваемой выборки (2) Flag_zer = aSoftInt[ 2] M_ClSc1 = aSoftInt[ 3] M_ClSc2 = aSoftInt[ 4] M_OpSc1 = aSoftInt[ 5] M_OpSc2 = aSoftInt[ 6] N_SKGrCl = aSoftInt[ 7] N_SKGrPr = aSoftInt[ 8] K_N_ClSc = aSoftInt[ 9] K_N_OpSc = aSoftInt[10] K_N_GrClSc = aSoftInt[11] K_N_GrOpSc = aSoftInt[12] M_ObAnk = aSoftInt[13] N_Chast = aSoftInt[14] M_Interval = aSoftInt[15] M_Scenario = aSoftInt[16] K_GradNClSc = aSoftInt[17] // Количество градаций в числовой классификационной шкале K_GradNOpSc = aSoftInt[18] // Количество градаций в числовой описательной шкале mGorizMin = aSoftInt[19] mGorizMax = aSoftInt[20] mGlubMin = aSoftInt[21] mGlubMax = aSoftInt[22] M_ChastObi = aSoftInt[23] M_ChastRso = aSoftInt[24] N_ChastObi = aSoftInt[25] N_ChastRso = aSoftInt[26] M_XlsDbf = aSoftInt[27] mTxtCSField = aSoftInt[28] // Способ интерпретации значений текстовых полей - классификационных шкал файла исходных данных mTxtOSField = aSoftInt[29] // Способ интерпретации значений текстовых полей - описательных шкал файла исходных данных mTxtCSSep = aSoftInt[30] mTxtOSSep = aSoftInt[31] * mScenario = aSoftInt[32] // mScenario=1 Не применять сценарный метод АСК-анализа и спец.интерпретацию TXT-полей (старый вариант) mScenario = aSoftInt[32] // mScenario=1 Не применять сценарный метод АСК-анализа mSpecInterprCls = aSoftInt[33] // .T. - Применить спец.интерпретацию текстовых полей классов, .F. - не применять mSpecInterprAtr = aSoftInt[34] // .T. - Применить спец.интерпретацию текстовых полей признаков, .F. - не применять mNameGrNumSc= aSoftInt[35] // Какие наименования ГРАДАЦИЙ числовых шкал использовать mClsAvr = aSoftInt[36] // .F. - делать модель из Inp_data, .T. - делать модель из Inp_data_avr mSortUnqCls = aSoftInt[37] // Выделять уникальные значения классов и сортировать, 1-да, 2-нет mLemmatCls = IF(mSpecInterprCls,aSoftInt[38],2) // Проводить лемматизацию классов, 1-да, 2-нет mSortUnqGos = aSoftInt[39] // Выделять уникальные значения признаков и сортировать, 1-да, 2-нет mLemmatGos = IF(mSpecInterprAtr,aSoftInt[40],2) // Проводить лемматизацию классов, 1-да, 2-нет ENDIF ************************************************* **** ВАЖНО!!! Лематизируются сами исходные данные ************************************************* NWordsAll = 0 mN_LemmsNew = 0 nSeconds := Seconds() IF mLemmatCls=1 .OR. mLemmatGos=1 // Задана лемматизация классов или признаков DO CASE CASE mRegim = 1 // Формализация предметной области (1) IF .NOT. FILE(Disk_dir+"\AID_DATA\Inp_data\Inp_data.dbf") aMess := {} AADD(aMess, L('Нет файла: ')+Disk_dir+"\AID_DATA\Inp_data\Inp_data.dbf") AADD(aMess, L('Возможно необходимо выполнить режим: 2.3.2.2.')) LB_Warning(aMess) ReTURN nil ENDIF CASE mRegim = 2 // Ввод распознаваемой выборки (2) IF .NOT. FILE(Disk_dir+"\AID_DATA\Inp_data\Inp_rasp.dbf") aMess := {} AADD(aMess, L('Нет файла: ')+Disk_dir+"\AID_DATA\Inp_data\Inp_rasp.dbf") AADD(aMess, L('Возможно необходимо выполнить режим: 2.3.2.2.')) LB_Warning(aMess) ReTURN nil ENDIF ENDCASE DIRCHANGE(Disk_dir) IF .NOT. FILE('Lemma.dbf') aMess := {} AADD(aMess, L('База данных для лемматизации: "Lemma.dbf"')) AADD(aMess, L('отсутствует в текущей директории системы:')) AADD(aMess, Disk_dir+'.') AADD(aMess, L('Ее можно скачать на сайте разработчика:')) AADD(aMess, L('по ссылке: http://lc.kubagro.ru/Lemma.rar')) AADD(aMess, L('разархивировать и записать в папку с системой.')) AADD(aMess, L('Также она есть в полной инсталляции системы.')) AADD(aMess, L('А пока будет создана и начнет заполняться')) AADD(aMess, L('пустая база "Lemma.dbf". Корректировка этой')) AADD(aMess, L('базы возможна в режиме 5.13.')) LB_Warning(aMess, L('(c) Система "Эйдос"')) aStructure := { { "Num" , "N", 9, 0 },; { "WordForm", "C", 40, 0 },; { "Lemma" , "C", 40, 0 },; { "Error" , "C", 3, 0 },; { "N_Obr" , "N", 9, 0 } } DbCreate( 'Lemma', aStructure ) ENDIF oScrn := DC_WaitOn(L('Лемматизация'),,,,,,,,,,,.F.) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DO CASE CASE mRegim = 1 // Формализация предметной области (1) Name_SS = Disk_dir+"\AID_DATA\Inp_data\Inp_data.dbf" Name_DD = Disk_dir+"\AID_DATA\Inp_data\Inp_data_tmp.dbf" // Исходные данные до лемматизации COPY FILE (Name_SS) TO (Name_DD) Name_DD = Disk_dir+"\Inp_data.dbf" // Исходные данные для лемматизации COPY FILE (Name_SS) TO (Name_DD) CASE mRegim = 2 // Ввод распознаваемой выборки (2) Name_SS = Disk_dir+"\AID_DATA\Inp_data\Inp_rasp.dbf" Name_DD = Disk_dir+"\AID_DATA\Inp_data\Inp_rasp_tmp.dbf" // Исходные данные до лемматизации COPY FILE (Name_SS) TO (Name_DD) Name_DD = Disk_dir+"\Inp_rasp.dbf" // Исходные данные для лемматизации COPY FILE (Name_SS) TO (Name_DD) ENDCASE DIRCHANGE(Disk_dir) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Lemma EXCLUSIVE NEW SELECT Lemma IF RECCOUNT() = 0 mNum = 0 ELSE DBGOBOTTOM() mNum = NUM ENDIF INDEX ON WordForm TO Lemma CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Lemma INDEX Lemma EXCLUSIVE NEW DO CASE CASE mRegim = 1 // Формализация предметной области (1) USE Inp_data EXCLUSIVE NEW SELECT Inp_data CASE mRegim = 2 // Ввод распознаваемой выборки (2) USE Inp_rasp EXCLUSIVE NEW SELECT Inp_rasp ENDCASE FOR ff=2 TO FCOUNT() // Начало цикла по полям Inp_data.dbf или Inp_rasp.dbf ******** Лемматизировать ли поле mFlagCls = .F. mFlagGos = .F. IF FIELDTYPE(ff) = "C" // Колонка текстовая IF M_ClSc1 <= ff .AND. ff <= M_ClSc2 // Относится к классам IF mTxtCSField = 3 // Задана опция, рассматривать слова, как классы mFlagCls = .T. ENDIF ENDIF IF M_OpSc1 <= ff .AND. ff <= M_OpSc2 // Относится к признакам IF mTxtOSField = 3 // Задана опция, рассматривать слова, как признаки mFlagGos = .T. ENDIF ENDIF ENDIF * DC_DebugQout( mFlagCls, mFlagGos) IF mFlagCls .OR. mFlagGos // Лемматизировать ли поле (все записи) DO CASE CASE mRegim = 1 // Формализация предметной области (1) SELECT Inp_data CASE mRegim = 2 // Ввод распознаваемой выборки (2) SELECT Inp_rasp ENDCASE DBGOTOP() DO WHILE .NOT. EOF() FvLemm = '' // Значение поля из лемматизированных слов через пробел Fv = ALLTRIM(FIELDGET(ff)) // Переводить все слова в нижний регистр // Оставить только цифры и буквы, А ТАКЖЕ ПОДЧЕРКИВАНИЕ (95) <===################## FOR j= 1 TO 47;Fv = STRTRAN(Fv,CHR(j),' ');NEXT FOR j= 58 TO 64;Fv = STRTRAN(Fv,CHR(j),' ');NEXT FOR j= 91 TO 94;Fv = STRTRAN(Fv,CHR(j),' ');NEXT FOR j= 96 TO 96;Fv = STRTRAN(Fv,CHR(j),' ');NEXT FOR j=123 TO 127;Fv = STRTRAN(Fv,CHR(j),' ');NEXT FOR j=176 TO 223;Fv = STRTRAN(Fv,CHR(j),' ');NEXT FOR j=242 TO 255;Fv = STRTRAN(Fv,CHR(j),' ');NEXT FOR w=1 TO NumToken( Fv, ' ' ) // Цикл по словам mWord = LOWER(TOKEN( Fv, ' ', w)) NWordsAll++ IF LEN(ALLTRIM(mWord)) > 3 // Слова короче 4 символов не рассматривать mFlag = .T. // В слове есть латинская буква, то не лемматизировать его * FOR j=1 TO LEN(mWord) * IF ASC(SUBSTR(mWord,j,1)) < 128 * mFlag = .F. // В слове есть латинская буква, то не лемматизировать его * EXIT * ENDIF * NEXT IF mFlag // Лемматизация ************************** SELECT Lemma;SET ORDER TO 1;T=DBSEEK(mWord) IF T mWord = ALLTRIM(Lemma) // Лемма найдена mNObr = N_Obr REPLACE N_Obr WITH mNObr+1 // Счетчик числа использований лемм ELSE // Если лемма не найдена, то вместо леммы используется нелемматизированное слово APPEND BLANK // Слово, для которого не найдена лемма, заносится в базу данных лемматизации mN_LemmsNew++ * DC_DebugQout( mNum ) REPLACE NUM WITH ++mNum REPLACE WORDFORM WITH mWord REPLACE LEMMA WITH mWord // В режиме 5.13. "Ввод-корректировка БД лемматизации" можно ввести лемму для данной словоформы REPLACE ERROR WITH 'NEW' // В режиме 5.13. "Ввод-корректировка БД лемматизации" можно ввести лемму для данной словоформы REPLACE N_Obr WITH 1 // Счетчик числа использований лемм ENDIF ENDIF FvLemm = FvLemm + mWord + ' ' // Значение поля из лемматизированных слов ENDIF NEXT DO CASE CASE mRegim = 1 // Формализация предметной области (1) SELECT Inp_data CASE mRegim = 2 // Ввод распознаваемой выборки (2) SELECT Inp_rasp ENDCASE FIELDPUT(ff, FvLemm) DBSKIP(1) ENDDO ENDIF NEXT **** Пронумеровать словоформы в базе лемматизации SELECT Lemma SET ORDER TO DBGOTOP() mNum = 0 DO WHILE .NOT. EOF() REPLACE Num WITH ++mNum DBSKIP(1) ENDDO **** Скопировать лемматизированные исходные данные в папку Inp_data и в папку текущего приложения CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DO CASE CASE mRegim = 1 // Формализация предметной области (1) Name_SS = Disk_dir+"\Inp_data.dbf" // Лемматизированные исходные данные Name_DD = Disk_dir+"\AID_DATA\Inp_data\Inp_data.dbf" * MsgBox(Name_SS+' => '+Name_DD) COPY FILE (Name_SS) TO (Name_DD) Name_DD = M_NewAppl+"Inp_data.dbf" COPY FILE (Name_SS) TO (Name_DD) * MsgBox(Name_SS+' => '+Name_DD) DIRCHANGE(M_NewAppl) // Перейти в папку с новым приложением CASE mRegim = 2 // Ввод распознаваемой выборки (2) Name_SS = Disk_dir+"\Inp_rasp.dbf" // Лемматизированные исходные данные Name_DD = Disk_dir+"\AID_DATA\Inp_data\Inp_rasp.dbf" COPY FILE (Name_SS) TO (Name_DD) ENDCASE DC_Impl(oScrn) ENDIF // Конец лемматизации исходных данных IF mPar CrLf = CHR(13)+CHR(10) // Конец строки (записи) mMess = L('На лемматизацию текста из')+' '+ALLTRIM(STR(NWordsAll))+' '+L('слов')+CrLf+; L('затрачено:')+' '+Alltrim(Str(Seconds()-nSeconds,15,7)) +' '+L('секунд,')+CrLf+; L('в среднем:')+' '+Alltrim(Str((Seconds()-nSeconds)/NWordsAll,15,7))+' '+L('секунды на слово.')+CrLf+CrLf+; IF(mN_LemmsNew>0,L('В базу лемматизации: "..Lemma.dbf" добавлено:')+' '+ALLTRIM(STR(mN_LemmsNew))+' '+L('новых слов. Можно указать для них леммы'),'')+CrLf+; IF(mN_LemmsNew>0,L('в режиме 5.13. "Ввод-корректировка БД лемматизации"'),'') MsgBox(mMess) ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций ReTURN nil ******************************************************* ******** Просмотр и редактирование БД лемматизации ******** Сделать копирование леммы из предыдущей строки ################## ******** и отметку новых и уже готовых строк ******************************************************* FUNCTION F5_13() LOCAL GetList := {}, aPres, oBrowse, oToolBar, aColors, bColor, GetOptions Running(.T.) IF .NOT. FILE('Lemma.dbf') aMess := {} AADD(aMess, L('База данных для лемматизации: "Lemma.dbf"')) AADD(aMess, L('отсутствует в текущей директории системы:')) AADD(aMess, Disk_dir+'.') AADD(aMess, L('Ее можно скачать на сайте разработчика:')) AADD(aMess, L('по ссылке: http://lc.kubagro.ru/Lemma.rar') ) AADD(aMess, L('разархивировать и записать в папку с системой.')) AADD(aMess, L('Эта база есть также в полной инсталляции системы.')) AADD(aMess, L('А пока будет создана и начнет заполняться')) AADD(aMess, L('пустая база "Lemma.dbf". Корректировка этой')) AADD(aMess, L('базы возможна в режиме 5.13.')) LB_Warning(aMess, L('(c) Система "Эйдос"')) aStructure := { { "Num" , "N", 9, 0 },; { "WordForm", "C", 40, 0 },; { "Lemma" , "C", 40, 0 },; { "Error" , "C", 3, 0 },; { "N_Obr" , "N", 9, 0 } } DbCreate( 'Lemma', aStructure ) ENDIF IF .NOT. FILE('Lemma.ntx') oScrn := DC_WaitOn(L('Переиндексация БД лемматизации: "Lemma.dbf"'),,,,,,,,,,,.F.) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Lemma EXCLUSIVE NEW SELECT Lemma INDEX ON ALLTRIM(WordForm) TO Lemma DC_Impl(oScrn) ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Lemma EXCLUSIVE NEW SET ORDER TO aColors := { {GRA_CLR_WHITE,GRA_CLR_DARKRED },; {GRA_CLR_WHITE,GRA_CLR_DARKBLUE },; {GRA_CLR_BLACK,GRA_CLR_DARKGREEN} } aPres := ; { { XBP_PP_COL_HA_FGCLR, GRA_CLR_WHITE },; // Header FG Color { XBP_PP_COL_HA_BGCLR, GRA_CLR_DARKGRAY },; // Header BG Color { XBP_PP_COL_FA_FGCLR, GRA_CLR_YELLOW },; // Footer FG Color { XBP_PP_COL_FA_BGCLR, GRA_CLR_DARKGRAY },; // Footer BG Color { XBP_PP_COL_DA_ROWSEPARATOR, XBPCOL_SEP_DOTTED },; // Row Sep { XBP_PP_COL_DA_COLSEPARATOR, XBPCOL_SEP_DOTTED },; // Col Sep { XBP_PP_COL_HA_ALIGNMENT, XBPALIGN_LEFT },; // Header alignment { XBP_PP_COL_DA_ROWHEIGHT, 20 },; // Row Height { XBP_PP_COL_DA_CELLHEIGHT, 20 } } // Cell Height /* ----- Create ToolBar ----- */ @ 27.5, 1 DCTOOLBAR oToolBar SIZE 142, 1.5 d = 5 DCADDBUTTON CAPTION L('Помощь') ; SIZE LEN(L("Помощь"))+5 ; ACTION {||Help513(), DC_GetRefresh(GetList)} ; PARENT oToolBar @ DCGUI_ROW, DCGUI_COL + d DCPUSHBUTTON CAPTION L('Сортировка по словоформам') ; SIZE LEN(L("Сортировка по словоформам")), 1.5 ; ACTION {||SortLemma(1), DC_GetRefresh(GetList)} ; PARENT oToolBar ; @ DCGUI_ROW, DCGUI_COL + d DCPUSHBUTTON CAPTION L('Сорт.по леммам') ; SIZE LEN(L("Сорт.по леммам"))+2, 1.5 ; ACTION {||SortLemma(2), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Сортировка по леммам') @ DCGUI_ROW, DCGUI_COL + d DCPUSHBUTTON CAPTION L('Сорт.по новым словам') ; SIZE LEN(L("Сорт.по новым словам")), 1.5 ; ACTION {||SortLemma(3), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Сортировка по новым словам') @ DCGUI_ROW, DCGUI_COL + d DCPUSHBUTTON CAPTION L('Сорт.по числу использ.лемм') ; SIZE LEN(L("Сорт.по числу использ.лемм"))-1, 1.5 ; ACTION {||SortLemma(4), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Сортировка по числу использования лемм') @ DCGUI_ROW, DCGUI_COL + d DCPUSHBUTTON CAPTION L('Удаление слова') ; SIZE LEN(L("Удаление слова"))+2, 1.5 ; ACTION {||DelWLemma(), DC_GetRefresh(GetList)} ; PARENT oToolBar @ DCGUI_ROW, DCGUI_COL + d DCPUSHBUTTON CAPTION L('Поиск слова') ; SIZE LEN(L("Поиск слова"))+2, 1.5 ; ACTION {||SearchWLemma(), DC_GetRefresh(GetList)} ; PARENT oToolBar @ DCGUI_ROW, DCGUI_COL + d DCPUSHBUTTON CAPTION L('Сброс БД') ; SIZE LEN(L("Сброс БД"))+3, 1.5 ; ACTION {||DelLemma(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Сброс баз данных лемматизации') /* ----- Create browse ----- */ @ 1, 0 DCBROWSE oBrowse ALIAS 'Lemma' SIZE 143,26 ; HEADLINES 2 ; // Кол-во строк в заголовке (перенос строки - ";") EDIT xbeBRW_ItemSelected MODE DCGUI_BROWSE_EDITDOWN ; PRESENTATION aPres ; DCBROWSECOL FIELD Lemma->Num HEADER L('Номер;п/п' ) PARENT oBrowse WIDTH 7 PROTECT {|| .T. } DCBROWSECOL FIELD Lemma->WordForm HEADER L('Словоформа' ) PARENT oBrowse WIDTH 35 DCBROWSECOL FIELD Lemma->Lemma HEADER L('Лемма' ) PARENT oBrowse WIDTH 30 COLOR {||{nil,aColor[100]}} DCBROWSECOL FIELD Lemma->Error HEADER L('Новое;слово' ) PARENT oBrowse WIDTH 5 DCBROWSECOL FIELD Lemma->N_Obr HEADER L('Частота;леммы') PARENT oBrowse WIDTH 7 PROTECT {|| .T. } DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; OPTIONS GetOptions ; MODAL ; TITLE L('5.13. Просмотр и редактирование БД лемматизации: "Lemma.dbf"'); FIT ; CLEAREVENTS ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) ReTURN nil ****************************************************************************************** ************************************************************************************************** FUNCTION Help513() aHelp := {} AADD(aHelp, L('Режим: 5.13. Просмотр и редактирование БД лемматизации: "Lemma.dbf". ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Лемматизация - это приведение словоформ к исходному слову в единственном числе именительного падежа. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Если Вы собираетесь работать с текстами, то необходимо скачать базу данных для лемматизации "Lemma.DBF" ')) AADD(aHelp, L('по ссылке: http://lc.kubagro.ru/Lemma.rar и разархивировать ее в папку с системой "Эйдос-Х++" (архив ')) AADD(aHelp, L('имеет размер около 10 Мб, сама база около 150 Мб). База для лемматизации сделана на основе словаря ')) AADD(aHelp, L('Зализняка и из базы, представленной автором статьи: https://habrahabr.ru/company/realweb/blog/265375/. ')) AADD(aHelp, L('Эта база дополняется системой при встрече новых слов. Новые слова будут дополнены признаком: "New". ')) AADD(aHelp, L('Исходные слова для словоформ необходимо ввести вручную. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Если базы данных лемматизации "Lemma.DBF" нет в текущей папке с системой (никогда не было или она была ')) AADD(aHelp, L('удалена), то эта база будет создана системой пустой и будет заполняться системой при встрече новых слов.')) AADD(aHelp, L('Новые слова будут дополнены признаком: "New". Исходные слова для словоформ необходимо ввести вручную. ')) AADD(aHelp, L('Чтобы в режиме 2.3.2.2 слова переводились в нижний регистр нужно сбросить БД лемматизации в режиме ')) AADD(aHelp, L('5.13 и задать лемматизацию при вводе данных из "Inp_data.xls" и "Inp_rasp.xls". ')) mHelpMax = -999;FOR h=1 TO LEN(aHelp);mHelpMax = MAX(mHelpMax, LEN(ALLTRIM(aHelp[h])));NEXT s=1;d=0.9;@0,0 DCGROUP oGroup1 CAPTION L(' ') SIZE mHelpMax-15, LEN(aHelp)*d+1.5 FOR h=1 TO LEN(aHelp);@s,2 DCSAY aHelp[h] SIZE 0 PARENT ogroup1;s=s+d;NEXT DCREAD GUI TO lExit FIT TITLE L('5.13. Просмотр и редактирование БД лемматизации: "Lemma.dbf"') RETURN NIL ************************************************************************************************** FUNCTION SortLemma(mPar) LOCAL nMax, oProgress, Mess, oDialog aStructure := { { "Num" , "N", 9, 0 },; { "WordForm", "C", 40, 0 },; { "Lemma" , "C", 40, 0 },; { "Error" , "C", 3, 0 },; { "N_Obr" , "N", 9, 0 } } DbCreate( 'LemmaTmp', aStructure ) USE LemmaTmp EXCLUSIVE NEW oScrn := DC_WaitOn(L('Переиндексация БД лемматизации: "Lemma.dbf"'),,,,,,,,,,,.F.) SELECT Lemma SET ORDER TO DO CASE CASE mPar = 1 INDEX ON ALLTRIM(WordForm) TO LemmaTmp CASE mPar = 2 INDEX ON ALLTRIM(Lemma) TO LemmaTmp CASE mPar = 3 INDEX ON ALLTRIM(Error) TO LemmaTmp CASE mPar = 4 INDEX ON STR(99999999-N_Obr,9) TO LemmaTmp ENDCASE DC_Impl(oScrn) ******* Физическая сортировка nMax = RECCOUNT() Mess = L('5.13. Физическая сортировка базы лемматизации: "Lemma.dbf" ') @ 4,5 DCPROGRESS oProgress SIZE 70,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 DCREAD GUI TITLE Mess PARENT @oDialog FIT EXIT oDialog:show() nTime = 0 DC_GetProgress(oProgress,0,nMax) DBGOTOP() mNum = 0 DO WHILE .NOT. EOF() ** Копирование записи в рассортированную БД Tmp Ar := {} FOR j=1 TO FCOUNT() AADD(Ar, FIELDGET(j)) NEXT SELECT LemmaTmp APPEND BLANK FOR j=1 TO LEN(Ar) FIELDPUT(j, Ar[j]) NEXT FIELDPUT(1, ++mNum) DC_GetProgress(oProgress, ++nTime, nMax) SELECT Lemma DBSKIP(1) ENDDO *MsgBox('STOP') DC_GetProgress(oProgress,nMax,nMax) oDialog:Destroy() ***** Копирование БД Tmp => Lemma CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций ERASE("Lemma.dbf") COPY FILE ("LemmaTmp.dbf") TO ("Lemma.dbf") ERASE("LemmaTmp.dbf") ERASE("LemmaTmp.ntx") CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Lemma EXCLUSIVE NEW SET ORDER TO ReTURN nil **************************************************************************************************** *Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time *nMax = N_InpFiles *Mess = L('2.3.2.6. Объединение нескольких файлов исходных данных в один' *@ 4,5 DCPROGRESS oProgress SIZE 70,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 *DCREAD GUI TITLE Mess PARENT @oDialog FIT EXIT *oDialog:show() *nTime = 0 *DC_GetProgress(oProgress,0,nMax) *FOR ff=1 TO N_InpFiles * DC_GetProgress(oProgress, ++nTime, nMax) *NEXT **MsgBox('STOP') *DC_GetProgress(oProgress,nMax,nMax) *oDialog:Destroy() *Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time_Time **************************************************************************************************** ****************************************************************************************** FUNCTION DelWLemma() DELETE PACK ReTURN nil ****************************************************************************************** FUNCTION DelLemma() ZAP ReTURN nil ****************************************************************************************** FUNCTION SearchWLemma() mWord = WordForm @0,0 DCGROUP oGroup1 CAPTION L('Задайте исходную словоформу для поиска:') SIZE 40.0, 2.5 @1,2 DCGET mWord PICTURE "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" PARENT oGroup1 DCREAD GUI; TO lExit ; FIT; ADDBUTTONS; MODAL; TITLE L('(c) Система "ЭЙДОС-X++"') IF lExit ** Button Ok ELSE RETURN NIL ENDIF ******************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Lemma INDEX Lemma EXCLUSIVE NEW SELECT Lemma SET ORDER TO 1 T=DBSEEK(ALLTRIM(mWord)) IF .NOT. T LB_Warning(L('Слово: "')+(ALLTRIM(mWord))+L('" не найдено'), L('(c) Система "ЭЙДОС-X++"') ) DBGOTOP() ENDIF SET ORDER TO ReTURN nil ******************************************************************************************** ******** 4.1.3.11.Объединение в одной БД строк по самым достоверным моделям ******** Объединение в одной БД "AddData.dbf" строк по наиболее достоверным моделям ******** из Dost_modCls, формируемых в режиме 4.1.3.6. ******************************************************************************************** FUNCTION F4_1_3_11(mPar) Running(.T.) oScrn := DC_WaitOn(L('Формирование баз данных по наиболее достоверным моделям разных приложений'),,,,,,,,,,,.F.) DIRCHANGE(Disk_dir) aStructure := { { "Type_model" , "C", 90, 0 }, ; { "Int_krit" , "C", 40, 0 }, ; { "N_LogObj" , "N", 15, 0 }, ; // 3. Количество логических объектов расп.выборки, фактически относящихся к классу (TP+FN) { "N_T_Ident" , "N", 15, 0 }, ; // 4. Количество верно идентифицированных объектов расп.выборки (TP) { "N_F_NIdent" , "N", 15, 0 }, ; // 5. Количество ошибочно неидентифицированных объектов расп.выборки (FN) { "N_F_Ident" , "N", 15, 0 }, ; // 6. Количество ошибочно идентифицированных объектов расп.выборки (FP) { "N_T_NIdent" , "N", 15, 0 }, ; // 7. Количество верно неидентифицированных объектов расп.выборки (TN) { "P_T_Ident" , "N", 15, 7 }, ; // 8. Вероятность верной идентификации объекта с классом с использованием модели { "P_T_NIdent" , "N", 15, 7 }, ; // 9. Вероятность верной не идентификации объекта с классом с использованием модели { "P_F_Ident" , "N", 15, 7 }, ; // 10.Вероятность ошибочной идентификации объекта с классом с использованием модели { "P_F_NIdent" , "N", 15, 7 }, ; // 11.Вероятность ошибочной не идентификации объекта с классом с использованием модели { "P_Avr_T" , "N", 15, 7 }, ; // 12.Вероятность верной идентификации или неидентификации объекта с классом с использованием модели (моя мера) { "DVMod" , "N", 15, 7 }, ; // 13.M_DVMod = (NT-NF)/(NT+NF)*100 Моя мера качества модели-классификатора (в знаменателе: "всего объектов") { "Precision" , "N", 15, 7 }, ; // 14.Precision = TP/(TP+FP) - точность { "Recall" , "N", 15, 7 }, ; // 15.Recall = TP/(TP+FN) - полнота { "F_mera" , "N", 15, 7 }, ; // 16.F-mera = 2*(Precision*Recall)/(Precision+Recall) (мультиклассовый вариант) { "S_T_Ident" , "N", 15, 7 }, ; // 17.Сумма модулей уровней сходства верно идентифицированных объектов расп.выборки { "S_F_NIdent" , "N", 15, 7 }, ; // 18.Сумма модулей уровней сходства ошибочно неидентифицированных объектов расп.выборки { "S_F_Ident" , "N", 15, 7 }, ; // 19.Сумма модулей уровней сходства ошибочно идентифицированных объектов расп.выборки { "S_T_NIdent" , "N", 15, 7 }, ; // 20.Сумма модулей уровней сходства верно неидентифицированных объектов расп.выборки { "SPrecision" , "N", 15, 7 }, ; // 21.SPrecision = STP/(STP+SFP) - точность с учетом уровней сходства { "SRecall" , "N", 15, 7 }, ; // 22.SRecall = STP/(STP+SFN) - полнота с учетом уровней сходства { "L1_mera" , "N", 15, 7 }, ; // 23.L1-mera = 2*(SPrecision*SRecall)/(SPrecision+SRecall) (L1-мера проф.Е.В.Луценко - нечеткое мультиклассовое обобщение F-меры Ван Ризбергена) { "A_T_IDENT" , "N", 15, 7 }, ; // 24.Среднее модулей уровней сходства верно идентифицированных объектов расп.выборки (ATP=STP/TP) { "A_F_NIDENT" , "N", 15, 7 }, ; // 25.Среднее модулей уровней сходства ошибочно неидентифицированных объектов расп.выборки (AFN=SFN/FN) { "A_F_IDENT " , "N", 15, 7 }, ; // 26.Среднее модулей уровней сходства ошибочно идентифицированных объектов расп.выборки (AFP=SFP/FP) { "A_T_NIDENT" , "N", 15, 7 }, ; // 27.Среднее модулей уровней сходства верно неидентифицированных объектов расп.выборки (ATN=STN/TN) { "APRECISION" , "N", 15, 7 }, ; // 28.APrecision = ATP/(ATP+AFP) - точность с учетом уровней сходства { "ARECALL" , "N", 15, 7 }, ; // 29.ARecall = ATP/(ATP+AFN) - полнота с учетом уровней сходства { "L2_MERA" , "N", 15, 7 }, ; // 30.L2-mera = 2*(APrecision*ARecall)/(APrecision+ARecall) (L2-мера проф.Е.В.Луценко - нечеткое мультиклассовое обобщение { "Date" , "C", 10, 0 }, ; // 31.Дата формирования записи БД { "Time" , "C", 8, 0 } } // 32.Время формирования записи БД *DbCreate( "Dost_modCls.dbf", aStructure, "DBFNTX" ) DbCreate( "AddDataF" , aStructure, "DBFNTX" ) DbCreate( "AddDataL1" , aStructure, "DBFNTX" ) DbCreate( "AddDataL2" , aStructure, "DBFNTX" ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Appls EXCLUSIVE NEW USE AddDataF EXCLUSIVE NEW USE AddDataL1 EXCLUSIVE NEW USE AddDataL2 EXCLUSIVE NEW ****** Выбрать в массив пути на модели aAppl := {} SELECT Appls DBGOTOP() DO WHILE .NOT. EOF() AADD(aAppl, Path_appl) DBSKIP(1) ENDDO mFlagErr = .F. FOR m=1 TO LEN(aAppl) DIRCHANGE(aAppl[m]) IF .NOT. FILE('Dost_modCls.dbf') mFlagErr = .T. EXIT ELSE USE Dost_modCls EXCLUSIVE NEW SELECT Dost_modCls ********** Найти и запомнить строку с максимальной L2-мерой M_MaxValF = -9999999999 M_MaxValL1 = -9999999999 M_MaxValL2 = -9999999999 DBGOTOP() DO WHILE .NOT. EOF() IF Dost_modCls->F_mera > M_MaxValF M_MaxValF = Dost_modCls->F_mera mRecnoF = RECNO() ENDIF IF Dost_modCls->L1_mera > M_MaxValL1 M_MaxValL1 = Dost_modCls->L1_mera mRecnoL1 = RECNO() ENDIF IF Dost_modCls->L2_mera > M_MaxValL2 M_MaxValL2 = Dost_modCls->L2_mera mRecnoL2 = RECNO() ENDIF DBSKIP(1) ENDDO DBGOTO(mRecnoF) aRF := {} FOR j=1 TO FCOUNT() AADD(aRF, FIELDGET(j)) NEXT DBGOTO(mRecnoL1) aRL1 := {} FOR j=1 TO FCOUNT() AADD(aRL1, FIELDGET(j)) NEXT DBGOTO(mRecnoL2) aRL2 := {} FOR j=1 TO FCOUNT() AADD(aRL2, FIELDGET(j)) NEXT **** Записать строку с всеми показателями этой строки DIRCHANGE(Disk_dir) SELECT AddDataF APPEND BLANK FOR j=1 TO LEN(aRF) FIELDPUT(j, aRF[j]) NEXT SELECT AddDataL1 APPEND BLANK FOR j=1 TO LEN(aRL1) FIELDPUT(j, aRL1[j]) NEXT SELECT AddDataL2 APPEND BLANK FOR j=1 TO LEN(aRL2) FIELDPUT(j, aRL2[j]) NEXT ENDIF NEXT DC_Impl(oScrn) IF mFlagErr aMess := {} AADD(aMess, L('В некоторых приложениях не выполнен режим 3.5 и поэтому в них нет')) AADD(aMess, L('базы оценки достверности моделей: "Dost_modCls.dbf". Надо выполнить')) AADD(aMess, L('режим 3.5 во всех приложениях и запустить данный режим снова.')) LB_Warning(aMess, L('4.1.3.11.Объединение в одной БД строк по самым достоверным моделям')) ELSE IF mPar aMess := {} AADD(aMess, L('Базы данных по наиболее достоверным моделям различных приложений успешно сформированы!')) AADD(aMess, L(' ')) AADD(aMess, L('Вот эти базы данных:')) AADD(aMess, L('- по F-критерию Ван Ризбергена : ')+Disk_dir+'\"AddDataF.dbf"') AADD(aMess, L('- по L1-критерию проф.Е.В.Луценко: ')+Disk_dir+'\"AddDataL1.dbf"') AADD(aMess, L('- по L2-критерию проф.Е.В.Луценко: ')+Disk_dir+'\"AddDataL2.dbf"') AADD(aMess, L(' ')) AADD(aMess, L('Все эти базы данных открыватся в MS Excel.')) LB_Warning(aMess, L('4.1.3.11.Объединение в одной БД строк по самым достоверным моделям')) ENDIF ENDIF ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN nil ****************************************************************************************** ******** Лаб.раб.№ 4.01: АСК-анализ мирового времени по данным сайта: "ftp://tai.bipm.org" ****************************************************************************************** FUNCTION LW401() ***************************************************************** *** Скачать по FTP файлы по маске по заданному пути *** Преобразовать их в DBF и XLS(X) для 2.3.2.3. *** - сформировать обобщенные горизонтальную и вертикальную шапки *** путем перебора и просмотра всех файлов исходных данных *** - заполнить матрицу расхождениями в темпе времени *** Сформировать параметры для 2.3.2.2 и запустить его ***************************************************************** ***************************************************************** *** Скачать по FTP файлы по заданному пути ***************************************************************** oScrn := DC_WaitOn( L('Получение FTP-доступа к серверу: "ftp://tai.bipm.org/"' ),,,,,,,,,,,.F.) Ftp_User = 'anonymous' Ftp_Passw = 'anonymous' DIRCHANGE(Disk_dir+"\AID_DATA\Inp_data\") // Перейти в папку Inp_data Zap_InpData() // Удалить все файлы из папки Inp_data cGDServer := "ftp://tai.bipm.org" oFtp := FTPClient():new( cGDServer, Ftp_User, Ftp_Passw ) // Соединение с моим сайтом и авторизация IF oFtp:connect() // Есть соединение с моим сайтом и авторизация? DC_Impl(oScrn) **** Сделать текущей папку: ftp://tai.bipm.org/UTCr/Results/pilot_experiment/ oScrn := DC_WaitOn( L('Переход в папку: "/UTCr/Results/pilot_experiment/"' ),,,,,,,,,,,.F.) IF oFtp:curDir() <> '/UTCr/Results/pilot_experiment/' DC_Impl(oScrn) LB_Warning(L('Не удалось сделать текущей директорию: "/UTCr/Results/pilot_experiment/"'), L('(C) Система "Эйдос-Х++"' )) RETURN NIL ENDIF DC_Impl(oScrn) PUBLIC aDir := oFtp:Directory('UTCr_1*') // Борис Борзик, для этого нужен только FTP, т.к. под HTTP не работает oHttp:Directory() * DC_DebugQout( aDir ) **** Просмотр массива директории с FTP-сервера от Роджера mN = LEN(ALLTRIM(STR(Len(aDir)))) // Число разрядов, которое нужно для нумерации файлов mLenMax = -99999 aDirectory := {} FOR i := 1 TO Len(aDir) AADD(aDirectory, ALLTRIM(aDir[i])) mString = STRTRAN(STR(i,mN),' ','0')+' '+ConvToOemCP(aDir[i]) aDir[i] := { mString } mLenMax = MAX(mLenMax, LEN(mString)) NEXT **** Визуализация списка файлов @ 0,0 DCBROWSE oBrowse DATA aDir SIZE mLenMax+2,30 FIT FONT '10.Lucida Console' DCBROWSECOL ELEMENT 1 HEADER L('На FTP-сервере: ')+ALLTRIM(STR(Len(aDir)))+L(' табличных файлов исходных данных:') PARENT oBrowse WIDTH mLenMax+2 DCREAD GUI FIT *** Имя файла всегда последнее в строке, искать его справа налево до " " *** Отличать имена файлов от имен папок, использовать только имена файлов aFileName := {} oScrn := DC_WaitOn( L('Загрузка ')+ALLTRIM(STR(LEN(aDirectory)))+L(' файлов с FTP-сервера: "ftp://tai.bipm.org/UTCr/Results/pilot_experiment/"' ),,,,,,,,,,,.F.) FOR j=1 TO LEN(aDirectory) mPos = RAT(' ',aDirectory[j]) mFileName = SUBSTR(aDirectory[j],mPos+1,LEN(aDirectory[j])-mPos) * oScrn := DC_WaitOn( L('Загрузка файла: ')+ALLTRIM(STR(j))+'/'+ALLTRIM(STR(LEN(aDirectory)))+'-"'+ConvToOemCP(mFileName)+L('.txt" с FTP-сервера: "ftp://tai.bipm.org/UTCr/Results/pilot_experiment/"' ),,,,,,,,,,,.F.) IF oFtp:GetFile(mFileName, mFileName) AADD(aFileName, mFileName) ENDIF * DC_Impl(oScrn) NEXT DC_Impl(oScrn) ELSE DC_Impl(oScrn) LB_Warning(L('Нет соединения с FTP-сервером'), L('(C) Система "Эйдос-Х++"')) RETURN NIL ENDIF *** Перенос файлов приложения из папки с исполнимым модулем системы "Эйдос" в папку Inp_data DIRCHANGE(Disk_dir) // Перейти в папку с системой ASORT(aFileName) FOR j=1 TO LEN(aFileName) Name_SS = aFileName[j] Name_DD = Disk_dir+"\AID_DATA\Inp_data\"+aFileName[j]+'.txt' RenameFile(Name_SS, Name_DD) NEXT ************************************************************************************************ aMess := {} AADD(aMess, L('С FTP-сервера: "ftp://tai.bipm.org/UTCr/Results/pilot_experiment/"')) AADD(aMess, L('успешно скачано: ')+ALLTRIM(STR(LEN(aFileName))) +L(' табличных файлов исходных данных.')) AADD(aMess, L('Эти файлы записаны в папку: "') + Disk_dir+'\AID_DATA\Inp_data\"') LB_Warning(aMess, L('(C) Система "Эйдос-Х++"')) ***************************************************************** *** Преобразовать их в DBF и XLS(X) для 2.3.2.3. *** - сформировать обобщенные горизонтальную и вертикальную шапки *** путем перебора и просмотра всех файлов исходных данных *** - заполнить матрицу расхождениями в темпе времени ***************************************************************** *** - сформировать обобщенные горизонтальную и вертикальную шапки *** путем перебора и просмотра всех файлов исходных данных ********* Найти все TXT-файлы в папке Inp_data DIRCHANGE(Disk_dir+"\AID_DATA\Inp_data\") // Перейти в папку Inp_data mNTxtFiles = ADIR("*.TXT") // Кол-во TXT-файлов IF mNTxtFiles = 0 LB_Warning(L('В папке: ')+Disk_dir+L('\AID_DATA\Inp_data\ нет TXT-файлов'), L('(c) Система "ЭЙДОС-X++"')) ELSE PRIVATE aFileName[mNTxtFiles] ADIR("*.txt", aFileName) ENDIF aLaboratory := {} // Наименования станций мирового времени aDate := {} // Дата в стиле: 'ГГГГ_ММ_ДД' aMonth := {'JAN','FEB','MAR','APR','MAY','JUN','JUL','AUG','SEPT','OCT','NOV','DEC'} aYear := {} FOR j=1900 TO 2200 AADD(aYear, ALLTRIM(STR(j))) NEXT oScrn := DC_WaitOn( L('Анализ шапок файлов с FTP-сервера' ),,,,,,,,,,,.F.) FOR f=1 TO LEN(aFileName) // Цикл по файлам исходных данных табличного типа ******* Считать текущий файл, заменить в нем символы окончания строки на CrLf и опять записать. CrLf = CHR(13)+CHR(10) // Конец строки (записи) mFile = FileStr(aFileName[f]) // Загрузка файла mFile = STRTRAN(mFile, CHR(10), CrLf ) // Заменить HEX(OA) на HEX(OD)+HEX(OA) StrFile(mFile, aFileName[f]) // Запись файла ******* Открыть файл исходных данных и организовать цикл по строкам и построчный анализ nHandle := DC_txtOpen( aFileName[f] ) mNumLine = 0 // Номер обрабатываемой строки DO WHILE !DC_TxtEOF( nHandle ) // Начало цикла по строкам mNumLine++ mLine = DC_TxtLine( nHandle ) // Выделить строку из текстового файла * MsgBox(mLine + '; число элементов: ' + STR(NUMTOKEN(mLine," "))) IF NUMTOKEN(mLine," ") > 0 * Nстр********* Пример файла исходных данных ****************************************************** * 01 UTCr_1205 * 02 2012 FEBRUARY 27, 15h UTC * 03 * 04 The results in this page are established by the BIPM Time Department in the frame of * 05 the pilot experiment on a rapid UTC, UTCr. The computed values [UTCr-UTC(k)] are reported. * 06 * 07 Date 2012 0h UTC JAN 30 JAN 31 FEB 1 FEB 2 FEB 3 FEB 4 FEB 5 * 08 MJD 55956 55957 55958 55959 55960 55961 55962 * 09 Laboratory k [UTCr-UTC(k)]/ns * 10 * 11 AOS (Borowiec) -2.3 -3.1 -3.4 -3.8 -4.1 -5.2 -6.7 * 12 BEV (Wien) 71.6 70.9 73.3 71.7 71.7 70.8 69.7 * 13 CAO (Cagliari) -6214.5 -6216.6 -6215.7 -6213.7 -6213.7 -6212.0 -6218.5 * 14 CH (Bern) -9.0 -8.5 -8.4 -8.9 -9.4 -9.1 -9.3 * CNM (Queretaro) -12.8 -13.0 -11.3 -11.6 -11.5 -11.7 -12.0 * CNMP (Panama) 37.4 39.7 44.2 47.4 52.4 55.3 63.2 * DTAG (Frankfurt/M) 33.5 33.7 30.7 28.3 22.5 21.6 19.0 * IPQ (Caparica) -9.0 -12.4 -12.6 -15.5 -13.4 -15.3 -12.7 * IT (Torino) -13.3 -12.8 -13.1 -14.0 -14.6 -13.8 -13.9 * KRIS (Daejeon) 27.3 26.7 26.2 25.5 24.2 23.5 22.7 * LT (Vilnius) 71.0 70.1 75.2 73.3 68.3 68.9 68.4 * MSL (Lower Hutt) 109.4 106.4 97.5 97.2 97.7 103.9 105.4 <=######## пробел в названии * NICT (Tokyo) 0.3 0.6 1.2 1.6 1.4 1.5 1.5 * NIM (Beijing) -9.0 -8.7 -8.5 -8.2 -8.2 -7.6 -7.0 * NIMT (Pathumthani) 841.5 843.4 847.8 852.8 854.9 858.1 857.5 * NIS (Cairo) -729.5 -730.4 -728.2 -731.2 -730.9 -729.6 -732.8 * NIST (Boulder) -0.3 0.0 -0.6 -0.5 -0.1 -1.0 -2.3 * NMIJ (Tsukuba) -4.7 -5.1 -4.8 -5.1 -5.7 -5.5 -5.6 * NMLS (Sepang) -609.4 -610.6 -614.3 -613.5 -614.9 -617.1 -619.2 * NRC (Ottawa) -26.4 -27.2 -30.6 -27.7 -28.0 -25.7 -24.7 * NTSC (Lintong) 3.5 3.1 7.5 7.8 5.4 4.7 4.1 * ONRJ (Rio de Janeiro) -23.1 -15.8 -17.3 -20.6 -20.3 -26.6 -25.3 * OP (Paris) -22.2 -21.3 -20.3 -20.3 -21.6 -19.0 -20.3 * ORB (Bruxelles) 2.6 1.9 1.2 0.1 -1.2 -2.5 -2.2 * PTB (Braunschweig) -3.9 -4.0 -4.2 -4.5 -5.0 -5.1 -4.8 * ROA (San Fernando) -12.5 -12.5 -12.5 -12.8 -13.1 -13.0 -12.6 * SP (Boras) -9.1 -9.6 -10.0 -10.5 -10.9 -11.0 -11.0 * SU (Moskva) -4.8 -4.1 -4.1 -3.7 -3.2 -3.5 -4.3 * TL (Chung-Li) 18.2 18.1 18.0 17.1 16.4 16.2 16.1 * UME (Gebze-Kocaeli) 64.4 69.3 69.4 68.7 69.3 72.2 70.8 * USNO (Washington DC) 2.3 2.4 2.6 2.0 1.6 1.6 1.6 * VSL (Delft) 3.0 4.1 1.8 -1.1 -2.9 -3.7 -1.8 * * These results should not be used as a prediction of UTC. * UTC remains available from the monthly Circular T at * (http://www.bipm.org/jsp/en/TimeFtp.jsp?TypePub=publication). * The BIPM retains full internationally protected copyright of these results. * The BIPM declines all liability in the event of improper use of these results. * ********* Пример файла исходных данных ****************************************************** *** Разбор строки и формирование выходной базы данных * aLaboratory := {} // Наименования станций мирового времени * aDate := {} // Дата в стиле: 'ГГГГ_ММ_ДД' * aMJD := {} // Юлианский день DO CASE CASE mNumLine = 7 // Наименования полей в стиле: 'ГГГГ_ММ_ДД' aStringInp := {} // Входная строка "как есть" FOR w=1 TO NUMTOKEN(mLine," ") // Разделитель между показателями - пробел mWord = ALLTRIM(TOKEN(mLine, " ", w)) AADD(aStringInp, mWord) NEXT * DC_DebugQout( aStringInp ) * Date 2012 0h UTC JAN 30 JAN 31 FEB 1 FEB 2 FEB 3 FEB 4 FEB 5 <- Called From: LW210(39606), ADDSAPPLS(8011), (B)F1_3(8011) * 1 2 3 4 5 6 7 8 9 1011 1213 1415 1617 18 FOR j=5 TO LEN(aStringInp) STEP 2 // Цикл по элементам входной строки FOR y=1 TO LEN(aYear) IF AT(aYear[y], mLine) > 0 EXIT ENDIF NEXT IF y = 0 DC_Impl(oScrn) MsgBox('В 7-й строке файла исходных данных нет ни одного года из диапазона: 1900-2200!') DIRCHANGE(Disk_dir) // Перейти в папку с системой RETURN nil ENDIF mDate = aYear[y]+'_'+STRTRAN(STR(ASCAN(aMonth,aStringInp[j]),2),' ','0')+'_'+STRTRAN(STR(VAL(aStringInp[j+1]),2),' ','0') IF ASCAN(aDate, mDate) = 0 AADD (aDate, mDate) ENDIF NEXT CASE mNumLine > 10 .AND. NUMTOKEN(mLine," ") > 0 // Наименования станций мирового времени aStringInp := {} // Входная строка "как есть" mLaboratory = SUBSTR(mLine, 1, AT(")", mLine)) // Это нужно потому, что в названии лабораторий встречаются пробелы AADD(aStringInp, mLaboratory) * DC_DebugQout( aStringInp ) IF ASCAN(aLaboratory, mLaboratory) = 0 AADD (aLaboratory, mLaboratory) ENDIF ENDCASE ENDIF ** Выход из цикла по строкам по пустой строке в конце файла IF mNumLine > 10 .AND. NUMTOKEN(mLine," ") = 0 EXIT ENDIF DC_TxtSkip( nHandle, 1 ) ENDDO DC_TxtClose( nHandle ) NEXT DC_Impl(oScrn) ASORT( aLaboratory ) ASORT( aDate ) * DC_DebugQout( aLaboratory );MsgBox('STOP') * DC_DebugQout( aDate );MsgBox('STOP') **** Создать базу входных данных Inp_data.dbf по сформированым массивам mMaxLen = -999999 FOR j=1 TO LEN(aLaboratory) mMaxLen = MAX(mMaxLen, LEN(ALLTRIM(aLaboratory[j]))) NEXT aStructure := { { "Object" , "C", mMaxLen, 0 },; { "Laboratory", "C", mMaxLen, 0 } } FOR j=1 TO LEN(aDate) mFN = aDate[j] AADD(aStructure, { mFN, "N", 15, 7 }) NEXT DbCreate( 'Inp_data.dbf', aStructure ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Inp_data EXCLUSIVE NEW FOR i=1 TO LEN(aLaboratory) APPEND BLANK REPLACE Object WITH aLaboratory[i] REPLACE Laboratory WITH aLaboratory[i] FOR j=1 TO LEN(aDate) FIELDPUT(2+j, 0 ) NEXT NEXT ********************************************************************** **** Записать в БД "Inp_data.dbf" данные из TXT-файлов исходных данных ********************************************************************** oScrn := DC_WaitOn( L('Запись в БД "Inp_data.dbf" информации из исходных TXT-файлов с FTP-сервера' ),,,,,,,,,,,.F.) ********** Имена полей БД "Inp_data.dbf" aFieldName := {} FOR j=1 TO FCOUNT() AADD(aFieldName, ALLTRIM(FIELDNAME(j))) NEXT DC_ASave(aFieldName, "_ColumnNames.arx") // Запись массива наименований шкал (колонок) aInp_name в виде файла "_Inp_name.arx" ********** Имена 1-го поля записей БД "Inp_data.dbf" * aLaboratory := {} * DBGOTOP() * DO WHILE .NOT. EOF() * AADD(aLaboratory, ALLTRIM(FIELDNAME(1))) * DBSKIP(1) * ENDDO FOR f=1 TO LEN(aFileName) // Цикл по файлам исходных данных табличного типа ******* Считать текущий файл, заменить в нем символы окончания строки на CrLf и опять записать. CrLf = CHR(13)+CHR(10) // Конец строки (записи) mFile = FileStr(aFileName[f]) // Загрузка файла mFile = STRTRAN(mFile, CHR(10), CrLf ) // Заменить HEX(OA) на HEX(OD)+HEX(OA) StrFile(mFile, aFileName[f]) // Запись файла ******* Открыть файл исходных данных и организовать цикл по строкам и построчный анализ nHandle := DC_txtOpen( aFileName[f] ) mNumLine = 0 // Номер обрабатываемой строки DO WHILE !DC_TxtEOF( nHandle ) // Начало цикла по строкам mNumLine++ mLine = DC_TxtLine( nHandle ) // Выделить строку из текстового файла IF NUMTOKEN(mLine," ") > 0 IF mNumLine = 7 aStringInp7 := {} // Входная строка "как есть" FOR w=1 TO NUMTOKEN(mLine," ") // Разделитель между показателями - пробел mWord = ALLTRIM(TOKEN(mLine, " ", w)) AADD(aStringInp7, mWord) NEXT FOR y=1 TO LEN(aYear) IF AT(aYear[y], mLine) > 0 mYear = aYear[y] EXIT ENDIF NEXT IF y = 0 DC_Impl(oScrn) MsgBox(L('В 7-й строке файла исходных данных нет ни одного года из диапазона: 1900-2200!')) DIRCHANGE(Disk_dir) // Перейти в папку с системой RETURN nil ENDIF ENDIF IF mNumLine > 10 .AND. NUMTOKEN(mLine," ") > 0 // Строки с данными по станциям мирового времени aStringInp := {} // Входная строка "как есть" mLaboratory = SUBSTR(mLine, 1, AT(")", mLine)) // Это нужно потому, что в названии лабораторий встречаются пробелы AADD(aStringInp, mLaboratory) mSubLine = SUBSTR(mLine, AT(")", mLine)+1, LEN(mLine)-AT(")", mLine)) FOR w=1 TO NUMTOKEN(mSubLine," ") // Разделитель между показателями - пробел mWord = ALLTRIM(TOKEN(mSubLine, " ", w)) AADD(aStringInp, mWord) NEXT *** Разбор строки и формирование выходной базы данных * MsgBox(STR(mNumLine)+' '+mSubLine+' '+STR(NUMTOKEN(mSubLine," "))) FOR j=2 TO LEN(aStringInp) // Цикл по элементам входной строки *** Определение номера поля и номера строки и занесение информации из файла иходных данных в БД "Inp_data.dbf" * 07 Date 2012 0h UTC JAN 30 JAN 31 FEB 1 FEB 2 FEB 3 FEB 4 FEB 5 Всего 18 * 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 * 08 MJD 55956 55957 55958 55959 55960 55961 55962 * 09 Laboratory k [UTCr-UTC(k)]/ns * 10 * 11 AOS (Borowiec) -2.3 -3.1 -3.4 -3.8 -4.1 -5.2 -6.7 Всего 8 * 1 2 3 4 5 6 7 8 * 12 BEV (Wien) 71.6 70.9 73.3 71.7 71.7 70.8 69.7 * 13 CAO (Cagliari) -6214.5 -6216.6 -6215.7 -6213.7 -6213.7 -6212.0 -6218.5 mDate = mYear+'_'+STRTRAN(STR(ASCAN(aMonth,aStringInp7[j*2+1]),2),' ','0')+'_'+STRTRAN(STR(VAL(aStringInp7[j*2+2]),2),' ','0') mCol = ASCAN(aFieldName , mDate ) mLaboratory = aStringInp[1] mRec = ASCAN(aLaboratory, mLaboratory) * MsgBox(STR(j)+' '+mDate+' '+STR(mCol)+' '+mLaboratory+' '+STR(mRec)) IF mRec * mCol > 0 DBGOTO(mRec) FIELDPUT(mCol, VAL(aStringInp[j])) ENDIF NEXT ENDIF ENDIF ** Выход из цикла по строкам по пустой строке в конце файла IF mNumLine > 10 .AND. NUMTOKEN(mLine," ") = 0 EXIT ENDIF DC_TxtSkip( nHandle, 1 ) ENDDO DC_TxtClose( nHandle ) NEXT DC_Impl(oScrn) ***** Формирование параметров для 2.3.2.2 и его запуск ***** Записать новые файлы: Inp_name.txt и Inp_nameALL.txt для БД Inp_data.dbf CrLf = CHR(13)+CHR(10) // Конец строки (записи) mNField = LEN(aFieldName) String = '' FOR j=1 TO mNField String = String + aFieldName[j] + CrLf NEXT StrFile(String, "Inp_nameAll.txt") // Запись текстового файла "Inp_nameAll.txt" String = '' FOR j=2 TO mNField String = String + aFieldName[j] + CrLf NEXT StrFile(String, "Inp_name.txt") // Запись текстового файла "Inp_name.txt" Regim = 1 // Формализации ПО или ген.расп.выб. Flag_zer = 2 // Считать нули и пробелы отсутствием данных? [1]-да, [2]-нет N_Chast = 1 // На сколько частей N разбивать обучающую или распознаваемую выборку (в зависимости от Regim) M_ClSc1 = 2 // Номер начального столбца диапазона классификационных шкал M_ClSc2 = 2 // Номер конечного столбца диапазона классификационных шкал M_OpSc1 = 3 // Номер начального столбца диапазона описательных шкал M_OpSc2 = FCOUNT() // Номер конечного столбца диапазона описательных шкал M_ObAnk = 3 // Создавать анкеты исходной выборки по строкам Inp_data-[1], по классам-[2], и 1-е, и 2-е [3] M_Interval = 2 // 1-равные интервалы, 2-адаптивные интервалы (с примерно равным количеством наблюдений, по Котельникову) N_SKGrCl = 5 N_SKGrPr = 5 K_N_ClSc = 1 K_N_OpSc = 1 K_N_GrClSc = 10 K_N_GrOpSc = 10 M_Scenario = .F. mGorizMin = 5 mGorizMax = 5 mGlubMin = 5 mGlubMax = 5 K_GradNClSc = 5 K_GradNOpSc = 5 M_ChastObi = .F. M_ChastRso = .F. N_ChastObi = 1 N_ChastRso = 1 M_XlsDbf = 3 mTxtCSField = 1 // Способ интерпретации значений текстовых полей - классификационных шкал файла исходных данных mTxtOSField = 1 // Способ интерпретации значений текстовых полей - описательных шкал файла исходных данных mTxtCSSep = " " // Разделитель элементов классификационных шкал, если mTxtCSField=3 mTxtOSSep = " " // Разделитель элементов описательных шкал, если mTxtOSField=3 * mScenario = 1 // mScenario=1 Не применять сценарный метод АСК-анализа и спец.интерпретацию TXT-полей (старый вариант) mScenario = 1 // Не применять сценарный метод АСК-анализа mSpecInterprCls = .F. // .T. - Применить спец.интерпретацию текстовых полей классов, .F. - не применять mSpecInterprAtr = .F. // .T. - Применить спец.интерпретацию текстовых полей признаков, .F. - не применять mNameGrNumSc= 1 // Какие наименования ГРАДАЦИЙ числовых шкал использовать mClsAvr = .F. // .F. - делать модель из Inp_data, .T. - делать модель из Inp_data_avr mSortUnqCls = 1 // Выделять уникальные значения классов и сортировать, 1-да, 2-нет mLemmatCls = 2 // Проводить лемматизацию классов, 1-да, 2-нет mSortUnqGos = 1 // Выделять уникальные значения признаков и сортировать, 1-да, 2-нет mLemmatGos = 2 // Проводить лемматизацию признаков, 1-да, 2-нет // Сохранить файл с информацией о заданых параметрах программного интерфейса в текущей директории системы PRIVATE aSoftInt[40] aSoftInt[ 1] = Regim aSoftInt[ 2] = Flag_zer aSoftInt[ 3] = M_ClSc1 aSoftInt[ 4] = M_ClSc2 aSoftInt[ 5] = M_OpSc1 aSoftInt[ 6] = M_OpSc2 aSoftInt[ 7] = N_SKGrCl aSoftInt[ 8] = N_SKGrPr aSoftInt[ 9] = K_N_ClSc aSoftInt[10] = K_N_OpSc aSoftInt[11] = K_N_GrClSc aSoftInt[12] = K_N_GrOpSc aSoftInt[13] = M_ObAnk aSoftInt[14] = N_Chast aSoftInt[15] = M_Interval aSoftInt[16] = M_Scenario aSoftInt[17] = K_GradNClSc // Количество градаций в числовой классификационной шкале aSoftInt[18] = K_GradNOpSc // Количество градаций в числовой описательной шкале aSoftInt[19] = mGorizMin aSoftInt[20] = mGorizMax aSoftInt[21] = mGlubMin aSoftInt[22] = mGlubMax aSoftInt[23] = M_ChastObi aSoftInt[24] = M_ChastRso aSoftInt[25] = N_ChastObi aSoftInt[26] = N_ChastRso aSoftInt[27] = M_XlsDbf aSoftInt[28] = mTxtCSField aSoftInt[29] = mTxtOSField aSoftInt[30] = mTxtCSSep aSoftInt[31] = mTxtOSSep * aSoftInt[32] = mScenario // mScenario=1 Не применять сценарный метод АСК-анализа и спец.интерпретацию TXT-полей (старый вариант) aSoftInt[32] = mScenario // mScenario=1 Не применять сценарный метод АСК-анализа aSoftInt[33] = mSpecInterprCls // Применить спец.интерпретацию текстовых полей классов aSoftInt[34] = mSpecInterprAtr // Применить спец.интерпретацию текстовых полей признаков aSoftInt[35] = mNameGrNumSc // Какие наименования ГРАДАЦИЙ числовых шкал использовать aSoftInt[36] = mClsAvr // .F. = модель без усреднения по классам aSoftInt[37] = mSortUnqCls // Выделять уникальные значения классов и сортировать, 1-да, 2-нет aSoftInt[38] = IF(mSpecInterprCls,mLemmatCls,2) // Проводить лемматизацию классов, 1-да, 2-нет aSoftInt[39] = mSortUnqGos // Выделять уникальные значения признаков и сортировать, 1-да, 2-нет aSoftInt[40] = IF(mSpecInterprAtr,mLemmatGos,2) // Проводить лемматизацию признаков, 1-да, 2-нет DC_ASave(aSoftInt , Disk_dir +"\_2_3_2_2.arx") * DC_ASave(aSoftInt , M_NewAppl+"\_2_3_2_2.arx") F2_3_2_2('Лаб.раб.№ 2.10: АСК-анализ мирового времени по данным сайта: "ftp://tai.bipm.org"',"1.3()") // Запуск универсального программного интерфейса с внешними базами данных DIRCHANGE(Disk_dir) // Перейти в папку с системой RETURN nil **************************************************** ******** Преобразование Abs, Prc#, Inf# из TXT в DBF **************************************************** FUNCTION ConvTXTtoDBF() // Проверить наличие основных файлов и выдать сообщение, если каких-то не хватает DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения IF .NOT. FILE( "Opis_Sc.dbf" ) .OR. ; .NOT. FILE( "Gr_OpSc.dbf" ) aMess := {} AADD(aMess, L('В папке текущего приложения: "#" нет необходимых файлов.')) aMess[1] = STRTRAN(aMess[1], "#", UPPER(ALLTRIM(M_PathAppl))) AADD(aMess, L('Необходимо создать приложение в режиме: 1.3 или 2.3.2.2 !!!')) LB_Warning(aMess, L('4.5. Визуализация когнитивных функций системы "Эйдос-Х++"' )) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы RETURN NIL ENDIF IF FILE( "ABS.txt" ) .OR. ; FILE( "PRC1.txt" ) .OR. ; FILE( "PRC2.txt" ) .OR. ; FILE( "INF1.txt" ) .OR. ; FILE( "INF2.txt" ) .OR. ; FILE( "INF3.txt" ) .OR. ; FILE( "INF4.txt" ) .OR. ; FILE( "INF5.txt" ) .OR. ; FILE( "INF6.txt" ) .OR. ; FILE( "INF7.txt" ) * OK ELSE aMess := {} AADD(aMess, L('В папке текущего приложения: "#"')) AADD(aMess, L('должен быть хотя бы один из файлов: Abs.txt, Prc1.txt, Prc2.txt, Inf1.txt, Inf2.txt, Inf3.txt, Inf4.txt, Inf5.txt, Inf6.txt, Inf7.txt')) aMess[1] = STRTRAN(aMess[1], "#", UPPER(ALLTRIM(M_PathAppl))) AADD(aMess, L("Для того, чтобы их создать необходимо выполнить режим 3.4 или 3.5.")) LB_Warning(aMess, L('4.5. Визуализация когнитивных функций системы "Эйдос-Х++"' )) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы RETURN NIL ENDIF mLenNameMax = CreateStructAll() // Создание файлов структур баз данных всех моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Attributes EXCLUSIVE NEW USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() // Количество классов (градаций классификационных шкал) USE Gr_OpSc EXCLUSIVE NEW;N_Gos = RECCOUNT() // Количество признаков (градаций описательных шкал) USE Opis_Sc EXCLUSIVE NEW PRIVATE aInfTime[LEN(Ar_Model)] // Время создания основных баз данных моделей: Abs, Prc#, Inf# FOR z=1 TO LEN(Ar_Model) aInfTime[z] = FileTime(Ar_Model[z]+'.txt') NEXT DC_ASave(aInfTime, "_InfTime.arx") // Сформировать и записать массив времен создания основных баз данных моделей, если его не было *aInfTime = DC_ARestore("_InfTime.arx") ***** Копирование основных БД всех моделей из txt в dbf формат с числом полей до 2035 IF N_Cls > 2035 LB_Warning(L("Будут показаны только первые 2035 колонок"), L('5.5. Просмотр основных БД всех моделей' )) ENDIF * ########################################################################### // Открытие текстовых баз данных ******************************************** *** Создание баз данных в dbf-формате с найденной максимальной длиной наименования шкалы + строки и столбцы, как в Inf# GenDbfAbsOld(mLenNameMax) GenDbfPrcOld(mLenNameMax) GenDbfInfOld(mLenNameMax) *DC_ASave(aInfStruct, "_InfStruct.arx") // Когда БД создается - записывать структуру, когда открывается - считывать aInfStruct = DC_ARestore("_InfStruct.arx") *DC_ASave(aStrEmpty, "_aStrEmpty.arx") // Записывать только после расчета Abs.txt, а при расчете остальных БД только считывать *DC_ASave(aColEmpty, "_aColEmpty.arx") aStrEmpty = DC_ARestore("_aStrEmpty.arx") aColEmpty = DC_ARestore("_aColEmpty.arx") ************************************************* ***** Формирование пустой записи N_Col = N_Cls+6 // Число полей CrLf = CHR(13)+CHR(10) // Конец строки (записи) Lc_buf = "" FOR j=1 TO N_Col * S = IF(j=2*INT(j/2),"#","X") // Для отладки S = " " // Для работы Lc_buf = Lc_buf + REPLICATE(S, aInfStruct[j,3]) NEXT Lc_buf = Lc_buf + CrLf PUBLIC Len_LcBuf := LEN(Lc_buf) ****** Открываем стат.базы и базы знаний (7 по частным критериям знаний) Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } PUBLIC nHandle[LEN(Ar_Model)] FOR z=1 TO LEN(Ar_Model) nHandle[z] := FOpen( Ar_Model[z]+".txt", FO_READWRITE ) // Открыть все текстовые базы данных ######################################## NEXT **** Рассчет массива начальных позиций полей в строке PUBLIC aPos[N_Col] aPos[1] = 1 FOR j=2 TO N_Col aPos[j] = aPos[j-1] + aInfStruct[j-1,3] NEXT * ########################################################################### ***** Открытие основных БД.dbf всех моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() // Количество классов (градаций классификационных шкал) FOR z=1 TO LEN(Ar_Model) M_Inf = Ar_Model[z] USE (M_Inf) EXCLUSIVE NEW NEXT ***************************** nMax = N_Gos + 4 + ( N_Gos + 3 ) * 9 Mess = L('Копирование основных баз данных моделей: Abs, Prc#, Inf#: txt=>dbf') @ 4,5 DCPROGRESS oProgr SIZE 80,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 DCREAD GUI TITLE Mess PARENT @oDial FIT EXIT oDial:show() nTime = 0 DC_GetProgress(oProgr,0,nMax) ***************************** *** Копирование БД.txt => БД.dbf ************** (но не более 2035 полей классов) mNCls = IF(N_Cls<=2035,N_Cls,2035) FOR z=1 TO LEN(Ar_Model) M_Inf = Ar_Model[z] SELECT(M_Inf) FOR i=1 TO N_Gos * IF aStrEmpty[i] DBGOTO(i) Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], i, 1 ));FIELDPUT(1, Fv) Fv = LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], i, 2 ) ;FIELDPUT(2, Fv) FOR j=1 TO mNCls * IF aColEmpty[j] Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], i, 2+j ));FIELDPUT(2+j, Fv) * ENDIF NEXT FOR j=1 TO 3 Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], i, mNCls+2+j ));FIELDPUT(mNCls+2+j, Fv) NEXT * ENDIF DC_GetProgress(oProgr, ++nTime, nMax) NEXT FOR i=1 TO 4 DBGOTO(N_Gos+i) Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], N_Gos+i, 1 ));FIELDPUT(1, Fv) Fv = LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], N_Gos+i, 2 ) ;FIELDPUT(2, Fv) FOR j=1 TO mNCls * IF aColEmpty[j] Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], N_Gos+i, 2+j ));FIELDPUT(2+j, Fv) * ENDIF NEXT FOR j=1 TO 3 Fv = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], N_Gos+i, mNCls+2+j ));FIELDPUT(mNCls+2+j, Fv) NEXT DC_GetProgress(oProgr, ++nTime, nMax) NEXT NEXT *** Закрыть все текстовые БД ****** FOR z=1 TO LEN(Ar_Model) FClose( nHandle[z] ) // Закрытие текстовой базы данных ###################################### NEXT DC_GetProgress(oProgr,nMax,nMax) oDial:Destroy() RETURN nil *************************************************************************************** ******** Убрать подряд идущие нули после значащих цифр в числовом интервальном значении *************************************************************************************** FUNCTION DelZeroNameGr(mNameGrDelZero) LOCAL p1, p2, p3, aOutData := {}, mMinGR := '', mMaxGR := '', mFlag, j * 4/10-{30.7000000, 40.6000000} * 12345678911111111112222222222 * 01234567890123456789 * 1234567891 1234567891 * 0 0 p1 = AT('{',mNameGrDelZero) // = 6 p2 = AT(',',mNameGrDelZero) // = 17 p3 = AT('}',mNameGrDelZero) // = 29 mMinGR = '' mMaxGR = '' IF NUMAT(',',mNameGrDelZero) = 1 .AND. NUMAT('{',mNameGrDelZero) = 1 .AND. NUMAT('}',mNameGrDelZero) = 1 IF p1+p2+p3 > 0 mMinGR = SUBSTR(mNameGrDelZero,p1+1,p2-p1-1) // SUBSTR(mNameGrDelZero,7,10), p1+1= 7, p2-p1-1=17- 6-1=10 mMaxGR = SUBSTR(mNameGrDelZero,p2+2,p3-p2-2) // SUBSTR(mNameGrDelZero,19,p3-p2), p2+2=19, p3-p2-2=29-17-2=10 ENDIF * MsgBox(mNameGrDelZero+' '+mMinGR+' '+mMaxGR) IF SUBSTR(mMinGR, LEN(mMinGR), 1) = '0' j=LEN(mMinGR) mFlag = .T. DO WHILE mFlag // Ищем справа на лево 1-й не 0. Если это точка - добавляем 0 IF SUBSTR(mMinGR, j, 1) = '0' j-- ELSE IF SUBSTR(mMinGR, j, 1) = '.' j++ ENDIF mFlag = .F. ENDIF ENDDO mMinGR = SUBSTR(mMinGR, 1, j) ENDIF IF SUBSTR(mMaxGR, LEN(mMaxGR), 1) = '0' j=LEN(mMaxGR) mFlag = .T. DO WHILE mFlag // Ищем справа на лево 1-й не 0. Если это точка - добавляем 0 IF SUBSTR(mMaxGR, j, 1) = '0' j-- ELSE IF SUBSTR(mMaxGR, j, 1) = '.' j++ ENDIF mFlag = .F. ENDIF ENDDO mMaxGR = SUBSTR(mMaxGR, 1, j) ENDIF IF p1+p2+p3 > 0 zn = 1 mMinGR = ALLTRIM(STR(ROUND(VAL(mMinGR),zn),19,zn)) // Округление до zn знаков после запятой mMaxGR = ALLTRIM(STR(ROUND(VAL(mMaxGR),zn),19,zn)) mNameGrDelZero = SUBSTR(mNameGrDelZero, 1, p1-1)+'{'+mMinGR+', '+mMaxGR+'}' ENDIF * MsgBox(mNameGrDelZero+' '+mMinGR+' '+mMaxGR) ENDIF aOutData := {} AADD(aOutData, VAL(mMinGR)) AADD(aOutData, VAL(mMaxGR)) AADD(aOutData, ALLTRIM(mNameGrDelZero)) RETURN(ALLTRIM(mNameGrDelZero)) ************************************************* ******** Сохранение экрана (Screen grabber) Roger ************************************************* FUNCTION GraSaveScreen( oSourcePS, aPos, aSize ) LOCAL oBitmap := XbpBitmap():new():create( oSourcePS ) LOCAL oTargetPS := XbpPresSpace():new():create() LOCAL aSourceRect[4], aTargetRect aSourceRect[1] := aSourceRect[3] := aPos[1] aSourceRect[2] := aSourceRect[4] := aPos[2] aSourceRect[3] += aSize[1] aSourceRect[4] += aSize[2] aTargetRect := {0, 0, aSize[1], aSize[2]} oBitmap:presSpace( oTargetPS ) oBitmap:make( aSize[1], aSize[2] ) GraBitBlt( oTargetPS, oSourcePS, aTargetRect, aSourceRect ) RETURN oBitmap ****************************************************************************************** ************************************************************************* // PC CAW 12-30-05 modified to not do winapi printscreen if object passed ** Function LB_Scrn2ClipBoard( oXbp ) ** Copies the specified object (oXbp) to clipboard or the application ** Application desktop if not specified ************************************************************************* FUNCTION LB_Scrn2ClipBoard( oXbp ) LOCAL oSourcePS, oBitmap, oClipBoard, aPos oSourcePS := oXbp:lockPS() IF oXbp:isDerivedFrom('XbpDialog') IF left(OS(OS_VERSION),3) >= '06.' aPos := { -8, -8 } ELSE aPos := { -4, -4 } ENDIF ELSE aPos := { 0, 0 } ENDIF oBitmap := GraSaveScreen( oSourcePS, aPos, oXbp:currentSize() ) oSourcePS:unlockPS() RETURN oBitmap ****************************************************************************************************** ******** 2.Создать все xls-языковые базы для on-line перевода на основе русской языковой базы ****************************************************************************************************** FUNCTION CreateAllLangDB() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Languages EXCLUSIVE NEW USE Lang_ru EXCLUSIVE NEW SELECT Languages mRecno = RECNO() PUBLIC mNum1 := 1 PUBLIC mNum2 := RECCOUNT() @0,0 DCGROUP oGroup1 CAPTION L('Задайте диапазон языков для перевода:') SIZE 68.0, 3.5 @1,2 DCSAY L("Начальный номер:") PARENT oGroup1 @2,2 DCSAY L("Конечный номер:") PARENT oGroup1 @1,32 DCGET mNum1 PICTURE "#####" PARENT oGroup1 @2,32 DCGET mNum2 PICTURE "#####" PARENT oGroup1 DCREAD GUI; TO lExit ; FIT; ADDBUTTONS; MODAL; TITLE L('1.4. Мультиязычная поддержка интерфейса в системе ЭЙДОС-X++') ******************************************************************** IF lExit ** Button Ok ELSE * ADS_SERVER_QUIT() QUIT ENDIF ******************************************************************** IF mNum1 < 1 LB_Warning(L('Начальный номер языка не может быть меньше 1'), L('1.4. Мультиязычная поддержка интерфейса в системе ЭЙДОС-X++')) DBGOTO(mRecno) RETURN NIL ENDIF IF mNum2 > RECCOUNT() LB_Warning(L('Конечный номер языка не может быть больше числа языков:')+' '+ALLTRIM(STR(RECCOUNT())), L('1.4. Мультиязычная поддержка интерфейса в системе ЭЙДОС-X++')) DBGOTO(mRecno) RETURN NIL ENDIF IF mNum1 > mNum2 LB_Warning(L('Начальный номер языка:')+' '+ALLTRIM(STR(mNum1))+' '+L(' не может быть больше конечного:')+' '+ALLTRIM(STR(mNum2)), L('1.4. Мультиязычная поддержка интерфейса в системе ЭЙДОС-X++')) DBGOTO(mRecno) RETURN NIL ENDIF ******************************************************************** aISO639_1 := {} SELECT Languages DBGOTOP() DO WHILE .NOT. EOF() mISO639_1 = ALLTRIM(ISO639_1) * IF mISO639_1 <> 'ru' AADD(aISO639_1, mISO639_1) * ENDIF DBSKIP(1) ENDDO aLangRu := {} mLF = -99999 SELECT Lang_ru DBGOTOP() DO WHILE .NOT. EOF() mTxt = ALLTRIM(TEXTORIG) mLF = MAX(mLF, LEN(mTxt)) AADD(aLangRu, mTxt) DBSKIP(1) ENDDO FOR j=mNum1 TO mNum2 IF aISO639_1[j] <> 'ru' mNameLangDB = 'LangTr_' + aISO639_1[j] mNameLangXls = 'LangTransl_' + aISO639_1[j] + '.XLS' aStructure := { { "TextOrig", "C", mLF, 0 } } DbCreate((mNameLangDB), aStructure ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mNameLangDB) EXCLUSIVE NEW SELECT (mNameLangDB) FOR i=1 TO LEN(aLangRu) APPEND BLANK REPLACE TextOrig WITH aLangRu[i] NEXT * MsgBox(Disk_dir+mNameLangXls) aFields := { 'TextOrig' } DC_WorkArea2Excel(Disk_dir+"\"+mNameLangXls,,,,aFields) // Преобразовать БД mNameLangDB в XLS-файл CLose All ERASE(Disk_dir+"/"+mNameLangDB+'.DBF') ENDIF NEXT CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Languages EXCLUSIVE NEW SELECT Languages DBGOTOP() aMess := {} AADD(aMess, L('На основе актуальной русской языковой базы успешно созданы все заданные языковые XLS-файлы для on-line перевода.')) AADD(aMess, L('Сам on-line перевод XLS-таблиц осуществляется в режиме: "3.Перевод и конвертирование LangBase: xls=>dbf"')) LB_Warning(aMess) RETURN NIL ******************************************************************************************************* ******** Перевод и конвертирование LangBase: xls=>dbf ******************************************************************************************************* FUNCTION TranslConvLangBase(mISO639_1, mRecno) mISO639_1 = ALLTRIM(mISO639_1) n=0 IF InternetGetConnectedState( @n, 0 ) == 0 LB_Warning(L('Нет соединения с Internet, что необходимо для данного режима!'), L('(C) Система "Эйдос-Х++"' )) RETURN NIL ENDIF IF mISO639_1 = 'ru' LB_Warning(L('Русскую языковую базу выбирать для перевода не нужно!'), L('(C) Система "Эйдос-Х++"' )) RETURN NIL ENDIF mNameLangXls = Disk_dir+'\LangTransl_' + mISO639_1 + '.XLS' IF .NOT. FILE(mNameLangXls) aMess := {} AADD(aMess, L('Вы выбрали для перевода языковую базу:'+' '+mNameLangXls)) AADD(aMess, L('Но ее нет в текущей директории. Необходимо выполнить режим:')) AADD(aMess, L('2.Создать все xls-LangBase для on-line перевода')) LB_Warning(aMess) RETURN NIL ENDIF mNameLangXlsTransl = Disk_dir+'\LangTransl_' + mISO639_1 + '.ru.'+mISO639_1+'.XLS' *IF .NOT. FILE("Languages.dbf") ************************************************ **** Сокращенный список языков (всего 51 из 93), **** на которые реально переводит Яндекс ******* **** и результаты отображаются в OEM-866 ******* ************************************************ PUBLIC aLanguages := {; { "Albanian" , "албанский" , "sq" }, ; // 1 { "English" , "английский" , "en" }, ; // 2 { "Afrikaans" , "африкаанс" , "af" }, ; // 3 { "Basque" , "баскский" , "eu" }, ; // 4 { "Bulgarian" , "болгарский" , "bg" }, ; // 5 { "Bosnian" , "боснийский" , "bs" }, ; // 6 { "Welsh" , "валлийский" , "cy" }, ; // 7 { "Hungarian" , "венгерский" , "hu" }, ; // 8 { "Galician" , "галисийский" , "gl" }, ; // 9 { "Greek" , "греческий" , "el" }, ; // 10 { "Danish" , "датский" , "da" }, ; // 11 { "Indonesian" , "индонезийский" , "id" }, ; // 12 { "Irish" , "ирландский" , "ga" }, ; // 13 { "Italian" , "итальянский" , "it" }, ; // 14 { "Icelandic" , "исландский" , "is" }, ; // 15 { "Spanish" , "испанский" , "es" }, ; // 16 { "Catalan" , "каталанский" , "ca" }, ; // 17 { "braid" , "коса" , "xh" }, ; // 18 { "Latin" , "латынь" , "la" }, ; // 19 { "Latvian" , "латышский" , "lv" }, ; // 20 { "Lithuanian" , "литовский" , "lt" }, ; // 21 { "luxembourg" , "люксембургский" , "lb" }, ; // 22 { "Malagasy" , "малагасийский" , "mg" }, ; // 23 { "Malay" , "малайский" , "ms" }, ; // 24 { "Maltese" , "мальтийский" , "mt" }, ; // 25 { "Macedonian" , "македонский" , "mk" }, ; // 26 { "Maori" , "маори" , "mi" }, ; // 27 { "German" , "немецкий" , "de" }, ; // 28 { "Norwegian" , "норвежский" , "no" }, ; // 29 { "Polish" , "польский" , "pl" }, ; // 30 { "Portuguese" , "португальский" , "pt" }, ; // 31 { "Romanian" , "румынский" , "ro" }, ; // 32 { "Russian" , "русский" , "ru" }, ; // 33 { "Cebu" , "себуанский" , "ceb" }, ; // 34 { "Serbian" , "сербский" , "sr" }, ; // 35 { "Slovak" , "словацкий" , "sk" }, ; // 36 { "Slovenian" , "словенский" , "sl" }, ; // 37 { "Swahili" , "суахили" , "sw" }, ; // 38 { "Sundanese" , "сунданский" , "su" }, ; // 39 { "Turkish" , "турецкий" , "tr" }, ; // 40 { "Uzbek" , "узбекский" , "uz" }, ; // 41 { "Ukrainian" , "украинский" , "uk" }, ; // 42 { "Finnish" , "финский" , "fi" }, ; // 43 { "French" , "французский" , "fr" }, ; // 44 { "Croatian" , "хорватский" , "hr" }, ; // 45 { "Czech" , "чешский" , "cs" }, ; // 46 { "Swedish" , "шведский" , "sv" }, ; // 47 { "Scottish" , "шотландский" , "gd" }, ; // 48 { "Estonian" , "эстонский" , "et" }, ; // 49 { "Esperanto" , "эсперанто" , "eo" }, ; // 50 { "Javanese" , "яванский" , "jw" } } // 51 *ENDIF **** Определить заданное направление перевода ** * ************************************************ * **** Сокращенный список языков (всего 25 из 93), * **** на которые реально переводит Яндекс ******* * **** и результаты отображаются в OEM-866 ******* * ************************************************ mLang = '' FOR j=1 TO LEN(aLanguages) IF ALLTRIM(aLanguages[j,3]) = mISO639_1 mLang = ALLTRIM(aLanguages[j,1]) EXIT ENDIF NEXT aMess := {} AADD(aMess, L('После выхода из данного комментария Вы будете перенаправлены на сайт для on-line перевода XLS-файлов: https://www.onlinedoctranslator.com.' )) AADD(aMess, L('Вы выбрали для перевода языковую базу:')+' '+mNameLangXls+L('. Укажите на сайте этот файл для перевода, задайте направление перевода' )) AADD(aMess, L('с русского языка на:')+' '+UPPER(mLang)+' '+L('язык, а после окончания процесса перевода скачайте файл с переводом:')+' '+mNameLangXlsTransl ) AADD(aMess, L('и поместите его в папку с системой:')+' '+Disk_dir ) LB_Warning(aMess) RunShell('/C c:\Windows\System32\TaskList.exe /V /FO CSV > TaskList1.csv',,.F.,.T.) // .F. - чтобы программа не продожалась дальше, пока не закончится перевод LC_RunUrl( 'https://www.onlinedoctranslator.com/translationform', .T., .T. ) aMess := {} AADD(aMess, L('Этот комментарий выводится для того, чтобы дать Вам время выполнить ранее рекомендованные действия. После выхода из данного комментария полученный')) AADD(aMess, L('перевод будет включен в библиотеку языковых баз системы "Эйдос". После перезагрузки системы "Эйдос" данный язык станет текущим для интерфейса' )) AADD(aMess, L('и графических выходных форм.')) AADD(aMess, L('PS')) AADD(aMess, L('1. Если бы у сайта: https://www.onlinedoctranslator.com/translationform был свой API, то все это было бы сделано в системе "Эйдос" автоматически.' )) AADD(aMess, L('2. Если файл с переводом:')+' '+mNameLangXlsTransl+' '+L('был уже был создан, то еще раз создавать его имеет смысл только после выполнения режима' )) AADD(aMess, L('"2.Создать все xls-LangBase для on-line перевода", создающего базы-заготовки для on-line перевода на основе актуальной русской языковой базы.' )) LB_Warning(aMess) ********************************************************************************************************************* ***** Принудительно закрыть сайт: https://www.onlinedoctranslator.com/translationform ********************************************************************************************************************* MILLISEC(100) RunShell('/C c:\Windows\System32\TaskList.exe /V /FO CSV > TaskList2.csv',,.F.,.T.) // .F. - чтобы программа не продожалась дальше, пока не закончится перевод ******* Определить, какой браузер открылся (установленный по умолчанию) и его принудительно закрыть, если он не был открыт до запуска системы Эйдос ************** aTaskList1 := {} // Все программы, запущенные на компьютере ДО обращения к FTP-серверу nHandle := DC_txtOpen( 'TaskList1.csv' ) DO WHILE !DC_TxtEOF( nHandle ) // Начало цикла по строкам mLine = DC_TxtLine( nHandle ) // Выделить строку из текстового файла mPosExe = AT('.exe', mLine) IF mPosExe > 0 mPos = AT('","', mLine) mModName = SUBSTR(mLine,2,mPos-2) * MsgBox(ConvToOemCP(mLine)) * MsgBox(mModName) * IF ASCAN(aTaskList1, mModName) = 0 // Каждая программа запоминается только один раз AADD (aTaskList1, mModName) * ENDIF ENDIF DC_TxtSkip( nHandle, 1 ) ENDDO DC_TxtClose( nHandle ) aTaskList2 := {} // Все программы, запущенные на компьютере ПОСЛЕ обращения к FTP-серверу nHandle := DC_txtOpen( 'TaskList2.csv' ) DO WHILE !DC_TxtEOF( nHandle ) // Начало цикла по строкам mLine = DC_TxtLine( nHandle ) // Выделить строку из текстового файла mPosExe = AT('.exe', mLine) IF mPosExe > 0 mPos = AT('","', mLine) mModName = SUBSTR(mLine,2,mPos-2) * MsgBox(ConvToOemCP(mLine)) * MsgBox(mModName) * IF ASCAN(aTaskList2, mModName) = 0 // Каждая программа запоминается только один раз AADD (aTaskList2, mModName) * ENDIF ENDIF DC_TxtSkip( nHandle, 1 ) ENDDO DC_TxtClose( nHandle ) aBrowsers := {} // Наименования exe-модулей различных браузеров. ДОБАВИТЬ их как можно больше AADD(aBrowsers, 'opera.exe' ) AADD(aBrowsers, 'firefox.exe' ) AADD(aBrowsers, 'chrome.exe' ) AADD(aBrowsers, 'iexplore.exe') aTaskList12 := {} // Только новые программы, запущенные на компьютере ПОСЛЕ обращения к FTP-серверу, их и надо принудительно закрыть FOR j=1 TO LEN(aTaskList2) IF ASCAN(aTaskList1, aTaskList2[j]) = 0 // Новая программа, запущенная на компьютере ПОСЛЕ обращения к FTP-серверу IF ASCAN(aBrowsers, aTaskList2[j]) > 0 // Запоминать только названия exe-модулей браузеров * IF ASCAN(aTaskList12, aTaskList2[j]) = 0 // Каждая новая программа запоминается только один раз AADD (aTaskList12, aTaskList2[j]) * ENDIF ENDIF ENDIF NEXT IF LEN(aTaskList12) > 0 FOR j=1 TO LEN(aTaskList12) DO CASE CASE aTaskList12[j] = 'opera.exe' RunShell('/F /IM ' + 'opera.exe' ,'c:\Windows\System32\taskKill.exe',.T.,.F.) // принудительно закрыть новую программу: aTaskList12[j] CASE aTaskList12[j] = 'firefox.exe' RunShell('/F /IM ' + 'firefox.exe' ,'c:\Windows\System32\taskKill.exe',.T.,.F.) // принудительно закрыть новую программу: aTaskList12[j] CASE aTaskList12[j] = 'chrome.exe' RunShell('/F /IM ' + 'chrome.exe' ,'c:\Windows\System32\taskKill.exe',.T.,.F.) // принудительно закрыть новую программу: aTaskList12[j] CASE aTaskList12[j] = 'iexplore.exe' RunShell('/F /IM ' + 'iexplore.exe','c:\Windows\System32\taskKill.exe',.T.,.F.) // принудительно закрыть новую программу: aTaskList12[j] ENDCASE NEXT ENDIF ********************************************************************************************************************* ********************************************************************************************************************* mNameTr = 'LangTransl_' + mISO639_1 + '.ru.'+mISO639_1+'.xls' * MsgBox(mNameTr) IF .NOT. FILE(mNameTr) aMess := {} AADD(aMess, L('Вы что-то сделали не так, т.к. файла:')+' '+mNameTr+' '+L('нет в папке с системой:')+' '+Disk_dir) LB_Warning(aMess) RETURN NIL ENDIF ***** Преобразовать mNameLangXlsTransl в DBF cExcelFile = mNameTr LC_Excel2WorkArea( cExcelFile, Disk_dir ) ***** Создать и заполнить языковую базу данных по заданному языку mNameLangDB = 'Lang_' + mISO639_1 aStructure := { { "NumPP" , "N", 6, 0 }, ; { "TextOrig" , "C", 200, 0 }, ; { "TextTransl" , "C", 200, 0 }, ; { "NumbUses" , "N", 15, 0 }, ; { "TextOrigM" , "M", 10, 0 }, ; // MEMO-FIELD { "TextTranM" , "M", 10, 0 }, ; // MEMO-FIELD { "Date" , "C", 10, 0 }, ; { "Time" , "C", 8, 0 } } DbCreate((mNameLangDB), aStructure ) mNameTr = 'LangTransl_' + mISO639_1 CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Lang_ru EXCLUSIVE NEW USE (mNameTr) EXCLUSIVE NEW USE (mNameLangDB) EXCLUSIVE NEW aLang_ru := {} SELECT Lang_ru DBGOTOP() DO WHILE .NOT. EOF() AADD(aLang_ru, ALLTRIM(TEXTORIG)) DBSKIP(1) ENDDO aLang_xx := {} SELECT (mNameTr) DBGOTOP() DO WHILE .NOT. EOF() AADD(aLang_xx, ALLTRIM(N1)) DBSKIP(1) ENDDO SELECT (mNameLangDB) IF LEN(aLang_ru)*LEN(aLang_xx) > 0 FOR mNumLine=1 TO MIN(LEN(aLang_ru), LEN(aLang_xx)) APPEND BLANK REPLACE NumPP WITH mNumLine REPLACE TextOrig WITH ALLTRIM(SUBSTR(aLang_ru[mNumLine],1,200)) REPLACE TextTransl WITH ALLTRIM(SUBSTR(aLang_xx[mNumLine],1,200)) REPLACE TextOrigM WITH ALLTRIM(aLang_ru[mNumLine]) REPLACE TextTranM WITH ALLTRIM(aLang_xx[mNumLine]) REPLACE NumbUses WITH 0 REPLACE Date WITH DTOC(DATE()) REPLACE Time WITH TIME() NEXT ENDIF SelectLang(1, mISO639_1, 'один') // Сделать выбранный язык текущим CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Languages EXCLUSIVE NEW SELECT Languages DBGOTO(mRecno) aMess := {} AADD(aMess, L('После перезагрузки системы "Эйдос" язык:')+' "'+UPPER(mLang)+'" '+L('будет текущим для ее интерфейса и выходных форм.')) LB_Warning(aMess) RETURN NIL ******************************************************************************************************* ******** 1.4. Multi-language support ******** Данный режим обеспечивает: ******** 1) задание текущего языка интерфейса (по умолчанию - русский); ******** 2) перевод русской языковой базы на другой язык, заданный текущим ******** 3) корректировку не русской языковой базы данных по текущему языку с целью улучшения перевода ******************************************************************************************************* FUNCTION F1_4() LOCAL GetList := {}, aPres, oBrowse, oToolBar, aColors, bColor, GetOptions, oEventsKO, bItems, n:=0 Running(.T.) *Razrab() *RETURN NIL ** Если ранее язык интерфейса не был задан - то задать русский, ** если был - то использовать тот, который был задан ** Если нет языковых баз - то создать их и задать текущим русский язык SET EXACT ON // Присравнении .T. если совпадают все символы, включая совпадение длины CreateDBLang() // Сделать с флагами стран <===####################### CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Languages EXCLUSIVE NEW SELECT Languages DBGOTOP() ******* Отображение БД ******* /* ----- Create ToolBar ----- */ mStr1 = L('Помощь' );mStr1Len = LEN(mStr1) mStr2 = L('1.Выбрать язык текущим' );mStr2Len = LEN(mStr2) mStr3 = L('2.Создать xls-LangBase для on-line перевода' );mStr3Len = LEN(mStr3) mStr4 = L('3.Перевод и конвертирование LangBase: xls=>dbf' );mStr4Len = LEN(mStr4) *mStr5 = L('4.Конверт всех переведенных LangBase: xls=>dbf' );mStr5Len = LEN(mStr5) *mStr3 = L('2.Выбрать язык текущим и сделать перевод');mStr3Len = LEN(mStr3) *mStr4 = L('3.Создать все языковые базы' );mStr4Len = LEN(mStr4) d = 3 n = 1.1 mL = 23 mK = 0.3 *bSaveScreen := {||SaveScreenAsFile(Disk_dir+'/Aid_data/Screenshots/F1_4.jpg'), DC_GetRefresh(GetList)} @ 37.5, 0 DCGROUP oGroup1 CAPTION L(' ') SIZE 148, 3.0 @ 1, 1 DCPUSHBUTTON CAPTION mStr1 SIZE mStr1Len+(mL-mStr1Len)*mK+n, 1.5 ACTION {||Help14() , DC_GetRefresh(GetList)} PARENT oGroup1 // Помощь' @ 1, DCGUI_COL+d DCPUSHBUTTON CAPTION mStr2 SIZE mStr2Len+(mL-mStr2Len)*mK+n, 1.5 ACTION {||SelectLang(1, Languages->ISO639_1,'один') , DC_GetRefresh(GetList)} PARENT oGroup1 // 1.Выбрать язык текущим' @ 1, DCGUI_COL+d DCPUSHBUTTON CAPTION mStr3 SIZE mStr3Len+(mL-mStr3Len)*mK+n, 1.5 ACTION {||CreateAllLangDB() , DC_GetRefresh(GetList)} PARENT oGroup1 // 2.Создать xls-LangBase для on-line перевода' @ 1, DCGUI_COL+d DCPUSHBUTTON CAPTION mStr4 SIZE mStr4Len+(mL-mStr4Len)*mK+n, 1.5 ACTION {||TranslConvLangBase(Languages->ISO639_1, RECNO()), DC_GetRefresh(GetList)} PARENT oGroup1 // 3.Перевод и конвертирование LangBase: xls=>dbf' *@ 1, DCGUI_COL+d DCPUSHBUTTON CAPTION mStr5 SIZE mStr5Len+(mL-mStr5Len)*mK+n, 1.5 ACTION {||Razrab() , DC_GetRefresh(GetList)} PARENT oGroup1 // 4.Конверт всех переведенных LangBase: xls=>dbf' *@ 1, DCGUI_COL+d DCPUSHBUTTON CAPTION mStr3 SIZE mStr3Len+(mL-mStr3Len)*mK+n, 1.5 ACTION {||SelectLang(0, Languages->ISO639_1,'один') , DC_GetRefresh(GetList)} PARENT oGroup1 *@ 1, DCGUI_COL+d DCPUSHBUTTON CAPTION mStr4 SIZE mStr4Len+(mL-mStr4Len)*mK+n, 1.5 ACTION {||CreateAllLangBases() , DC_GetRefresh(GetList)} PARENT oGroup1 *@ 1, DCGUI_COL+d DCPUSHBUTTON CAPTION 'PrtScr' SIZE LEN('PrtScr'), 1.5 ACTION {||SaveScreenAsFile(Disk_dir+'/Aid_data/Screenshots/F1_4.jpg'), DC_GetRefresh(GetList)} PARENT oGroup1 ****** Отображение таблицы *************** DCSETPARENT TO @ 5, 0 DCBROWSE oBrowse ALIAS 'Languages' SIZE 150,33 ; PRESENTATION LC_BrowPres() ; // Только просмотр БД NOSOFTTRACK ; HEADLINES 2 ; // Кол-во строк в заголовке (перенос строки - ";") SCOPE ; ITEMMARKED bItems; COLOR {||IIF(LEN(ALLTRIM(Languages->SELECT))>0, {nil,aColor[153]}, IIF(Languages->APPEALS>0, {nil,aColor[39]}, {nil,GRA_CLR_WHITE}))} *DCSETPARENT oBrowse DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE *** Подарок от Роджера DCBROWSECOL FIELD Languages->LANGCODE HEADER L("Lang;Code" ) PARENT oBrowse WIDTH 4 DCBROWSECOL FIELD Languages->SELECT HEADER L("Current;language" ) PARENT oBrowse WIDTH 9 DCBROWSECOL FIELD Languages->LANGUAGE HEADER L("ISO language name") PARENT oBrowse WIDTH 30 DCBROWSECOL FIELD Languages->LANG_RUS HEADER L("ISO Наимененование;языка") PARENT oBrowse WIDTH 30 DCBROWSECOL FIELD Languages->APPEALS HEADER L("Number;appeals" ) PARENT oBrowse WIDTH 10 DCBROWSECOL FIELD Languages->ISO639_1 HEADER L("ISO;639-1" ) PARENT oBrowse WIDTH 6 DCGETOPTIONS SAYFONT '10.Helv Bold' TABSTOP AUTORESIZE *bSaveScreen := {||SaveScreenAsFile(137,38+3,Disk_dir+'/Aid_data/Screenshots/F1_4.jpg'), DC_GetRefresh(GetList)} *bSaveScreen := {||Print_Window(1,Disk_dir+'/Aid_data/Screenshots/F1_4.jpg'), DC_GetRefresh(GetList)} bSaveScreen := {||DC_Scrn2ImageFile(oBrowse,Disk_dir+'/Aid_data/Screenshots/F1_4.bmp'), DC_GetRefresh(GetList)} // Работает, но не совсем так, как хотелось бы DCREAD GUI ; FIT ; OPTIONS GetOptions ; MODAL ; SetAppWindow; TITLE L('1.4. Выбор текущего языка интерфейса системы "Эйдос-Х++"'); CLEAREVENTS; EVAL bSaveScreen ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ***************************************************************** ******** Создать все языковые базы данных в цикле ***************************************************************** FUNCTION CreateAllLangBases() ******** 0. Проверить, не выполняется ли в данный момент перевод с другого запуска системы Эйдос. Если выполняется (на FTP-сервере есть файл: flag14.txt), то выдать ******** сообщение об этом (чтобы попробовали позже) и выйти, а иначе продолжить. ********************************************************************************************************** Xb2NetKey() cFtpServer:="94.25.18.114" // Это везде одинаково <<<===############ oFtp := FTPClient():new( cFtpServer, Ftp_User, Ftp_Passw ) // Соединение с моим сайтом и авторизация IF oFtp:connect() // Есть соединение с моим сайтом и авторизация? ********************************************************************************************************** **** Сделать текущей папку: ftp://lc.kubagro.ru/public_html IF oFtp:curDir() <> "/" oFtp:curDir("public_html") LB_Warning(L('Не удалось сделать текущей директорию: "\"'), L('(C) Система "Эйдос-Х++"' )) oFtp:disconnect() RETURN NIL ENDIF IF oFtp:GetFile("flag14.txt") aMess := {} AADD(aMess,L('В настоящее время режим on-line перевода (1.4) используется другим пользователем.')) AADD(aMess,L('Попробуйте запустить данный режим позже. Будут использоваться имеющиеся языковые базы!')) LB_Warning(aMess, L('(C) Система "Эйдос-Х++"' )) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Languages EXCLUSIVE NEW SELECT Languages DBGOTOP() oFtp:disconnect() RETURN NIL ELSE * LB_Warning(L('Файла: "flag14.txt" нет на FTP-сервере', '(C) Система "Эйдос-Х++"' )) // Значит можно переводить ENDIF ELSE LB_Warning(L('Нет соединения с FTP-сервером'), L('(C) Система "Эйдос-Х++"')) RETURN NIL ENDIF oFtp:disconnect() ********** Ввод параметров перевода ************ CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Languages EXCLUSIVE NEW * USE Lang_ru EXCLUSIVE NEW SELECT Languages mRecno = RECNO() PUBLIC mNum1 := 1 PUBLIC mNum2 := RECCOUNT() @0,0 DCGROUP oGroup1 CAPTION L('Задайте диапазон языков для перевода:') SIZE 68.0, 3.5 @1,2 DCSAY L("Начальный номер:") PARENT oGroup1 @2,2 DCSAY L("Конечный номер:") PARENT oGroup1 @1,32 DCGET mNum1 PICTURE "#####" PARENT oGroup1 @2,32 DCGET mNum2 PICTURE "#####" PARENT oGroup1 * SELECT Lang_ru * PUBLIC mLine1 := 1 * PUBLIC mLine2 := RECCOUNT() * PUBLIC mLine3 := 10 * @4,0 DCGROUP oGroup2 CAPTION L('Задайте диапазон строк русской языковой базы для перевода:') SIZE 68.0, 3.5 * @1,2 DCSAY L("Начальный номер строки:") PARENT oGroup2 * @2,2 DCSAY L("Конечный номер строки:") PARENT oGroup2 * @1,32 DCGET mLine1 PICTURE "#####" PARENT oGroup2 * @2,32 DCGET mLine2 PICTURE "#####" PARENT oGroup2 * @8,0 DCGROUP oGroup3 CAPTION L('Через сколько строк сохранять информацию в языковых базах?') SIZE 68.0, 2.5 * @1,2 DCSAY L("Число строк:") PARENT oGroup3 * @1,32 DCGET mLine3 PICTURE "#####" PARENT oGroup3 DCREAD GUI; TO lExit ; FIT; ADDBUTTONS; MODAL; TITLE L('1.4. Мультиязычная поддержка интерфейса в системе ЭЙДОС-X++') ******************************************************************** IF lExit ** Button Ok ELSE * ADS_SERVER_QUIT() QUIT ENDIF ******************************************************************** IF mNum1 < 1 LB_Warning(L('Начальный номер языка не может быть меньше 1'), L('1.4. Мультиязычная поддержка интерфейса в системе ЭЙДОС-X++')) DBGOTO(mRecno) RETURN NIL ENDIF IF mNum2 > RECCOUNT() LB_Warning(L('Конечный номер языка не может быть больше числа языков:')+' '+ALLTRIM(STR(RECCOUNT())), L('1.4. Мультиязычная поддержка интерфейса в системе ЭЙДОС-X++')) DBGOTO(mRecno) RETURN NIL ENDIF IF mNum1 > mNum2 LB_Warning(L('Начальный номер языка:')+' '+ALLTRIM(STR(mNum1))+' '+L(' не может быть больше конечного:')+' '+ALLTRIM(STR(mNum2)), L('1.4. Мультиязычная поддержка интерфейса в системе ЭЙДОС-X++')) DBGOTO(mRecno) RETURN NIL ENDIF * IF mLine1 < 1 * LB_Warning(L('Начальный номер строки не может быть меньше 1'), L('1.4. Мультиязычная поддержка интерфейса в системе ЭЙДОС-X++')) * DBGOTO(mRecno) * RETURN NIL * ENDIF * IF mLine2 > RECCOUNT() * LB_Warning(L('Конечный номер строки не может быть больше числа строк:')+' '+ALLTRIM(STR(RECCOUNT())), L('1.4. Мультиязычная поддержка интерфейса в системе ЭЙДОС-X++')) * DBGOTO(mRecno) * RETURN NIL * ENDIF * IF mLine1 > mLine2 * LB_Warning(L('Начальный номер строки:')+' '+ALLTRIM(STR(mLine1))+' '+L(' не может быть больше конечного:')+' '+ALLTRIM(STR(mLine2)), L('1.4. Мультиязычная поддержка интерфейса в системе ЭЙДОС-X++')) * DBGOTO(mRecno) * RETURN NIL * ENDIF * mLine3 = IF(mLine3 <= mLine2-mLine1+1, mLine3, mLine2-mLine1+1) ********* Отметить текущий язык в основной базе языков CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Languages EXCLUSIVE NEW aISO639_1 := {} DBGOTOP() DO WHILE .NOT. EOF() AADD(aISO639_1, ALLTRIM(ISO639_1)) DBSKIP(1) ENDDO CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций FOR mLang = mNum1 TO mNum2 SelectLang(0, aISO639_1[mLang],'много') NEXT LB_Warning(L('Все языковые базы созданы успешно!!!'), L('1.4. Мультиязычная поддержка интерфейса в системе ЭЙДОС-X++')) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Languages EXCLUSIVE NEW SELECT Languages DBGOTO(mRecno) RETURN NIL ********************************************************************************************************************************************************* FUNCTION Help14() @0,0 DCGROUP oGroup1 CAPTION L(' ') SIZE 102.0, 30.0 s=1 d=0.8 h=1.5 @s,2 DCSAY L('Помощь по режиму: 1.4. МУЛЬТИЯЗЫЧНАЯ ПОДДЕРЖКА ТЕКСТОВЫХ ЭЛЕМЕНТОВ ИНТЕРФЕЙСА СИСТЕМЫ "ЭЙДОС" ') PARENT ogroup1;s=s+d*h @s,2 DCSAY L('Данный режим обеспечивает: ') PARENT oGroup1;s=s+d @s,2 DCSAY L('1.Выбор текущего языка интерфейса и графических выходных форм (по умолчанию - русский). ') PARENT oGroup1;s=s+d @s,2 DCSAY L('2.Создание xls-LangBase для on-line перевода ') PARENT oGroup1;s=s+d @s,2 DCSAY L('3.Перевод и конвертирование LangBase: xls=>dbf ') PARENT oGroup1;s=s+d*h @s,2 DCSAY L('Если в папке с системой нет начальных языковых баз (базы языков и русской языковой базы), то они создаются. ') PARENT oGroup1;s=s+d @s,2 DCSAY L('Если начальные языковые базы есть, то для ускорения работы русская языковая база переносится в языковый массив. ') PARENT oGroup1;s=s+d @s,2 DCSAY L('Если текущим задан не русский язык, то в массив переносится и языковая база по этому языку. ') PARENT oGroup1;s=s+d*h @s,2 DCSAY L('В процессе работы системы в русский языковый массив заносятся все новые текстовые элементы интерфейса. Если выход ') PARENT oGroup1;s=s+d @s,2 DCSAY L('из системы сделан через пункт меню: "7. Выход", то русский языковый массив записывается в русскую языковую базу. ') PARENT oGroup1;s=s+d @s,2 DCSAY L('Если текущим задан не русский язык, то не русский языковый массив также записывается в не русскую языковую базу. ') PARENT oGroup1;s=s+d*h @s,2 DCSAY L('Режим-1. Задание текущего языка для текстовых элементов интерфейса (по умолчанию - русский). ') PARENT oGroup1;s=s+d @s,2 DCSAY L('Этот режим может быть выполнен только если выбранный язык уже задавался текущим и по нему уже есть языковая база. ') PARENT oGroup1;s=s+d @s,2 DCSAY L('Если же языковой базы по заданному языку нет, то для ее создания необходимо выполнить перевод в режимах 2 и 3. ') PARENT oGroup1;s=s+d*h @s,2 DCSAY L('В настоящее время в инсталляции системы "Эйдос" есть возможность создания языковых баз по следующим 50 языкам: ') PARENT oGroup1;s=s+d @s,2 DCSAY L('Albanian, English, Afrikaans, Basque, Bulgarian, Bosnian, Welsh, Hungarian, Galician, Greek, Danish, Indonesian, ') PARENT oGroup1;s=s+d @s,2 DCSAY L('Irish, Italian, Icelandic, Spanish, Catalan, braid, Latin, Latvian, Lithuanian, luxembourg,Malagasy,Malay,Maltese,') PARENT oGroup1;s=s+d @s,2 DCSAY L(' Macedonian, Maori, German, Norwegian, Polish, Portuguese, Romanian, Russian, Cebu, Serbian, Slovak, Slovenian, ') PARENT oGroup1;s=s+d @s,2 DCSAY L('Swahili, Sundanese, Turkish, Uzbek, Ukrainian, Finnish, French, Croatian, Czech, Swedish, Scottish, Estonian, ') PARENT oGroup1;s=s+d @s,2 DCSAY L('Esperanto, Javanese. Для некоторых из этих языков возможно неверное отображение отдельных символов их алфавитов ') PARENT oGroup1;s=s+d @s,2 DCSAY L('в элементах интерфейса и выходных формах. Эти языки выбраны из примерно сотни языков потому, что результаты ') PARENT oGroup1;s=s+d @s,2 DCSAY L('перевода на эти языки с русского языка правильно отображаются в кодировке OEM-866, используемой в системе "Эйдос".') PARENT oGroup1;s=s+d*h @s,2 DCSAY L('Режим-2. Данный режим служит для создания заданных (в т.ч. всех) xls-LangBase - заготовок для on-line перевода. ') PARENT oGroup1;s=s+d @s,2 DCSAY L('Для on-line перевода русской языковой базы на язык, заданный текущим, используется бесплатный on-line переводчик ') PARENT oGroup1;s=s+d @s,2 DCSAY L('https://www.onlinedoctranslator.com/translationform, обеспечивающий перевод xls-файлов с сохранением их структуры.') PARENT oGroup1;s=s+d*h @s,2 DCSAY L('Режим-3. Обеспечивает on-line перевод ранее заготовленных в режиме-2 xls-LangBase и их конвертирование xls=>dbf, ') PARENT oGroup1;s=s+d @s,2 DCSAY L('а затем назначение выбранного языка текущим для интерфейса системы "Эйдос" и графических выходных форм. ') PARENT oGroup1;s=s+d*h @s,2 DCSAY L('Язык, заданный текущим, начинает использоваться сразу при открытии нового окна или новом запуске системы "Эйдос". ') PARENT ogroup1;s=s+d @s,2 DCSAY L('Текстовые элементы интерфейса, еще не отраженные в языковых базах данных, будут отображаться на русском языке. ') PARENT oGroup1;s=s+d @s,2 DCSAY L('Чтобы они также начали отображаться на другом языке, заданном текущим, надо выполнить режимы 2 и 3. ') PARENT oGroup1;s=s+d*h @s,2 DCSAY L('Текущий язык отображается на золотом фоне, а языки, задававшиеся текущими ранее - на светло-зеленом фоне. ') PARENT oGroup1 DCREAD GUI TO lExit FIT ADDBUTTONS MODAL TITLE L('Помощь по режиму: 1.4. Мультиязычная поддержка интерфейса в системе ЭЙДОС-X++') IF lExit ** Button Ok ELSE RETURN NIL ENDIF RETURN NIL ********************************************************************************************************************************************************* ******************************************************** ******** Задать текущий язык ******** mPar = 1 - без перевода, mPar = 0 - с переводом ******************************************************** FUNCTION SelectLang(mPar, mISO639_1, mOneMany) mISO639_1 = ALLTRIM(mISO639_1) mNameLangDB = 'Lang_'+mISO639_1 ******************************************************************************************************* ***** Если задан не русский язык, то: ***** - посмотреть, есть ли локальная языковая база по этому языку. ***** - если есть - то создать языковый массив на ее основе. ***** - если нет - выдать сообщение о необходимости выполнить режим 2. ******************************************************************************************************* * MsgBox(STR(mPar)+' '+mISO639_1+' '+mOneMany+' '+mNameLangDB+'.dbf') IF mISO639_1 <> 'ru' // Если задан не русский язык IF FILE(mNameLangDB+'.dbf') // - посмотреть, есть ли языковая база по этому языку CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций // - если есть - то создать языковый массив на ее основе. USE (mNameLangDB) EXCLUSIVE NEW;mNxxTxtEls = RECCOUNT() IF mNxxTxtEls > 0 DBGOTOP() DO WHILE .NOT. EOF() mPos = RECNO() IF mPos <= LEN(aLang_xx) aLang_xx[mPos] = ALLTRIM(SUBSTR(TextTransl,1,200)) // <<===######################## ENDIF IF mPos <= LEN(aNumUses) aNumUses[mPos] = aNumUses[mPos] + 1 // <<===######################## ENDIF DBSKIP(1) ENDDO ENDIF ELSE // - если нет - выдать сообщение о необходимости выполнить режим 2. IF mPar = 1 aMess := {} AADD(aMess, 'Ранее выбранный язык не использовался и языковой базы по нему нет.') // <<===######### В языковых программах нигде не использовать L() AADD(aMess, 'Для создания языковой базы по выбранному языку используйте режим 2') LB_Warning(aMess, '1.4. Мультиязычная поддержка интерфейса в системе ЭЙДОС-X++') RETURN NIL ENDIF ENDIF ENDIF *************************************************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Languages EXCLUSIVE NEW SELECT Languages ********* Отметить текущий язык в основной базе языков // Делать язык текущим только если языковая база по нему существует <===############ А ЕСЛИ ОН ДЕЛАЕТСЯ ТЕКУЩИМ ВПЕРВЫЕ С ПЕРЕВОДОМ? // Это неверно. Просто если языковой базы по языку, заданному текущим, не существует, то надо ее создать или просто рекомендовать это сделать *IF FILE(mNameLangDB+'.dbf') DBGOTOP() DO WHILE .NOT. EOF() IF mISO639_1 = ISO639_1 mLangCode = LangCode mLanguage = ALLTRIM(Language) mAppeals = Appeals+1 mRecnoSL = RECNO() REPLACE Select WITH "SELECT" REPLACE Appeals WITH mAppeals ELSE REPLACE Select WITH "" ENDIF DBSKIP(1) ENDDO *ENDIF *DBGOTOP() *DO WHILE .NOT. EOF() * IF Select = "SELECT" * mLangCode = LangCode * mLanguage = ALLTRIM(Language) * ENDIF * DBSKIP(1) *ENDDO DBGOTOP() DBGOTO(mLangCode) StrFile(ALLTRIM(mISO639_1)+' '+mLanguage, 'Language.txt') // <===########### почему-то задаешь англ, а язык остается русский ******************************************************************************************************************************************************************************** ***** Если задан русский язык, то функция перевода возвращает входной параметр, но русская языковая база все равно создается, чтобы накапливать текстовые элементы для перевода. ***** Русская языковая база является основой для создания языковых баз данных других языков. Если в русской базе нет текстового элемента для перевода, то он добавляется. ******************************************************************************************************************************************************************************** IF mISO639_1 = 'ru' // Текущим задан русский язык CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Languages EXCLUSIVE NEW SELECT Languages DBGOTOP() DBGOTO(mLangCode) RETURN NIL ENDIF *IF FILE(mNameLangDB+'.dbf') // Всегда переводить не языковую базу, а русский языковый массив, а он полный IF mPar = 1 // Если задан язык без перевода CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Languages EXCLUSIVE NEW SELECT Languages DBGOTOP() DBGOTO(mLangCode) RETURN NIL ENDIF *ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Languages EXCLUSIVE NEW SELECT Languages DBGOTOP() DBGOTO(mRecnoSL) RETURN NIL ********************************************************** ********************************************************** ******** Создать языковые базы: Languages.dbf, Lang_ru.dbf ******** и соответствующие языковые массивы aLang_ru ********************************************************** FUNCTION CreateDBLang() * oScrTime := DC_WaitOn('Метка-2.1.2: '+SubStr( Time()-cTime1, 1, 2)+':'+SubStr( Time()-cTime1, 4, 2)+':'+SubStr( Time()-cTime1, 7, 2),,,,,,,,,,,.F.) IF .NOT. FILE('Language.txt') StrFile('ru Russian', 'Language.txt') mISO639_1 = 'ru' ELSE mISO639_1 = ALLTRIM(SUBSTR(FileStr('Language.txt'),1,3)) ENDIF mNameLangDB = 'Lang_'+mISO639_1 * ********************************************************** * **** Исходный список 93-х языков on-line переводчика ***** * ********************************************************** * *ISO language name Код языка 639-1 IF .NOT. FILE("Languages.dbf") * PUBLIC aLanguages := {; * { "Azerbaijani" , "азербайджанский" , "az" }, ; // --- * { "Albanian" , "албанский" , "sq" }, ; // --- * { "Amharic" , "амхарский" , "am" }, ; // --- * { "English" , "английский" , "en" }, ; // Отлично * { "Arab" , "арабский" , "ar" }, ; // --- * { "Armenian" , "армянский" , "hy" }, ; // --- * { "Afrikaans" , "африкаанс" , "af" }, ; // Отлично * { "Basque" , "баскский" , "eu" }, ; // Отлично * { "Bashkir" , "башкирский" , "ba" }, ; // --- * { "Belarusian" , "белорусский" , "be" }, ; // --- * { "Bengal" , "бенгальский" , "bn" }, ; // --- * { "Burmese" , "бирманский" , "my" }, ; // --- * { "Bulgarian" , "болгарский" , "bg" }, ; // --- * { "Bosnian" , "боснийский" , "bs" }, ; // Отлично * { "Welsh" , "валлийский" , "cy" }, ; // Отлично нет перевода xls-файла * { "Hungarian" , "венгерский" , "hu" }, ; // --- * { "Vietnamese" , "вьетнамский" , "vi" }, ; // --- * { "Haitian (Creole)" , "гаитянский (креольский)", "ht" }, ; // --- * { "Galician" , "галисийский" , "gl" }, ; // --- * { "Dutch" , "голландский" , "nl" }, ; // Отлично * { "Mari" , "горномарийский" , "mrj" }, ; // --- * { "Greek" , "греческий" , "el" }, ; // --- * { "Georgian" , "грузинский" , "ka" }, ; // --- * { "Gujarati" , "гуджарати" , "gu" }, ; // --- * { "Danish" , "датский" , "da" }, ; // Отлично * { "Hebrew" , "иврит" , "he" }, ; // --- * { "Yiddish" , "идиш" , "yi" }, ; // --- * { "Indonesian" , "индонезийский" , "id" }, ; // Отлично * { "Irish" , "ирландский" , "ga" }, ; // --- * { "Italian" , "итальянский" , "it" }, ; // Пойдет * { "Icelandic" , "исландский" , "is" }, ; // --- * { "Spanish" , "испанский" , "es" }, ; // --- * { "Kazakh" , "казахский" , "kk" }, ; // --- * { "Kannada" , "каннада" , "kn" }, ; // --- * { "Catalan" , "каталанский" , "ca" }, ; // --- * { "Kirghiz" , "киргизский" , "ky" }, ; // --- * { "Chinese" , "китайский" , "zh" }, ; // --- * { "Korean" , "корейский" , "ko" }, ; // --- * { "braid" , "коса" , "xh" }, ; // Отлично * { "Khmer" , "кхмерский" , "km" }, ; // --- * { "Laotian" , "лаосский" , "lo" }, ; // --- * { "Latin" , "латынь" , "la" }, ; // Отлично * { "Latvian" , "латышский" , "lv" }, ; // --- * { "Lithuanian" , "литовский" , "lt" }, ; // --- * { "luxembourg" , "люксембургский" , "lb" }, ; // --- * { "Malagasy" , "малагасийский" , "mg" }, ; // Отлично * { "Malay" , "малайский" , "ms" }, ; // Отлично * { "Malayalam" , "малаялам" , "ml" }, ; // --- * { "Maltese" , "мальтийский" , "mt" }, ; // --- * { "Macedonian" , "македонский" , "mk" }, ; // --- * { "Maori" , "маори" , "mi" }, ; // --- * { "Marathi" , "маратхи" , "mr" }, ; // --- * { "Mari" , "марийский" , "mhr" }, ; // --- * { "Mongolian" , "монгольский" , "mn" }, ; // --- * { "German" , "немецкий" , "de" }, ; // Отлично * { "Nepalese" , "непальский" , "ne" }, ; // --- * { "Norwegian" , "норвежский" , "no" }, ; // Отлично * { "Punjabi" , "панджаби" , "pa" }, ; // --- * { "Papiamento" , "папьяменто" , "pap" }, ; // --- * { "Persian" , "персидский" , "fa" }, ; // --- * { "Polish" , "польский" , "pl" }, ; // --- * { "Portuguese" , "португальский" , "pt" }, ; // --- * { "Romanian" , "румынский" , "ro" }, ; // Пойдет * { "Russian" , "русский" , "ru" }, ; // Превосходно * { "Cebu" , "себуанский" , "ceb" }, ; // Отлично * { "Serbian" , "сербский" , "sr" }, ; // --- * { "Sinhalese" , "сингальский" , "si" }, ; // --- * { "Slovak" , "словацкий" , "sk" }, ; // --- * { "Slovenian" , "словенский" , "sl" }, ; // --- * { "Swahili" , "суахили" , "sw" }, ; // Отлично * { "Sundanese" , "сунданский" , "su" }, ; // --- * { "Tajik" , "таджикский" , "tg" }, ; // --- * { "Thai" , "тайский" , "th" }, ; // --- * { "Tagalog" , "тагальский" , "tl" }, ; // Отлично нет перевода xls-файла * { "tamil" , "тамильский" , "ta" }, ; // --- * { "tartar" , "татарский" , "tt" }, ; // --- * { "Telugu" , "телугу" , "te" }, ; // --- * { "Turkish" , "турецкий" , "tr" }, ; // --- * { "Udmurt" , "удмуртский" , "udm" }, ; // --- * { "Uzbek" , "узбекский" , "uz" }, ; // Отлично * { "Ukrainian" , "украинский" , "uk" }, ; // --- * { "Urdu" , "урду" , "ur" }, ; // --- * { "Finnish" , "финский" , "fi" }, ; // --- * { "French" , "французский" , "fr" }, ; // Пойдет * { "hindi" , "хинди" , "hi" }, ; // --- * { "Croatian" , "хорватский" , "hr" }, ; // Пойдет * { "Czech" , "чешский" , "cs" }, ; // --- * { "Swedish" , "шведский" , "sv" }, ; // Отлично * { "Scottish" , "шотландский" , "gd" }, ; // Пойдет * { "Estonian" , "эстонский" , "et" }, ; // --- * { "Esperanto" , "эсперанто" , "eo" }, ; // Пойдет * { "Javanese" , "яванский" , "jw" }, ; // Отлично нет перевода xls-файла * { "Japanese" , "японский" , "ja" } } // --- ************************************************ **** Сокращенный список языков (всего 51 из 93), **** на которые реально переводит Яндекс ******* **** и результаты отображаются в OEM-866 ******* ************************************************ PUBLIC aLanguages := {; { "Albanian" , "албанский" , "sq" }, ; // 1 { "English" , "английский" , "en" }, ; // 2 { "Afrikaans" , "африкаанс" , "af" }, ; // 3 { "Basque" , "баскский" , "eu" }, ; // 4 { "Bulgarian" , "болгарский" , "bg" }, ; // 5 { "Bosnian" , "боснийский" , "bs" }, ; // 6 { "Welsh" , "валлийский" , "cy" }, ; // 7 { "Hungarian" , "венгерский" , "hu" }, ; // 8 { "Galician" , "галисийский" , "gl" }, ; // 9 { "Greek" , "греческий" , "el" }, ; // 10 { "Danish" , "датский" , "da" }, ; // 11 { "Indonesian" , "индонезийский" , "id" }, ; // 12 { "Irish" , "ирландский" , "ga" }, ; // 13 { "Italian" , "итальянский" , "it" }, ; // 14 { "Icelandic" , "исландский" , "is" }, ; // 15 { "Spanish" , "испанский" , "es" }, ; // 16 { "Catalan" , "каталанский" , "ca" }, ; // 17 { "braid" , "коса" , "xh" }, ; // 18 { "Latin" , "латынь" , "la" }, ; // 19 { "Latvian" , "латышский" , "lv" }, ; // 20 { "Lithuanian" , "литовский" , "lt" }, ; // 21 { "luxembourg" , "люксембургский" , "lb" }, ; // 22 { "Malagasy" , "малагасийский" , "mg" }, ; // 23 { "Malay" , "малайский" , "ms" }, ; // 24 { "Maltese" , "мальтийский" , "mt" }, ; // 25 { "Macedonian" , "македонский" , "mk" }, ; // 26 { "Maori" , "маори" , "mi" }, ; // 27 { "German" , "немецкий" , "de" }, ; // 28 { "Norwegian" , "норвежский" , "no" }, ; // 29 { "Polish" , "польский" , "pl" }, ; // 30 { "Portuguese" , "португальский" , "pt" }, ; // 31 { "Romanian" , "румынский" , "ro" }, ; // 32 { "Russian" , "русский" , "ru" }, ; // 33 { "Cebu" , "себуанский" , "ceb" }, ; // 34 { "Serbian" , "сербский" , "sr" }, ; // 35 { "Slovak" , "словацкий" , "sk" }, ; // 36 { "Slovenian" , "словенский" , "sl" }, ; // 37 { "Swahili" , "суахили" , "sw" }, ; // 38 { "Sundanese" , "сунданский" , "su" }, ; // 39 { "Turkish" , "турецкий" , "tr" }, ; // 40 { "Uzbek" , "узбекский" , "uz" }, ; // 41 { "Ukrainian" , "украинский" , "uk" }, ; // 42 { "Finnish" , "финский" , "fi" }, ; // 43 { "French" , "французский" , "fr" }, ; // 44 { "Croatian" , "хорватский" , "hr" }, ; // 45 { "Czech" , "чешский" , "cs" }, ; // 46 { "Swedish" , "шведский" , "sv" }, ; // 47 { "Scottish" , "шотландский" , "gd" }, ; // 48 { "Estonian" , "эстонский" , "et" }, ; // 49 { "Esperanto" , "эсперанто" , "eo" }, ; // 50 { "Javanese" , "яванский" , "jw" } } // 51 // Создание БД Languages.dbf Ln = -9999 FOR j=1 TO LEN(aLanguages) Ln = MAX(Ln, LEN(ALLTRIM(aLanguages[j,1]))) Ln = MAX(Ln, LEN(ALLTRIM(aLanguages[j,2]))) NEXT CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций aStructure := { { "SELECT" , "C", 6, 0 }, ; { "LANGUAGE", "C", Ln, 0 }, ; { "LANG_RUS", "C", Ln, 0 }, ; { "APPEALS" , "N", 15, 0 }, ; { "ISO639_1", "C", 3, 0 }, ; { "LangCode", "N", 5, 0 }, ; { "Date" , "C", 10, 0 }, ; { "Time" , "C", 8, 0 } } DbCreate( 'Languages', aStructure ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Languages EXCLUSIVE NEW SELECT Languages * DC_Impl(oScrTime);oScrTime := DC_WaitOn('Метка-2.1.2.1: '+SubStr( Time()-cTime1, 1, 2)+':'+SubStr( Time()-cTime1, 4, 2)+':'+SubStr( Time()-cTime1, 7, 2),,,,,,,,,,,.F.) FOR j=1 TO LEN(aLanguages) APPEND BLANK REPLACE LANGUAGE WITH ALLTRIM(aLanguages[j,1]) REPLACE LANG_RUS WITH ALLTRIM(aLanguages[j,2]) REPLACE ISO639_1 WITH ALLTRIM(aLanguages[j,3]) REPLACE LangCode WITH j REPLACE Date WITH DTOC(DATE()) REPLACE Time WITH TIME() IF aLanguages[j,1] = 'Russian' REPLACE SELECT WITH 'SELECT' REPLACE APPEALS WITH 1 ELSE REPLACE APPEALS WITH 0 ENDIF NEXT ENDIF * DC_Impl(oScrTime);oScrTime := DC_WaitOn('Метка-2.1.3: '+SubStr( Time()-cTime1, 1, 2)+':'+SubStr( Time()-cTime1, 4, 2)+':'+SubStr( Time()-cTime1, 7, 2),,,,,,,,,,,.F.) IF .NOT. FILE('Lang_ru.dbf') // Перенести в начало системы aStructure := { { "NumPP" , "N", 6, 0 }, ; { "TextOrig" , "C", 200, 0 }, ; { "TextTransl" , "C", 200, 0 }, ; { "NumbUses" , "N", 15, 0 }, ; { "TextOrigM" , "M", 10, 0 }, ; // MEMO-FIELD { "TextTranM" , "M", 10, 0 }, ; // MEMO-FIELD { "Date" , "C", 10, 0 }, ; { "Time" , "C", 8, 0 } } DbCreate( 'Lang_ru.dbf', aStructure ) ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Lang_ru EXCLUSIVE NEW;mNRusTxtEls = RECCOUNT() IF mNRusTxtEls > 0 // <<<===#################### Почему-то это ИНОГДА (на некоторых компьютерах) очень медленно работает, когда много языковых баз данных DBGOTOP() DO WHILE .NOT. EOF() * mPos = ASCAN(aLang_ru, ALLTRIM(SUBSTR(TextOrig,1,200))) // Если текстовый элемент русской языковой базы уже есть в языковом массиве, то не добавлять его) mPos = ASCAN(aLang_ru, ALLTRIM(TextOrigM)) // Если текстовый элемент русской языковой базы уже есть в языковом массиве, то не добавлять его) IF mPos = 0 * AADD(aLang_ru, ALLTRIM(SUBSTR(TextOrig,1,200))) // Добавить в русский языковый массив текстовые элементы, которых в нем не было AADD(aLang_ru, ALLTRIM(TextOrigM)) // Добавить в русский языковый массив текстовые элементы, которых в нем не было AADD(aLang_xx, '') // Добавить в нерусский языковый массив текстовые элементы, которых в нем не было AADD(aNumUses, 1) ENDIF DBSKIP(1) ENDDO ENDIF * DC_Impl(oScrTime);oScrTime := DC_WaitOn('Метка-2.1.4: '+SubStr( Time()-cTime1, 1, 2)+':'+SubStr( Time()-cTime1, 4, 2)+':'+SubStr( Time()-cTime1, 7, 2),,,,,,,,,,,.F.) IF mISO639_1 <> 'ru' // Текущим задан не русский язык IF .NOT. FILE(mNameLangDB+'.dbf') // Языковой базы по заданному языку нет aStructure := { { "NumPP" , "N", 6, 0 }, ; { "TextOrig" , "C", 200, 0 }, ; { "TextTransl" , "C", 200, 0 }, ; { "NumbUses" , "N", 15, 0 }, ; { "TextOrigM" , "M", 10, 0 }, ; // MEMO-FIELD { "TextTranM" , "M", 10, 0 }, ; // MEMO-FIELD { "Date" , "C", 10, 0 }, ; { "Time" , "C", 8, 0 } } DbCreate((mNameLangDB), aStructure ) ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mNameLangDB) EXCLUSIVE NEW;mNxxTxtEls = RECCOUNT() IF mNxxTxtEls > 0 DBGOTOP() DO WHILE .NOT. EOF() mPos = RECNO() IF mPos <= LEN(aLang_xx) aLang_xx[mPos] = ALLTRIM(SUBSTR(TextTransl,1,200)) * aLang_xx[mPos] = ALLTRIM(TextTranM) // <===########## для нерусских языков с мемо-полями проблемы aNumUses[mPos] = aNumUses[mPos] + 1 ENDIF DBSKIP(1) ENDDO ENDIF ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Languages EXCLUSIVE NEW SELECT Languages DBGOTOP() * DC_Impl(oScrTime);oScrTime := DC_WaitOn('Метка-2.1.5: '+SubStr( Time()-cTime1, 1, 2)+':'+SubStr( Time()-cTime1, 4, 2)+':'+SubStr( Time()-cTime1, 7, 2),,,,,,,,,,,.F.) RETURN NIL ********************************************************************************************************************************** ***** Если текстовый элемент найден в русском языковом массиве, то: ***** - если задан русский язык, то вернуть входной параметр; ***** - если текущим задан не русский язык - то вернуть перевод ***** увеличить счетчик числа использований текстового элемента ***** а если текстовый элемент не найден в русском языковом массиве, то добавить его и вернуть входной параметр ********************************************************************************************************************************** FUNCTION L(mParInp) *RETURN mParInp SET EXACT ON // Присравнении .T. если совпадают все символы, включая совпадение длины mParOut = ALLTRIM(mParInp) // Вернуть входной текстовый элемент IF LEN(ALLTRIM(mParInp)) = 0 RETURN mParOut ENDIF mISO639_1 = ALLTRIM(SUBSTR(FileStr('Language.txt'),1,3)) * mParInp = ALLTRIM(SUBSTR(mParInp,1,200)) mParInp = ALLTRIM(mParInp) mPos = ASCAN(aLang_ru, mParInp) // Если текстовый элемент найден в русской языковой базе. IF mPos > 0 IF mISO639_1 = 'ru' // Если текущим задан русский язык, то просто вернуть входной параметр mParOut = mParInp // Вернуть входной текстовый элемент ELSE IF mPos <= LEN(aLang_xx) mParOut = ALLTRIM(aLang_xx[mPos]) // Взять перевод из нерусского языкового массива ELSE mParOut = mParInp // Вернуть входной текстовый элемент ENDIF ENDIF aNumUses[mPos] = aNumUses[mPos] + 1 // Увеличить число использований данного текстового элемента интерфейса ELSE // Если текстовый элемент интерфейса ранее не встречался (новый), то добавить его в русский и не русский языковые массивы IF LEN(ALLTRIM(mParInp)) > 0 AADD(aLang_ru, ALLTRIM(mParInp)) AADD(aLang_xx, '') AADD(aNumUses, 1) ENDIF mParOut = ALLTRIM(mParInp) // Если русского элемента нет в языковой базе, то вернуть входной текстовый элемент ENDIF IF LEN(ALLTRIM(mParOut)) = 0 // Если нет перевода, то вернуть входной текстовый элемент mParOut = ALLTRIM(mParInp) ENDIF RETURN mParOut ********************************************************************************************* ******** Запись языковых баз ********************************************************************************************* FUNCTION SaveLangDB() DIRCHANGE(Disk_dir) // Перейти в папку: c:\Aidos-X\ mRecno = RECNO() mISO639_1 = ALLTRIM(SUBSTR(FileStr('Language.txt'),1,3)) mNameLangDB = 'Lang_'+mISO639_1 *************************************************************************************** ****** Объединить языковые массивы с локальными базами данных Lang_ru.dbf и Lang_xx.dbf *************************************************************************************** oScrn2 := DC_WaitOn( 'Пересоздание языковых баз: "Lang_ru.dbf" и "'+mNameLangDB+'.dbf"' ,,,,,,,,,,,.F.) // <<===############### не обращаться к L() перед записью БД CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Lang_ru EXCLUSIVE NEW;ZAP SELECT Lang_ru IF LEN(aLang_ru) > 0 * MsgBox(STR(LEN(aLang_ru))+STR(LEN(aNumUses))) FOR mNumLine=1 TO LEN(aLang_ru) IF LEN(aNumUses) < mNumLine AADD(aNumUses, 1) ENDIF NEXT FOR mNumLine=1 TO LEN(aLang_ru) APPEND BLANK REPLACE NumPP WITH mNumLine REPLACE TextOrig WITH ALLTRIM(SUBSTR(aLang_ru[mNumLine],1,200)) REPLACE TextTransl WITH ALLTRIM(SUBSTR(aLang_ru[mNumLine],1,200)) REPLACE TextOrigM WITH ALLTRIM(aLang_ru[mNumLine]) REPLACE TextTranM WITH ALLTRIM(aLang_ru[mNumLine]) REPLACE NumbUses WITH aNumUses[mNumLine] // <<===############### не обращаться к L() перед записью БД REPLACE Date WITH DTOC(DATE()) REPLACE Time WITH TIME() NEXT ENDIF IF mISO639_1 <> "ru" *** Создание БД (mNameLangDB) IF .NOT. FILE(mNameLangDB+'.dbf') aStructure := { { "NumPP" , "N", 6, 0 }, ; { "TextOrig" , "C", 200, 0 }, ; { "TextTransl" , "C", 200, 0 }, ; { "NumbUses" , "N", 15, 0 }, ; { "TextOrigM" , "M", 10, 0 }, ; // MEMO-FIELD { "TextTranM" , "M", 10, 0 }, ; // MEMO-FIELD { "Date" , "C", 10, 0 }, ; { "Time" , "C", 8, 0 } } DbCreate((mNameLangDB), aStructure ) ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mNameLangDB) EXCLUSIVE NEW;ZAP SELECT (mNameLangDB) DBGOTOP() IF LEN(aLang_ru) > 0 FOR mNumLine=1 TO MIN(LEN(aLang_ru), LEN(aLang_xx)) APPEND BLANK REPLACE NumPP WITH mNumLine REPLACE TextOrig WITH ALLTRIM(SUBSTR(aLang_ru[mNumLine],1,200)) REPLACE TextTransl WITH ALLTRIM(SUBSTR(aLang_xx[mNumLine],1,200)) REPLACE TextOrigM WITH ALLTRIM(aLang_ru[mNumLine]) REPLACE TextTranM WITH ALLTRIM(aLang_xx[mNumLine]) REPLACE NumbUses WITH aNumUses[mNumLine] REPLACE Date WITH DTOC(DATE()) REPLACE Time WITH TIME() NEXT ENDIF ENDIF DC_Impl(oScrn2) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Languages EXCLUSIVE NEW SELECT Languages DBGOTOP() DBGOTO(mRecno) RETURN NIL * ------------------------------------------------------------------------ * ***************************************************************************************************** ******** Блокировка запуска функции главного меню, если какая-либо функция главного меню уже запущена ***************************************************************************************************** FUNCTION Running(lValue) STATIC lRunning := .F. IF PCOUNT() > 0 lRunning := lValue ENDIF * IF lRunning = .F. * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * CLoseAllWindows() // Закрытие всех окон * CLoseAllFiles() // Закрытие всех файлов <<<===######### пока этого нет * ************************************************************** * ***** БД, открытые перед запуском главного меню * ***** Восстанавливать их после выхода из функций главного меню * ************************************************************** * DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы * USE PathGrAp EXCLUSIVE NEW * USE Appls EXCLUSIVE NEW * USE Users EXCLUSIVE NEW * ENDIF RETURN lRunning * ------------------------------------------------------------------------ * ************************************************************************************************************************* ******** 4.2.2.3. Когнитивная агломеративная древовидная кластеризация классов ******** Когнитивная кластеризация, путем объединения пар классов в матрице абсолютных частот и пересчет матриц условных ******** и безусловных процентных распределений и системно-когнитивных моделей. Построение и визуализация древовидных ******** диаграмм объединения классов (дендрограмм) в графическом виде ************************************************************************************************************************* FUNCTION F4_2_2_3() PUBLIC GetList[0], GetOptions, oSay, hDC1, hDC2, oStatic, oStatic1, aPixel, oBitmap Running(.T.) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!"),L('4.2.2.3. Агломеративная древовидная кластеризация классов')) Running(.F.) RETURN NIL ENDIF ** Имя графического файла для рисования *PUBLIC X_MaxW := 1910, Y_MaxW := 950 // Размер графического окна для самого графика в пикселях *PUBLIC X_MaxW := 1900, Y_MaxW := 950 // Размер графического окна для самого графика в пикселях *PUBLIC X_MaxW := nWidth, Y_MaxW := nHeight // Размер графического окна для самого графика в пикселях PUBLIC X_MaxW := 1800, Y_MaxW := 900 // Размер графического окна для самого графика в пикселях PUBLIC nXSize := X_MaxW // Размер изображения в пикселях ################## НАДО БРАТЬ ПУТЕМ ОПРЕДЕЛЕНИЯ РАЗРЕШЕНИЯ ЭКРАНА PUBLIC nYSize := Y_MaxW StrFile(STR(nXSize,9)+' '+STR(nYSize,9), '_XYSize.txt') // Запись текстового файла с параметрами nXSize, nYSize PRIVATE aSize := {X_MaxW,Y_MaxW} *PRIVATE nColor := BD_LIGHTGREY PRIVATE nColor := GraMakeRGBColor({ 255, 255, 255}) PUBLIC oBitmap := XbpBitmap() :new() :create() // create Bitmap PUBLIC oPS := XbpPresSpace():new() // NO :Create() here oPS:create( oBitmap, { aSize[1],aSize[2] } ) // here :Create() oBitmap:presSpace( oPS ) // assing to Bitmap:presSpace oBitmap:make( aSize[1],aSize[2] ) // make empty Bitmap mFileName = 'Gra4223.jpg' IF .NOT. FILE('Gra4223.jpg') *** Если этого файла нет, то создать изображение и сохранить его GraSetColor( oPS, nColor, nColor ) // Background Color GraBox( oPS, {0,0}, {aSize[1],aSize[2]}, 1 ) // fill Background oBitmap:saveFile('Gra4223.jpg',XBPBMP_FORMAT_JPG) * LB_Warning(L('В текущей папке системы'+Disk_dir+' должен быть файл: "Gra4223.bmp" или "Gra4223.jpg" 1910 x 1000 pix', mTitle ) * RETURN nil ENDIF ClearImage4223() // Очистка изображения ************************ IF ApplChange("4.2.2.3()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций *MsgBox(Disk_dir+'Gra4223.jpg'+' ====> '+M_PathAppl+'Gra4223.jpg') *COPY FILE (Disk_dir+'\Gra4223.jpg') TO (M_PathAppl+'Gra4223.jpg') // Не работает с ADS ADS_CopyFile(Disk_dir+'\Gra4223.jpg', M_PathAppl+'Gra4223.jpg', .F., .F.) // Скопировать новый файл запуска со стандартным именем и удалить новый файл с ADS IF .NOT. FILE('Abs.TXT' ) .OR. ; .NOT. FILE('Prc1.TXT') .OR. ; .NOT. FILE('Prc2.TXT') .OR. ; .NOT. FILE('Inf1.TXT') .OR. ; .NOT. FILE('Inf2.TXT') .OR. ; .NOT. FILE('Inf3.TXT') .OR. ; .NOT. FILE('Inf4.TXT') .OR. ; .NOT. FILE('Inf5.TXT') .OR. ; .NOT. FILE('Inf6.TXT') .OR. ; .NOT. FILE('Inf7.TXT') aMess := {} AADD(aMess, L('Отсутствуют одна или несколько системно-когнитивных моделей!')) // TXT или DBF AADD(aMess, L('Чтобы их создать необходимо выполнить режим:')) AADD(aMess, L('"3.5. Синтез и верификация заданных из 10 моделей"')) LB_Warning(aMess,L('4.2.2.3. Агломеративная древовидная кластеризация классов')) Running(.F.) RETURN NIL ENDIF IF .NOT. FILE('Abs.DBF' ) .OR. ; .NOT. FILE('Prc1.DBF') .OR. ; .NOT. FILE('Prc2.DBF') .OR. ; .NOT. FILE('Inf1.DBF') .OR. ; .NOT. FILE('Inf2.DBF') .OR. ; .NOT. FILE('Inf3.DBF') .OR. ; .NOT. FILE('Inf4.DBF') .OR. ; .NOT. FILE('Inf5.DBF') .OR. ; .NOT. FILE('Inf6.DBF') .OR. ; .NOT. FILE('Inf7.DBF') Running(.F.) F5_5(.F.) ENDIF *IF .NOT. FILE('SxodClsAbs.DBF' ) .OR. ; * .NOT. FILE('SxodClsPrc1.DBF') .OR. ; * .NOT. FILE('SxodClsPrc2.DBF') .OR. ; * .NOT. FILE('SxodClsInf1.DBF') .OR. ; * .NOT. FILE('SxodClsInf2.DBF') .OR. ; * .NOT. FILE('SxodClsInf3.DBF') .OR. ; * .NOT. FILE('SxodClsInf4.DBF') .OR. ; * .NOT. FILE('SxodClsInf5.DBF') .OR. ; * .NOT. FILE('SxodClsInf6.DBF') .OR. ; * .NOT. FILE('SxodClsInf7.DBF') * aMess := {} * AADD(aMess, L('Отсутствуют одна или несколько матриц сходства классов!')) * AADD(aMess, L('Чтобы их создать необходимо выполнить режим:')) * AADD(aMess, L('"4.2.2.1. Расчет матриц сходства, кластеров и конструктов"')) * LB_Warning(aMess,L('4.2.2.3. Агломеративная древовидная кластеризация классов')) * Running(.F.) * RETURN NIL *ENDIF mModError = .T. PRIVATE Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } FOR m=1 TO LEN(Ar_Model) IF FILE('SxodCls'+Ar_model[m]+'.DBF') mModError = .F. EXIT ENDIF NEXT IF mModError aMess := {} AADD(aMess, L('Нет ни одной модели, в которой была бы посчитана матрица сходства классов!')) AADD(aMess, L('Чтобы сделать это необходимо выполнить режим:')) AADD(aMess, L('"4.2.2.1. Расчет матриц сходства, кластеров и конструктов"')) LB_Warning(aMess,L('4.2.2.3. Агломеративная древовидная кластеризация классов')) Running(.F.) RETURN NIL ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW N_Rec = RECCOUNT() IF N_Rec > 111 aMess := {} AADD(aMess, L('В данной модели')+' '+ALLTRIM(STR(N_Rec))+' '+L('классов. При таком количестве классов процесс агломеративной когнитивной кластеризации может занять заметное время.')) AADD(aMess, L('Кроме того для отображения дендрограммы когнитивной кластеризации может потребоваться графический файл с большим числом пикселей по X и по Y.')) AADD(aMess, L('Задать размерность графического файла, а также размер используемых шрифтов, толщину линий и другие параметры отображения дендрограммы можно')) AADD(aMess, L('кликнув по кнопке: "Параметры". Если задать и модель для отображения дендрограммы и ранее в ней проводился расчет дендрогаммы, то отобразить')) AADD(aMess, L('ее без перерасчета (т.е. значительно быстрее, чем с расчетом) можно кликнув по кнопке: "Перерисовать без перерасчета". Эту операцию можно')) AADD(aMess, L('повторять много раз, что позволяет подобрать нужные параметры визуализации')) LB_Warning(aMess,L('4.2.2.3. Агломеративная древовидная кластеризация классов')) * Running(.F.) * RETURN NIL ENDIF IF FILEDATE("ClsClustTree",16) = CTOD("//") DIRMAKE("ClsClustTree") aMess := {} AADD(aMess, L('В папке текущего приложения: "'+UPPER(ALLTRIM(M_PathAppl))+'"')) AADD(aMess, L('не было директории "ClsClustTree" для дендрограмм классов и она была создана!')) AADD(aMess, L('В эту папку записываются исходные изображения высокого качества (без масштабирования)')) LB_Warning(aMess, L('4.2.2.3. Агломеративная древовидная кластеризация классов' )) ENDIF // Сделать с текстовыми файлами: NameCls1-##-#####, NameCls2-##-##### и NAMECLSF-##-##### // где: № модели (01-10) KODCL_NEW * DIRCHANGE(M_PathAppl+"\ClsClustTree\") // Перейти в папку ClsClustTree * cFileName = M_PathAppl+"\ClsClustTree\NameCls1"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+"-"+STRTRAN(STR(KODCL_NEW,5)," ","0")+".txt" * StrFile(mClustCls, cFileName) // Запись текстового файла NameCls1-##-#####.txt, где ##-номер модели, #####-KODCL_NEW * mClustCls = FileStr(cFileName) // Считывание текстового файла NameCls1-##-#####.txt, где ##-номер модели, #####-KODCL_NEW *************** ДИАЛОГ ЗАДАНИЯ ПАРАМЕТРОВ КЛАСТЕРИЗАЦИИ ****************************** *** РЕАЛИЗАЦИЯ АЛГОРИТМА: *** 0. Задать в диалоге параметры кластеризации. *** Здесь можно задать: *** - размер шрифта для надписей наименований классов; *** - толщину линий дендрограммы *** - делать паузу после вывода изображения? *** - отображать кластеры различным цветом? *** - и т.д. ... mNumMod = Options4223(.F.) mNameTree = 'TreeCls-'+STRTRAN(STR(mNumMod,2),' ','0') // mNumMod из Options4223 H = 1.5 // Высота кнопки @ 0,0 DCSTATIC TYPE XBPSTATIC_TYPE_BITMAP CAPTION mFileName OBJECT oStatic1 ; PREEVAL {|o|o:autoSize := .t.} EVAL {|o|hDC1 := GetWindowDC(o:getHWnd()), o:motion := {|a,b,o|ShowColorTr( hDC1, a, oSay, o )},; aPixel := Array(o:caption:xSize,o:caption:ySize), o:paint := {|a,b,o|Gratest(o)}} p=25;d=6 @ 1.5, 1 DCPUSHBUTTON CAPTION L('Помощь' ) SIZE LEN(L('Помощь' )) +2, H ACTION {||Help4223()} @ 1.5, 10 DCPUSHBUTTON CAPTION L('Параметры' ) SIZE LEN(L('Параметры')) +2, H ACTION {||Options4223(.T.)} @ 1.5, p DCPUSHBUTTON CAPTION L('ABS ' ) SIZE LEN(L('ABS ') ) +2, H ACTION {||TreeCls(1)};p=p+d-1 @ 1.5, p DCPUSHBUTTON CAPTION L('PRC1' ) SIZE LEN(L('PRC1') ) +2, H ACTION {||TreeCls(2)};p=p+d @ 1.5, p DCPUSHBUTTON CAPTION L('PRC2' ) SIZE LEN(L('PRC2') ) +2, H ACTION {||TreeCls(3)};p=p+d @ 1.5, p DCPUSHBUTTON CAPTION L('INF1' ) SIZE LEN(L('INF1') ) +2, H ACTION {||TreeCls(4)};p=p+d @ 1.5, p DCPUSHBUTTON CAPTION L('INF2' ) SIZE LEN(L('INF2') ) +2, H ACTION {||TreeCls(5)};p=p+d @ 1.5, p DCPUSHBUTTON CAPTION L('INF3' ) SIZE LEN(L('INF3') ) +2, H ACTION {||TreeCls(6)};p=p+d @ 1.5, p DCPUSHBUTTON CAPTION L('INF4' ) SIZE LEN(L('INF4') ) +2, H ACTION {||TreeCls(7)};p=p+d @ 1.5, p DCPUSHBUTTON CAPTION L('INF5' ) SIZE LEN(L('INF5') ) +2, H ACTION {||TreeCls(8)};p=p+d @ 1.5, p DCPUSHBUTTON CAPTION L('INF6' ) SIZE LEN(L('INF6') ) +2, H ACTION {||TreeCls(9)};p=p+d @ 1.5, p DCPUSHBUTTON CAPTION L('INF7' ) SIZE LEN(L('INF7') ) +2, H ACTION {||TreeCls(10)} ;p=p+d*1.7 @ 1.5, p DCPUSHBUTTON CAPTION L('Все модели') SIZE LEN(L('Все модели'))+2, H ACTION {||TreeClsAll()};p=p+16 @ 1.5, p DCPUSHBUTTON CAPTION L('Перерисовать без перерасчета') SIZE LEN(L('Перерисовать без перерасчета'))-2, H ACTION {||DrawClustCls()} ;p=p+27 //############### @ 1.5, p DCPUSHBUTTON CAPTION L('Статья о когн.кластеризации' ) SIZE LEN(L('Статья о когн.кластеризации' ))-3, H ACTION {||LC_RunUrl( 'http://ej.kubagro.ru/2011/07/pdf/40.pdf' , .T., .T. )};p=p+25 //############### @ 1.5, p DCPUSHBUTTON CAPTION L('Свидетельство РосПатента' ) SIZE LEN(L('Свидетельство РосПатента' ))-0, H ACTION {||LC_RunUrl( 'http://lc.kubagro.ru/aidos/2012610135.jpg', .T., .T. )} //############### DCREAD GUI FIT OPTIONS GetOptions EVAL {||GraTest(oStatic1)} SETAPPWINDOW; TITLE L('4.2.2.3. Агломеративная древовидная кластеризация классов. (C) Универсальная когнитивная аналитическая система "Эйдос-Х++"') oStatic1:unlockPS() ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ************************************************************************************************************************* FUNCTION Options4223(mPar) PUBLIC GetList[0] *** Здесь можно задать: *** - размер шрифта для надписей наименований классов; *** - толщину линий дендрограммы *** - делать паузу после вывода изображения? *** - отображать кластеры различным цветом? *** - делать фон по классам полосками белого и светло-голубого цвета *** - размеры графического файла (до 4K, т.е. до 4096 Х 4096) *** - и т.д. ... ****** Параметры визуализации дендрограммы ******************** PUBLIC mFontSize := 3 PUBLIC mLineWidth := 2 PUBLIC mSaveDBases:= 1 PUBLIC mBGrColor := 2 PUBLIC mNumMod := 6 // <<<===################## Надо определять, для каких моделей есть матрицы сходства PUBLIC mXSize := 1800 PUBLIC mYSize := 900 IF FILE('_Options4223.txt') mStr = FileStr('_Options4223.txt') mFontSize = VAL(SUBSTR(mStr, 1,1)) mLineWidth = VAL(SUBSTR(mStr, 2,1)) mSaveDBases = VAL(SUBSTR(mStr, 3,1)) mBGrColor = VAL(SUBSTR(mStr, 4,1)) mNumMod = VAL(SUBSTR(mStr, 5,2)) mXSize = VAL(SUBSTR(mStr, 7,4)) mYSize = VAL(SUBSTR(mStr,11,4)) mFontSize = IF(mFontSize =0,3,mFontSize ) mLineWidth = IF(mLineWidth =0,2,mLineWidth ) mSaveDBases = IF(mSaveDBases=0,1,mSaveDBases) mBGrColor = IF(mBGrColor =0,2,mBGrColor ) mNumMod = IF(mNumMod =0,6,mNumMod ) mXSize = IF(mXSize =0,1800,mXSize ) mYSize = IF(mYSize =0, 900,mYSize ) ENDIF *************************************************************** IF mPar @0, 0 DCGROUP oGroup1 CAPTION L('Задайте размер шрифта:') SIZE 75.0, 5.5 @1, 2 DCRADIO mFontSize VALUE 1 PROMPT L('Очень мелкий') PARENT oGroup1 @2, 2 DCRADIO mFontSize VALUE 2 PROMPT L('Мелкий' ) PARENT oGroup1 @3, 2 DCRADIO mFontSize VALUE 3 PROMPT L('Средний' ) PARENT oGroup1 @4, 2 DCRADIO mFontSize VALUE 4 PROMPT L('Крупный' ) PARENT oGroup1 @6, 0 DCGROUP oGroup2 CAPTION L('Задайте толщину линий:') SIZE 75.0, 3.5 @1, 2 DCRADIO mLineWidth VALUE 1 PROMPT L('Тонкие' ) PARENT oGroup2 @2, 2 DCRADIO mLineWidth VALUE 2 PROMPT L('Толстые' ) PARENT oGroup2 @10,0 DCGROUP oGroup3 CAPTION L('Сохранять промежуточные базы данных?') SIZE 75.0, 3.5 @1, 2 DCRADIO mSaveDBases VALUE 1 PROMPT L('Нет' ) PARENT oGroup3 @2, 2 DCRADIO mSaveDBases VALUE 2 PROMPT L('Да.' ) PARENT oGroup3 @2.2, 10 DCSAY L('Надо иметь в виду, что их может быть очень много!') EDITPROTECT {|| .NOT.mSaveDBases=2 } HIDE {|| .NOT.mSaveDBases=2 } FONT '9.Arial Bold' COLOR GRA_CLR_RED PARENT oGroup3 @14,0 DCGROUP oGroup4 CAPTION L('Рисовать кластеры на цветном фоне?') SIZE 75.0, 3.5 @1, 2 DCRADIO mBGrColor VALUE 1 PROMPT L('Нет' ) PARENT oGroup4 @2, 2 DCRADIO mBGrColor VALUE 2 PROMPT L('Да.' ) PARENT oGroup4 @18,0 DCGROUP oGroup5 CAPTION L('Задайте размер изображения в пикселях (не более 4K):') SIZE 75.0, 3.5 @ 1,2 DCSAY L("Размер по X:") GET mXSize PICTURE "####" PARENT oGroup5 @ 2,2 DCSAY L("Размер по Y:") GET mYSize PICTURE "####" PARENT oGroup5 p=2; d=7 @22,0 DCGROUP oGroup6 CAPTION L('Задайте ранее просчитанную модель для перерисовки без перерасчета:') SIZE 75.0, 2.5 @1, p DCRADIO mNumMod VALUE 1 PROMPT L('Abs' ) PARENT oGroup6;p=p+d @1, p DCRADIO mNumMod VALUE 2 PROMPT L('Prc1') PARENT oGroup6;p=p+d @1, p DCRADIO mNumMod VALUE 3 PROMPT L('Prc2') PARENT oGroup6;p=p+d @1, p DCRADIO mNumMod VALUE 4 PROMPT L('Inf1') PARENT oGroup6;p=p+d @1, p DCRADIO mNumMod VALUE 5 PROMPT L('Inf2') PARENT oGroup6;p=p+d @1, p DCRADIO mNumMod VALUE 6 PROMPT L('Inf3') PARENT oGroup6;p=p+d @1, p DCRADIO mNumMod VALUE 7 PROMPT L('Inf4') PARENT oGroup6;p=p+d @1, p DCRADIO mNumMod VALUE 8 PROMPT L('Inf5') PARENT oGroup6;p=p+d @1, p DCRADIO mNumMod VALUE 9 PROMPT L('Inf6') PARENT oGroup6;p=p+d @1, p DCRADIO mNumMod VALUE 10 PROMPT L('Inf7') PARENT oGroup6;p=p+d DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; OPTIONS GetOptions ; ADDBUTTONS; MODAL ; TITLE L('4.2.2.3. Агломеративная древовидная кластеризация классов') ENDIF mXSize = IF(mXSize<1800,1800,mXSize ) mXSize = IF(mXSize>4096,4096,mXSize ) mYSize = IF(mYSize< 900, 900,mYSize ) mYSize = IF(mYSize>4096,4096,mYSize ) StrFile(STR(mFontSize,1)+STR(mLineWidth,1)+STR(mSaveDBases,1)+STR(mBGrColor,1)+STR(mNumMod,2)+STR(mXSize,4)+STR(mYSize,4), '_Options4223.txt') // Запись текстового файла с параметрами nXSize, nYSize DC_ASave(mNumMod , "_NumMod.arx") * mNumMod = DC_ARestore("_NumMod.arx") PUBLIC mNameTree := 'TreeCls-'+STRTRAN(STR(mNumMod,2),' ','0') // mNumMod из Options4223 RETURN(mNumMod) ********************************************************** ******** Когнитивная кластеризация классов во всех моделях ********************************************************** FUNCTION TreeClsAll() ***************************************************************************************************** *** АЛГОРИТМ: *** 0. Задать в диалоге параметры кластеризации. *** 1. Цикл по моделям ******** *** 2. Создать БД классов и кластеров: CLS_CLUST, абсолютных частот: ABS_CLUST1, информативностей: INF_CLUST, *** сходства классов: MSC_CLUST путем КОПИРОВАНИЯ ранее расчитанных по текущей модели. *** Создать БД учета объединения классов TreeCls.dbf и занести в нее начальную информацию. *** 3. Начало цикла итераций до тех пор, пока не останется 2 кластера. **** *** 4. Найти заданное число пар классов наиболее похожих классов в матрице сходства. *** 5. Объединить заданное число пар классов с НАИБОЛЬШИМ уровнем сходства в ABS_CLUST2. *** 6. На основе ABS_CLUST2 РАССЧИТАТЬ матрицу информативностей: INF_CLUST в текущей модели, *** рассчитать матрицу сходства классов: MSC_CLUST, при этом принудительно обеспечить, чтобы объединенный класс имел более низкое сходство со всеми классами, чем входящие в него классы, *** а также БД учета объединения классов TreeCls.dbf и занести в нее информацию об объединении классов в БД IterCls###.dbf. *** Скопировать ABS_CLUST2 => ABS_CLUST1 *** 7. Конец цикла итераций. Проверить критерий остановки: если в MSC_CLUST осталось больше 2 **** *** колонок, то перейти на продолжение итераций (п.4), а иначе на рисование результатов (п.8). *** 8. Нарисовать дерево объединения классов: *** ..\System\ClustTreeCls\ClustTreeCls-#-##.bmp *** 9. Конец цикла по моделям ******** ***************************************************************************************************** *** 1. Цикл по моделям **** PUBLIC Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } FOR mNumMod = 1 TO 10 // Для всех моделей DC_ASave(mNumMod , "_NumMod.arx") TreeCls(mNumMod) // Кластеризация NEXT *** 9. Конец цикла по моделям **** **** Объединить структуры дендрогамм всех моделей в одном файле CrLf = CHR(13)+CHR(10) // Конец строки (абзаца) (CrLf) mClustCls = '' FOR mNumMod = 1 TO 10 // Для всех моделей mClustCls = mClustCls + STR(mNumMod,2) + ' ' + Ar_Model[mNumMod] + ': ' + FileStr('_ClustCls-'+STRTRAN(STR(mNumMod,2),' ','0')+'.txt') + CrLf // Считывание текстового файла _ClustCls-##.txt, где ##-номер модели NEXT StrFile(mClustCls, '_ClustCls-ALL.txt') // Запись текстового файла _ClustCls-##.txt, где ##-номер модели aMess := {} AADD(aMess, L('Когнитивная кластеризация завершена успешно!')) AADD(aMess, L(' ')) AADD(aMess, L('Результаты (дендрограммы) находятся в папке:')) AADD(aMess, M_PathAppl+'ClsClustTree\') LB_Warning(aMess,L('4.2.2.3. Агломеративная древовидная кластеризация классов')) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций RETURN NIL ************************************************************************************************** FUNCTION Help4223() aHelp := {} AADD(aHelp, L('Помощь по режиму: "4.2.2.3. Агломеративная древовидная кластеризация классов" ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Данный режим обеспечивает агломеративную когнитивную кластеризацию классов и вывод дендрограмм в виде графических форм. При этом применяется ')) AADD(aHelp, L('авторский алгоритм, имеющий ряд особенностей, по сравнению с традиционными: ')) AADD(aHelp, L('- матрица сходства (расстояний) рассчитывается не только на основе матрицы частот ABS, отражающей количество наблюдений градаций описательных ')) AADD(aHelp, L('шкал в группах по градациям классификационных шкал (классам), но и на основе матриц условных и безусловных процентных распределений: PRC1, PRC2, ')) AADD(aHelp, L('а также матриц системно-когнитивных моделей: INF1, INF2, INF3, INF4, INF5, INF6, INF7; ')) AADD(aHelp, L('- в качестве меры расстояния между классами и кластерами используется не Евклидового расстояние, а неметрический интегральный критерий ')) AADD(aHelp, L('(информационное расстояние), применение которого корректно для неортонормированных пространств (которые только и встречаются на практике); ')) AADD(aHelp, L('- после объединения классов (кластеров) в кластеры пересчитывается матрица расстояний путем перерасчета не только матрицы абсолютных частот, но и')) AADD(aHelp, L('матриц условных и безусловных процентных распределений и системно-когнитивных моделей (список этих моделей можно увидеть в режимах: 3.5,5.5,5.6).')) AADD(aHelp, L('Персчет матрицы абсолютных частот происходит таким образом, как будто объекты обучающей выборки относятся не к исходным классам, а к кластерам. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('АЛГОРИТМ: ')) AADD(aHelp, L('0. Задать в диалоге параметры кластеризации. ')) AADD(aHelp, L('1. Цикл по моделям ')) AADD(aHelp, L('2. Создать БД классов и кластеров: CLS_CLUST, абсолютных частот: ABS_CLUST1, информативностей: INF_CLUST, сходства классов: MSC_CLUST ')) AADD(aHelp, L('путем КОПИРОВАНИЯ ранее рассчитанных по текущей модели. Создать БД учета объединения классов TreeCls.dbf и занести в нее начальную информацию. ')) AADD(aHelp, L('3. Начало цикла итераций до тех пор, пока не останется 2 кластера. ')) AADD(aHelp, L('4. Найти пару наиболее похожих классов в матрице сходства. ')) AADD(aHelp, L('5. Объединить пару классов с НАИБОЛЬШИМ уровнем сходства в ABS_CLUST2. ')) AADD(aHelp, L('6. На основе ABS_CLUST2 РАССЧИТАТЬ матрицу информативностей: INF_CLUST в текущей модели, рассчитать матрицу сходства классов: MSC_CLUST, ')) AADD(aHelp, L('а также БД учета объединения классов TreeCls.dbf и занести в нее информацию об объединении классов. Скопировать ABS_CLUST2 => ABS_CLUST1 ')) AADD(aHelp, L('7. Конец цикла итераций. Проверить критерий остановки: если в MSC_CLUST осталось больше 2 колонок, то перейти на продолжение итераций (п.4), ')) AADD(aHelp, L('а иначе на выход рисование результатов (п.8). ')) AADD(aHelp, L('8. Нарисовать дерево объединения классов (дендрограмму) на экране и записать файл: ClustCls-##.bmp, где: ## - номер модели. ')) AADD(aHelp, L('9. Нарисовать график изменения межкластерных расстояний на экране и записать файл: ClustClsDist-##.bmp, где: ## - номер модели. ')) AADD(aHelp, L('10. Конец цикла по моделям. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Статья и свидетельство РосПатента по когнитивной кластеризации: ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Луценко Е.В. Метод когнитивной кластеризации или кластеризация на основе знаний (кластеризация в системно-когнитивном анализе и интеллектуальной ')) AADD(aHelp, L('системе <Эйдос>) / Е.В. Луценко, В.Е. Коржаков // Политематический сетевой электронный научный журнал Кубанского государственного аграрного ')) AADD(aHelp, L('университета (Научный журнал КубГАУ) [Электронный ресурс]. - Краснодар: КубГАУ, 2011. - №07(071). С. 528 - 576. - Шифр Информрегистра: ')) AADD(aHelp, L('0421100012\0253, IDA [article ID]: 0711107040. - Режим доступа: http://ej.kubagro.ru/2011/07/pdf/40.pdf, 3,062 у.п.л. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Луценко Е.В. Подсистема агломеративной когнитивной кластеризации классов системы <Эйдос> ("Эйдос-кластер") / Е.В. Луценко, В.Е. Коржаков // Пат. ')) AADD(aHelp, L('№ 2012610135 РФ. Заяв. № 2011617962 РФ 26.10.2011. Опубл. От 10.01.2012. - Режим доступа: http://lc.kubagro.ru/aidos/2012610135.jpg, 3,125 у.п.л.')) mHelpMax = -999;FOR h=1 TO LEN(aHelp);mHelpMax = MAX(mHelpMax, LEN(ALLTRIM(aHelp[h])));NEXT s=1;d=0.9;@0,0 DCGROUP oGroup1 CAPTION L(' ') SIZE mHelpMax-25, LEN(aHelp)*d+1.5 FOR h=1 TO LEN(aHelp);@s,2 DCSAY aHelp[h] SIZE 0 PARENT ogroup1;s=s+d;NEXT DCREAD GUI TO lExit FIT TITLE L('4.2.2.3. Агломеративная древовидная кластеризация классов. (C) Система "ЭЙДОС-X++"') RETURN NIL ************************************************************************************************** ***************************************************************************************** ******** Когнитивная кластеризация для одной заданной модели **************************** ***************************************************************************************** FUNCTION TreeCls(mNumMod) *mNumMod = DC_ARestore("_NumMod.arx") DC_ASave(mNumMod, "_NumMod.arx") *MsgBox(STR(mNumMod)) IF .NOT. FILE("SxodCls"+Ar_Model[mNumMod]+".dbf") aMess := {} AADD(aMess, L('Сначала необходимо в режиме 4.2.2.1 посчитать матрицу сходства в модели:')+' '+Ar_Model[mNumMod]) LB_Warning(aMess,L('4.2.2.3. Агломеративная древовидная кластеризация классов')) RETURN NIL ENDIF StrFile(STR(mFontSize,1)+STR(mLineWidth,1)+STR(mSaveDBases,1)+STR(mBGrColor,1)+STR(mNumMod,2)+STR(mXSize,4)+STR(mYSize,4), '_Options4223.txt') // Запись текстового файла с параметрами nXSize, nYSize PUBLIC mNameTree := 'TreeCls-'+STRTRAN(STR(mNumMod,2),' ','0') // mNumMod из Options4223 *oScrn2 := DC_WaitOn( L('Идет процесс когнитивной кластеризации классов в модели: ')+ALLTRIM(STR(mNumMod))+'/10-'+Ar_Model[mNumMod],,,,,,,,,,,.F.) ****** Параметры визуализации дендрограммы ******************** Options4223(.F.) *************************************************************** *** 2. Создать БД абсолютных частот: ABS_CLUST1, информативностей: INF_CLUST, *** сходства классов: MSC_CLUST путем КОПИРОВАНИЯ ранее расчитанных по текущей модели. *** Создать БД учета объединения классов TreeCls.dbf и занести в нее начальную информацию. CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } COPY FILE ("Classes.dbf") TO ("CLS_CLUST.dbf") COPY FILE ("ABS.dbf") TO ("ABS_CLUST1.dbf") COPY FILE ("INF.dbf") TO ("INF_CLUST.dbf") *COPY FILE ("SxodClsAbs.dbf") TO ("MSC_CLUST.dbf") COPY FILE ("SxodCls"+Ar_Model[mNumMod]+".dbf") TO ("MSC_CLUST.dbf") *MsgBox("SxodCls"+Ar_Model[mNumMod]+".dbf") *** Создать массив наименований атрибутов CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Attributes EXCLUSIVE NEW;N_Atr = RECCOUNT() SELECT Attributes aAtr := {} DBGOTOP() DO WHILE .NOT. EOF() AADD(aAtr, ALLTRIM(Name_atr)) DBSKIP(1) ENDDO *** Создать БД учета объединения классов TreeCls.dbf и занести в нее начальную информацию. CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Classes = RECCOUNT() SELECT Classes aNameCls := {} DBGOTOP() DO WHILE .NOT. EOF() AADD(aNameCls, ALLTRIM(STR(Kod_cls))) DBSKIP(1) ENDDO ***** Создаем БД для сохранения информации об объединении классов aStructure := { { "Num_it" , "N", 15, 0 }, ; { "Num_pp" , "N", 15, 0 }, ; { "NameCls1" , "C", 255, 0 }, ; // Мемо-поле не работает, поэтому использовать текстовые файлы со значениями полей NameCls1 с именами, приведенными ниже { "NameCls2" , "C", 255, 0 }, ; // Мемо-поле не работает, поэтому использовать текстовые файлы со значениями полей NameCls2 с именами, приведенными ниже { "KodCl_old1" , "N", 15, 0 }, ; { "KodCl_old2" , "N", 15, 0 }, ; { "NameCls_Sh" , "C", 255, 0 }, ; { "NameCls_Fu" , "C", 255, 0 }, ; // Мемо-поле не работает, поэтому использовать текстовые файлы со значениями полей NameCls_Fu с именами, приведенными ниже { "Ur_sxod" , "N", 19, 7 }, ; { "Ur_razl" , "N", 19, 7 }, ; { "Ur_razlIsh" , "N", 19, 7 }, ; { "Normalizat" , "C", 19, 0 }, ; { "KodCl_new" , "N", 19, 0 }, ; { "Hierarchy" , "N", 19, 0 }, ; { "Filtr" , "C", 1, 0 }, ; { "Color" , "C", 4, 0 }, ; { "X_koord" , "N", 19, 7 }, ; { "Y_koord" , "N", 19, 7 } } mNameTree = 'TreeCls-'+STRTRAN(STR(mNumMod,2),' ','0') DbCreate( mNameTree, aStructure ) * cFileName = M_PathAppl+"\ClsClustTree\NameCls1"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+"-"+STRTRAN(STR(KODCL_NEW,5)," ","0")+".txt" * StrFile(mClustCls, cFileName) // Запись текстового файла NameCls1-##-#####.txt, где ##-номер модели, #####-KODCL_NEW * mClustCls = FileStr(cFileName) // Считывание текстового файла NameCls1-##-#####.txt, где ##-номер модели, #####-KODCL_NEW ********************************************************************************* *** 3. Начало цикла итераций до тех пор, пока не останется 2 кластера. **** ********************************************************************************* Wsego = N_Classes mTitleName = L('4.2.2.3. Агломеративная древовидная кластеризация классов. (C) Система "ЭЙДОС-X++"') // Отображение стадии исполнения. Будет написано прямо в окне Progress-bar d = 0 @0,0 DCGROUP oGroup1 CAPTION L('Стадии исполнения процесса') FONT "6.Helv" SIZE 105+d, 2.5 PARENT oTabPage1 @4,0 DCGROUP oGroup2 CAPTION L('Прогноз времени исполнения') FONT "6.Helv" SIZE 105+d, 5.0 PARENT oTabPage2 s = 1 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 1] FONT "10.Helv" s++ @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay97 FONT "10.HelvBold" s++ @0.2+s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay98 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @1.5+s ,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay99 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @s ,1 DCPROGRESS oProgress ; SIZE 95,1.5 ; PERCENT ; EVERY 1+INT(Wsego/nEvery) ; // Кол-во обновлений изображения MAXCOUNT Wsego ; COLOR GRA_CLR_CYAN // Цвет полосы @s++,97 DCPUSHBUTTON CAPTION L('&Cancel') ; ACTION {||lOk:=.T.} OBJECT oButton ; SIZE 7,1.5 DCREAD GUI ; TITLE mTitleName ; PARENT @oDialog ; FIT ; EXIT ; MODAL oDialog:alwaysOnTop = .T. // Окно открывается на переднем плане oDialog:show() // Начало отсчета времени для прогнозирования длительности исполнения Time_progress = 0 // Прошло секунд с начала процесса // Процесс может идти больше суток, поэтому для определения // во всех случаях вычисляется время, прошедшее с начала года T_Mess1 = L("Начало:")+" "+TIME() // Начало Sec_1 = (DOY(DATE())-1)*86400+SECONDS() PUBLIC T1 := (DOY(DATE())-1)*86400+SECONDS() // Время предыдущей индикации процесса исполнения PUBLIC T2 := (DOY(DATE())-1)*86400+SECONDS()+1 // Текущее время (1-й раз оно заметно больше T1 чтобы было отображение) PUBLIC T1tp := T1 PUBLIC T2tp := T2 ********************************************************************************* aKodCls := {} // Массив для исключения повторов классов и/или кластеров FOR mNumIter = 1 TO N_Classes // Начало цикла итераций ******** * oScrn2 := DC_WaitOn( L('Идет процесс когнитивной кластеризации классов в модели: ')+ALLTRIM(STR(mNumMod))+'/10-'+Ar_Model[mNumMod]+'. '+ALLTRIM(STR(mNumIter))+'/'+ALLTRIM(STR(N_Classes)),,,,,,,,,,,.F.) aSay[ 1]:SetCaption(L('Идет процесс когнитивной кластеризации классов в модели: ')+ALLTRIM(STR(mNumMod))+'/10-'+Ar_Model[mNumMod]+'. '+ALLTRIM(STR(mNumIter))+'/'+ALLTRIM(STR(N_Classes))) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW;N_Atr = RECCOUNT() USE CLS_CLUST EXCLUSIVE NEW USE ABS_CLUST1 EXCLUSIVE NEW USE MSC_CLUST EXCLUSIVE NEW USE (mNameTree) EXCLUSIVE NEW *** 4. Найти пару наиболее похожих классов или кластеров в матрице сходства. SELECT CLS_CLUST N_Cls = RECCOUNT() // Число классов (кластеров) будет увеличиваться SELECT MSC_CLUST IF N_Cls > 2 mMaxUrSx = -999 // Искать пару классов с наивысшим сходством по всей матрице сходства mFlagAdd = .F. FOR mKodCls1 = 1 TO N_Cls // Строка DBGOTO(mKodCls1) FOR mKodCls2 = mKodCls1+1 TO N_Cls // Колонка IF ASCAN(aKodCls, mKodCls1) = 0 .AND.; // Ни один из классов еще не включен в кластер ASCAN(aKodCls, mKodCls2) = 0 M_UrSx = FIELDGET(mKodCls2+3) IF mMaxUrSx < M_UrSx mFlagAdd = .T. mMaxUrSx = M_UrSx mNameClustSh = '('+ALLTRIM(STR(MIN(mKodCls1,mKodCls2),15))+','+ALLTRIM(STR(MAX(mKodCls1,mKodCls2),15))+')' //########### IF LEN(aNameCls[mKodCls1]) > LEN(aNameCls[mKodCls2]) mKodCls1Max = mKodCls2 mKodCls2Max = mKodCls1 mClsName1 = aNameCls[mKodCls2] mClsName2 = aNameCls[mKodCls1] mNameClustFu = '('+aNameCls[mKodCls2]+','+aNameCls[mKodCls1]+')' ELSE mKodCls1Max = mKodCls1 mKodCls2Max = mKodCls2 mClsName1 = aNameCls[mKodCls1] mClsName2 = aNameCls[mKodCls2] mNameClustFu = '('+aNameCls[mKodCls1]+','+aNameCls[mKodCls2]+')' ENDIF ENDIF ENDIF NEXT NEXT IF mFlagAdd SELECT CLS_CLUST APPEND BLANK mKodClsNew = RECNO() REPLACE Kod_cls WITH mKodClsNew REPLACE Name_cls WITH mNameClustFu SELECT (mNameTree) DBGOBOTTOM() mNumPP = Num_pp APPEND BLANK REPLACE Num_it WITH mNumIter REPLACE Num_pp WITH ++mNumPP REPLACE KodCl_old1 WITH mKodCls1Max REPLACE KodCl_old2 WITH mKodCls2Max REPLACE NameCls1 WITH aNameCls[mKodCls1Max] REPLACE NameCls2 WITH aNameCls[mKodCls2Max] REPLACE NameCls_Sh WITH mNameClustSh REPLACE NameCls_Fu WITH mNameClustFu REPLACE Ur_sxod WITH mMaxUrSx REPLACE Ur_razl WITH 100-mMaxUrSx REPLACE Ur_razlIsh WITH 100-mMaxUrSx REPLACE KodCl_new WITH mKodClsNew StrFile(ALLTRIM(NameCls1), M_PathAppl+"\ClsClustTree\NameCls1"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+"-"+STRTRAN(STR(KODCL_NEW,5)," ","0")+".txt") // Запись текстового файла NameCls1-##-#####.txt, где ##-номер модели, #####-KODCL_NEW StrFile(ALLTRIM(NameCls2), M_PathAppl+"\ClsClustTree\NameCls2"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+"-"+STRTRAN(STR(KODCL_NEW,5)," ","0")+".txt") // Запись текстового файла NameCls2-##-#####.txt, где ##-номер модели, #####-KODCL_NEW * mClustCls = FileStr(M_PathAppl+"\ClsClustTree\NameCls1"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+"-"+STRTRAN(STR(KODCL_NEW,5)," ","0")+".txt") // Считывание текстового файла NameCls1-##-#####.txt, где ##-номер модели, #####-KODCL_NEW StrFile(ALLTRIM(mNameClustFu), M_PathAppl+"\ClsClustTree\NameClsF"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+"-"+STRTRAN(STR(KODCL_NEW,5)," ","0")+".txt") // Запись текстового файла NameClsF-##-#####.txt, где ##-номер модели, #####-KODCL_NEW * mNameClustFu = FileStr(M_PathAppl+"\ClsClustTree\NameClsF"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+"-"+STRTRAN(STR(KODCL_NEW,5)," ","0")+".txt") // Считывание текстового файла NameClsF-##-#####.txt, где ##-номер модели, #####-KODCL_NEW AADD(aKodCls , mKodCls1Max) AADD(aKodCls , mKodCls2Max) AADD(aNameCls, mNameClustFu) ENDIF ENDIF *** 5. Объединить заданное число пар классов с НАИБОЛЬШИМ уровнем сходства в ABS_CLUST2. SELECT CLS_CLUST N_Cls = RECCOUNT() // Число классов (кластеров) будет увеличиваться ******* Создать БД ABS_CLUST с объединенными классами (кластерами) aStructure := { { "Kod_pr", "N", 15, 0 },; { "Name" , "C", 255, 0 } } FOR j=1 TO N_Cls FieldName = "CLS"+ALLTRIM(STR(j,15)) AADD(aStructure, { FieldName, "N", 19, 1 }) NEXT AADD(aStructure, { "SUMMA", "N", 19, 1 } ) AADD(aStructure, { "SREDN", "N", 19, 1 } ) AADD(aStructure, { "DISP" , "N", 19, 1 } ) DbCreate( 'ABS_CLUST2', aStructure ) USE ABS_CLUST2 EXCLUSIVE NEW ******* Посчитать абс.частоты в объединенных столбцах БД ABS_CLUST2.DBF на основе БД ABS_CLUST1.DBF SELECT (mNameTree) DBGOBOTTOM() mKodClsOld1 = KODCL_OLD1 mKodClsOld2 = KODCL_OLD2 mKodClsNew = KODCL_NEW * ******* Запомнить уровни сходства объединяемых классов со всеми классами * ******* Это нужно для того, чтобы принудительно обеспечить правильную дендрограмму <<<===#################### * SELECT MSC_CLUST * PRIVATE aKodClsOld1[N_Cls], aKodClsOld2[N_Cls] * AFILL(aKodClsOld1, 0) * AFILL(aKodClsOld2, 0) * DBGOTO(mKodClsOld1) * FOR j=1 TO N_Cls * aKodClsOld1[j] = FIELDGET(2+j) * NEXT * DBGOTO(mKodClsOld2) * FOR j=1 TO N_Cls * aKodClsOld2[j] = FIELDGET(2+j) * NEXT SELECT ABS_CLUST1 *********** Выход из процесса кластеризации, т.к. осталось 2 класса или меньше IF FCOUNT() <= 7 * DC_Impl(oScrn2) aMess := {} AADD(aMess, L("Выход из процесса кластеризации,")) AADD(aMess, L("т.к. осталось 2 класса или меньше.")) AADD(aMess, L("Работа системы будет завершена!")) LB_Warning(aMess ) Running(.F.) * ADS_SERVER_QUIT() QUIT ENDIF DBGOTOP() DO WHILE .NOT. EOF() SELECT ABS_CLUST1 mN1 = FIELDGET(2+mKodClsOld1) mN2 = FIELDGET(2+mKodClsOld2) FIELDPUT(2+mKodClsOld1, 0) FIELDPUT(2+mKodClsOld2, 0) aR := {} FOR j=1 TO FCOUNT() AADD(aR, FIELDGET(j)) NEXT SELECT ABS_CLUST2 APPEND BLANK FOR j=1 TO LEN(aR) FIELDPUT(j, aR[j]) NEXT FIELDPUT(2+mKodClsNew, mN1 + mN2) // Это и есть объединение классов mKodClsOld1 и mKodClsOld2 SELECT ABS_CLUST1 DBSKIP(1) ENDDO ***** Пересчитать в БД ABS_CLUST2.DBF из БД ABS_CLUST1.DBF колонку SUMMA (по строкам), ***** а также сумму числа признаков и сумму числа объектов SELECT ABS_CLUST2 *** Расчет сумм числа признаков по строкам FOR i = 1 TO N_Atr DBGOTO(i) mSumma = 0 FOR j=1 TO N_Cls mSumma = mSumma + FIELDGET(2+j) // SUMMA по строке NEXT REPLACE SUMMA WITH mSumma NEXT *** Расчет суммы числа признаков - всего mSumma = 0 DBGOTO(N_Atr+1) FOR j=1 TO N_Cls mSumma = mSumma + FIELDGET(2+j) // SUMMA по строке NEXT REPLACE SUMMA WITH mSumma *** Расчет суммы числа объектов - всего mSumma = 0 DBGOTO(N_Atr+4) FOR j=1 TO N_Cls mSumma = mSumma + FIELDGET(2+j) // SUMMA по строке NEXT REPLACE SUMMA WITH mSumma *** 6. На основе ABS_CLUST2 РАССЧИТАТЬ матрицу информативностей: INF_CLUST в текущей модели, *** рассчитать матрицу сходства классов: MSC_CLUST, при этом принудительно обеспечить, чтобы объединенный класс имел более низкое сходство со всеми классами, чем входящие в него классы, *** а также БД учета объединения классов TreeCls.dbf и занести в нее информацию об объединении классов в БД IterCls###.dbf. *** Скопировать ABS_CLUST2 => ABS_CLUST1 ****** Создать БД INF_CLUST с объединенными классами aStructure := { { "Kod_pr", "N", 15, 0 },; { "Name" , "C", 255, 0 } } IF mNumMod = 1 FOR j=1 TO N_Cls FieldName = "CLS"+ALLTRIM(STR(j,15)) AADD(aStructure, { FieldName, "N", 19, 1 }) NEXT AADD(aStructure, { "SUMMA", "N", 19, 1 } ) AADD(aStructure, { "SREDN", "N", 19, 1 } ) AADD(aStructure, { "DISP" , "N", 19, 1 } ) ELSE FOR j=1 TO N_Cls FieldName = "CLS"+ALLTRIM(STR(j,15)) AADD(aStructure, { FieldName, "N", 19, 7 }) NEXT AADD(aStructure, { "SUMMA", "N", 19, 7 } ) AADD(aStructure, { "SREDN", "N", 19, 7 } ) AADD(aStructure, { "DISP" , "N", 19, 7 } ) ENDIF DbCreate( 'INF_CLUST', aStructure ) ******* Создать в БД INF_CLUST.DBF строки с наименованиями описательных шкал и градаций USE INF_CLUST EXCLUSIVE NEW SELECT INF_CLUST FOR i=1 TO LEN(aAtr) APPEND BLANK REPLACE Kod_pr WITH i REPLACE Name WITH aAtr[i] FOR j=3 TO FCOUNT() FIELDPUT(j, 0) NEXT NEXT APPEND BLANK // Запись N_Atr+1 - строка: "Сумма", REPLACE Name WITH "Сумма числа признаков" FOR j=3 TO FCOUNT();FIELDPUT(j, 0);NEXT APPEND BLANK // Запись N_Atr+2 - "Среднее" REPLACE Name WITH "Среднее" FOR j=3 TO FCOUNT();FIELDPUT(j, 0);NEXT APPEND BLANK // Запись N_Atr+3 - "Среднеквадратичное отклонение", "Редукция класса" REPLACE Name WITH "Среднеквадратичное отклонение" FOR j=3 TO FCOUNT();FIELDPUT(j, 0);NEXT *** На основе ABS_CLUST2 РАССЧИТАТЬ матрицу информативностей: INF_CLUST в текущей модели *** (матрица информативностей в модели ABS есть сама матрица ABS) SELECT ABS_CLUST2 DBGOTO(N_Atr+1);N = SUMMA // SUMM угловой элемент DBGOTO(N_Atr+4);Nobj = SUMMA // Всего логических объектов обучающей выборки K = LOG(N_Cls)/LOG(N)/LOG(2) // Нормировочный коэффицент для перевода в биты *** Начало цикла по классам ******************* FOR j = 1 TO N_Cls SELECT ABS_CLUST2 DBGOTO(N_Atr+1);Nj = FIELDGET(2+j) // Суммарное число признаков по j-му классу DBGOTO(N_Atr+4);Njo = FIELDGET(2+j) // Суммарное число объектов по j-му классу FOR i = 1 TO N_Atr ****** Выбор способа расчета для разных моеделей PUBLIC Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } SELECT ABS_CLUST2 DBGOTO(i) Nij = FIELDGET(2+j) Ni = SUMMA Iij = 0 // На случай, если вообще не посчитается, чтобы не возникала ошибка при присвоении значения полю базы DO CASE CASE mNumMod = 1 // ABS (модель ABS есть сама матрица ABS, т.е. ее рассчиывать не нужно) Iij = Nij CASE mNumMod = 2 // PRC1 IF Nj <> 0 Iij = Nij/Nj ENDIF CASE mNumMod = 3 // PRC2 IF Njo <> 0 Iij = Nij/Njo ENDIF CASE mNumMod = 4 // INF1 IF Nij*Ni*Nj*N <> 0 Iij = K*LOG((Nij*N)/(Ni*Nj)) ENDIF CASE mNumMod = 5 // INF2 IF Nij*Ni*Njo*Nobj <> 0 Iij = LOG((Nij*Nobj)/(Ni*Njo))/LOG(2) ENDIF CASE mNumMod = 6 // INF3 IF N <> 0 Iij = Nij-Ni*Nj/N ENDIF CASE mNumMod = 7 // INF4 IF Ni*N <> 0 Iij = (Nij*N)/(Ni*Nj) - 1 ENDIF CASE mNumMod = 8 // INF5 IF Ni*Njo*Nobj <> 0 Iij = (Nij*Nobj)/(Ni*Njo) - 1 ENDIF CASE mNumMod = 9 // INF6 IF Nj*Nobj <> 0 Iij = (Nij/Nj) - (Ni/N) ENDIF CASE mNumMod = 10 // INF7 IF Njo*Nobj <> 0 Iij = (Nij/Njo) - (Ni/Nobj) ENDIF ENDCASE SELECT INF_CLUST DBGOTO(i) FIELDPUT(2+j,Iij) // сам элемент Iij REPLACE SUMMA WITH SUMMA + Iij // столбец SUMMA DBGOTO(N_Atr+1) FIELDPUT(2+j,FIELDGET(2+j)+Iij) // строка SUMMA REPLACE SUMMA WITH SUMMA + Iij // Угл.эл. SUMMA NEXT NEXT ****** Расчет средних по строкам SELECT INF_CLUST FOR i = 1 TO N_Atr DBGOTO(i) REPLACE SREDN WITH SUMMA/N_Cls NEXT ** Расчет средних по столбцам GO N_Atr+2 // SREDN строка FOR j = 1 TO N_Cls DBGOTO(N_Atr+1);mSumma = FIELDGET(2+j) // SUMMA строка DBGOTO(N_Atr+2);FIELDPUT(2+j,mSumma/N_Atr) // SREDN строка NEXT DBGOTO(N_Atr+1);mSredn = SUMMA/(N_Cls*N_Atr) DBGOTO(N_Atr+2);REPLACE SREDN WITH mSredn // SREDN угловой элемент ****** Расчет столбца интегральной информативности факторов Ds = 0 // угловой элемент DISP FOR i = 1 TO N_Atr DBGOTO(i);mSredn = SREDN FOR j = 1 TO N_Cls Iij = FIELDGET(2+j) // Информативность-элемент (i,j) REPLACE DISP WITH DISP+(mSredn-Iij)^2 Ds = Ds + (mSredn-Iij)^2 NEXT NEXT **** Дорасчет интегральной информативности факторов FOR i = 1 TO N_Atr DBGOTO(i);mDisp = DISP // DISP столбец REPLACE DISP WITH SQRT(DISP/(N_Cls-1)) NEXT *** Расчет степени редукции классов FOR j = 1 TO N_Cls DBGOTO(N_Atr+2);mSredn=FIELDGET(2+j) FOR i = 1 TO N_Atr DBGOTO(i);Iij=FIELDGET(2+j) // Информативность-элемент (i,j) DBGOTO(N_Atr+3);FIELDPUT(2+j,FIELDGET(2+j)+(mSredn-Iij)^2) // <===############ Не хватает размера поля NEXT NEXT **** Дорасчет среднеквадратичного оклонения по классам и угл.элемент DBGOTO(N_Atr+3) FOR j = 1 TO N_Cls FIELDPUT(2+j,SQRT(FIELDGET(2+j)/(N_Atr-1))) NEXT REPLACE DISP WITH SQRT(Ds/(N_Cls*N_Atr-1)) // DISP - угловой элемент **************************************************** *** РАСЧЕТ МАТРИЦ СХОДСТВА КЛАССОВ из F4_2_2_1() *** **************************************************** *** ############################################################################### *** САМИ МАТРИЦЫ В КАЖДОЙ МОДЕЛИ МОЖНО РАССЧИТЫВАТЬ С ПОМОЩЬЮ РАЗНЫХ МЕР РАССТОЯНИЙ *** ############################################################################### ********** Создание матриц сходства классов для заданных моделей ********** Структура создаваемой базы *********** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций aStructure := { { "Kod_cls" , "N", 15, 0},; // 1 { "Kod_ClSc", "N", 15, 0},; // 2 { "Name_cls", "C",255, 0} } // 3 FOR j=1 TO N_Cls FieldName = "N"+ALLTRIM(STR(j,15)) AADD(aStructure, { FieldName, "N", 19, 7 }) NEXT DbCreate( 'MSC_CLUST', aStructure ) ***** Открытие основных БД.dbf всех заданных моделей Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE CLS_CLUST EXCLUSIVE NEW USE MSC_CLUST EXCLUSIVE NEW USE INF_CLUST EXCLUSIVE NEW ****** Присвоение записям матрицы сходства MSC_CLUST кодов и наименований классов SELECT CLS_CLUST DBGOTOP() DO WHILE .NOT. EOF() mKodClsNew = Kod_cls mNestPairs = Name_cls SELECT MSC_CLUST APPEND BLANK REPLACE Kod_cls WITH mKodClsNew REPLACE Name_cls WITH mNestPairs FOR j=1 TO N_Cls FIELDPUT(3+j,0) NEXT SELECT CLS_CLUST DBSKIP(1) ENDDO **** Расчет матрицы сходства (M_SxodCls) **** Похоже как в пакетном распознавании **** принудительно обеспечить, чтобы объединенный класс имел более низкое сходство со всеми классами, чем входящие в него классы, <<<===#################### IF N_Cls >= 2 PRIVATE aNameCls1[N_Atr], aNameCls2[N_Atr] Max = -9999999 Min = 9999999 SELECT INF_CLUST FOR mCls1 = 1 TO N_Cls // Цикл по классам подматрицы Inf.dbf заданного диапазона классов ####### SELECT INF_CLUST **************** Формирование массива 1-го класса FlagCls1 = .F. AFILL(aNameCls1,0) SumCls1 = 0 // Сумма FOR i=1 TO N_Atr GO i;aNameCls1[i] = FIELDGET(2+mCls1) IF VALTYPE(aNameCls1[i]) = 'N' SumCls1 = SumCls1 + aNameCls1[i] IF aNameCls1[i] <> 0 FlagCls1 = .T. // Флаг наличия данных ENDIF ENDIF NEXT IF FlagCls1 // Если есть данные по 1-му классу ***** Расчет среднего и дисперсии массива 1-го класса SrCls1 = SumCls1/N_Atr // Среднее массива 1-го класса DiCls1 = 0 // Дисперсия массива 1-го класса FOR i=1 TO N_Atr DiCls1 = DiCls1 + ( aNameCls1[i] - SrCls1 ) ^ 2 NEXT DiCls1 = SQRT( DiCls1 / (N_Atr - 1)) // Дорасчет дисперсии массива 1-го класса * FOR mCls2 = 1 TO N_Cls // Цикл по классам подматрицы Inf.dbf заданного диапазона классов ####### FOR mCls2 = mCls1 TO N_Cls // Цикл по классам подматрицы Inf.dbf заданного диапазона классов ####### SELECT INF_CLUST **************** Формирование массива 2-го класса FlagCls2 = .F. AFILL(aNameCls2,0) SumCls2 = 0 // Сумма FOR i=1 TO N_Atr GO i;aNameCls2[i] = FIELDGET(2+mCls2) IF VALTYPE(aNameCls2[i]) = 'N' SumCls2 = SumCls2 + aNameCls2[i] // ################################################# IF aNameCls2[i] <> 0 FlagCls2 = .T. // Флаг наличия данных ENDIF ENDIF NEXT IF FlagCls2 // Если есть данные по классу2-му ***** Расчет среднего и дисперсии массива 2-го класса SrCls2 = SumCls2/N_Atr // Среднее массива 1-го класса DiCls2 = 0 // Дисперсия массива 1-го класса FOR i=1 TO N_Atr DiCls2 = DiCls2 + ( aNameCls2[i] - SrCls2 ) ^ 2 NEXT DiCls2 = SQRT( DiCls2 / (N_Atr - 1)) // Дорасчет дисперсии массива 1-го класса ******** Расчет нормированной к 100% корреляции массивов ******** локатора источника и информативностей признаков объекта Korr = 0 FOR i=1 TO N_Atr Korr = Korr + (aNameCls1[i] - SrCls1) * (aNameCls2[i] - SrCls2) NEXT Korr = Korr / ( (N_Atr-1) * DiCls1 * DiCls2 ) * 100 * **** Принудительно обеспечить, чтобы объединенный класс имел более низкое сходство со всеми классами, чем входящие в него классы , <<<===#################### * d=3 * IF Korr <= aKodClsOld1[mCls1] * ELSE * Korr = IF(aKodClsOld1[mCls1]-d<=-100,aKodClsOld1[mCls1]-d,-100) * ENDIF * IF Korr <= aKodClsOld2[mCls2] * ELSE * Korr = IF(aKodClsOld2[mCls2]-d<=-100,aKodClsOld2[mCls2]-d,-100) * ENDIF *** Вообще-то 1 вычитать не надо, в Help Excel приведена формула без вычитания 1, *** НО в Excel-2003 СЧИТАЕТСЯ ОНА ТАК, КАК БУДТО 1 ВСЕ ЖЕ ВЫЧИТАЕТСЯ (См.: "Кореляция" и "Ковариация") *** В Excel-2007 и выше все считается правильно, а в Excel-2003 просто неверно и формула корреляции приведена неправильная Max = MAX(Max, Korr) Min = MIN(Min, Korr) SELECT MSC_CLUST GO mCls1;FIELDPUT(3+mCls2, Korr) GO mCls2;FIELDPUT(3+mCls1, Korr) ENDIF NEXT ENDIF NEXT ENDIF ***** СКОПИРОВАТЬ ВСЕ БАЗЫ С ИМЕНЕМ, ВКЛЮЧАЮЩИМ НОМЕР МОДЕЛИ И НОМЕР ИТЕРАЦИИ IF mSaveDBases = 2 CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций COPY FILE ("CLS_CLUST.dbf") TO ('CLS_CLUSTC-'+STRTRAN(STR(mNumMod,2),' ','0')+'-'+STRTRAN(STR(mNumIter,3),' ','0')+".dbf") COPY FILE ("ABS_CLUST1.dbf") TO ('ABS_CLUSTC-'+STRTRAN(STR(mNumMod,2),' ','0')+'-'+STRTRAN(STR(mNumIter,3),' ','0')+".dbf") COPY FILE ("INF_CLUST.dbf") TO ('INF_CLUSTC-'+STRTRAN(STR(mNumMod,2),' ','0')+'-'+STRTRAN(STR(mNumIter,3),' ','0')+".dbf") COPY FILE ("MSC_CLUST.dbf") TO ('MSC_CLUSTC-'+STRTRAN(STR(mNumMod,2),' ','0')+'-'+STRTRAN(STR(mNumIter,3),' ','0')+".dbf") ENDIF ***** Скопировать ABS_CLUST2 => ABS_CLUST1 CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций COPY FILE ("ABS_CLUST2.dbf") TO ("ABS_CLUST1.dbf") // Переход на следующую итерацию lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) * DC_Impl(oScrn2) NEXT oSay97:SetCaption(L("Когнитивная агломеративная древовидная кластеризация классов успешно завершена !!!")) *** 7. Конец цикла итераций. Проверить критерий остановки: если в MSC_CLUST осталось больше 2 ********** *** колонок, то перейти на продолжение итераций (п.4), а иначе на рисование результатов (п.8). *********************************************************************************************************** ***** Проставление уровней иерархии и физическая сортировка по уровням иерархии CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mNameTree) EXCLUSIVE NEW SELECT (mNameTree) DBGOTOP() DO WHILE .NOT. EOF() * mNameClustFu = ALLTRIM(NameCls_Fu) mNameClustFu = FileStr(M_PathAppl+"\ClsClustTree\NameClsF"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+"-"+STRTRAN(STR(KODCL_NEW,5)," ","0")+".txt") // Считывание текстового файла NameClsF-##-#####.txt, где ##-номер модели, #####-KODCL_NEW mHierarchy = 0 FOR j=LEN(mNameClustFu) TO 1 STEP -1 IF SUBSTR(mNameClustFu,j,1) = ')' mHierarchy++ ELSE REPLACE Hierarchy WITH mHierarchy EXIT ENDIF NEXT DBSKIP(1) ENDDO CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mNameTree) EXCLUSIVE NEW COPY STRUCTURE TO Temp.dbf CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mNameTree) EXCLUSIVE NEW INDEX ON STR(Hierarchy, 15)+STR(999999.9999999-UR_SXOD,15,7) TO (mNameTree) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mNameTree) INDEX (mNameTree) EXCLUSIVE NEW USE Temp EXCLUSIVE NEW;ZAP SELECT (mNameTree) SET ORDER TO 1 DBGOTOP() DO WHILE .NOT. EOF() a := {} FOR j=1 TO FCOUNT() AADD(a, FIELDGET(j)) NEXT SELECT Temp APPEND BLANK FOR j=1 TO LEN(a) FIELDPUT(j, a[j]) NEXT SELECT (mNameTree) DBSKIP(1) ENDDO CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций ERASE(mNameTree+'.dbf') DO WHILE FILE(mNameTree+'.dbf');ENDDO RenameFile( "Temp.dbf", mNameTree+'.dbf') DO WHILE FILE("Temp.dbf");ENDDO *COPY FILE ("Temp.dbf") TO (mNameTree+'.dbf') *DC_Impl(oScrn2) MILLISEC(1000) oSay97:SetCaption(oSay97:caption) oButton:SetCaption(L('&Ok')) // Деструктурирование окна отображения графического Progress-bar oButton:activate := {||PostAppEvent(xbeP_Close,,,oDialog)} //<<<<<< Add This DC_AppEvent( @lOk ) * PostAppEvent(xbeP_Activate,,,DC_GetObject(GetList,'DCGUI_BUTTON_OK')) // Роджер oDialog:Destroy() // Просто перед рисованием копировать БД и начинать рисовать всегда с одной и той же копии, т.к. в процессе рисования она меняется ############ // т.е. само рисовавние выполнять изменяя не исходную БД, а ее копию DrawClustCls() // 8. НАРИСОВАТЬ ДЕРЕВО ОБЪЕДИНЕНИЯ КЛАССОВ: ..\System\ClustTreeCls\ClustTreeCls-#-##.jpg RETURN NIL *** 9. Конец цикла по моделям ******** ****************************************************************************************** *######################################################################################### ****************************************************************************************** ****************************************************** *** 8. НАРИСОВАТЬ ДЕРЕВО ОБЪЕДИНЕНИЯ КЛАССОВ: *** ..\System\ClsClustTree\ClustCls-##.jpg ****************************************************** FUNCTION DrawClustCls() ***** Проверить наличие БД mNameTree в папке приложения, и, если ее нет, то выдать соответствующиме сообщения и выйти <===######### mNumMod = Options4223(.F.) mNameTree := 'TreeCls-'+STRTRAN(STR(mNumMod,2),' ','0') IF .NOT. FILE(mNameTree+'.dbf') Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } aMess := {} AADD(aMess, L('В папке текущего приложения:')+' '+M_PathAppl) AADD(aMess, L('отсутствует база данных с результатами кластеризации:')+' '+mNameTree+'.dbf,') AADD(aMess, L('созданная в модели:')+' "'+Ar_Model[mNumMod]+L('", заданной в "Параметрах" для визуализации.')) AADD(aMess, L('Чтобы создать эту базу необходимо выполнить кластеризацию в данной модели.')) LB_Warning(aMess) RETURN NIL ENDIF ************************************************************************************ **** Создание временной БД - копии mNameTree, для рисования COPY FILE (mNameTree+'.dbf') TO ('TreeCls.dbf') // Временная БД для рисования дендрограммы и графика расстояний ***** Формирование массива кодов классов в порядке, нужном для отображения кластеров CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE TreeCls EXCLUSIVE NEW DBGOBOTTOM() *mClustCls = '('+ALLTRIM(NameCls1)+',('+ALLTRIM(NameCls2)+')' *mClustCls = NameCls_Fu // Считать из файла, а не из поля mClustCls = FileStr(M_PathAppl+"\ClsClustTree\NameClsF"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+"-"+STRTRAN(STR(KODCL_NEW,5)," ","0")+".txt") // Считывание текстового файла NameClsF-##-#####.txt, где ##-номер модели, #####-KODCL_NEW StrFile(ALLTRIM(mClustCls), '_ClustCls-'+STRTRAN(STR(mNumMod,2),' ','0')+'.txt') // Запись текстового файла _ClustCls-##.txt, где ##-номер модели *StrFile(ALLTRIM(NameCls1), M_PathAppl+"\ClsClustTree\NameCls1"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+"-"+STRTRAN(STR(KODCL_NEW,5)," ","0")+".txt") // Запись текстового файла NameCls1-##-#####.txt, где ##-номер модели, #####-KODCL_NEW *StrFile(ALLTRIM(NameCls2), M_PathAppl+"\ClsClustTree\NameCls2"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+"-"+STRTRAN(STR(KODCL_NEW,5)," ","0")+".txt") // Запись текстового файла NameCls2-##-#####.txt, где ##-номер модели, #####-KODCL_NEW *** Сруктура всей дендрограммы в кодах исходных классов (кластеры разных уровней объединены скобками) (это структура для модели 10 отладочного примера): *** Уровень *** иерархии *** --------------------------- 6 *** | | *** | ------------- 5 *** | | | *** --------- | --------- 4 *** | | | | | *** | ------- | | ------- 3 *** | | | | | | | *** | | ------ | | | ------ 2 *** | | | | | | | | | *** ---- | | ---- ---- ---- | | ---- 1 *** | | | | | | | | | | | | | | *** (((9,13),(2,(3,(4,14)))),((5,12),((8,10),(1,(7,(6,11)))))) 0 mClustCls = STRTRAN(mClustCls,'(',' ') mClustCls = STRTRAN(mClustCls,')',' ') mClustCls = STRTRAN(mClustCls,',',' ') mClustCls = CHARONE(' ',mClustCls) // Замена нескольких подряд идущих пробелов на один пробел aClustClsNum := {} aClustClsChr := {} FOR j=1 TO NUMTOKEN(mClustCls, ' ') AADD(aClustClsNum, VAL(TOKEN(mClustCls, ' ', j))) AADD(aClustClsChr, TOKEN(mClustCls, ' ', j)) NEXT *LB_Warning(aClustClsNum) *LB_Warning(aClustClsChr) DC_ASave(aClustClsNum, "_ClustClsNum.arx") DC_ASave(aClustClsChr, "_ClustClsChr.arx") * aClustClsNum = DC_ARestore("_ClustClsNum.arx") * aClustClsChr = DC_ARestore("_ClustClsChr.arx") ************************************************************************************************* ********* ВЫВОД ДЕНДРОГРАММЫ КЛАССОВ В ГРАФИЧЕСКОМ ВИДЕ ***************************************** ************************************************************************************************* CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE TreeCls EXCLUSIVE NEW USE Classes EXCLUSIVE NEW SELECT Classes aNameCls := {} DBGOTOP() DO WHILE .NOT. EOF() AADD(aNameCls, ALLTRIM(Name_cls)) DBSKIP(1) ENDDO ***************************************************************************************************************************************************** SELECT Classes mRecno = RECNO() mKodCls = Kod_cls * PUBLIC X_MaxW := 1800, Y_MaxW := 900 // Размер графического окна для отображения когнитивных диаграмм в пикселях * PUBLIC nXSize := 1800 * PUBLIC nYSize := 900 PUBLIC X_MaxW := mXSize, Y_MaxW := mYSize // Размер графического окна для отображения когнитивных диаграмм в пикселях PUBLIC nXSize := mXSize PUBLIC nYSize := mYSize // Create new bitmap with given size oPS := XBPPRESSPACE() :new() :Create() oBMP := XBPBITMAP() :New() :Create() * oBMP:Make( nXSize, nYSize, nPlanes, nBits ) oBMP:Make( nXSize, nYSize ) oBMP:presSpace( oPS ) // here your GRA* Code **** Закрасить фон прямоугольника *************** * GraSetColor( oPS, GRA_CLR_WHITE, GRA_CLR_WHITE ) GraSetColor( oPS, BD_LIGHTGREY, BD_LIGHTGREY ) GraBox( oPS, { 0, 0 }, { nXSize, nYSize }, GRA_FILL ) // Просто перед рисованием копировать БД и начинать рисовать всегда с одной и той же копии, т.к. в процессе рисования она меняется ############ // т.е. само рисовавние выполнять изменяя не исходную БД, а ее копию *####################################################################################################### GraClustCls( oPS, oBMP, 'File' ) // Графическая функция <<<===######################### *####################################################################################################### *** Так как модуль кластеризации формирует два изображения, то надо их записывать на диск, масштабироватьи и показывать прямо в самой функции ***************************************************************************************************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций RETURN NIL *** 9. Конец цикла по моделям ******** ****************************************************************************************** *######################################################################################### ****************************************************************************************** ********* Очистка изображения ************************ FUNCTION ClearImage4223() * GraSetColor( oPS, BD_LIGHTGREY, BD_LIGHTGREY ) * GraSetColor( oPS, BD_WHITE, BD_WHITE ) nColor = GraMakeRGBColor({ 255, 255, 255}) StrFile(STR(nColor),'nColor.TXT') GraSetColor( oPS, nColor, nColor ) GraBox( oPS, { 0, 0 }, { X_MaxW, Y_MaxW }, GRA_FILL ) RETURN NIL ****************************************************************** ****** Визуализация дендрограммы и графика межкластерных расстяний ****************************************************************** STATIC FUNCTION GraClustCls( oPS, oStatic, mPar ) * DC_ASave(mNumMod , "_NumMod.arx") mNumMod = DC_ARestore("_NumMod.arx") ***** Проверить наличие БД mNameTree в папке приложения, и, если ее нет, то выдать соответствующиме сообщения и выйти <===######### ****** Параметры визуализации дендрограммы ******************** mNumMod = Options4223(.F.) *************************************************************** IF .NOT. FILE(mNameTree+'.dbf') Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } aMess := {} AADD(aMess, L('В папке текущего приложения:')+' '+M_PathAppl) AADD(aMess, L('отсутствует база данных с результатами кластеризации:')+' '+mNameTree+'.dbf') AADD(aMess, L('Чтобы ее создать необходимо выполнить кластеризацию в модели:')+' "'+Ar_Model[mNumMod]+'"') LB_Warning(aMess) RETURN NIL ENDIF * DC_ASave(aClustClsNum, "_ClustClsNum.arx") * DC_ASave(aClustClsChr, "_ClustClsChr.arx") aClustClsNum = DC_ARestore("_ClustClsNum.arx") aClustClsChr = DC_ARestore("_ClustClsChr.arx") oScrn2 := DC_WaitOn( L('Расчет дендрограммы когнитивной кластеризации в модели: ')+ALLTRIM(STR(mNumMod))+'/10-'+Ar_Model[mNumMod],,,,,,,,,,,.F.) IndentLeft = 20 // Отступ слева IndentRight = 20 // Отступ справа LY := 80 // Зона над областью графика для наименования ДЕНДРОГРАММЫ и под областью графика для легенды X0 := IndentLeft // Начало координат по оси X Y0 := LY // Начало координат по оси Y ClearImage4223() // Очистка изображения ************************ ***** Нарисовать рамку изображения и отделить место для легенды ******************* aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты ****** Начало координат в центре рисунка GraArc ( oPS, { X0, Y0 }, 5 ) // Начало координат **** Написать заголовок диаграммы aFonts := XbpFont():new():list() // Все доступные шрифты oFont := XbpFont():new():create("22.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraStringAt( oPS, { X_MaxW/2, Y_MaxW-25 }, 'ДЕНДРОГРАММА КОГНИТИВНОЙ КЛАСТЕРИЗАЦИИ КЛАССОВ В МОДЕЛИ: "'+UPPER(Ar_Model[mNumMod])+'"') oFont := XbpFont():new():create("18.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) IF LEN(ALLTRIM(M_NameAppl)) < 70 GraStringAt( oPS, { X_MaxW/2, Y_MaxW-52 }, "Приложение: "+'"'+ALLTRIM(M_NameAppl)+'"' ) ELSE GraStringAt( oPS, { X_MaxW/2, Y_MaxW-52 }, '"'+ALLTRIM(M_NameAppl)+'"' ) ENDIF *********** Отобразить коды и наименования классов слева сверху вниз DO CASE CASE mFontSize = 1 oFont := XbpFont():new():create("6.Arial") CASE mFontSize = 2 oFont := XbpFont():new():create("8.Arial") CASE mFontSize = 3 oFont := XbpFont():new():create("10.Arial") CASE mFontSize = 4 oFont := XbpFont():new():create("12.Arial") OTHERWISE oFont := XbpFont():new():create("8.Arial") ENDCASE GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) * aTxtPar = DC_GraQueryTextbox(mTitle, oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox("Длина текста в пикселях="+ALLTRIM(STR(aTxtPar[1]))+". Высота текста в пикселях="+ALLTRIM(STR(aTxtPar[2]))) ********************************************** ******* НАИМЕНОВАНИЯ КЛАССОВ И ИХ КОДЫ ******* ********************************************** mInterval = (Y_MaxW - 2 * LY) / (LEN(aClustClsNum) + 1) // Межстрочный интервал в пикселях. Сделать его расчет mMaxlen = -9999 PUBLIC DeltaY := 9 // ####################### FOR j = 1 TO LEN(aClustClsNum) aTxtPar = DC_GraQueryTextbox(aNameCls[aClustClsNum[j]], oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов mMaxlen = MAX(mMaxlen, aTxtPar[1]) GraSetColor( oPS, GRA_CLR_BLACK, GRA_CLR_BLACK ) GraStringAt( oPS, { IndentLeft, Y_MaxW-LY-(j-1)*mInterval-DeltaY}, aNameCls[aClustClsNum[j]] ) // НАИМЕНОВАНИЯ КЛАССОВ ######## NEXT aColorY := {} // Для определения цвета дендрограммы по координате Y FOR j = 1 TO LEN(aClustClsNum) GraStringAt( oPS, { IndentLeft+mMaxlen+110, Y_MaxW-LY-(j-1)*mInterval-DeltaY}, STR(aClustClsNum[j],4) ) // КОДЫ КЛАССОВ ################ * REPLACE Y_koord WITH Y_MaxW-LY-(r-1)*mInterval-DeltaY NEXT ****** Формирование массивов для определения цвета дендрограммы ****** Найти координату Y посередине между последним элементом массива aKodClsBlue и первым элементом массива mKodClsRed ################# SELECT TreeCls DBGOBOTTOM() * Если файл: "M_PathAppl+"\ClsClustTree\NameCls1"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+"-"+STRTRAN(STR(KODCL_NEW,5)," ","0")+".txt" СУЩЕСТВУЕТ!!!! ######### * mKodClsBlue = NameCls1 // Синий mKodClsBlue = FileStr(M_PathAppl+"\ClsClustTree\NameCls1"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+"-"+STRTRAN(STR(KODCL_NEW,5)," ","0")+".txt") // Считывание текстового файла NameCls1-##-#####.txt, где ##-номер модели, #####-KODCL_NEW mKodClsBlue = STRTRAN(mKodClsBlue,'(',' ') mKodClsBlue = STRTRAN(mKodClsBlue,')',' ') mKodClsBlue = STRTRAN(mKodClsBlue,',',' ') mKodClsBlue = CHARONE(' ',mKodClsBlue) // Замена нескольких подряд идущих пробелов на один пробел aKodClsBlue := {} FOR j=1 TO NUMTOKEN(mKodClsBlue, ' ') AADD(aKodClsBlue, VAL(TOKEN(mKodClsBlue, ' ', j))) NEXT * Если файл: "M_PathAppl+"\ClsClustTree\NameCls2"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+"-"+STRTRAN(STR(KODCL_NEW,5)," ","0")+".txt" СУЩЕСТВУЕТ!!!! ######### * mKodClsRed = NameCls2 // Красный mKodClsRed = FileStr(M_PathAppl+"\ClsClustTree\NameCls2"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+"-"+STRTRAN(STR(KODCL_NEW,5)," ","0")+".txt") // Считывание текстового файла NameCls2-##-#####.txt, где ##-номер модели, #####-KODCL_NEW mKodClsRed = STRTRAN(mKodClsRed,'(',' ') mKodClsRed = STRTRAN(mKodClsRed,')',' ') mKodClsRed = STRTRAN(mKodClsRed,',',' ') mKodClsRed = CHARONE(' ',mKodClsRed) // Замена нескольких подряд идущих пробелов на один пробел aKodClsRed := {} FOR j=1 TO NUMTOKEN(mKodClsRed, ' ') AADD(aKodClsRed, VAL(TOKEN(mKodClsRed, ' ', j))) NEXT * LB_Warning(aKodClsBlue) * LB_Warning(aKodClsRed) * LB_Warning(aClustClsNum) * LB_Warning(aKodClsBlue) ***** Найти координату Y посередине между последним элементом массива aKodClsBlue и первым элементом массива mKodClsRed ################# mRec1 = ASCAN(aClustClsNum, aKodClsBlue[LEN(aKodClsBlue)]) mRec2 = ASCAN(aClustClsNum, aKodClsRed [1 ]) mYblue = Y_MaxW-LY-(mRec1-1)*mInterval-DeltaY mYred = Y_MaxW-LY-(mRec2-1)*mInterval-DeltaY mYbluered = mYred + (mYblue - mYred) / 2 ***** Рисование самой дендрограммы ************ SELECT TreeCls N_rec = RECCOUNT() *** Добавить в начало БД TreeCls наименования исходных классов в порядке, выводимом в дендрограмме, например: *** (((9,13),(2,(3,(4,14)))),((5,12),((8,10),(1,(7,(6,11)))))) *** Сдвинуть все N_rec записей БД TreeCls вниз на LEN(aClustClsNum) записей arz := {} FOR j=1 TO LEN(aClustClsNum) APPEND BLANK AADD(arz, FIELDGET(j)) NEXT FOR r=1 TO N_rec DBGOTO(r) arf := {} FOR j=1 TO FCOUNT() AADD(arf, FIELDGET(j)) // Запомнили NEXT DBGOTO(r+LEN(aClustClsNum)) FOR j=1 TO LEN(arf) FIELDPUT(j, arf[j]) // Записали NEXT NEXT *** Добавить в начало БД TreeCls наименования исходных классов FOR r = 1 TO LEN(aClustClsNum) DBGOTO(r) FOR j=1 TO LEN(arz) FIELDPUT(j, arz[j]) // Стерли NEXT ******* Записали REPLACE KODCL_NEW WITH aClustClsNum[r] // <===############### тип данных в поле? REPLACE NAMECLS_FU WITH aNameCls[aClustClsNum[r]] REPLACE Y_koord WITH Y_MaxW-LY-(r-1)*mInterval-DeltaY REPLACE Hierarchy WITH 0 NEXT *** Сделать расчет Y координат линий на кластеры aRec := {} // Массив номеров записей с кодами классов и кластеров aUrRazl := {} // Массив уровней различий aXkoord := {} // Массив X координат aYkoord := {} // Массив Y координат FOR r = 1 TO RECCOUNT() DBGOTO(r) REPLACE X_koord WITH IndentLeft+mMaxlen+141 AADD(aRec , KODCL_NEW) AADD(aUrRazl, UR_RAZL ) AADD(aXkoord, ROUND(X_koord,0)) AADD(aYkoord, ROUND(Y_koord,0)) NEXT *** Формирование массива цветов линий дендрограммы // ####################################################### SELECT TreeCls *** Расчет Y координат линий дендрограммы FOR r = LEN(aClustClsNum)+1 TO RECCOUNT() DBGOTO(r) mRec1 = ASCAN(aRec, KODCL_OLD1) mRec2 = ASCAN(aRec, KODCL_OLD2) IF mRec1 * mRec2 > 0 mY1=aYkoord[mRec1] // ######################### mY2=aYkoord[mRec2] mYkoord = ROUND(MIN(mY2,mY1) + (MAX(mY2,mY1) - MIN(mY2,mY1)) / 2,0) REPLACE Y_KOORD WITH mYkoord aYkoord[r] = mYkoord ENDIF NEXT ************************************************ **** Само рисование дендрограммы *************** ************************************************ DC_Impl(oScrn2) oScrn2 := DC_WaitOn('Немного подождите! Идет формирование изображения в памяти и его масштабирование',,,,,,,,,,,.F.) GraLine(oPS, { X0, Y_MaxW-LY }, { X_MaxW, Y_MaxW-LY } ) // Нарисовать линию вверху дендрограммы GraLine(oPS, { X0, Y0 }, { X_MaxW, Y0 } ) // Нарисовать линию внизу дендрограммы GraLine(oPS, { IndentLeft+mMaxlen+140, Y0 }, { IndentLeft+mMaxlen+140, Y_MaxW-LY } ) // Нарисовать вертикальную линию в конце надписей GraLine(oPS, { IndentLeft+mMaxlen+141, Y0 }, { IndentLeft+mMaxlen+141, Y_MaxW-LY } ) // Нарисовать вертикальную линию в конце надписей ***** Задать атрибуты линии ******************* aAttrL := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttrL [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttrL [ GRA_AL_COLOR ] := GraMakeRGBColor({ 0, 0, 255}) // Задать цвет линии DO CASE CASE mLineWidth = 1 aAttrL [ GRA_AL_WIDTH ] := 1 // Задать толщину линии CASE mLineWidth = 2 aAttrL [ GRA_AL_WIDTH ] := 3 // Задать толщину линии OTHERWISE aAttrL [ GRA_AL_WIDTH ] := 1 // Задать толщину линии ENDCASE graSetAttrLine( oPS, aAttrL ) // Установить атрибуты aAttrM := ARRAY( GRA_AM_COUNT ) // Массив для атрибутов маркеров aAttrM [ GRA_AM_SYMBOL ] := GRA_MARKSYM_DOT aAttrM [ GRA_AM_COLOR ] := GraMakeRGBColor({ 0, 0, 255}) // Задать цвет точки GraSetAttrMarker( oPS, aAttrM ) ********************************************************************************************************** <===##################### ****** Сделать, чтобы уровень различия при объединении кластеров всегда был выше, чем в исходных кластерах <===##################### ********************************************************************************************************** <===##################### SELECT TreeCls SET FILTER TO HIERARCHY = 1 aClust1 := {} // Массив наименований кластеров 1-го уровня иерархии DBGOTOP() DO WHILE .NOT. EOF() AADD(aClust1, ALLTRIM(NAMECLS_SH)) DBSKIP(1) ENDDO * ASORT(aClust1) * LB_Warning(aClust1) IF LEN(aClust1) > 0 FOR cl=1 TO LEN(aClust1) SET FILTER TO SET ORDER TO aName := {} DBGOTOP() DO WHILE .NOT. EOF() mNameClustFu = FileStr(M_PathAppl+"\ClsClustTree\NameClsF"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+"-"+STRTRAN(STR(KODCL_NEW,5)," ","0")+".txt") // Считывание текстового файла NameClsF-##-#####.txt, где ##-номер модели, #####-KODCL_NEW IF AT(ALLTRIM(aClust1[cl]), ALLTRIM(mNameClustFu)) > 0 REPLACE Filtr WITH '#' AADD(aName, ALLTRIM(mNameClustFu)) ELSE REPLACE Filtr WITH '' ENDIF DBSKIP(1) ENDDO * LB_Warning(aName) IF LEN(aName) > 0 ***** Сделать, чтобы уровень различия при объединении кластеров всегда был выше, чем в исходных кластерах <===##################### ***** Рассчет шага изменения уровня различия * INDEX ON STR(Ur_RazlIsh,15,7) TO (TreeCls) * INDEX ON STR(HIERARCHY,15) TO (TreeCls) * INDEX ON STR(KodCl_new,15) TO (TreeCls) SET FILTER TO Filtr = '#' COUNT TO N_Rec SET FILTER TO IF N_Rec > 0 * DBGOTOP() ;mMinUrRazl = Ur_RazlIsh * DBGOBOTTOM();mMaxUrRazl = Ur_RazlIsh * mStepUrRazl = (mMaxUrRazl-mMinUrRazl)/(N_Rec-1) * REPLACE Ur_razl WITH mMinUrRazl+(++j-1)*mStepUrRazl // Повышать уровень различия равномерно от минимального до максимального * INDEX ON STR(HIERARCHY,15) TO ('TreeCls') // ####################################################### INDEX ON STR(KodCl_new,15) TO ('TreeCls') SET FILTER TO Filtr = '#' DBGOTOP();DBGOBOTTOM();DBGOTOP() DBGOTOP() mUrRazlOld = Ur_Razl d = 1 DBSKIP(1) // Все же что-то не так. Не всегда работает ############## DO WHILE .NOT. EOF() // ПОВЫШАТЬ уровень различия на шаг только если он не повышается сам. Тогда отрицательных значений не будет в принципе IF Ur_razl - d <= mUrRazlOld REPLACE Ur_razl WITH Ur_razl + ( mUrRazlOld - Ur_razl ) + d REPLACE Normalizat WITH "Нормализовано" ENDIF mUrRazlOld = Ur_Razl DBSKIP(1) // Все же что-то не так. Не всегда работает ############## ENDDO ENDIF ENDIF NEXT ENDIF ********************************************************************************************************** ****** Визуализация дендрограммы ************************************************************************* SELECT TreeCls SET ORDER TO SET FILTER TO DBGOBOTTOM() mHierarchyMax = Hierarchy SET FILTER TO HIERARCHY > 0 * INDEX ON STR(Hierarchy,15)+STR(Ur_razl,15,7) TO ('TreeCls') INDEX ON STR(Ur_razl,15,7) TO ('TreeCls') **** Рассчитать коэффициент масштабирования для рисования дендрограммы **** Рисовать дендрограмму с рассчитанным коэффициентом масштабирования mMaxX = -99999 mMinX = +99999 mMaxY = -99999 mMinY = +99999 aPixelXY := {} // Для поиска уже нарисованных точек aPixelX := {} // Для масштабирования изображения по X aPixelY := {} // Для масштабирования изображения по Y aYkoordShelv := {} // Y координаты точек полочек mX1 = ROUND(X_koord,0) k = 7 // Коэффициент масштабирования по оси X ################################ // Сделать, чтобы уровень различия при объединении кластеров всегда был выше, чем в исходных кластерах <===##################### // Полочки более низкого уровня иерархии всегда должны быть левее полочек более высокого уровня иерархии <===##################### FOR h = 1 TO mHierarchyMax FOR r = LEN(aClustClsNum)+1 TO RECCOUNT() DBGOTO(r) IF Hierarchy = h mX1 = ROUND(X_koord,0) * mX2 = ROUND(mX1 + 10 + Ur_razl * k, 0) mX2 = ROUND(mX1 + (h-1)*3 + Ur_razl * k, 0) mMinX = MIN(mMinX, mX1) mMaxX = MAX(mMaxX, mX2) mRec1 = ASCAN(aRec, KODCL_OLD1) mRec2 = ASCAN(aRec, KODCL_OLD2) IF mRec1 * mRec2 > 0 mMinY = MIN(mMinY, aYkoord[mRec1]) // ############### mMaxY = MAX(mMaxY, aYkoord[mRec1]) mMinY = MIN(mMinY, aYkoord[mRec2]) mMaxY = MAX(mMaxY, aYkoord[mRec2]) REPLACE X_koord WITH mX2 // Сдвиг вправо следующего уровня иерархии дендрограммы НА ВЕЛИЧИНУ МАКСИМАЛЬНОГО ЗНАЧЕНИЯ Y ПРЕДЫДУЩЕГО УРОВНЯ ИЕРАРХИИ <<<===#################### * GraLine( oPS, {mX1 , aYkoord[mRec1]}, {mX2 , aYkoord[mRec1]} ) // Заменить на рисование линии от mX2 до mX1 попиксельно до пикселя не цвета фона mFlag = .F. IF LEN(aYkoordShelv) = 0 // Полочки еще не рисовали mFlag = .T. ENDIF IF .NOT. mFlag // Полочки уже рисовали IF ASCAN(aYkoordShelv, aYkoord[mRec1]) = 0 // Если рисуется не средняя линия дентрограммы mFlag = .T. ELSE FOR x = mX2 TO mX1 STEP -1 IF ASCAN(aPixelXY, STR(x,15)+STR(aYkoord[mRec1],15)) > 0 // Среднюю линию рисовать только в том случае, если есть часть дендрограммы, в которую она упирается mFlag = .T. EXIT ENDIF NEXT ENDIF ENDIF IF mFlag FOR x = mX2 TO mX1 STEP -1 mPixelXY = STR(x,15)+STR(aYkoord[mRec1],15) IF ASCAN(aPixelXY, mPixelXY) = 0 AADD (aPixelXY, mPixelXY) AADD (aPixelX , x) AADD (aPixelY , aYkoord[mRec1]) DO CASE CASE mLineWidth = 1 GraMarker( oPS, { x, aYkoord[mRec1] } ) CASE mLineWidth = 2 GraMarker( oPS, { x, aYkoord[mRec1]-1 } ) GraMarker( oPS, { x, aYkoord[mRec1] } ) GraMarker( oPS, { x, aYkoord[mRec1]+1 } ) ENDCASE ELSE EXIT ENDIF NEXT ENDIF * GraLine( oPS, {mX1 , aYkoord[mRec2]}, {mX2 , aYkoord[mRec2]} ) // Заменить на рисование линии от mX2 до mX1 попиксельно до пикселя не цвета фона mFlag = .F. IF LEN(aYkoordShelv) = 0 // Полочки еще не рисовали mFlag = .T. ENDIF IF .NOT. mFlag // Полочки уже рисовали IF ASCAN(aYkoordShelv, aYkoord[mRec2]) = 0 // Если рисуется не средняя линия дентрограммы mFlag = .T. ELSE FOR x = mX2 TO mX1 STEP -1 IF ASCAN(aPixelXY, STR(x,15)+STR(aYkoord[mRec2],15)) > 0 // Среднюю линию рисовать только в том случае, если есть часть дендрограммы, в которую она упирается mFlag = .T. EXIT ENDIF NEXT ENDIF ENDIF IF mFlag FOR x = mX2 TO mX1 STEP -1 mPixelXY = STR(x,15)+STR(aYkoord[mRec2],15) IF ASCAN(aPixelXY, mPixelXY) = 0 AADD (aPixelXY, mPixelXY) AADD (aPixelX , x) AADD (aPixelY , aYkoord[mRec2]) DO CASE CASE mLineWidth = 1 GraMarker( oPS, { x, aYkoord[mRec2] } ) CASE mLineWidth = 2 GraMarker( oPS, { x, aYkoord[mRec2]-1 } ) GraMarker( oPS, { x, aYkoord[mRec2] } ) GraMarker( oPS, { x, aYkoord[mRec2]+1 } ) ENDCASE ELSE EXIT ENDIF NEXT ENDIF // Рисование полочки <===################ // Сделать, чтобы уровень различия при объединении кластеров всегда был выше, чем в исходных кластерах <===##################### // Это наверное лучше делать прямо в матрице сходства: сохранять предыдущий вариант и сравнивать сходство объединяемых классов со всеми классами и новый кластер должен иметь сходство с каждым из классов меньше, чем у исходных классов // Полочки более низкого уровня иерархии всегда должны быть левее полочек более высокого уровня иерархии <===##################### * GraLine( oPS, {mX2+1, aYkoord[mRec1]}, {mX2+1, aYkoord[mRec2]} ) // Надо рисовать сначала более левые полочки, а потом которые правее FOR y = MIN(aYkoord[mRec1],aYkoord[mRec2]) TO MAX(aYkoord[mRec1],aYkoord[mRec2]) mPixelXY = STR(mX2+1,15)+STR(y,15) AADD (aPixelXY, mPixelXY) AADD (aPixelX , mX2+1) AADD (aPixelY , y) AADD (aYkoordShelv, y) // Y координаты точек полочек DO CASE CASE mLineWidth = 1 GraMarker( oPS, { mX2+1, y } ) CASE mLineWidth = 2 * GraMarker( oPS, { mX2-1, y+1 } ) GraMarker( oPS, { mX2 , y+1 } ) GraMarker( oPS, { mX2+1, y+1 } ) // (-x,+y) (x,+y) (+x,+y) * GraMarker( oPS, { mX2-1, y } ) GraMarker( oPS, { mX2 , y } ) GraMarker( oPS, { mX2+1, y } ) // (-x, y) (x, y) (+x, y) * GraMarker( oPS, { mX2-1, y-1 } ) GraMarker( oPS, { mX2 , y-1 } ) GraMarker( oPS, { mX2+1, y-1 } ) // (-x,-y) (x,-y) (+x,-y) ENDCASE NEXT ENDIF ENDIF NEXT NEXT ********************************************************************************************************** ****** Визуализация дендрограммы ************************************************************************* ********************************************************************************************************** ** Масштабировать вместе с пунктирными линиями по значениям на оси X // ############################# ** Масштабировать изображение по оси X так, чтобы mMaxX всегда было равно X_MaxW-100 mMaxXScale = (X_MaxW-100-mMinX)/(mMaxX-mMinX) ****** Сброс области рисования дендрограммы nColor = GraMakeRGBColor({ 255, 255, 255}) GraSetColor( oPS, nColor, nColor ) GraBox( oPS, { mX1, Y0 }, { X_MaxW, Y_MaxW-LY }, GRA_FILL ) // ############################# ** Надписи наименований классов с кодами на светло-зеленом и светло-желтом фоне // <<<===####################### IF mBGrColor = 2 FOR j = 1 TO LEN(aClustClsNum) aTxtPar = DC_GraQueryTextbox(aNameCls[aClustClsNum[j]], oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов mMaxlen = MAX(mMaxlen, aTxtPar[1]) IF j = 2*INT(j/2) GraSetColor( oPS, aColor[38], aColor[38] ) ELSE GraSetColor( oPS, aColor[73], aColor[73] ) ENDIF GraBox( oPS, { IndentLeft, Y_MaxW-LY-(j-1)*mInterval-DeltaY-aTxtPar[2]/2 }, { X_MaxW-50, Y_MaxW-LY-(j-1)*mInterval-DeltaY+aTxtPar[2]/2 }, GRA_FILL ) // Заливка фоном области наименования класса <<<===################# GraSetColor( oPS, GRA_CLR_BLACK, GRA_CLR_BLACK ) GraStringAt( oPS, { IndentLeft, Y_MaxW-LY-(j-1)*mInterval-DeltaY}, aNameCls[aClustClsNum[j]] ) // НАИМЕНОВАНИЯ КЛАССОВ ######## GraStringAt( oPS, { IndentLeft+mMaxlen+110, Y_MaxW-LY-(j-1)*mInterval-DeltaY}, STR(aClustClsNum[j],4) ) // КОДЫ КЛАССОВ ################ NEXT ENDIF aAttr [ GRA_AL_COLOR ] := BD_BLACK // Задать цвет линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_SOLID // Задать тип линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты GraLine(oPS, { X0, Y_MaxW-LY }, { X_MaxW, Y_MaxW-LY } ) // Нарисовать линию вверху дендрограммы GraLine(oPS, { X0, Y0 }, { X_MaxW, Y0 } ) // Нарисовать линию внизу дендрограммы GraLine(oPS, { IndentLeft+mMaxlen+140, Y0 }, { IndentLeft+mMaxlen+140, Y_MaxW-LY } ) // Нарисовать вертикальную линию в конце надписей GraLine(oPS, { IndentLeft+mMaxlen+141, Y0 }, { IndentLeft+mMaxlen+141, Y_MaxW-LY } ) // Нарисовать вертикальную линию в конце надписей aAttrM := ARRAY( GRA_AM_COUNT ) // Массив для атрибутов маркеров aAttrM [ GRA_AM_SYMBOL ] := GRA_MARKSYM_DOT GraSetAttrMarker( oPS, aAttrM ) FOR j=1 TO LEN(aPixelX) x = mMinX+(aPixelX[j]-mMinX)*mMaxXScale IF aPixelY[j] < mYbluered aAttrM [ GRA_AM_COLOR ] := GraMakeRGBColor({ 255, 0, 0}) // Задать цвет точки RED ELSE aAttrM [ GRA_AM_COLOR ] := GraMakeRGBColor({ 0, 0, 255}) // Задать цвет точки BLUE ENDIF GraSetAttrMarker( oPS, aAttrM ) DO CASE CASE mLineWidth = 1 GraMarker( oPS, { x, aPixelY[j] } ) CASE mLineWidth = 2 GraMarker( oPS, { x, aPixelY[j]-1 } ) GraMarker( oPS, { x, aPixelY[j] } ) GraMarker( oPS, { x, aPixelY[j]+1 } ) ENDCASE NEXT *********************************************** * SetPixel(hDC1, 300,300, AutomationTranslateColor(GraMakeRGBColor({ 255, 0, 0}),.f.) ) ***** Нарисовать шкалу расстояний объединения ****************** aUrRazl := {} aXkoord := {} SELECT TreeCls DBGOTOP() DO WHILE .NOT. EOF() IF LEN(ALLTRIM(NameCls_Sh)) > 0 AADD(aUrRazl, Ur_razl) AADD(aXkoord, X_koord) ENDIF DBSKIP(1) ENDDO ASORT(aUrRazl) ASORT(aXkoord) * LB_Warning(aUrRazl) // ########################## * MsgBox(STR(n)) // ########################## n = LEN(aUrRazl) Drazl = ( aUrRazl[n] - aUrRazl[1] ) / 9 // ########################## Dxkrd = ( aXkoord[n] - aXkoord[1] ) / 9 DO CASE CASE mFontSize = 1 oFont := XbpFont():new():create("6.Arial") CASE mFontSize = 2 oFont := XbpFont():new():create("8.Arial") CASE mFontSize = 3 oFont := XbpFont():new():create("10.Arial") CASE mFontSize = 4 oFont := XbpFont():new():create("12.Arial") OTHERWISE oFont := XbpFont():new():create("8.Arial") ENDCASE GraSetFont( oPS ,oFont ) aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты aAttrM := ARRAY( GRA_AM_COUNT ) // Массив для атрибутов маркеров aAttrM [ GRA_AM_SYMBOL ] := GRA_MARKSYM_DOT aAttrM [ GRA_AM_COLOR ] := GraMakeRGBColor({ 255, 128, 128}) // Задать цвет точки GraSetAttrMarker( oPS, aAttrM ) GraStringAt( oPS, { IndentLeft, LY-20 }, 'МЕЖКЛАСТЕРНЫЕ РАССТОЯНИЯ:' ) FOR j = 2 TO 11 x = IndentLeft+mMaxlen+141+(j-1)*Dxkrd*mMaxXScale GraStringAt( oPS, { x, LY-20 }, ALLTRIM(STR(ROUND((j-1)*Drazl,0),4)) ) // Надпись расстояния FOR y=Y0 TO Y_MaxW-LY STEP 3 // Рисование вертикальной пуктирной линии mPixelXY = STR(x,15)+STR(y,15) IF ASCAN(aPixelXY, mPixelXY) = 0 GraMarker( oPS, { x, y } ) ENDIF NEXT NEXT *********************************************** aAttr [ GRA_AL_COLOR ] := BD_BLACK // Задать цвет линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_SOLID // Задать тип линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты GraLine(oPS, { X0, Y_MaxW-LY }, { X_MaxW, Y_MaxW-LY } ) // Нарисовать линию вверху дендрограммы GraLine(oPS, { X0, Y0 }, { X_MaxW, Y0 } ) // Нарисовать линию внизу дендрограммы GraLine(oPS, { IndentLeft+mMaxlen+140, Y0 }, { IndentLeft+mMaxlen+140, Y_MaxW-LY } ) // Нарисовать вертикальную линию в конце надписей GraLine(oPS, { IndentLeft+mMaxlen+141, Y0 }, { IndentLeft+mMaxlen+141, Y_MaxW-LY } ) // Нарисовать вертикальную линию в конце надписей ***** Легенда ********************************* DO CASE CASE mFontSize = 1 oFont := XbpFont():new():create("6.Arial") CASE mFontSize = 2 oFont := XbpFont():new():create("8.Arial") CASE mFontSize = 3 oFont := XbpFont():new():create("10.Arial") CASE mFontSize = 4 oFont := XbpFont():new():create("12.Arial") OTHERWISE oFont := XbpFont():new():create("8.Arial") ENDCASE GraSetFont( oPS ,oFont ) aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты * StrFile(mClustCls, '_ClustCls-'+STRTRAN(STR(mNumMod,2),' ','0')+'.txt') // Запись текстового файла _ClustCls-##.txt, где ##-номер модели mClustCls = FileStr('_ClustCls-'+STRTRAN(STR(mNumMod,2),' ','0')+'.txt') // Считывание текстового файла _ClustCls-##.txt, где ##-номер модели AxName = "КЛАСТЕРНАЯ ФОРМУЛА: "+mClustCls GraStringAt( oPS, { 20, LY-65 }, AxName ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_DARKRED GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты AxName = "Форма создана: "+DTOC(DATE())+"-"+TIME() GraStringAt( oPS, { X_MaxW - 300, LY-45 }, AxName ) ********************************************************* oFont := XbpFont():new():create("16.Times Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := BD_SILVER aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты AyName = '(С) Универсальная когнитивная аналитическая система "Эйдос-Х++"' aTxtPar = DC_GraQueryTextbox(AyName, oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов aMatrix := GraInitMatrix() IF LEN(AyName) < 70 // Длина наименования оси Y меньше высоты изображения aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraRotate( oPS, aMatrix, 90, { X_MaxW-30, Y0+Y_MaxW/2-LY }, GRA_TRANSFORM_ADD ) // <<<########## oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) // <<<########## GraStringAt( oPS, { X_MaxW-30, Y0+Y_MaxW/2-LY }, AyName ) // Надпись оси Y ELSE // Писать наименование с начала изображения aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraRotate( oPS, aMatrix, 90, { X_MaxW-30, 10 }, GRA_TRANSFORM_ADD ) // <<<########## oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) // <<<########## GraStringAt( oPS, { X_MaxW-30, 10 }, AyName ) // Надпись оси Y ENDIF ****** Не получается отключить режим вращения изображения ****** Вместо отключения можно докрутить до 360 градусов aMatrix := GraInitMatrix() // <<<########## GraRotate( oPS, aMatrix, 0, {X_MaxW, Y_MaxW}, GRA_TRANSFORM_REPLACE ) // <<<########## oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) // <<<########## ********* Записать файл изображения в папке ClsClustTree DC_Impl(oScrn2) IF mPar = 'Screen' DIRCHANGE(M_PathAppl+"\ClsClustTree\") // Перейти в папку ClsClustTree cFileName = "ClustCls"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+".bmp" ERASE(cFileName) DC_Scrn2ImageFile( oStatic1, cFileName ) ENDIF IF mPar = 'File' ****** Запись полноразмерного графического файла в папку: M_PathAppl+"\ClsClustTree\" DIRCHANGE(M_PathAppl+"\ClsClustTree\") // Перейти в папку ClsClustTree cFileName = "ClustCls"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+".jpg" ERASE(cFileName) oBMP:SaveFile(cFileName,XBPBMP_FORMAT_JPG) IF nWidth > 1800 FullView( cFileName, "по верху", 65 ) // Визуализация полноразмерного файла на мониторе высокого разрешения ELSE ****** Формирование с помощью bmp2bmp() и отображение масштабированного изображения aNewSize := {nWidth,nHeight-29} // Новый размер изображения (еще немного уменьшается, чтобы не рисовать по панели задач) oBMP:loadFile(cFileName) // Загрузка полноразмерного изображения oRet := BMP2BMP(oBMP,aNewSize) // Масштабирование изображения cFileNameScale = SUBSTR(cFileName,1,AT(".jpg",cFileName)-1)+"_scaled.jpg" ERASE(cFileNameScale) oRet:saveFile(cFileNameScale,XBPBMP_FORMAT_JPG) // Запись масштабированного графического файла в в папку приложения для визуализации FullView( cFileNameScale, "по верху", 0 ) // Визуализация масштабированного графического файла на мониторе ограниченного разрешения ENDIF * DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения ENDIF ***************************************************************************************** ********* ВЫВОД ГРАФИКА ИЗМЕНЕНИЙ МЕЖКЛАСТЕРНЫХ РАССТОЯНИЙ ****************************** ***************************************************************************************** oScrn2 := DC_WaitOn('Немного подождите! Идет формирование изображения в памяти и его масштабирование',,,,,,,,,,,.F.) ****** Текущая папка: c:\Aidos-X\AID_DATA\A0000001\System\ClsClustTree\ * DIRCHANGE(M_PathAppl) DIRCHANGE('..') ****** Сброс области рисования графика изменения межкластерных расстояний nColor = GraMakeRGBColor({ 255, 255, 255}) GraSetColor( oPS, nColor, nColor ) GraBox( oPS, { 0, 0 }, { X_MaxW, Y_MaxW }, GRA_FILL ) ***** Заголовок ******************************** oFont := XbpFont():new():create("20.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraStringAt( oPS, { X_MaxW/2, Y_MaxW-25 }, 'ИЗМЕНЕНИЕ МЕЖКЛАСТЕРНЫХ РАССТОЯНИЙ ПРИ КОГНИТИВНОЙ КЛАСТЕРИЗАЦИИ КЛАССОВ В МОДЕЛИ: "'+UPPER(Ar_Model[mNumMod])+'"') oFont := XbpFont():new():create("18.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) IF LEN(ALLTRIM(M_NameAppl)) < 70 GraStringAt( oPS, { X_MaxW/2, Y_MaxW-50 }, "Приложение: "+'"'+ALLTRIM(M_NameAppl)+'"' ) ELSE GraStringAt( oPS, { X_MaxW/2, Y_MaxW-50 }, '"'+ALLTRIM(M_NameAppl)+'"' ) ENDIF SELECT TreeCls SET FILTER TO HIERARCHY > 0 * INDEX ON STR(Ur_razlIsh,15,7) TO ('TreeCls') INDEX ON STR(Ur_razl ,15,7) TO ('TreeCls') // Сортировка в соответствии с исправленным уровнем различий mNumClust := {} // Массив номеров кластеров mDisClust := {} // Массив исходных межкластерных расстояний aUrRazl := {} // Массив исходных межкластерных расстояний DBGOTOP() DO WHILE .NOT. EOF() AADD(mNumClust, NUM_PP) * AADD(mDisClust, Ur_razlIsh) * AADD(aUrRazl , Ur_razlIsh) AADD(mDisClust, Ur_razl ) AADD(aUrRazl , Ur_razl ) DBSKIP(1) ENDDO Dx = 100 Dy = Y0 Kx = (X_MaxW-2*Dx)/n // Нормирование по X Ky = (Y_MaxW-2*LY)/(aUrRazl[n]-aUrRazl[1]) // Нормирование по Y aAttr [ GRA_AL_COLOR ] := BD_BLACK // Задать цвет линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_SOLID // Задать тип линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты GraLine(oPS, { Dx, Y_MaxW-LY }, { X_MaxW-Dx, Y_MaxW-LY } ) // Линия вверху графика GraLine(oPS, { Dx, Y0 }, { X_MaxW-Dx, Y0 } ) // Ось X GraLine(oPS, { Dx, Y0 }, { Dx, Y_MaxW-LY } ) // Ось Y GraLine(oPS, { X_MaxW-Dx, Y0 }, { X_MaxW-Dx, Y_MaxW-LY } ) // Правая граница графика **** Пунктирные линии по значениям X // ############################# aAttrM := ARRAY( GRA_AM_COUNT ) // Массив для атрибутов маркеров aAttrM [ GRA_AM_SYMBOL ] := GRA_MARKSYM_DOT aAttrM [ GRA_AM_COLOR ] := GraMakeRGBColor({ 255, 128, 128}) // Задать цвет точки GraSetAttrMarker( oPS, aAttrM ) j=1 DBGOTOP() DO WHILE .NOT. EOF() j++ x = Dx + (j-1)*Kx FOR y=Y0 TO Y_MaxW-LY STEP 3 // Рисование вертикальной пунктирной линии GraMarker( oPS, { x, y } ) NEXT DBSKIP(1) ENDDO ***** Рисование графика межкластерных расстояний *************************************************** ***** Сделать рисование линий двух цветов, внутри посветлее, а снаружи потемнее (эффект объема) ***** для этого рисовать от внешних частей линии к внутренним уменьшающейся толщиной линии и более светлым цветом ПОВЕРХ РАНЕЕ НАРИСОВАННОГО aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DOT aAttr [ GRA_AL_COLOR ] := aColor[181] // Задать цвет снаружи линии aAttr [ GRA_AL_WIDTH ] := 5 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты j=1 DBGOTOP() DBSKIP(1) DO WHILE .NOT. EOF() j++ x1 = Dx+(j-1)*Kx y1 = Dy+(aUrRazl[j-1]-aUrRazl[1])*Ky x2 = Dx+(j )*Kx y2 = Dy+(aUrRazl[j ]-aUrRazl[1])*Ky GraLine(oPS, { x1,y1 }, { x2,y2 } ) DBSKIP(1) ENDDO aAttr [ GRA_AL_COLOR ] := aColor[108] // Задать цвет внутри линии aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты j=1 DBGOTOP() DBSKIP(1) DO WHILE .NOT. EOF() j++ x1 = Dx+(j-1)*Kx y1 = Dy+(aUrRazl[j-1]-aUrRazl[1])*Ky x2 = Dx+(j )*Kx y2 = Dy+(aUrRazl[j ]-aUrRazl[1])*Ky GraLine(oPS, { x1,y1 }, { x2,y2 } ) DBSKIP(1) ENDDO aAttr [ GRA_AL_COLOR ] := aColor[180] // Задать цвет внутри линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты j=1 DBGOTOP() DBSKIP(1) DO WHILE .NOT. EOF() j++ x1 = Dx+(j-1)*Kx y1 = Dy+(aUrRazl[j-1]-aUrRazl[1])*Ky x2 = Dx+(j )*Kx y2 = Dy+(aUrRazl[j ]-aUrRazl[1])*Ky GraLine(oPS, { x1,y1 }, { x2,y2 } ) DBSKIP(1) ENDDO ***** Надписи значений по осям X // Написать здесь номера кластеров в том же порядке, в каком в таблице на рисунке DO CASE CASE mFontSize = 1 oFont := XbpFont():new():create("6.Arial") CASE mFontSize = 2 oFont := XbpFont():new():create("8.Arial") CASE mFontSize = 3 oFont := XbpFont():new():create("10.Arial") CASE mFontSize = 4 oFont := XbpFont():new():create("12.Arial") OTHERWISE oFont := XbpFont():new():create("8.Arial") ENDCASE GraSetFont( oPS ,oFont ) aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты j=1 DBGOTOP() DBSKIP(1) DO WHILE .NOT. EOF() j++ x = Dx + (j-1)*Kx GraStringAt( oPS, { x, LY-20 }, ALLTRIM(STR(mNumClust[j-1],4)) ) DBSKIP(1) ENDDO j++ x = Dx + (j-1)*Kx GraStringAt( oPS, { x, LY-20 }, ALLTRIM(STR(mNumClust[j-1],4)) ) **** Надписи по оси Y и пунктир oFont := XbpFont():new():create("12.Arial") GraSetFont( oPS ,oFont ) aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты Ky = (Y_MaxW-2*LY) / 9 // Нормировочный коэффициент для координат Zy = (mDisClust[n]-mDisClust[1])/9 FOR j = 1 TO 10 x = Dx - 60 y = Y0 + (j-1)*Ky GraStringAt( oPS, { x, y }, ALLTRIM(STR(mDisClust[1]+(j-1)*Zy,15,2)) ) FOR x=Dx TO X_MaxW-Dx STEP 3 // Рисование горизонтальной пунктирной линии GraMarker( oPS, { x, y } ) NEXT NEXT ***** Легенда ****************************************** oFont := XbpFont():new():create("10.Arial Bold") GraSetFont( oPS ,oFont ) aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты ********************************************************* ***** Вывод таблички с данными о кластерах ************** ********************************************************* DBGOBOTTOM() s = 1 y = Y_MaxW-LY-9 //###################### * aTxtPar = DC_GraQueryTextbox(ALLTRIM(NAMECLS_FU), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов mNameClustFu = FileStr(M_PathAppl+"\ClsClustTree\NameClsF"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+"-"+STRTRAN(STR(KODCL_NEW,5)," ","0")+".txt") // Считывание текстового файла NameClsF-##-#####.txt, где ##-номер модели, #####-KODCL_NEW aTxtPar = DC_GraQueryTextbox(ALLTRIM(mNameClustFu), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов aTxtPar[1] = IF(aTxtPar[1] <= 1300, aTxtPar[1], 1300) // Если межкластерные расстояния не помещаются из-за длинных наименований кластеров - все равно их писать поверх mMaxlen = MAX(mMaxlen, aTxtPar[1]) GraStringAt( oPS, { Dx*1.5 , y }, '№' ) GraStringAt( oPS, { Dx*1.5+40, y }, 'Наим.кластера в кодах исх.классов' ) DO CASE CASE mFontSize = 1 oFont := XbpFont():new():create("6.Arial") GraStringAt( oPS, { Dx*1.5+100+aTxtPar[1], y }, 'Расстояние между кластерами' ) CASE mFontSize = 2 oFont := XbpFont():new():create("8.Arial") GraStringAt( oPS, { Dx*1.5+150+aTxtPar[1], y }, 'Расстояние между кластерами' ) CASE mFontSize = 3 oFont := XbpFont():new():create("10.Arial") GraStringAt( oPS, { Dx*1.5+250+aTxtPar[1], y }, 'Расстояние между кластерами' ) CASE mFontSize = 4 oFont := XbpFont():new():create("12.Arial") GraStringAt( oPS, { Dx*1.5+450+aTxtPar[1], y }, 'Расстояние между кластерами' ) OTHERWISE oFont := XbpFont():new():create("8.Arial") GraStringAt( oPS, { Dx*1.5+150+aTxtPar[1], y }, 'Расстояние между кластерами' ) ENDCASE GraSetFont( oPS ,oFont ) aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты * aTxtPar = DC_GraQueryTextbox(ALLTRIM(NAMECLS_FU), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов mNameClustFu = FileStr(M_PathAppl+"\ClsClustTree\NameClsF"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+"-"+STRTRAN(STR(KODCL_NEW,5)," ","0")+".txt") // Считывание текстового файла NameClsF-##-#####.txt, где ##-номер модели, #####-KODCL_NEW aTxtPar = DC_GraQueryTextbox(ALLTRIM(mNameClustFu), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов aTxtPar[1] = IF(aTxtPar[1] <= 1300, aTxtPar[1], 1300) // Если межкластерные расстояния не помещаются из-за длинных наименований кластеров - все равно их писать поверх mMaxlen = MAX(mMaxlen, aTxtPar[1]) mInterval = (Y_MaxW - 2 * LY - 10) / (LEN(aClustClsNum) + 1) // Межстрочный интервал в пикселях. Сделать его расчет * 10, чтобы текст не шел по рамке mInterval = IF( mInterval < aTxtPar[2]+3, mInterval, aTxtPar[2]+3 ) // Если межстрочный интервал большой, т.к. мало кластеров, то делать его по размеру шрифта, а иначе вписывать таблицу в форму y = y - 5 DBGOTOP() DO WHILE .NOT. EOF() y = y - mInterval GraStringAt( oPS, { Dx*1.5 , y }, ALLTRIM(STR(NUM_PP,4)) ) * GraStringAt( oPS, { Dx*1.5+40 , y }, ALLTRIM(NAMECLS_FU) ) mNameClustFu = FileStr(M_PathAppl+"\ClsClustTree\NameClsF"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+"-"+STRTRAN(STR(KODCL_NEW,5)," ","0")+".txt") // Считывание текстового файла NameClsF-##-#####.txt, где ##-номер модели, #####-KODCL_NEW GraStringAt( oPS, { Dx*1.5+40 , y }, ALLTRIM(mNameClustFu) ) DO CASE CASE mFontSize = 1 GraStringAt( oPS, { Dx*1.5+100+aTxtPar[1], y }, ALLTRIM(STR(UR_RAZL,15,2)) ) CASE mFontSize = 2 GraStringAt( oPS, { Dx*1.5+150+aTxtPar[1], y }, ALLTRIM(STR(UR_RAZL,15,2)) ) CASE mFontSize = 3 GraStringAt( oPS, { Dx*1.5+250+aTxtPar[1], y }, ALLTRIM(STR(UR_RAZL,15,2)) ) CASE mFontSize = 4 GraStringAt( oPS, { Dx*1.5+450+aTxtPar[1], y }, ALLTRIM(STR(UR_RAZL,15,2)) ) OTHERWISE GraStringAt( oPS, { Dx*1.5+150+aTxtPar[1], y }, ALLTRIM(STR(UR_RAZL,15,2)) ) ENDCASE DBSKIP(1) ENDDO oFont := XbpFont():new():create("10.Arial Bold") GraSetFont( oPS ,oFont ) aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты y = y - 20 SET ORDER TO DO CASE CASE mFontSize = 1 oFont := XbpFont():new():create("6.Arial") CASE mFontSize = 2 oFont := XbpFont():new():create("8.Arial") CASE mFontSize = 3 oFont := XbpFont():new():create("10.Arial") CASE mFontSize = 4 oFont := XbpFont():new():create("12.Arial") OTHERWISE oFont := XbpFont():new():create("8.Arial") ENDCASE GraSetFont( oPS ,oFont ) aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты * StrFile(mClustCls, '_ClustCls-'+STRTRAN(STR(mNumMod,2),' ','0')+'.txt') // Запись текстового файла _ClustCls-##.txt, где ##-номер модели mClustCls = FileStr('_ClustCls-'+STRTRAN(STR(mNumMod,2),' ','0')+'.txt') // Считывание текстового файла _ClustCls-##.txt, где ##-номер модели AxName = "КЛАСТЕРНАЯ ФОРМУЛА: "+mClustCls GraStringAt( oPS, { 20, LY-65 }, AxName ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_DARKRED GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты AxName = "Форма создана: "+DTOC(DATE())+"-"+TIME() GraStringAt( oPS, { X_MaxW - 300, LY-45 }, AxName ) ***** Надпись наименования шкалы X oFont := XbpFont():new():create("12.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты AxName = 'Номера кластеров' aTxtPar = DC_GraQueryTextbox(AxName, oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов IF LEN(AxName) < 140 // Длина наименования оси X меньше ширины изображения aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraStringAt( oPS, { X_MaxW/2, LY-45}, AxName ) // Надпись оси Х ELSE aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraStringAt( oPS, { 50, LY-45}, AxName ) // Надпись оси Х ENDIF ***** Надпись наименования шкалы Y (с поворотом на 90 градусов) oFont := XbpFont():new():create("12.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты AyName = 'Межкластерные расстояния' aTxtPar = DC_GraQueryTextbox(AyName, oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов aMatrix := GraInitMatrix() IF LEN(AyName) < 70 // Длина наименования оси Y меньше высоты изображения aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraRotate( oPS, aMatrix, 90, { 15, Y0+Y_MaxW/2-LY }, GRA_TRANSFORM_ADD ) // <<<########## oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) // <<<########## GraStringAt( oPS, { 15, Y0+Y_MaxW/2-LY }, AyName ) // Надпись оси Y ELSE // Писать наименование с начала изображения aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraRotate( oPS, aMatrix, 90, { 15, 10 }, GRA_TRANSFORM_ADD ) // <<<########## oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) // <<<########## GraStringAt( oPS, { 15, 10 }, AyName ) // Надпись оси Y ENDIF ********************************************************* oFont := XbpFont():new():create("18.Times Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := BD_SILVER aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты AyName = '(С) Универсальная когнитивная аналитическая система "Эйдос-Х++"' aTxtPar = DC_GraQueryTextbox(AyName, oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов aMatrix := GraInitMatrix() IF LEN(AyName) < 70 // Длина наименования оси Y меньше высоты изображения aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraRotate( oPS, aMatrix, 90, { X_MaxW-30, Y0+Y_MaxW/2-LY }, GRA_TRANSFORM_ADD ) // <<<########## oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) // <<<########## GraStringAt( oPS, { X_MaxW-30, Y0+Y_MaxW/2-LY }, AyName ) // Надпись оси Y ELSE // Писать наименование с начала изображения aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraRotate( oPS, aMatrix, 90, { X_MaxW-30, 10 }, GRA_TRANSFORM_ADD ) // <<<########## oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) // <<<########## GraStringAt( oPS, { X_MaxW-30, 10 }, AyName ) // Надпись оси Y ENDIF ****** Не получается отключить режим вращения изображения ****** Вместо отключения можно докрутить до 360 градусов aMatrix := GraInitMatrix() // <<<########## GraRotate( oPS, aMatrix, 0, {X_MaxW, Y_MaxW}, GRA_TRANSFORM_REPLACE ) // <<<########## oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) // <<<########## ********* Рамка рисунка ******************************** aAttr [ GRA_AL_COLOR ] := BD_BLACK // Задать цвет линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_SOLID // Задать тип линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты GraLine(oPS, { Dx, Y_MaxW-LY }, { X_MaxW-Dx, Y_MaxW-LY } ) // Линия вверху графика GraLine(oPS, { Dx, Y0 }, { X_MaxW-Dx, Y0 } ) // Ось X GraLine(oPS, { Dx, Y0 }, { Dx, Y_MaxW-LY } ) // Ось Y GraLine(oPS, { X_MaxW-Dx, Y0 }, { X_MaxW-Dx, Y_MaxW-LY } ) // Правая граница графика ********* Записать файл изображения в папке ClsClustTree DC_Impl(oScrn2) IF mPar = 'Screen' DIRCHANGE(M_PathAppl+"\ClsClustTree\") // Перейти в папку ClsClustTree cFileName = "ClustClsDist"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+".bmp" ERASE(cFileName) DC_Scrn2ImageFile( oStatic1, cFileName ) ENDIF IF mPar = 'File' ****** Запись полноразмерного графического файла в папку: M_PathAppl+"\ClsClustTree\" * DC_ASave(mNumMod , "_NumMod.arx") mNumMod = DC_ARestore("_NumMod.arx") DIRCHANGE(M_PathAppl+"\ClsClustTree\") // Перейти в папку ClsClustTree cFileName = "ClustClsDist"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+".jpg" ERASE(cFileName) oBMP:SaveFile(cFileName,XBPBMP_FORMAT_JPG) IF nWidth > 1800 FullView( cFileName, "по верху", 65 ) ELSE ****** Формирование с помощью bmp2bmp() и отображение масштабированного изображения aNewSize := {nWidth,nHeight-29} // Новый размер изображения (еще немного уменьшается, чтобы не рисовать по панели задач) oBMP:loadFile(cFileName) // Загрузка полноразмерного изображения oRet := BMP2BMP(oBMP,aNewSize) // Масштабирование изображения cFileNameScale = SUBSTR(cFileName,1,AT(".jpg",cFileName)-1)+"_scaled.jpg" ERASE(cFileNameScale) oRet:saveFile(cFileNameScale,XBPBMP_FORMAT_JPG) // Запись масштабированного графического файла в в папку приложения для визуализации FullView( cFileNameScale, "по верху", 0 ) // Визуализация масштабированного графического файла на мониторе ограниченного разрешения ENDIF ENDIF ****** Текущая папка: c:\Aidos-X\AID_DATA\A0000001\System\ClsClustTree\ * DIRCHANGE(M_PathAppl) DIRCHANGE('..') RETURN NIL ************************************************************************************************************************** ******** 4.3.2.3. Агломеративная древовидная кластеризация признаков ******** Когнитивная кластеризация, путем объединения пар признаков в матрице абсолютных частот и пересчет матриц условных ******** и безусловных процентных распределений и системно-когнитивных моделей. Построение и визуализация древовидных ******** диаграмм объединения признаков (дендрограмм) в графическом виде ************************************************************************************************************************** FUNCTION F4_3_2_3() PUBLIC GetList[0], GetOptions, oSay, hDC1, hDC2, oStatic, oStatic1, aPixel, oBitmap Running(.T.) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!"),L('4.3.2.3. Агломеративная древовидная кластеризация признаков')) Running(.F.) RETURN NIL ENDIF ** Имя графического файла для рисования *PUBLIC X_MaxW := 1910, Y_MaxW := 950 // Размер графического окна для самого графика в пикселях *PUBLIC X_MaxW := 1900, Y_MaxW := 950 // Размер графического окна для самого графика в пикселях *PUBLIC X_MaxW := nWidth, Y_MaxW := nHeight // Размер графического окна для самого графика в пикселях PUBLIC X_MaxW := 1800, Y_MaxW := 900 // Размер графического окна для самого графика в пикселях PUBLIC nXSize := X_MaxW // Размер изображения в пикселях ################## НАДО БРАТЬ ПУТЕМ ОПРЕДЕЛЕНИЯ РАЗРЕШЕНИЯ ЭКРАНА PUBLIC nYSize := Y_MaxW StrFile(STR(nXSize,9)+' '+STR(nYSize,9), '_XYSize.txt') // Запись текстового файла с параметрами nXSize, nYSize PRIVATE aSize := {X_MaxW,Y_MaxW} *PRIVATE nColor := BD_LIGHTGREY PRIVATE nColor := GraMakeRGBColor({ 255, 255, 255}) PUBLIC oBitmap := XbpBitmap() :new() :create() // create Bitmap PUBLIC oPS := XbpPresSpace():new() // NO :Create() here oPS:create( oBitmap, { aSize[1],aSize[2] } ) // here :Create() oBitmap:presSpace( oPS ) // assing to Bitmap:presSpace oBitmap:make( aSize[1],aSize[2] ) // make empty Bitmap mFileName = 'Gra4323.jpg' IF .NOT. FILE('Gra4323.jpg') *** Если этого файла нет, то создать изображение и сохранить его GraSetColor( oPS, nColor, nColor ) // Background Color GraBox( oPS, {0,0}, {aSize[1],aSize[2]}, 1 ) // fill Background oBitmap:saveFile('Gra4323.jpg',XBPBMP_FORMAT_JPG) * LB_Warning(L('В текущей папке системы'+Disk_dir+' должен быть файл: "Gra4323.jpg" 1910 x 1000 pix', mTitle ) * RETURN nil ENDIF ClearImage4323() // Очистка изображения ************************ IF ApplChange("4.3.2.3()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций *MsgBox(Disk_dir+'\Gra4323.jpg'+' ====> '+M_PathAppl+'Gra4323.jpg') *COPY FILE (Disk_dir+'\Gra4323.jpg') TO (M_PathAppl+'Gra4323.jpg') // Не работает с ADS ADS_CopyFile(Disk_dir+'\Gra4323.jpg', M_PathAppl+'Gra4323.jpg', .F., .F.) // Скопировать новый файл запуска со стандартным именем и удалить новый файл с ADS IF .NOT. FILE('Abs.TXT' ) .OR. ; .NOT. FILE('Prc1.TXT') .OR. ; .NOT. FILE('Prc2.TXT') .OR. ; .NOT. FILE('Inf1.TXT') .OR. ; .NOT. FILE('Inf2.TXT') .OR. ; .NOT. FILE('Inf3.TXT') .OR. ; .NOT. FILE('Inf4.TXT') .OR. ; .NOT. FILE('Inf5.TXT') .OR. ; .NOT. FILE('Inf6.TXT') .OR. ; .NOT. FILE('Inf7.TXT') aMess := {} AADD(aMess, L('Отсутствуют одна или несколько системно-когнитивных моделей!')) // TXT или DBF AADD(aMess, L('Чтобы их создать необходимо выполнить режим:')) AADD(aMess, L('"3.5. Синтез и верификация заданных из 10 моделей"')) LB_Warning(aMess,L('4.3.2.3. Агломеративная древовидная кластеризация признаков')) Running(.F.) RETURN NIL ENDIF IF .NOT. FILE('Abs.DBF' ) .OR. ; .NOT. FILE('Prc1.DBF') .OR. ; .NOT. FILE('Prc2.DBF') .OR. ; .NOT. FILE('Inf1.DBF') .OR. ; .NOT. FILE('Inf2.DBF') .OR. ; .NOT. FILE('Inf3.DBF') .OR. ; .NOT. FILE('Inf4.DBF') .OR. ; .NOT. FILE('Inf5.DBF') .OR. ; .NOT. FILE('Inf6.DBF') .OR. ; .NOT. FILE('Inf7.DBF') Running(.F.) F5_5(.F.) ENDIF *IF .NOT. FILE('SxodAtrAbs.DBF' ) .OR. ; * .NOT. FILE('SxodAtrPrc1.DBF') .OR. ; * .NOT. FILE('SxodAtrPrc2.DBF') .OR. ; * .NOT. FILE('SxodAtrInf1.DBF') .OR. ; * .NOT. FILE('SxodAtrInf2.DBF') .OR. ; * .NOT. FILE('SxodAtrInf3.DBF') .OR. ; * .NOT. FILE('SxodAtrInf4.DBF') .OR. ; * .NOT. FILE('SxodAtrInf5.DBF') .OR. ; * .NOT. FILE('SxodAtrInf6.DBF') .OR. ; * .NOT. FILE('SxodAtrInf7.DBF') * aMess := {} * AADD(aMess, L('Отсутствуют одна или несколько матриц сходства признаков!')) * AADD(aMess, L('Чтобы их создать необходимо выполнить режим:')) * AADD(aMess, L('"4.3.2.1. Расчет матриц сходства, кластеров и конструктов"')) * LB_Warning(aMess,L('4.3.2.3. Агломеративная древовидная кластеризация признаков')) * Running(.F.) * RETURN NIL *ENDIF mModError = .T. PRIVATE Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } FOR m=1 TO LEN(Ar_Model) IF FILE('SxodAtr'+Ar_model[m]+'.DBF') mModError = .F. EXIT ENDIF NEXT IF mModError aMess := {} AADD(aMess, L('Нет ни одной модели, в которой была бы посчитана матрица сходства признаков!')) AADD(aMess, L('Чтобы сделать это необходимо выполнить режим:')) AADD(aMess, L('"4.3.2.1. Расчет матриц сходства, кластеров и конструктов"')) LB_Warning(aMess,L('4.3.2.3. Агломеративная древовидная кластеризация классов')) Running(.F.) RETURN NIL ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Attributes EXCLUSIVE NEW N_Rec = RECCOUNT() IF N_Rec > 111 aMess := {} AADD(aMess, L('В данной модели')+' '+ALLTRIM(STR(N_Rec))+' '+L('признаков. При таком количестве признаков процесс агломеративной когнитивной кластеризации может занять заметное время.')) AADD(aMess, L('Кроме того для отображения дендрограммы когнитивной кластеризации может потребоваться графический файл с большим числом пикселей по X и по Y.')) AADD(aMess, L('Задать размерность графического файла, а также размер используемых шрифтов, толщину линий и другие параметры отображения дендрограммы можно')) AADD(aMess, L('кликнув по кнопке: "Параметры". Если задать и модель для отображения дендрограммы и ранее в ней проводился расчет дендрогаммы, то отобразить')) AADD(aMess, L('ее без перерасчета (т.е. значительно быстрее, чем с расчетом) можно кликнув по кнопке: "Перерисовать без перерасчета". Эту операцию можно')) AADD(aMess, L('повторять много раз, что позволяет подобрать нужные параметры визуализации')) LB_Warning(aMess,L('4.3.2.3. Агломеративная древовидная кластеризация признаков')) * Running(.F.) * RETURN NIL ENDIF IF FILEDATE("AtrClustTree",16) = CTOD("//") DIRMAKE("AtrClustTree") aMess := {} AADD(aMess, L('В папке текущего приложения: "'+UPPER(ALLTRIM(M_PathAppl))+'"')) AADD(aMess, L('не было директории "AtrClustTree" для дендрограмм признаков и она была создана!')) AADD(aMess, L('В эту папку записываются исходные изображения высокого качества (без масштабирования)')) LB_Warning(aMess, L('4.3.2.3. Агломеративная древовидная кластеризация признаков' )) ENDIF // Сделать с текстовыми файлами: NameAtr1-##-#####, NameAtr2-##-##### и NAMEAtrF-##-##### // где: № модели (01-10) KODCL_NEW * DIRCHANGE(M_PathAppl+"\AtrClustTree\") // Перейти в папку AtrClustTree * cFileName = M_PathAppl+"\AtrClustTree\NameAtr1"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+"-"+STRTRAN(STR(KODCL_NEW,5)," ","0")+".txt" * StrFile(mClustAtr, cFileName) // Запись текстового файла NameAtr1-##-#####.txt, где ##-номер модели, #####-KODCL_NEW * mClustAtr = FileStr(cFileName) // Считывание текстового файла NameAtr1-##-#####.txt, где ##-номер модели, #####-KODCL_NEW *************** ДИАЛОГ ЗАДАНИЯ ПАРАМЕТРОВ КЛАСТЕРИЗАЦИИ ****************************** *** РЕАЛИЗАЦИЯ АЛГОРИТМА: *** 0. Задать в диалоге параметры кластеризации. *** Здесь можно задать: *** - размер шрифта для надписей наименований признаков; *** - толщину линий дендрограммы *** - делать паузу после вывода изображения? *** - отображать кластеры различным цветом? *** - и т.д. ... mNumMod = Options4323(.F.) mNameTree = 'TreeAtr-'+STRTRAN(STR(mNumMod,2),' ','0') // mNumMod из Options4323 H = 1.5 // Высота кнопки @ 0,0 DCSTATIC TYPE XBPSTATIC_TYPE_BITMAP CAPTION mFileName OBJECT oStatic1 ; PREEVAL {|o|o:autoSize := .t.} EVAL {|o|hDC1 := GetWindowDC(o:getHWnd()), o:motion := {|a,b,o|ShowColorTr( hDC1, a, oSay, o )},; aPixel := Array(o:caption:xSize,o:caption:ySize), o:paint := {|a,b,o|Gratest(o)}} p=25;d=6 @ 1.5, 1 DCPUSHBUTTON CAPTION L('Помощь' ) SIZE LEN(L('Помощь' )) +2, H ACTION {||Help4323()} @ 1.5, 10 DCPUSHBUTTON CAPTION L('Параметры' ) SIZE LEN(L('Параметры')) +2, H ACTION {||Options4323(.T.)} @ 1.5, p DCPUSHBUTTON CAPTION L('ABS ' ) SIZE LEN(L('ABS ') ) +2, H ACTION {||TreeAtr(1)};p=p+d-1 @ 1.5, p DCPUSHBUTTON CAPTION L('PRC1' ) SIZE LEN(L('PRC1') ) +2, H ACTION {||TreeAtr(2)};p=p+d @ 1.5, p DCPUSHBUTTON CAPTION L('PRC2' ) SIZE LEN(L('PRC2') ) +2, H ACTION {||TreeAtr(3)};p=p+d @ 1.5, p DCPUSHBUTTON CAPTION L('INF1' ) SIZE LEN(L('INF1') ) +2, H ACTION {||TreeAtr(4)};p=p+d @ 1.5, p DCPUSHBUTTON CAPTION L('INF2' ) SIZE LEN(L('INF2') ) +2, H ACTION {||TreeAtr(5)};p=p+d @ 1.5, p DCPUSHBUTTON CAPTION L('INF3' ) SIZE LEN(L('INF3') ) +2, H ACTION {||TreeAtr(6)};p=p+d @ 1.5, p DCPUSHBUTTON CAPTION L('INF4' ) SIZE LEN(L('INF4') ) +2, H ACTION {||TreeAtr(7)};p=p+d @ 1.5, p DCPUSHBUTTON CAPTION L('INF5' ) SIZE LEN(L('INF5') ) +2, H ACTION {||TreeAtr(8)};p=p+d @ 1.5, p DCPUSHBUTTON CAPTION L('INF6' ) SIZE LEN(L('INF6') ) +2, H ACTION {||TreeAtr(9)};p=p+d @ 1.5, p DCPUSHBUTTON CAPTION L('INF7' ) SIZE LEN(L('INF7') ) +2, H ACTION {||TreeAtr(10)} ;p=p+d*1.7 @ 1.5, p DCPUSHBUTTON CAPTION L('Все модели') SIZE LEN(L('Все модели'))+2, H ACTION {||TreeAtrAll()};p=p+16 @ 1.5, p DCPUSHBUTTON CAPTION L('Перерисовать без перерасчета') SIZE LEN(L('Перерисовать без перерасчета'))-2, H ACTION {||DrawClustAtr()} ;p=p+27 //############### @ 1.5, p DCPUSHBUTTON CAPTION L('Статья о когн.кластеризации' ) SIZE LEN(L('Статья о когн.кластеризации' ))-3, H ACTION {||LC_RunUrl( 'http://ej.kubagro.ru/2011/07/pdf/40.pdf' , .T., .T. )} ;p=p+25 //############### @ 1.5, p DCPUSHBUTTON CAPTION L('Свидетельство РосПатента' ) SIZE LEN(L('Свидетельство РосПатента' ))-0, H ACTION {||LC_RunUrl( 'http://lc.kubagro.ru/aidos/2012610135.jpg', .T., .T. )} //############### DCREAD GUI FIT OPTIONS GetOptions EVAL {||GraTest(oStatic1)} SETAPPWINDOW; TITLE L('4.3.2.3. Агломеративная древовидная кластеризация признаков. (C) Универсальная когнитивная аналитическая система "Эйдос-Х++"') oStatic1:unlockPS() ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ************************************************************************************************************************* FUNCTION Options4323(mPar) PUBLIC GetList[0] *** Здесь можно задать: *** - размер шрифта для надписей наименований классов; *** - толщину линий дендрограммы *** - делать паузу после вывода изображения? *** - отображать кластеры различным цветом? *** - делать фон по классам полосками белого и светло-голубого цвета *** - размеры графического файла (до 4K, т.е. до 4096 Х 4096) *** - и т.д. ... ****** Параметры визуализации дендрограммы ******************** PUBLIC mFontSize := 3 PUBLIC mLineWidth := 2 PUBLIC mSaveDBases:= 1 PUBLIC mBGrColor := 2 PUBLIC mNumMod := 6 PUBLIC mXSize := 1800 PUBLIC mYSize := 900 IF FILE('_Options4323.txt') mStr = FileStr('_Options4323.txt') mFontSize = VAL(SUBSTR(mStr, 1,1)) mLineWidth = VAL(SUBSTR(mStr, 2,1)) mSaveDBases = VAL(SUBSTR(mStr, 3,1)) mBGrColor = VAL(SUBSTR(mStr, 4,1)) mNumMod = VAL(SUBSTR(mStr, 5,2)) mXSize = VAL(SUBSTR(mStr, 7,4)) mYSize = VAL(SUBSTR(mStr,11,4)) mFontSize = IF(mFontSize =0,3,mFontSize ) mLineWidth = IF(mLineWidth =0,2,mLineWidth ) mSaveDBases = IF(mSaveDBases=0,1,mSaveDBases) mBGrColor = IF(mBGrColor =0,2,mBGrColor ) mNumMod = IF(mNumMod =0,6,mNumMod ) mXSize = IF(mXSize =0,1800,mXSize ) mYSize = IF(mYSize =0, 900,mYSize ) ENDIF *************************************************************** IF mPar @0, 0 DCGROUP oGroup1 CAPTION L('Задайте размер шрифта:') SIZE 75.0, 5.5 @1, 2 DCRADIO mFontSize VALUE 1 PROMPT L('Очень мелкий') PARENT oGroup1 @2, 2 DCRADIO mFontSize VALUE 2 PROMPT L('Мелкий' ) PARENT oGroup1 @3, 2 DCRADIO mFontSize VALUE 3 PROMPT L('Средний' ) PARENT oGroup1 @4, 2 DCRADIO mFontSize VALUE 4 PROMPT L('Крупный' ) PARENT oGroup1 @6, 0 DCGROUP oGroup2 CAPTION L('Задайте толщину линий:') SIZE 75.0, 3.5 @1, 2 DCRADIO mLineWidth VALUE 1 PROMPT L('Тонкие' ) PARENT oGroup2 @2, 2 DCRADIO mLineWidth VALUE 2 PROMPT L('Толстые' ) PARENT oGroup2 @10,0 DCGROUP oGroup3 CAPTION L('Сохранять промежуточные базы данных?') SIZE 75.0, 3.5 @1, 2 DCRADIO mSaveDBases VALUE 1 PROMPT L('Нет' ) PARENT oGroup3 @2, 2 DCRADIO mSaveDBases VALUE 2 PROMPT L('Да.' ) PARENT oGroup3 @2.2, 10 DCSAY L('Надо иметь в виду, что их может быть очень много!') EDITPROTECT {|| .NOT.mSaveDBases=2 } HIDE {|| .NOT.mSaveDBases=2 } FONT '9.Arial Bold' COLOR GRA_CLR_RED PARENT oGroup3 @14,0 DCGROUP oGroup4 CAPTION L('Рисовать кластеры на цветном фоне?') SIZE 75.0, 3.5 @1, 2 DCRADIO mBGrColor VALUE 1 PROMPT L('Нет' ) PARENT oGroup4 @2, 2 DCRADIO mBGrColor VALUE 2 PROMPT L('Да.' ) PARENT oGroup4 @18,0 DCGROUP oGroup5 CAPTION L('Задайте размер изображения в пикселях (не более 4K):') SIZE 75.0, 3.5 @ 1,2 DCSAY L("Размер по X:") GET mXSize PICTURE "####" PARENT oGroup5 @ 2,2 DCSAY L("Размер по Y:") GET mYSize PICTURE "####" PARENT oGroup5 p=2; d=7 @22,0 DCGROUP oGroup6 CAPTION L('Задайте ранее просчитанную модель для перерисовки без перерасчета:') SIZE 75.0, 2.5 @1, p DCRADIO mNumMod VALUE 1 PROMPT L('Abs' ) PARENT oGroup6;p=p+d @1, p DCRADIO mNumMod VALUE 2 PROMPT L('Prc1') PARENT oGroup6;p=p+d @1, p DCRADIO mNumMod VALUE 3 PROMPT L('Prc2') PARENT oGroup6;p=p+d @1, p DCRADIO mNumMod VALUE 4 PROMPT L('Inf1') PARENT oGroup6;p=p+d @1, p DCRADIO mNumMod VALUE 5 PROMPT L('Inf2') PARENT oGroup6;p=p+d @1, p DCRADIO mNumMod VALUE 6 PROMPT L('Inf3') PARENT oGroup6;p=p+d @1, p DCRADIO mNumMod VALUE 7 PROMPT L('Inf4') PARENT oGroup6;p=p+d @1, p DCRADIO mNumMod VALUE 8 PROMPT L('Inf5') PARENT oGroup6;p=p+d @1, p DCRADIO mNumMod VALUE 9 PROMPT L('Inf6') PARENT oGroup6;p=p+d @1, p DCRADIO mNumMod VALUE 10 PROMPT L('Inf7') PARENT oGroup6;p=p+d DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; OPTIONS GetOptions ; ADDBUTTONS; MODAL ; TITLE L('4.3.2.3. Агломеративная древовидная кластеризация признаков') ENDIF mXSize = IF(mXSize<1800,1800,mXSize ) mXSize = IF(mXSize>4096,4096,mXSize ) mYSize = IF(mYSize< 900, 900,mYSize ) mYSize = IF(mYSize>4096,4096,mYSize ) StrFile(STR(mFontSize,1)+STR(mLineWidth,1)+STR(mSaveDBases,1)+STR(mBGrColor,1)+STR(mNumMod,2)+STR(mXSize,4)+STR(mYSize,4), '_Options4323.txt') // Запись текстового файла с параметрами nXSize, nYSize DC_ASave(mNumMod , "_NumMod.arx") * mNumMod = DC_ARestore("_NumMod.arx") PUBLIC mNameTree := 'TreeAtr-'+STRTRAN(STR(mNumMod,2),' ','0') // mNumMod из Options4323 RETURN(mNumMod) ***************************************************************************************************** ******** Когнитивная кластеризация признаков во всех моделях ***************************************************************************************************** FUNCTION TreeAtrAll() ***************************************************************************************************** *** АЛГОРИТМ: *** 0. Задать в диалоге параметры кластеризации. *** 1. Цикл по моделям ******** *** 2. Создать БД признаков и кластеров: ATR_CLUST, абсолютных частот: ABS_CLUST1, информативностей: INF_CLUST, *** сходства признаков: MSA_CLUST путем КОПИРОВАНИЯ ранее расчитанных по текущей модели. *** Создать БД учета объединения признаков TreeAtr.dbf и занести в нее начальную информацию. *** 3. Начало цикла итераций до тех пор, пока не останется 2 кластера. **** *** 4. Найти заданное число пар признаков наиболее похожих признаков в матрице сходства. *** 5. Объединить заданное число пар признаков с НАИБОЛЬШИМ уровнем сходства в ABS_CLUST2. *** 6. На основе ABS_CLUST2 РАССЧИТАТЬ матрицу информативностей: INF_CLUST в текущей модели, *** рассчитать матрицу сходства признаков: MSA_CLUST, а также БД учета объединения признаков *** TreeAtr.dbf и занести в нее информацию об объединении признаков в БД IterAtr###.dbf. *** Скопировать ABS_CLUST2 => ABS_CLUST1 *** 7. Конец цикла итераций. Проверить критерий остановки: если в MSA_CLUST осталось больше 2 **** *** колонок, то перейти на продолжение итераций (п.4), а иначе на рисование результатов (п.8). *** 8. Нарисовать дерево объединения признаков: *** ..\System\ClustTreeAtr\ClustTreeAtr-#-##.bmp *** 9. Конец цикла по моделям ******** ***************************************************************************************************** *** 1. Цикл по моделям **** PUBLIC Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } FOR mNumMod = 1 TO 10 // Для всех моделей DC_ASave(mNumMod , "_NumMod.arx") TreeAtr(mNumMod) // Кластеризация NEXT *** 10.Конец цикла по моделям **** **** Объединить структуры дендрогамм всех моделей в одном файле CrLf = CHR(13)+CHR(10) // Конец строки (абзаца) (CrLf) mClustAtr = '' FOR mNumMod = 1 TO 10 // Для всех моделей mClustAtr = mClustAtr + STR(mNumMod,2) + ' ' + Ar_Model[mNumMod] + ': ' + FileStr('_ClustAtr-'+STRTRAN(STR(mNumMod,2),' ','0')+'.txt') + CrLf // Считывание текстового файла _ClustAtr-##.txt, где ##-номер модели NEXT StrFile(mClustAtr, '_ClustAtr-ALL.txt') // Запись текстового файла _ClustAtr-##.txt, где ##-номер модели aMess := {} AADD(aMess, L('Когнитивная кластеризация завершена успешно!')) AADD(aMess, L(' ')) AADD(aMess, L('Результаты (дендрограммы) находятся в папке:')) AADD(aMess, M_PathAppl+'AtrClustTree\') LB_Warning(aMess,L('4.3.2.3. Агломеративная древовидная кластеризация признаков')) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций RETURN NIL ************************************************************************************************** FUNCTION Help4323() aHelp := {} AADD(aHelp, L('Помощь по режиму: "4.3.2.3. Агломеративная древовидная кластеризация признаков" ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Данный режим обеспечивает агломеративную когнитивную кластеризацию признаков и вывод дендрограмм в виде графических форм. При этом применяется ')) AADD(aHelp, L('авторский алгоритм, имеющий ряд особенностей, по сравнению с традиционными: ')) AADD(aHelp, L('- матрица сходства (расстояний) рассчитывается не только на основе матрицы частот ABS, отражающей количество наблюдений градаций описательных ')) AADD(aHelp, L('шкал в группах по градациям классификационных шкал (классам), но и на основе матриц условных и безусловных процентных распределений: PRC1, PRC2, ')) AADD(aHelp, L('а также матриц системно-когнитивных моделей: INF1, INF2, INF3, INF4, INF5, INF6, INF7; ')) AADD(aHelp, L('- в качестве меры расстояния между классами и кластерами используется не Евклидового расстояние, а неметрический интегральный критерий ')) AADD(aHelp, L('(информационное расстояние), применение которого корректно для неортонормированных пространств (которые только и встречаются на практике); ')) AADD(aHelp, L('- после объединения признаков (кластеров) в кластеры пересчитывается матрица расстояний путем перерасчета не только матрицы абсолютных частот, но и')) AADD(aHelp, L('матриц условных и безусловных процентных распределений и системно-когнитивных моделей (список этих моделей можно увидеть в режимах: 3.5,5.5,5.6). ')) AADD(aHelp, L('Персчет матрицы абсолютных частот происходит таким образом, как будто объекты обучающей выборки относятся не к исходным классам, а к кластерам. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('АЛГОРИТМ: ')) AADD(aHelp, L('0. Задать в диалоге параметры кластеризации. ')) AADD(aHelp, L('1. Цикл по моделям ')) AADD(aHelp, L('2. Создать БД признаков и кластеров: ATR_CLUST, абсолютных частот: ABS_CLUST1, информативностей: INF_CLUST, сходства признаков: MSA_CLUST ')) AADD(aHelp, L('путем КОПИРОВАНИЯ ранее рассчитанных по текущей модели. Создать БД учета объединения признаков TreeAtr.dbf и занести в нее начальную информацию. ')) AADD(aHelp, L('3. Начало цикла итераций до тех пор, пока не останется 2 кластера. ')) AADD(aHelp, L('4. Найти пару наиболее похожих признаков в матрице сходства. ')) AADD(aHelp, L('5. Объединить пару признаков с НАИБОЛЬШИМ уровнем сходства в ABS_CLUST2. ')) AADD(aHelp, L('6. На основе ABS_CLUST2 РАССЧИТАТЬ матрицу информативностей: INF_CLUST в текущей модели, рассчитать матрицу сходства признаков: MSA_CLUST, ')) AADD(aHelp, L('а также БД учета объединения признаков TreeAtr.dbf и занести в нее информацию об объединении признаков. Скопировать ABS_CLUST2 => ABS_CLUST1 ')) AADD(aHelp, L('7. Конец цикла итераций. Проверить критерий остановки: если в MSA_CLUST осталось больше 2 колонок, то перейти на продолжение итераций (п.4), ')) AADD(aHelp, L('а иначе на выход рисование результатов (п.8). ')) AADD(aHelp, L('8. Нарисовать дерево объединения признаков (дендрограмму) на экране и записать файл: ClustAtr-##.bmp, где: ## - номер модели. ')) AADD(aHelp, L('9. Нарисовать график изменения межкластерных расстояний на экране и записать файл: ClustAtrDist-##.bmp, где: ## - номер модели. ')) AADD(aHelp, L('10. Конец цикла по моделям. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Статья и свидетельство РосПатента по когнитивной кластеризации: ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Луценко Е.В. Метод когнитивной кластеризации или кластеризация на основе знаний (кластеризация в системно-когнитивном анализе и интеллектуальной ')) AADD(aHelp, L('системе <Эйдос>) / Е.В. Луценко, В.Е. Коржаков // Политематический сетевой электронный научный журнал Кубанского государственного аграрного ')) AADD(aHelp, L('университета (Научный журнал КубГАУ) [Электронный ресурс]. - Краснодар: КубГАУ, 2011. - №07(071). С. 528 - 576. - Шифр Информрегистра: ')) AADD(aHelp, L('0421100012\0253, IDA [article ID]: 0711107040. - Режим доступа: http://ej.kubagro.ru/2011/07/pdf/40.pdf, 3,062 у.п.л. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Луценко Е.В. Подсистема агломеративной когнитивной кластеризации признаков системы <Эйдос> ("Эйдос-кластер") / Е.В. Луценко, В.Е. Коржаков // Пат. ')) AADD(aHelp, L('№ 2012610135 РФ. Заяв. № 2011617962 РФ 26.10.2011. Опубл. От 10.01.2012. - Режим доступа: http://lc.kubagro.ru/aidos/2012610135.jpg, 3,125 у.п.л. ')) mHelpMax = -999;FOR h=1 TO LEN(aHelp);mHelpMax = MAX(mHelpMax, LEN(ALLTRIM(aHelp[h])));NEXT s=1;d=0.9;@0,0 DCGROUP oGroup1 CAPTION L(' ') SIZE mHelpMax-25, LEN(aHelp)*d+1.5 FOR h=1 TO LEN(aHelp);@s,2 DCSAY aHelp[h] SIZE 0 PARENT ogroup1;s=s+d;NEXT DCREAD GUI TO lExit FIT TITLE L('4.3.2.3. Агломеративная древовидная кластеризация признаков. (C) Система "ЭЙДОС-X++"') RETURN NIL ************************************************************************************************** ***************************************************************************************** ******** Когнитивная кластеризация для одной заданной модели **************************** FUNCTION TreeAtr(mNumMod) *mNumMod = DC_ARestore("_NumMod.arx") DC_ASave(mNumMod, "_NumMod.arx") *MsgBox(STR(mNumMod)) IF .NOT. FILE("SxodAtr"+Ar_Model[mNumMod]+".dbf") aMess := {} AADD(aMess, L('Сначала необходимо в режиме 4.3.2.1 посчитать матрицу сходства в модели:')+' '+Ar_Model[mNumMod]) LB_Warning(aMess,L('4.3.2.3. Агломеративная древовидная кластеризация классов')) RETURN NIL ENDIF StrFile(STR(mFontSize,1)+STR(mLineWidth,1)+STR(mSaveDBases,1)+STR(mBGrColor,1)+STR(mNumMod,2)+STR(mXSize,4)+STR(mYSize,4), '_Options4323.txt') // Запись текстового файла с параметрами nXSize, nYSize PUBLIC mNameTree := 'TreeAtr-'+STRTRAN(STR(mNumMod,2),' ','0') // mNumMod из Options4323 *oScrn2 := DC_WaitOn( L('Идет процесс когнитивной кластеризации признаков в модели: ')+ALLTRIM(STR(mNumMod))+'/10-'+Ar_Model[mNumMod],,,,,,,,,,,.F.) ****** Параметры визуализации дендрограммы ******************** Options4323(.F.) *************************************************************** *** 2. Создать БД абсолютных частот: ABS_CLUST1, информативностей: INF_CLUST, *** сходства признаков: MSA_CLUST путем КОПИРОВАНИЯ ранее расчитанных по текущей модели. *** Создать БД учета объединения признаков TreeAtr.dbf и занести в нее начальную информацию. CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций COPY FILE ("Attributes.dbf") TO ("ATR_CLUST.dbf") COPY FILE ("ABS.dbf") TO ("ABS_CLUST1.dbf") COPY FILE ("ABS.dbf") TO ("ABS_CLUST2.dbf") COPY FILE ("INF.dbf") TO ("INF_CLUST.dbf") *COPY FILE ("SxodAtrAbs.dbf") TO ("MSA_CLUST.dbf") COPY FILE ("SxodAtr"+Ar_Model[mNumMod]+".dbf") TO ("MSA_CLUST.dbf") *** Создать массив наименований атрибутов CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Attributes EXCLUSIVE NEW;N_Attributes = RECCOUNT() // Начальное кол-во признаков SELECT Attributes aNameAtr := {} aAtr := {} DBGOTOP() DO WHILE .NOT. EOF() AADD(aNameAtr, ALLTRIM(STR(Kod_Atr))) AADD(aAtr , ALLTRIM(Name_atr)) DBSKIP(1) ENDDO ***** Создать БД для корректировки положений полочек по уровням иерархии TreeAtr.dbf aStructure := { { "Hierarchy" , "N", 15, 0 }, ; { "Filtr" , "C", 1, 0 }, ; { "X_koord" , "N", 15, 7 }, ; { "Y_koord" , "N", 15, 7 } } mNameHier = 'HierarAtr-'+STRTRAN(STR(mNumMod,2),' ','0') DbCreate( mNameHier, aStructure ) ***** Создать БД учета объединения признаков TreeAtr.dbf и занести в нее начальную информацию. aStructure := { { "Num_it" , "N", 15, 0 }, ; { "Num_pp" , "N", 15, 0 }, ; { "NameAtr1" , "C", 255, 0 }, ; // Мемо-поле не работает, поэтому использовать текстовые файлы со значениями полей NameAtr1 с именами, приведенными ниже { "NameAtr2" , "C", 255, 0 }, ; // Мемо-поле не работает, поэтому использовать текстовые файлы со значениями полей NameAtr2 с именами, приведенными ниже { "KodAtrOld1" , "N", 15, 0 }, ; { "KodAtrOld2" , "N", 15, 0 }, ; { "NameAtr_Sh" , "C", 255, 0 }, ; { "NameAtr_Fu" , "C", 255, 0 }, ; // Мемо-поле не работает, поэтому использовать текстовые файлы со значениями полей NameAtr_Fu с именем, приведенным ниже { "Ur_sxod" , "N", 15, 7 }, ; { "Ur_razl" , "N", 15, 7 }, ; { "Ur_razlIsh" , "N", 15, 7 }, ; { "Normalizat" , "C", 15, 0 }, ; { "KodAtrNew" , "N", 15, 0 }, ; { "Hierarchy" , "N", 15, 0 }, ; { "Filtr" , "C", 1, 0 }, ; { "Color" , "C", 4, 0 }, ; { "X_koord" , "N", 15, 7 }, ; { "Y_koord" , "N", 15, 7 } } mNameTree = 'TreeAtr-'+STRTRAN(STR(mNumMod,2),' ','0') DbCreate( mNameTree, aStructure ) * cFileName = M_PathAppl+"\AtrClustTree\NameAtr1"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+"-"+STRTRAN(STR(KodAtrNew,5)," ","0")+".txt" * StrFile(mClustAtr, cFileName) // Запись текстового файла NameAtr1-##-#####.txt, где ##-номер модели, #####-KodAtrNew * mClustAtr = FileStr(cFileName) // Считывание текстового файла NameAtr1-##-#####.txt, где ##-номер модели, #####-KodAtrNew ********************************************************************************* *** 3. Начало цикла итераций до тех пор, пока не останется 2 кластера. **** ********************************************************************************* ********************************************************************************* *** 3. Начало цикла итераций до тех пор, пока не останется 2 кластера. **** ********************************************************************************* Wsego = N_Attributes mTitleName = L('4.3.2.3. Агломеративная древовидная кластеризация признаков. (C) Система "ЭЙДОС-X++"') // Отображение стадии исполнения. Будет написано прямо в окне Progress-bar d = 0 @0,0 DCGROUP oGroup1 CAPTION L('Стадии исполнения процесса') FONT "6.Helv" SIZE 105+d, 2.5 PARENT oTabPage1 @4,0 DCGROUP oGroup2 CAPTION L('Прогноз времени исполнения') FONT "6.Helv" SIZE 105+d, 5.0 PARENT oTabPage2 s = 1 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 1] FONT "10.Helv" s++ @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay97 FONT "10.HelvBold" s++ @0.2+s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay98 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @1.5+s ,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT oSay99 FONT "9.Helv Bold" COLOR GRA_CLR_BLUE @s ,1 DCPROGRESS oProgress ; SIZE 95,1.5 ; PERCENT ; EVERY 1+INT(Wsego/nEvery) ; // Кол-во обновлений изображения MAXCOUNT Wsego ; COLOR GRA_CLR_CYAN // Цвет полосы @s++,97 DCPUSHBUTTON CAPTION L('&Cancel') ; ACTION {||lOk:=.T.} OBJECT oButton ; SIZE 7,1.5 DCREAD GUI ; TITLE mTitleName ; PARENT @oDialog ; FIT ; EXIT ; MODAL oDialog:alwaysOnTop = .T. // Окно открывается на переднем плане oDialog:show() // Начало отсчета времени для прогнозирования длительности исполнения Time_progress = 0 // Прошло секунд с начала процесса // Процесс может идти больше суток, поэтому для определения // во всех случаях вычисляется время, прошедшее с начала года T_Mess1 = L("Начало:")+" "+TIME() // Начало Sec_1 = (DOY(DATE())-1)*86400+SECONDS() PUBLIC T1 := (DOY(DATE())-1)*86400+SECONDS() // Время предыдущей индикации процесса исполнения PUBLIC T2 := (DOY(DATE())-1)*86400+SECONDS()+1 // Текущее время (1-й раз оно заметно больше T1 чтобы было отображение) PUBLIC T1tp := T1 PUBLIC T2tp := T2 ********************************************************************************* aKodAtr := {} // Массив для исключения повторов признаков и/или кластеров FOR mNumIter = 1 TO N_Attributes // Начало цикла итераций ******** * oScrn2 := DC_WaitOn( L('Идет процесс когнитивной кластеризации признаков в модели: ')+ALLTRIM(STR(mNumMod))+'/10-'+Ar_Model[mNumMod]+'. '+ALLTRIM(STR(mNumIter))+'/'+ALLTRIM(STR(N_Attributes)),,,,,,,,,,,.F.) aSay[ 1]:SetCaption(L('Идет процесс когнитивной кластеризации признаков в модели: ')+ALLTRIM(STR(mNumMod))+'/10-'+Ar_Model[mNumMod]+'. '+ALLTRIM(STR(mNumIter))+'/'+ALLTRIM(STR(N_Attributes))) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Attributes EXCLUSIVE NEW USE ATR_CLUST EXCLUSIVE NEW USE ABS_CLUST1 EXCLUSIVE NEW USE MSA_CLUST EXCLUSIVE NEW USE (mNameTree) EXCLUSIVE NEW * mNameHier = 'HierarAtr-'+STRTRAN(STR(mNumMod,2),' ','0') * USE (mNameHier) EXCLUSIVE NEW *** 4. Найти пару наиболее похожих признаков или кластеров в матрице сходства. SELECT ATR_CLUST N_Atr = RECCOUNT() // Переменное число признаков (кластеров), котрое увеличивается при добавлении кластеров SELECT MSA_CLUST IF N_Atr > 2 mMaxUrSx = -999 // Искать пару признаков с наивысшим сходством по всей матрице сходства mFlagAdd = .F. FOR mKodAtr1 = 1 TO N_Atr // Строка DBGOTO(mKodAtr1) FOR mKodAtr2 = mKodAtr1+1 TO N_Atr // Колонка IF ASCAN(aKodAtr, mKodAtr1) = 0 .AND.; // Ни один из признаков еще не включен в кластер ASCAN(aKodAtr, mKodAtr2) = 0 M_UrSx = FIELDGET(mKodAtr2+3) IF mMaxUrSx < M_UrSx mFlagAdd = .T. mMaxUrSx = M_UrSx mNameClustSh = '('+ALLTRIM(STR(MIN(mKodAtr1,mKodAtr2),15))+','+ALLTRIM(STR(MAX(mKodAtr1,mKodAtr2),15))+')' //########### IF LEN(aNameAtr[mKodAtr1]) > LEN(aNameAtr[mKodAtr2]) mKodAtr1Max = mKodAtr2 mKodAtr2Max = mKodAtr1 mAtrName1 = aNameAtr[mKodAtr2] mAtrName2 = aNameAtr[mKodAtr1] mNameClustFu = '('+aNameAtr[mKodAtr2]+','+aNameAtr[mKodAtr1]+')' ELSE mKodAtr1Max = mKodAtr1 mKodAtr2Max = mKodAtr2 mAtrName1 = aNameAtr[mKodAtr1] mAtrName2 = aNameAtr[mKodAtr2] mNameClustFu = '('+aNameAtr[mKodAtr1]+','+aNameAtr[mKodAtr2]+')' ENDIF ENDIF ENDIF NEXT NEXT IF mFlagAdd SELECT ATR_CLUST APPEND BLANK mKodAtrNew = RECNO() REPLACE Kod_Atr WITH mKodAtrNew REPLACE Name_Atr WITH mNameClustFu SELECT (mNameTree) DBGOBOTTOM() mNumPP = Num_pp APPEND BLANK REPLACE Num_it WITH mNumIter REPLACE Num_pp WITH ++mNumPP REPLACE KodAtrOld1 WITH mKodAtr1Max REPLACE KodAtrOld2 WITH mKodAtr2Max REPLACE NameAtr1 WITH aNameAtr[mKodAtr1Max] REPLACE NameAtr2 WITH aNameAtr[mKodAtr2Max] REPLACE NameAtr_Sh WITH mNameClustSh REPLACE NameAtr_Fu WITH mNameClustFu REPLACE Ur_sxod WITH mMaxUrSx REPLACE Ur_razl WITH 100-mMaxUrSx REPLACE Ur_razlIsh WITH 100-mMaxUrSx REPLACE KodAtrNew WITH mKodAtrNew StrFile(ALLTRIM(NameAtr1), M_PathAppl+"\AtrClustTree\NameAtr1"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+"-"+STRTRAN(STR(KodAtrNew,5)," ","0")+".txt") // Запись текстового файла NameAtr1-##-#####.txt, где ##-номер модели, #####-KodAtrNew StrFile(ALLTRIM(NameAtr2), M_PathAppl+"\AtrClustTree\NameAtr2"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+"-"+STRTRAN(STR(KodAtrNew,5)," ","0")+".txt") // Запись текстового файла NameAtr2-##-#####.txt, где ##-номер модели, #####-KodAtrNew * mClustAtr = FileStr(M_PathAppl+"\AtrClustTree\NameAtr1"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+"-"+STRTRAN(STR(KodAtrNew,5)," ","0")+".txt") // Считывание текстового файла NameAtr1-##-#####.txt, где ##-номер модели, #####-KodAtrNew StrFile(ALLTRIM(mNameClustFu), M_PathAppl+"\AtrClustTree\NameAtrF"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+"-"+STRTRAN(STR(KodAtrNew,5)," ","0")+".txt") // Запись текстового файла NameAtrF-##-#####.txt, где ##-номер модели, #####-KodAtrNew * mNameClustFu = FileStr(M_PathAppl+"\AtrClustTree\NameAtrF"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+"-"+STRTRAN(STR(KodAtrNew,5)," ","0")+".txt") // Считывание текстового файла NameAtrF-##-#####.txt, где ##-номер модели, #####-KodAtrNew AADD(aKodAtr , mKodAtr1Max) AADD(aKodAtr , mKodAtr2Max) AADD(aNameAtr, mNameClustFu) ENDIF ENDIF *** 5. Объединить заданное число пар признаков с НАИБОЛЬШИМ уровнем сходства в ABS_CLUST2. SELECT ATR_CLUST N_Atr = RECCOUNT() // Число признаков (кластеров) будет увеличиваться ******* Создать БД ABS_CLUST с объединенными признаками (кластерами) ################################# * aStructure := { { "Kod_pr", "N", 15, 0 },; * { "Name" , "C", 255, 0 } } * FOR j=1 TO N_Atr * FieldName = "Atr"+ALLTRIM(STR(j,15)) * AADD(aStructure, { FieldName, "N", 19, 1 }) * NEXT * AADD(aStructure, { "SUMMA", "N", 19, 1 } ) * AADD(aStructure, { "SREDN", "N", 19, 1 } ) * AADD(aStructure, { "DISP" , "N", 19, 1 } ) * DbCreate( 'ABS_CLUST2', aStructure ) *** Просто в самом начале скопировать БД ABS.DBF USE ABS_CLUST2 EXCLUSIVE NEW *** В БД ABS_CLUST1 удалить последние 4 строки, а потом снова сделать их и посчитать модели и матрицы сходства ################################################# SELECT ABS_CLUST2 FOR j=1 TO 4 DBGOBOTTOM() DELETE PACK NEXT ******* Посчитать абс.частоты в объединенных строках БД ABS_CLUST2.DBF на основе БД ABS_CLUST1.DBF SELECT (mNameTree) DBGOBOTTOM() mKodAtrOld1 = KodAtrOld1 mKodAtrOld2 = KodAtrOld2 mKodAtrNew = KodAtrNew mNameAtrNew = NameAtr_fu AADD(aAtr, mNameAtrNew) SELECT ABS_CLUST1 *********** Выход из процесса кластеризации, т.к. осталось 2 признака или меньше IF RECCOUNT() <= 6 DC_Impl(oScrn2) aMess := {} AADD(aMess, L("Выход из процесса кластеризации,")) AADD(aMess, L("т.к. осталось 2 признака или меньше.")) AADD(aMess, L("Работа системы будет завершена!")) LB_Warning(aMess) Running(.F.) * ADS_SERVER_QUIT() QUIT ENDIF * ****** В матрице частот добавляется новая строка, являющаяся объединением 2 строк с наивысшим сходством, а старые строки обнуляются SELECT ABS_CLUST1 DBGOTO(mKodAtrOld1) aOld1 := {} FOR j=3 TO FCOUNT()-3 AADD(aOld1, FIELDGET(j)) NEXT DBGOTO(mKodAtrOld2) aOld2 := {} FOR j=3 TO FCOUNT()-3 AADD(aOld2, FIELDGET(j)) NEXT SELECT ABS_CLUST2 APPEND BLANK FOR j=1 TO LEN(aOld1) FIELDPUT(2+j, aOld1[j]+aOld2[j]) NEXT FIELDPUT(1, mKodAtrNew );FIELDPUT(2, mNameAtrNew) // Добавить код и наименование кластера признаков новой строке DBGOTO(mKodAtrOld1);FOR j=3 TO FCOUNT();FIELDPUT(j, 0);NEXT // Стереть старые строки DBGOTO(mKodAtrOld2);FOR j=3 TO FCOUNT();FIELDPUT(j, 0);NEXT ****** Перенести итоговые строки из БД ABS_CLUST1.DBF в БД ABS_CLUST2.DBF SELECT ABS_CLUST1 DBGOTO(RECCOUNT()-3) aIt1 := {} FOR j=1 TO FCOUNT() AADD(aIt1, FIELDGET(j)) NEXT SELECT ABS_CLUST2 APPEND BLANK FOR j=1 TO LEN(aIt1) FIELDPUT(j, aIt1[j]) NEXT FIELDPUT(2,'Сумма числа признаков') SELECT ABS_CLUST1 DBGOTO(RECCOUNT()-2) aIt2 := {} FOR j=1 TO FCOUNT() AADD(aIt2, FIELDGET(j)) NEXT SELECT ABS_CLUST2 APPEND BLANK FOR j=1 TO LEN(aIt2) FIELDPUT(j, aIt2[j]) NEXT FIELDPUT(2,'Среднее') SELECT ABS_CLUST1 DBGOTO(RECCOUNT()-1) aIt3 := {} FOR j=1 TO FCOUNT() AADD(aIt3, FIELDGET(j)) NEXT SELECT ABS_CLUST2 APPEND BLANK FOR j=1 TO LEN(aIt3) FIELDPUT(j, aIt3[j]) NEXT FIELDPUT(2,'Среднеквадратичное отклонение') SELECT ABS_CLUST1 DBGOTO(RECCOUNT()-0) aIt4 := {} FOR j=1 TO FCOUNT() AADD(aIt4, FIELDGET(j)) NEXT SELECT ABS_CLUST2 APPEND BLANK FOR j=1 TO LEN(aIt4) FIELDPUT(j, aIt4[j]) NEXT FIELDPUT(2,'Среднеквадратичное отклонение') ***** Пересчитать в БД ABS_CLUST2.DBF итоговые колонки SELECT ABS_CLUST2 * N_Cls = FCOUNT()-5 *** Расчет колонок: SUMMA, SREDN FOR i = 1 TO RECCOUNT() DBGOTO(i) mSumma = 0 FOR j=3 TO FCOUNT()-3 mSumma = mSumma + FIELDGET(j) NEXT REPLACE SUMMA WITH mSumma REPLACE SREDN WITH mSumma/N_Cls NEXT *** Расчет колонки: DISP FOR i = 1 TO RECCOUNT() DBGOTO(i) mDisp = 0 FOR j=3 TO FCOUNT()-3 mDisp = mDisp + (SREDN-FIELDGET(j))^2 NEXT FIELDPUT(FCOUNT(),SQRT(mDisp/N_Cls)) NEXT *** 6. На основе ABS_CLUST2 РАССЧИТАТЬ матрицу информативностей: INF_CLUST в текущей модели, *** рассчитать матрицу сходства признаков: MSA_CLUST, а также БД учета объединения признаков *** (mNameTree).dbf и занести в нее информацию об объединении признаков в БД IterAtr###.dbf. *** Скопировать ABS_CLUST2 => ABS_CLUST1 ******* Создать в БД INF_CLUST.DBF строки с наименованиями описательных шкал и градаций, включая объединенные строки кластеров признаков (максимальная длина наименования) aStructure := { { "Kod_pr", "N", 15, 0 },; { "Name" , "C", 255, 0 } } IF mNumMod = 1 FOR j=1 TO N_Cls FieldName = "CLS"+ALLTRIM(STR(j,15)) AADD(aStructure, { FieldName, "N", 19, 1 }) NEXT AADD(aStructure, { "SUMMA", "N", 19, 1 } ) AADD(aStructure, { "SREDN", "N", 19, 1 } ) AADD(aStructure, { "DISP" , "N", 19, 1 } ) ELSE FOR j=1 TO N_Cls FieldName = "CLS"+ALLTRIM(STR(j,15)) AADD(aStructure, { FieldName, "N", 19, 7 }) NEXT AADD(aStructure, { "SUMMA", "N", 19, 7 } ) AADD(aStructure, { "SREDN", "N", 19, 7 } ) AADD(aStructure, { "DISP" , "N", 19, 7 } ) ENDIF DbCreate( 'INF_CLUST', aStructure ) USE INF_CLUST EXCLUSIVE NEW SELECT INF_CLUST * mKod = '' FOR i=1 TO LEN(aAtr)-1 APPEND BLANK REPLACE Kod_pr WITH i REPLACE Name WITH aAtr[i] FOR j=3 TO FCOUNT() FIELDPUT(j, 0) NEXT * mKod = mKod + str(i) NEXT * MsgBox(STR(LEN(aAtr))+' '+mKod) APPEND BLANK // Запись N_Atr+1 - строка: "Сумма", REPLACE Name WITH "Сумма числа признаков" FOR j=3 TO FCOUNT();FIELDPUT(j, 0);NEXT APPEND BLANK // Запись N_Atr+2 - "Среднее" REPLACE Name WITH "Среднее" FOR j=3 TO FCOUNT();FIELDPUT(j, 0);NEXT APPEND BLANK // Запись N_Atr+3 - "Среднеквадратичное отклонение", "Редукция класса" REPLACE Name WITH "Среднеквадратичное отклонение" FOR j=3 TO FCOUNT();FIELDPUT(j, 0);NEXT *** На основе ABS_CLUST2 РАССЧИТАТЬ матрицу информативностей: INF_CLUST в текущей модели *** (матрица информативностей в модели ABS есть сама матрица ABS) SELECT ABS_CLUST2 DBGOTO(N_Atr+1);N = SUMMA // SUMM угловой элемент DBGOTO(N_Atr+4);Nobj = SUMMA // Всего логических объектов обучающей выборки K = LOG(N_Atr)/LOG(N)/LOG(2) // Нормировочный коэффицент для перевода в биты *** Начало цикла по классам ******************* * N_Cls = FCOUNT()-5 FOR j = 1 TO N_Cls SELECT ABS_CLUST2 DBGOTO(N_Atr+1);Nj = FIELDGET(2+j) // Суммарное число признаков по j-му классу DBGOTO(N_Atr+4);Njo = FIELDGET(2+j) // Суммарное число объектов по j-му классу FOR i = 1 TO N_Atr ****** Выбор способа расчета для разных моеделей PUBLIC Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } SELECT ABS_CLUST2 DBGOTO(i) Nij = FIELDGET(2+j) Ni = SUMMA Iij = 0 // На случай, если вообще не посчитается, чтобы не возникала ошибка при присвоении значения полю базы DO CASE CASE mNumMod = 1 // ABS (модель ABS есть сама матрица ABS, т.е. ее рассчиывать не нужно) Iij = Nij CASE mNumMod = 2 // PRC1 IF Nj <> 0 Iij = Nij/Nj ENDIF CASE mNumMod = 3 // PRC2 IF Njo <> 0 Iij = Nij/Njo ENDIF CASE mNumMod = 4 // INF1 IF Nij*Ni*Nj*N <> 0 Iij = K*LOG((Nij*N)/(Ni*Nj)) ENDIF CASE mNumMod = 5 // INF2 IF Nij*Ni*Njo*Nobj <> 0 Iij = LOG((Nij*Nobj)/(Ni*Njo))/LOG(2) ENDIF CASE mNumMod = 6 // INF3 IF N <> 0 Iij = Nij-Ni*Nj/N ENDIF CASE mNumMod = 7 // INF4 IF Ni*N <> 0 Iij = (Nij*N)/(Ni*Nj) - 1 ENDIF CASE mNumMod = 8 // INF5 IF Ni*Njo*Nobj <> 0 Iij = (Nij*Nobj)/(Ni*Njo) - 1 ENDIF CASE mNumMod = 9 // INF6 IF Nj*Nobj <> 0 Iij = (Nij/Nj) - (Ni/N) ENDIF CASE mNumMod = 10 // INF7 IF Njo*Nobj <> 0 Iij = (Nij/Njo) - (Ni/Nobj) ENDIF ENDCASE SELECT INF_CLUST DBGOTO(i) FIELDPUT(2+j,Iij) // сам элемент Iij REPLACE SUMMA WITH SUMMA + Iij // столбец SUMMA DBGOTO(N_Atr+1) FIELDPUT(2+j,FIELDGET(2+j)+Iij) // строка SUMMA REPLACE SUMMA WITH SUMMA + Iij // Угл.эл. SUMMA NEXT NEXT ****** Расчет колонки средних по строкам SELECT INF_CLUST FOR i = 1 TO N_Atr DBGOTO(i) REPLACE SREDN WITH SUMMA/N_Cls NEXT ** Расчет средних по столбцам GO N_Atr+2 // SREDN строка FOR j = 1 TO N_Cls DBGOTO(N_Atr+1);mSumma = FIELDGET(2+j) // SUMMA строка DBGOTO(N_Atr+2);FIELDPUT(2+j,mSumma/N_Atr) // SREDN строка NEXT DBGOTO(N_Atr+1);mSredn = SUMMA/(N_Atr*N_Cls) DBGOTO(N_Atr+2);REPLACE SREDN WITH mSredn // SREDN угловой элемент ****** Расчет столбца интегральной информативности факторов Ds = 0 // угловой элемент DISP FOR i = 1 TO N_Atr DBGOTO(i);mSredn = SREDN FOR j = 1 TO N_Cls Iij = FIELDGET(2+j) // Информативность-элемент (i,j) REPLACE DISP WITH DISP+(mSredn-Iij)^2 Ds = Ds + (mSredn-Iij)^2 NEXT NEXT **** Дорасчет интегральной информативности факторов FOR i = 1 TO N_Atr DBGOTO(i);mDisp = DISP // DISP столбец ПРОВЕРИТЬ #################### REPLACE DISP WITH SQRT(DISP/(N_Atr-1)) NEXT *** Расчет степени редукции признаков FOR j = 1 TO N_Cls DBGOTO(N_Atr+2);mSredn=FIELDGET(2+j) FOR i = 1 TO N_Atr DBGOTO(i);Iij=FIELDGET(2+j) // Информативность-элемент (i,j) DBGOTO(N_Atr+3);FIELDPUT(2+j,FIELDGET(2+j)+(mSredn-Iij)^2) NEXT NEXT **** Дорасчет среднеквадратичного оклонения по классам и угл.элемент DBGOTO(N_Atr+3) FOR j = 1 TO N_Cls FIELDPUT(2+j,SQRT(FIELDGET(2+j)/(N_Cls-1))) NEXT REPLACE DISP WITH SQRT(Ds/(N_Atr*N_Cls-1)) // DISP - угловой элемент ****************************************************** *** РАСЧЕТ МАТРИЦ СХОДСТВА признаков из F4_3_2_1() *** ****************************************************** *** ############################################################################### *** САМИ МАТРИЦЫ В КАЖДОЙ МОДЕЛИ МОЖНО РАССЧИТЫВАТЬ С ПОМОЩЬЮ РАЗНЫХ МЕР РАССТОЯНИЙ *** ############################################################################### ********** Создание матриц сходства признаков для заданных моделей ********** Структура создаваемой базы *********** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций aStructure := { { "Kod_Atr" , "N", 15, 0},; // 1 { "Kod_Atrc", "N", 15, 0},; // 2 { "Name_Atr", "C",255, 0} } // 3 FOR j=1 TO N_Atr FieldName = "N"+ALLTRIM(STR(j,15)) AADD(aStructure, { FieldName, "N", 15, 7 }) NEXT DbCreate( 'MSA_CLUST', aStructure ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE ATR_CLUST EXCLUSIVE NEW USE MSA_CLUST EXCLUSIVE NEW USE INF_CLUST EXCLUSIVE NEW ****** Присвоение записям матрицы сходства кодов и наименований признаков SELECT ATR_CLUST DBGOTOP() DO WHILE .NOT. EOF() mKodAtrNew = Kod_Atr mNestPairs = ALLTRIM(Name_Atr) SELECT MSA_CLUST APPEND BLANK REPLACE Kod_Atr WITH mKodAtrNew REPLACE Name_Atr WITH mNestPairs FOR j=1 TO N_Atr FIELDPUT(3+j,0) NEXT SELECT ATR_CLUST DBSKIP(1) ENDDO **************************************** *** РАСЧЕТ МАТРИЦ СХОДСТВА ПРИЗНАКОВ *** **************************************** **** Расчет матрицы сходства (M_SxodAtr) **** Похоже как в пакетном распознавании IF N_Atr >= 2 PRIVATE aAtr1[N_Cls], aAtr2[N_Cls] Max = -9999999 Min = 9999999 SELECT INF_CLUST FOR mAtr1 = 1 TO N_Atr // Цикл по признакам подматрицы Inf.dbf заданного диапазона признаков ####### SELECT INF_CLUST DBGOTO(mAtr1) ************** Формирование массива 1-го признака FlagAtr1 = .F. AFILL(aAtr1,0) SumAtr1 = 0 // Сумма FOR j=1 TO N_Cls aAtr1[j] = FIELDGET(2+j) SumAtr1 = SumAtr1 + aAtr1[j] IF aAtr1[j] <> 0 FlagAtr1 = .T. // Флаг наличия данных ENDIF NEXT IF FlagAtr1 // Если есть данные по 1-му классу ***** Расчет среднего и дисперсии массива 1-го признака (из матрицы брать нельзя, т.к. будет большая погрешность расчетов) SrAtr1 = SumAtr1/N_Atr // Среднее массива 1-го признака DiAtr1 = 0 // Дисперсия массива 1-го признака FOR j=1 TO N_Cls DiAtr1 = DiAtr1 + ( aAtr1[j] - SrAtr1 ) ^ 2 NEXT DiAtr1 = SQRT( DiAtr1 / (N_Atr - 1)) // Дорасчет дисперсии массива 1-го признака FOR mAtr2=mAtr1 TO N_Atr // Цикл по признакам подматрицы Inf.dbf заданного диапазона признаков ####### SELECT INF_CLUST DBGOTO(mAtr2) * msgBox(STR(N_Atr)+STR(N_Cls)+STR(mAtr1)+STR(mAtr2)) **************** Формирование массива 2-го признака FlagAtr2 = .F. AFILL(aAtr2,0) SumAtr2 = 0 // Сумма FOR j=1 TO N_Cls aAtr2[j] = FIELDGET(2+j) SumAtr2 = SumAtr2 + aAtr2[j] IF aAtr2[j] <> 0 FlagAtr2 = .T. // Флаг наличия данных ENDIF NEXT IF FlagAtr2 // Если есть данные по классу2-му ***** Расчет среднего и дисперсии массива 2-го признака SrAtr2 = SumAtr2/N_Atr // Среднее массива 2-го признака DiAtr2 = 0 // Дисперсия массива 2-го признака FOR j=1 TO N_Cls DiAtr2 = DiAtr2 + ( aAtr2[j] - SrAtr2 ) ^ 2 NEXT DiAtr2 = SQRT( DiAtr2 / (N_Atr - 1)) // Дорасчет дисперсии массива 2-го признака ******** Расчет нормированной к 100% корреляции массивов ******** локатора источника и информативностей признаков объекта Korr = 0 FOR j=1 TO N_Cls Korr = Korr + (aAtr1[j] - SrAtr1) * (aAtr2[j] - SrAtr2) NEXT Korr = Korr / ( (N_Atr-1) * DiAtr1 * DiAtr2 ) * 100 *** Вообще-то 1 вычитать не надо, в Help Excel приведена формула без вычитания 1, *** НО в Excel-2003 СЧИТАЕТСЯ ОНА ТАК, КАК БУДТО 1 ВСЕ ЖЕ ВЫЧИТАЕТСЯ (См.: "Кореляция" и "Ковариация") *** В Excel-2007 и выше все считается правильно, а в Excel-2003 просто неверно и формула корреляции приведена неправильная Max = MAX(Max,Korr) Min = MIN(Min,Korr) SELECT MSA_CLUST GO mAtr1;FIELDPUT(3+mAtr2,Korr) GO mAtr2;FIELDPUT(3+mAtr1,Korr) ENDIF NEXT ENDIF NEXT ENDIF ***** СКОПИРОВАТЬ ВСЕ БАЗЫ С ИМЕНЕМ, ВКЛЮЧАЮЩИМ НОМЕР МОДЕЛИ И НОМЕР ИТЕРАЦИИ IF mSaveDBases = 2 CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций COPY FILE ("ATR_CLUST.dbf") TO ('ATR_CLUSTA-'+STRTRAN(STR(mNumMod,2),' ','0')+'-'+STRTRAN(STR(mNumIter,3),' ','0')+".dbf") COPY FILE ("ABS_CLUST1.dbf") TO ('ABS_CLUSTA-'+STRTRAN(STR(mNumMod,2),' ','0')+'-'+STRTRAN(STR(mNumIter,3),' ','0')+".dbf") COPY FILE ("INF_CLUST.dbf") TO ('INF_CLUSTA-'+STRTRAN(STR(mNumMod,2),' ','0')+'-'+STRTRAN(STR(mNumIter,3),' ','0')+".dbf") COPY FILE ("MSA_CLUST.dbf") TO ('MSA_CLUSTA-'+STRTRAN(STR(mNumMod,2),' ','0')+'-'+STRTRAN(STR(mNumIter,3),' ','0')+".dbf") ENDIF ***** Скопировать ABS_CLUST2 => ABS_CLUST1 CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций COPY FILE ("ABS_CLUST2.dbf") TO ("ABS_CLUST1.dbf") lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) * DC_Impl(oScrn2) NEXT *** 7. Конец цикла итераций. Проверить критерий остановки: если в MSA_CLUST осталось больше 2 **** *** колонок, то перейти на продолжение итераций (п.4), а иначе на рисование результатов (п.8). ***************************************************************************************************** ***** Проставление уровней иерархии и физическая сортировка по уровням иерархии CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mNameTree) EXCLUSIVE NEW SELECT (mNameTree) DBGOTOP() DO WHILE .NOT. EOF() * mNameClustFu = ALLTRIM(NameAtr_Fu) mNameClustFu = FileStr(M_PathAppl+"\AtrClustTree\NameAtrF"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+"-"+STRTRAN(STR(KodAtrNew,5)," ","0")+".txt") // Считывание текстового файла NameAtrF-##-#####.txt, где ##-номер модели, #####-KodAtrNew mHierarchy = 0 FOR j=LEN(mNameClustFu) TO 1 STEP -1 IF SUBSTR(mNameClustFu,j,1) = ')' mHierarchy++ ELSE REPLACE Hierarchy WITH mHierarchy EXIT ENDIF NEXT DBSKIP(1) ENDDO CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mNameTree) EXCLUSIVE NEW COPY STRUCTURE TO Temp.dbf CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mNameTree) EXCLUSIVE NEW INDEX ON STR(Hierarchy, 15)+STR(999999.9999999-UR_SXOD,15,7) TO (mNameTree) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mNameTree) INDEX (mNameTree) EXCLUSIVE NEW USE Temp EXCLUSIVE NEW;ZAP SELECT (mNameTree) SET ORDER TO 1 DBGOTOP() DO WHILE .NOT. EOF() a := {} FOR j=1 TO FCOUNT() AADD(a, FIELDGET(j)) NEXT SELECT Temp APPEND BLANK FOR j=1 TO LEN(a) FIELDPUT(j, a[j]) NEXT SELECT (mNameTree) DBSKIP(1) ENDDO CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций ERASE(mNameTree+'.dbf') DO WHILE FILE(mNameTree+'.dbf');ENDDO RenameFile( "Temp.dbf", mNameTree+'.dbf') DO WHILE FILE("Temp.dbf");ENDDO *COPY FILE ("Temp.dbf") TO (mNameTree+'.dbf') *DC_Impl(oScrn2) MILLISEC(1000) oSay97:SetCaption(oSay97:caption) oButton:SetCaption(L('&Ok')) // Деструктурирование окна отображения графического Progress-bar oButton:activate := {||PostAppEvent(xbeP_Close,,,oDialog)} //<<<<<< Add This DC_AppEvent( @lOk ) * PostAppEvent(xbeP_Activate,,,DC_GetObject(GetList,'DCGUI_BUTTON_OK')) // Роджер oDialog:Destroy() // Просто перед рисованием копировать БД и начинать рисовать всегда с одной и той же копии, т.к. в процессе рисования она меняется ############ // т.е. само рисовавние выполнять изменяя не исходную БД, а ее копию DrawClustAtr() // 8. НАРИСОВАТЬ ДЕРЕВО ОБЪЕДИНЕНИЯ ПРИЗНАКОВ: ..\System\ClustTreeAtr\ClustTreeAtr-#-##.jpg RETURN NIL *** 9. Конец цикла по моделям ******** ****************************************************************************************** *######################################################################################### ****************************************************************************************** ****************************************************** *** 8. Нарисовать дерево объединения признаков: *** ..\System\ClustTreeAtr\ClustTreeAtr-#-##.jpg ****************************************************** FUNCTION DrawClustAtr() ***** Проверить наличие БД mNameTree в папке приложения, и, если ее нет, то выдать соответствующиме сообщения и выйти <===######### mNumMod = Options4323(.F.) mNameTree := 'TreeAtr-'+STRTRAN(STR(mNumMod,2),' ','0') IF .NOT. FILE(mNameTree+'.dbf') Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } aMess := {} AADD(aMess, L('В папке текущего приложения:')+' '+M_PathAppl) AADD(aMess, L('отсутствует база данных с результатами кластеризации:')+' '+mNameTree+'.dbf,') AADD(aMess, L('созданная в модели:')+' "'+Ar_Model[mNumMod]+L('", заданной в "Параметрах" для визуализации.')) AADD(aMess, L('Чтобы создать эту базу необходимо выполнить кластеризацию в данной модели.')) LB_Warning(aMess) RETURN NIL ENDIF ************************************************************************************ **** Создание временной БД - копии mNameTree, для рисования COPY FILE (mNameTree+'.dbf') TO ('TreeAtr.dbf') // Временная БД для рисования дендрограммы и графика расстояний ***** Формирование массива кодов признаков в порядке, нужном для отображения кластеров CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE TreeAtr EXCLUSIVE NEW DBGOBOTTOM() *mClustAtr = '('+ALLTRIM(NameAtr1)+',('+ALLTRIM(NameAtr2)+')' *mClustAtr = NameAtr_Fu // Считать из файла, а не из поля mClustAtr = FileStr(M_PathAppl+"\AtrClustTree\NameAtrF"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+"-"+STRTRAN(STR(KodAtrNew,5)," ","0")+".txt") // Считывание текстового файла NameAtrF-##-#####.txt, где ##-номер модели, #####-KodAtrNew StrFile(ALLTRIM(mClustAtr), '_ClustAtr-'+STRTRAN(STR(mNumMod,2),' ','0')+'.txt') // Запись текстового файла _ClustAtr-##.txt, где ##-номер модели *StrFile(ALLTRIM(NameAtr1), M_PathAppl+"\AtrClustTree\NameAtr1"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+"-"+STRTRAN(STR(KodAtrNew,5)," ","0")+".txt") // Запись текстового файла NameAtr1-##-#####.txt, где ##-номер модели, #####-KodAtrNew *StrFile(ALLTRIM(NameAtr2), M_PathAppl+"\AtrClustTree\NameAtr2"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+"-"+STRTRAN(STR(KodAtrNew,5)," ","0")+".txt") // Запись текстового файла NameAtr2-##-#####.txt, где ##-номер модели, #####-KodAtrNew *** Сруктура всей дендрограммы в кодах исходных признаков (кластеры разных уровней объединены скобками) (это структура для модели 10 отладочного примера): *** Уровень *** иерархии *** --------------------------- 6 *** | | *** | ------------- 5 *** | | | *** --------- | --------- 4 *** | | | | | *** | ------- | | ------- 3 *** | | | | | | | *** | | ------ | | | ------ 2 *** | | | | | | | | | *** ---- | | ---- ---- ---- | | ---- 1 *** | | | | | | | | | | | | | | *** (((9,13),(2,(3,(4,14)))),((5,12),((8,10),(1,(7,(6,11)))))) 0 mClustAtr = STRTRAN(mClustAtr,'(',' ') mClustAtr = STRTRAN(mClustAtr,')',' ') mClustAtr = STRTRAN(mClustAtr,',',' ') mClustAtr = CHARONE(' ',mClustAtr) // Замена нескольких подряд идущих пробелов на один пробел aClustAtrNum := {} aClustAtrChr := {} FOR j=1 TO NUMTOKEN(mClustAtr, ' ') AADD(aClustAtrNum, VAL(TOKEN(mClustAtr, ' ', j))) AADD(aClustAtrChr, TOKEN(mClustAtr, ' ', j)) NEXT *LB_Warning(aClustAtrNum) *LB_Warning(aClustAtrChr) DC_ASave(aClustAtrNum, "_ClustAtrNum.arx") DC_ASave(aClustAtrChr, "_ClustAtrChr.arx") * aClustAtrNum = DC_ARestore("_ClustAtrNum.arx") * aClustAtrChr = DC_ARestore("_ClustAtrChr.arx") ************************************************************************************************* ********* ВЫВОД ДЕНДРОГРАММЫ признаков В ГРАФИЧЕСКОМ ВИДЕ *************************************** ************************************************************************************************* CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE TreeAtr EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW SELECT Attributes aNameAtr := {} DBGOTOP() DO WHILE .NOT. EOF() AADD(aNameAtr, ALLTRIM(Name_Atr)) DBSKIP(1) ENDDO ***************************************************************************************************************************************************** SELECT Attributes mRecno = RECNO() mKodAtr = Kod_atr * PUBLIC X_MaxW := 1800, Y_MaxW := 900 // Размер графического окна для отображения когнитивных диаграмм в пикселях * PUBLIC nXSize := 1800 * PUBLIC nYSize := 900 PUBLIC X_MaxW := mXSize, Y_MaxW := mYSize // Размер графического окна для отображения когнитивных диаграмм в пикселях PUBLIC nXSize := mXSize PUBLIC nYSize := mYSize // Create new bitmap with given size oPS := XBPPRESSPACE() :new() :Create() oBMP := XBPBITMAP() :New() :Create() * oBMP:Make( nXSize, nYSize, nPlanes, nBits ) oBMP:Make( nXSize, nYSize ) oBMP:presSpace( oPS ) // here your GRA* Code **** Закрасить фон прямоугольника *************** * GraSetColor( oPS, GRA_CLR_WHITE, GRA_CLR_WHITE ) GraSetColor( oPS, BD_LIGHTGREY, BD_LIGHTGREY ) GraBox( oPS, { 0, 0 }, { nXSize, nYSize }, GRA_FILL ) *####################################################################################################### GraClustAtr( oPS, oBMP, 'File' ) // Графическая функция <<<===######################### *####################################################################################################### *** Так как модуль кластеризации формирует два изображения, то надо их записывать на диск, масштабироватьи и показывать прямо в самой функции ***************************************************************************************************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций RETURN NIL *** 9. Конец цикла по моделям ******** ****************************************************************************************** *######################################################################################### ****************************************************************************************** ******** Очистка изображения ************************ FUNCTION ClearImage4323() * GraSetColor( oPS, BD_LIGHTGREY, BD_LIGHTGREY ) * GraSetColor( oPS, BD_WHITE, BD_WHITE ) nColor = GraMakeRGBColor({ 255, 255, 255}) StrFile(STR(nColor),'nColor.TXT') GraSetColor( oPS, nColor, nColor ) GraBox( oPS, { 0, 0 }, { X_MaxW, Y_MaxW }, GRA_FILL ) RETURN NIL ****************************************************************** ****** Визуализация дендрограммы и графика межкластерных расстяний ****************************************************************** STATIC FUNCTION GraClustAtr( oPS, oStatic, mPar ) *DC_ASave(mNumMod , "_NumMod.arx") mNumMod = DC_ARestore("_NumMod.arx") ***** Проверить наличие БД mNameTree в папке приложения, и, если ее нет, то выдать соответствующиме сообщения и выйти <===######### ****** Параметры визуализации дендрограммы ******************** mNumMod = Options4323(.F.) *************************************************************** IF .NOT. FILE(mNameTree+'.dbf') Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } aMess := {} AADD(aMess, L('В папке текущего приложения:')+' '+M_PathAppl) AADD(aMess, L('отсутвует база данных с результатами кластеризации:')+' '+mNameTree+'.dbf') AADD(aMess, L('Чтобы ее создать необходимо выполнить кластеризацию в модели:')+' "'+Ar_Model[mNumMod]+'"') LB_Warning(aMess) RETURN NIL ENDIF * DC_ASave(aClustAtrNum, "_ClustAtrNum.arx") * DC_ASave(aClustAtrChr, "_ClustAtrChr.arx") aClustAtrNum = DC_ARestore("_ClustAtrNum.arx") aClustAtrChr = DC_ARestore("_ClustAtrChr.arx") oScrn2 := DC_WaitOn( L('Расчет дендрограммы когнитивной кластеризации в модели: ')+ALLTRIM(STR(mNumMod))+'/10-'+Ar_Model[mNumMod],,,,,,,,,,,.F.) IndentLeft = 20 // Отступ слева IndentRight = 20 // Отступ справа LY := 80 // Зона над областью графика для наименования ДЕНДРОГРАММЫ и под областью графика для легенды X0 := IndentLeft // Начало координат по оси X Y0 := LY // Начало координат по оси Y ClearImage4323() // Очистка изображения ************************ ***** Нарисовать рамку изображения и отделить место для легенды ******************* aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты ****** Начало координат в центре рисунка GraArc ( oPS, { X0, Y0 }, 5 ) // Начало координат **** Написать заголовок диаграммы aFonts := XbpFont():new():list() // Все доступные шрифты oFont := XbpFont():new():create("22.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraStringAt( oPS, { X_MaxW/2, Y_MaxW-25 }, 'ДЕНДРОГРАММА КОГНИТИВНОЙ КЛАСТЕРИЗАЦИИ ПРИЗНАКОВ В МОДЕЛИ: "'+UPPER(Ar_Model[mNumMod])+'"') oFont := XbpFont():new():create("18.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) IF LEN(ALLTRIM(M_NameAppl)) < 70 GraStringAt( oPS, { X_MaxW/2, Y_MaxW-52 }, "Приложение: "+'"'+ALLTRIM(M_NameAppl)+'"' ) ELSE GraStringAt( oPS, { X_MaxW/2, Y_MaxW-52 }, '"'+ALLTRIM(M_NameAppl)+'"' ) ENDIF *********** Отобразить коды и наименования признаков слева сверху вниз DO CASE CASE mFontSize = 1 oFont := XbpFont():new():create("6.Arial") CASE mFontSize = 2 oFont := XbpFont():new():create("8.Arial") CASE mFontSize = 3 oFont := XbpFont():new():create("10.Arial") CASE mFontSize = 4 oFont := XbpFont():new():create("12.Arial") OTHERWISE oFont := XbpFont():new():create("8.Arial") ENDCASE GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) * aTxtPar = DC_GraQueryTextbox(mTitle, oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox("Длина текста в пикселях="+ALLTRIM(STR(aTxtPar[1]))+". Высота текста в пикселях="+ALLTRIM(STR(aTxtPar[2]))) ********************************************** ******* НАИМЕНОВАНИЯ признаков И ИХ КОДЫ ******* ********************************************** mInterval = (Y_MaxW - 2 * LY) / (LEN(aClustAtrNum) + 1) // Межстрочный интервал в пикселях. Сделать его расчет mMaxlen = -9999 PUBLIC DeltaY := 9 // ####################### FOR j = 1 TO LEN(aClustAtrNum) GraStringAt( oPS, { IndentLeft, Y_MaxW-LY-(j-1)*mInterval-DeltaY}, aNameAtr[aClustAtrNum[j]] ) // НАИМЕНОВАНИЯ признаков ######## aTxtPar = DC_GraQueryTextbox(aNameAtr[aClustAtrNum[j]], oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов mMaxlen = MAX(mMaxlen, aTxtPar[1]) NEXT aColorY := {} // Для определения цвета дендрограммы по координате Y FOR j = 1 TO LEN(aClustAtrNum) GraStringAt( oPS, { IndentLeft+mMaxlen+110, Y_MaxW-LY-(j-1)*mInterval-DeltaY}, STR(aClustAtrNum[j],4) ) // КОДЫ признаков ################ * REPLACE Y_koord WITH Y_MaxW-LY-(r-1)*mInterval-DeltaY NEXT ****** Формирование массивов для определения цвета дендрограммы ****** Найти координату Y посередине между последним элементом массива aKodAtrBlue и первым элементом массива mKodAtrRed ################# SELECT TreeAtr DBGOBOTTOM() * mKodAtrBlue = NameAtr1 // Синий mKodAtrBlue = FileStr(M_PathAppl+"\AtrClustTree\NameAtr1"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+"-"+STRTRAN(STR(KodAtrNew,5)," ","0")+".txt") // Считывание текстового файла NameAtr1-##-#####.txt, где ##-номер модели, #####-KodAtrNew mKodAtrBlue = STRTRAN(mKodAtrBlue,'(',' ') mKodAtrBlue = STRTRAN(mKodAtrBlue,')',' ') mKodAtrBlue = STRTRAN(mKodAtrBlue,',',' ') mKodAtrBlue = CHARONE(' ',mKodAtrBlue) // Замена нескольких подряд идущих пробелов на один пробел aKodAtrBlue := {} FOR j=1 TO NUMTOKEN(mKodAtrBlue, ' ') AADD(aKodAtrBlue, VAL(TOKEN(mKodAtrBlue, ' ', j))) NEXT * mKodAtrRed = NameAtr2 // Красный mKodAtrRed = FileStr(M_PathAppl+"\AtrClustTree\NameAtr2"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+"-"+STRTRAN(STR(KodAtrNew,5)," ","0")+".txt") // Считывание текстового файла NameAtr2-##-#####.txt, где ##-номер модели, #####-KodAtrNew mKodAtrRed = STRTRAN(mKodAtrRed,'(',' ') mKodAtrRed = STRTRAN(mKodAtrRed,')',' ') mKodAtrRed = STRTRAN(mKodAtrRed,',',' ') mKodAtrRed = CHARONE(' ',mKodAtrRed) // Замена нескольких подряд идущих пробелов на один пробел aKodAtrRed := {} FOR j=1 TO NUMTOKEN(mKodAtrRed, ' ') AADD(aKodAtrRed, VAL(TOKEN(mKodAtrRed, ' ', j))) NEXT * LB_Warning(aKodAtrBlue) * LB_Warning(aKodAtrRed) * LB_Warning(aClustAtrNum) * LB_Warning(aKodAtrBlue) ***** Найти координату Y посередине между последним элементом массива aKodAtrBlue и первым элементом массива mKodAtrRed ################# mRec1 = ASCAN(aClustAtrNum, aKodAtrBlue[LEN(aKodAtrBlue)]) mRec2 = ASCAN(aClustAtrNum, aKodAtrRed [1 ]) mYblue = Y_MaxW-LY-(mRec1-1)*mInterval-DeltaY mYred = Y_MaxW-LY-(mRec2-1)*mInterval-DeltaY mYbluered = mYred + (mYblue - mYred) / 2 ***** Рисование самой дендрограммы ************ SELECT TreeAtr N_rec = RECCOUNT() *** Добавить в начало БД (mNameTree) наименования исходных признаков в порядке, выводимом в дендрограмме, например: *** (((9,13),(2,(3,(4,14)))),((5,12),((8,10),(1,(7,(6,11)))))) *** Сдвинуть все N_rec записей БД (mNameTree) вниз на LEN(aClustAtrNum) записей arz := {} FOR j=1 TO LEN(aClustAtrNum) APPEND BLANK AADD(arz, FIELDGET(j)) NEXT FOR r=1 TO N_rec DBGOTO(r) arf := {} FOR j=1 TO FCOUNT() AADD(arf, FIELDGET(j)) // Запомнили NEXT DBGOTO(r+LEN(aClustAtrNum)) FOR j=1 TO LEN(arf) FIELDPUT(j, arf[j]) // Записали NEXT NEXT *** Добавить в начало БД (mNameTree) наименования исходных признаков FOR r = 1 TO LEN(aClustAtrNum) DBGOTO(r) FOR j=1 TO LEN(arz) FIELDPUT(j, arz[j]) // Стерли NEXT ******* Записали REPLACE KodAtrNew WITH aClustAtrNum[r] REPLACE NAMEAtr_FU WITH aNameAtr[aClustAtrNum[r]] REPLACE Y_koord WITH Y_MaxW-LY-(r-1)*mInterval-DeltaY REPLACE Hierarchy WITH 0 NEXT *** Сделать расчет Y координат линий на кластеры aRec := {} // Массив номеров записей с кодами признаков и кластеров aUrRazl := {} // Массив уровней различий aXkoord := {} // Массив X координат aYkoord := {} // Массив Y координат FOR r = 1 TO RECCOUNT() DBGOTO(r) REPLACE X_koord WITH IndentLeft+mMaxlen+141 AADD(aRec , KodAtrNew) AADD(aUrRazl, UR_RAZL ) AADD(aXkoord, ROUND(X_koord,0)) AADD(aYkoord, ROUND(Y_koord,0)) NEXT *** Формирование массива цветов линий дендрограммы // ####################################################### SELECT TreeAtr *** Расчет Y координат средних линий дендрограммы FOR r = LEN(aClustAtrNum)+1 TO RECCOUNT() DBGOTO(r) mRec1 = ASCAN(aRec, KodAtrOld1) mRec2 = ASCAN(aRec, KodAtrOld2) IF mRec1 * mRec2 > 0 mY1=aYkoord[mRec1] // ######################### mY2=aYkoord[mRec2] mYkoord = ROUND(MIN(mY2,mY1) + (MAX(mY2,mY1) - MIN(mY2,mY1)) / 2,0) REPLACE Y_KOORD WITH mYkoord aYkoord[r] = mYkoord ENDIF NEXT ************************************************ **** Само рисование дендрограммы *************** ************************************************ DC_Impl(oScrn2) oScrn2 := DC_WaitOn('Немного подождите! Идет формирование изображения в памяти и его масштабирование',,,,,,,,,,,.F.) GraLine(oPS, { X0, Y_MaxW-LY }, { X_MaxW, Y_MaxW-LY } ) // Нарисовать линию вверху дендрограммы GraLine(oPS, { X0, Y0 }, { X_MaxW, Y0 } ) // Нарисовать линию внизу дендрограммы GraLine(oPS, { IndentLeft+mMaxlen+140, Y0 }, { IndentLeft+mMaxlen+140, Y_MaxW-LY } ) // Нарисовать вертикальную линию в конце надписей GraLine(oPS, { IndentLeft+mMaxlen+141, Y0 }, { IndentLeft+mMaxlen+141, Y_MaxW-LY } ) // Нарисовать вертикальную линию в конце надписей ***** Задать атрибуты линии ******************* aAttrL := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttrL [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttrL [ GRA_AL_COLOR ] := GraMakeRGBColor({ 0, 0, 255}) // Задать цвет линии DO CASE CASE mLineWidth = 1 aAttrL [ GRA_AL_WIDTH ] := 1 // Задать толщину линии CASE mLineWidth = 2 aAttrL [ GRA_AL_WIDTH ] := 3 // Задать толщину линии OTHERWISE aAttrL [ GRA_AL_WIDTH ] := 1 // Задать толщину линии ENDCASE graSetAttrLine( oPS, aAttrL ) // Установить атрибуты aAttrM := ARRAY( GRA_AM_COUNT ) // Массив для атрибутов маркеров aAttrM [ GRA_AM_SYMBOL ] := GRA_MARKSYM_DOT aAttrM [ GRA_AM_COLOR ] := GraMakeRGBColor({ 0, 0, 255}) // Задать цвет точки GraSetAttrMarker( oPS, aAttrM ) ********************************************************************************************************** ****** Сделать, чтобы уровень различия при объединении кластеров всегда был выше, чем в исходных кластерах ********************************************************************************************************** SELECT TreeAtr SET FILTER TO HIERARCHY = 1 aClust1 := {} // Массив наименований кластеров 1-го уровня иерархии DBGOTOP() DO WHILE .NOT. EOF() AADD(aClust1, ALLTRIM(NAMEAtr_SH)) DBSKIP(1) ENDDO * ASORT(aClust1) * LB_Warning(aClust1) IF LEN(aClust1) > 0 FOR cl=1 TO LEN(aClust1) SET FILTER TO SET ORDER TO aName := {} DBGOTOP() DO WHILE .NOT. EOF() mNameClustFu = FileStr(M_PathAppl+"\AtrClustTree\NameAtrF"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+"-"+STRTRAN(STR(KodAtrNew,5)," ","0")+".txt") // Считывание текстового файла NameAtrF-##-#####.txt, где ##-номер модели, #####-KodAtrNew IF AT(ALLTRIM(aClust1[cl]), ALLTRIM(mNameClustFu)) > 0 REPLACE Filtr WITH '#' AADD(aName, ALLTRIM(mNameClustFu)) ELSE REPLACE Filtr WITH '' ENDIF DBSKIP(1) ENDDO * LB_Warning(aName) IF LEN(aName) > 0 ***** Сделать, чтобы уровень различия при объединении кластеров всегда был выше, чем в исходных кластерах ***** Рассчет шага изменения уровня различия * INDEX ON STR(Ur_RazlIsh,15,7) TO ('TreeAtr') * INDEX ON STR(HIERARCHY,15) TO ('TreeAtr') * INDEX ON STR(KodAtrNew,15) TO ('TreeAtr') SET FILTER TO Filtr = '#' COUNT TO N_Rec IF N_Rec > 0 * DBGOTOP() ;mMinUrRazl = Ur_RazlIsh * DBGOBOTTOM();mMaxUrRazl = Ur_RazlIsh * mStepUrRazl = (mMaxUrRazl-mMinUrRazl)/(N_Rec-1) * REPLACE Ur_razl WITH mMinUrRazl+(++j-1)*mStepUrRazl // Повышать уровень различия равномерно от минимального до максимального * INDEX ON STR(HIERARCHY,15) TO ('TreeAtr') INDEX ON STR(KodAtrNew,15) TO ('TreeAtr') SET FILTER TO Filtr = '#' DBGOTOP();DBGOBOTTOM();DBGOTOP() DBGOTOP() mUrRazlOld = Ur_Razl d = 1 DBSKIP(1) // Все же что-то не так. Не всегда работает ############## DO WHILE .NOT. EOF() // ПОВЫШАТЬ уровень различия на шаг только если он не повышается сам. Тогда отрицательных значений не будет в принципе IF Ur_razl - d <= mUrRazlOld REPLACE Ur_razl WITH Ur_razl + ( mUrRazlOld - Ur_razl ) + d REPLACE Normalizat WITH "Нормализовано" ENDIF mUrRazlOld = Ur_Razl DBSKIP(1) // Все же что-то не так. Не всегда работает ############## ENDDO ENDIF ENDIF NEXT ENDIF ********************************************************************************************************** ****** Визуализация дендрограммы ************************************************************************* SELECT TreeAtr SET ORDER TO SET FILTER TO * DBGOTOP() * DO WHILE .NOT. EOF() * REPLACE Ur_razl WITH Ur_razl + HIERARCHY // Чем выше уровень ирерахии дендрограммы, тем больше различие ## * DBSKIP(1) * ENDDO DBGOBOTTOM() mHierarchyMax = Hierarchy SET FILTER TO HIERARCHY > 0 INDEX ON STR(Ur_razl,15,7) TO ('TreeAtr') * INDEX ON STR(HIERARCHY,15) TO ('TreeAtr') **** Рассчитать коэффициент масштабирования для рисования дендрограммы **** Рисовать дендрограмму с рассчитанным коэффициентом масштабирования k = 6 // Коэффициент масштабирования по оси X ################################ mMaxX = -99999 mMinX = +99999 mMaxY = -99999 mMinY = +99999 aPixelXY := {} // Для поиска уже нарисованных точек aPixelX := {} // Для масштабирования изображения по X aPixelY := {} // Для масштабирования изображения по Y aYkoordShelv := {} // Y координаты точек полочек FOR h=1 TO mHierarchyMax FOR r = LEN(aClustAtrNum)+1 TO RECCOUNT() DBGOTO(r) IF Hierarchy = h mX1 = ROUND(X_koord,0) mX2 = ROUND(mX1 + 10 + Ur_razl * k, 0) mMinX = MIN(mMinX, mX1) mMaxX = MAX(mMaxX, mX2) mRec1 = ASCAN(aRec, KodAtrOld1) mRec2 = ASCAN(aRec, KodAtrOld2) IF mRec1 * mRec2 > 0 mMinY = MIN(mMinY, aYkoord[mRec1]) // ############### mMaxY = MAX(mMaxY, aYkoord[mRec1]) mMinY = MIN(mMinY, aYkoord[mRec2]) mMaxY = MAX(mMaxY, aYkoord[mRec2]) REPLACE X_koord WITH mX2 // Сдвиг вправо следующего уровня иерархии дендрограммы * GraLine( oPS, {mX1 , aYkoord[mRec1]}, {mX2 , aYkoord[mRec1]} ) // Заменить на рисование линии от mX2 до mX1 попиксельно до пикселя не цвета фона mFlag = .F. IF LEN(aYkoordShelv) = 0 // Полочки еще не рисовали mFlag = .T. ENDIF IF .NOT. mFlag // Полочки уже рисовали IF ASCAN(aYkoordShelv, aYkoord[mRec1]) = 0 // Если рисуется не средняя линия дентрограммы mFlag = .T. ELSE FOR x = mX2 TO mX1 STEP -1 IF ASCAN(aPixelXY, STR(x,15)+STR(aYkoord[mRec1],15)) > 0 // Среднюю линию рисовать только в том случае, если есть часть дендрограммы, в которую она упирается при рисовании справав на лево mFlag = .T. EXIT ENDIF NEXT ENDIF ENDIF IF mFlag FOR x = mX2 TO mX1 STEP -1 mPixelXY = STR(x,15)+STR(aYkoord[mRec1],15) IF ASCAN(aPixelXY, mPixelXY) = 0 AADD (aPixelXY, mPixelXY) AADD (aPixelX , x) AADD (aPixelY , aYkoord[mRec1]) DO CASE CASE mLineWidth = 1 GraMarker( oPS, { x, aYkoord[mRec1] } ) CASE mLineWidth = 2 GraMarker( oPS, { x, aYkoord[mRec1]-1 } ) GraMarker( oPS, { x, aYkoord[mRec1] } ) GraMarker( oPS, { x, aYkoord[mRec1]+1 } ) ENDCASE ELSE EXIT ENDIF NEXT ENDIF * GraLine( oPS, {mX1 , aYkoord[mRec2]}, {mX2 , aYkoord[mRec2]} ) // Заменить на рисование линии от mX2 до mX1 попиксельно до пикселя не цвета фона mFlag = .F. IF LEN(aYkoordShelv) = 0 // Полочки еще не рисовали mFlag = .T. ENDIF IF .NOT. mFlag // Полочки уже рисовали IF ASCAN(aYkoordShelv, aYkoord[mRec2]) = 0 // Если рисуется не средняя линия дентрограммы mFlag = .T. ELSE FOR x = mX2 TO mX1 STEP -1 IF ASCAN(aPixelXY, STR(x,15)+STR(aYkoord[mRec2],15)) > 0 // Среднюю линию рисовать только в том случае, если есть часть дендрограммы, в которую она упирается mFlag = .T. EXIT ENDIF NEXT ENDIF ENDIF IF mFlag FOR x = mX2 TO mX1 STEP -1 mPixelXY = STR(x,15)+STR(aYkoord[mRec2],15) IF ASCAN(aPixelXY, mPixelXY) = 0 AADD (aPixelXY, mPixelXY) AADD (aPixelX , x) AADD (aPixelY , aYkoord[mRec2]) DO CASE CASE mLineWidth = 1 GraMarker( oPS, { x, aYkoord[mRec2] } ) CASE mLineWidth = 2 GraMarker( oPS, { x, aYkoord[mRec2]-1 } ) GraMarker( oPS, { x, aYkoord[mRec2] } ) GraMarker( oPS, { x, aYkoord[mRec2]+1 } ) ENDCASE ELSE EXIT ENDIF * MILLISEC(10) NEXT ENDIF // Рисование полочки <===################ * GraLine( oPS, {mX2+1, aYkoord[mRec1]}, {mX2+1, aYkoord[mRec2]} ) // Надо рисовать сначала болеее левые полочки, а потом которые правее // Полочки более низкого уровня иерархии всегда должны быть левее полочек более высокого уровня иерархии FOR y = MIN(aYkoord[mRec1],aYkoord[mRec2]) TO MAX(aYkoord[mRec1],aYkoord[mRec2]) mPixelXY = STR(mX2+1,15)+STR(y,15) AADD (aPixelXY, mPixelXY) AADD (aPixelX , mX2+1) // Полочки более низкого уровня иерархии всегда должны быть левее полочек более высокого уровня иерархии AADD (aPixelY , y) AADD (aYkoordShelv, y) // Y координаты точек полочек DO CASE CASE mLineWidth = 1 GraMarker( oPS, { mX2+1, y } ) CASE mLineWidth = 2 * GraMarker( oPS, { mX2-1, y+1 } ) GraMarker( oPS, { mX2 , y+1 } ) GraMarker( oPS, { mX2+1, y+1 } ) // (-x,+y) (x,+y) (+x,+y) * GraMarker( oPS, { mX2-1, y } ) GraMarker( oPS, { mX2 , y } ) GraMarker( oPS, { mX2+1, y } ) // (-x, y) (x, y) (+x, y) * GraMarker( oPS, { mX2-1, y-1 } ) GraMarker( oPS, { mX2 , y-1 } ) GraMarker( oPS, { mX2+1, y-1 } ) // (-x,-y) (x,-y) (+x,-y) ENDCASE NEXT ENDIF ENDIF NEXT NEXT ********************************************************************************************************** ****** Визуализация дендрограммы ************************************************************************* ********************************************************************************************************** ** Масштабировать вместе с пунктирными линиями по значениям на оси X // ############################# ** Масштабировать изображение по оси X так, чтобы mMaxX всегда было равно X_MaxW-100 mMaxXScale = (X_MaxW-100-mMinX)/(mMaxX-mMinX) ****** Сброс области рисования дендрограммы nColor = GraMakeRGBColor({ 255, 255, 255}) GraSetColor( oPS, nColor, nColor ) GraBox( oPS, { mX1, Y0 }, { X_MaxW, Y_MaxW-LY }, GRA_FILL ) // ############################# *** Надписи наименований признаков с кодами на светло-зеленом и светло-желтом фоне *** Если спектральный АСК-анализ изображений, то до вертикальной линии заливать все надписи цветом спектрального диапазона <<<===######################## IF mBGrColor = 2 aRGBAtr := {} // Массив цветов признаков, если спектр FOR j = 1 TO LEN(aClustAtrNum) mNameAtr = ALLTRIM(aNameAtr[j]) IF SUBSTR(mNameAtr,1,12) = 'SPECTRINTERV' * SpectrInterv: 999/999-{123,123,123} * 123456789012 R G B mPosR1 = AT('{', mNameAtr)+1 mPosR2 = mPosR1+2 mPosG1 = mPosR2+2 mPosG2 = mPosG1+2 mPosB1 = mPosG2+2 mPosB2 = mPosB1+2 mRed = VAL(SUBSTR(mNameAtr, mPosR1, mPosR2-mPosR1+1)) mGreen = VAL(SUBSTR(mNameAtr, mPosG1, mPosG2-mPosG1+1)) mBlue = VAL(SUBSTR(mNameAtr, mPosB1, mPosB2-mPosB1+1)) * MsgBox(mNameAtr+' '+STR(mRed)+','+STR(mGreen)+','+STR(mBlue)) fColor := GraMakeRGBColor({ mRed, mGreen, mBlue}) * SetPixel(hDC1, x, y, AutomationTranslateColor(fColor,.f.) ) * AADD(aRGBAtr, AutomationTranslateColor(fColor,.f.)) AADD(aRGBAtr, fColor) ENDIF NEXT FOR j = 1 TO LEN(aClustAtrNum) aTxtPar = DC_GraQueryTextbox(aNameAtr[aClustAtrNum[j]], oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов mMaxlen = MAX(mMaxlen, aTxtPar[1]) NEXT FOR j = 1 TO LEN(aClustAtrNum) aTxtPar = DC_GraQueryTextbox(aNameAtr[aClustAtrNum[j]], oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов mMaxlen = MAX(mMaxlen, aTxtPar[1]) IF j = 2*INT(j/2) GraSetColor( oPS, aColor[38], aColor[38] ) ELSE GraSetColor( oPS, aColor[73], aColor[73] ) ENDIF GraBox( oPS, { IndentLeft, Y_MaxW-LY-(j-1)*mInterval-DeltaY-aTxtPar[2]/2 }, { X_MaxW-50, Y_MaxW-LY-(j-1)*mInterval-DeltaY+aTxtPar[2]/2 }, GRA_FILL ) // Заливка фоном области наименования признака mNameAtr = ALLTRIM(aNameAtr[aClustAtrNum[j]]) IF SUBSTR(mNameAtr,1,12) = 'SPECTRINTERV' // Цвета неверные <<<===################ * SPECTRINTERV: 10/35-{255,063,063} * 123456789012345678901234567890 * mPos1 = AT(':',mNameAtr) mPos2 = AT('/',mNameAtr) k = VAL(SUBSTR(mNameAtr, mPos1+2, mPos2-mPos1-2)) * MsgBox(mNameAtr+', k='+SUBSTR(mNameAtr, mPos1+2, mPos2-mPos1-2)+', k='+STR(k)) GraSetColor( oPS, aRGBAtr[k] , aRGBAtr[k] ) // Цвет фона для текста - цвет цветового диапазона * GraBox( oPS, { IndentLeft, Y_MaxW-LY-(j-1)*mInterval-DeltaY-aTxtPar[2]/2 }, { IndentLeft+mMaxlen+110, Y_MaxW-LY-(j-1)*mInterval-DeltaY+aTxtPar[2]/2 }, GRA_FILL ) // Заливка фоном области наименования признака GraBox( oPS, { IndentLeft+mMaxlen+40, Y_MaxW-LY-(j-1)*mInterval-DeltaY-aTxtPar[2]/2 }, { IndentLeft+mMaxlen+110, Y_MaxW-LY-(j-1)*mInterval-DeltaY+aTxtPar[2]/2 }, GRA_FILL ) // Заливка фоном области наименования признака ENDIF GraSetColor( oPS, GRA_CLR_BLACK, GRA_CLR_BLACK ) GraStringAt( oPS, { IndentLeft , Y_MaxW-LY-(j-1)*mInterval-DeltaY}, aNameAtr[aClustAtrNum[j]] ) // НАИМЕНОВАНИЯ ПРИЗНАКОВ ######## GraStringAt( oPS, { IndentLeft+mMaxlen+110, Y_MaxW-LY-(j-1)*mInterval-DeltaY}, STR(aClustAtrNum[j],4) ) // КОДЫ ПРИЗНАКОВ ################ NEXT ENDIF aAttr [ GRA_AL_COLOR ] := BD_BLACK // Задать цвет линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_SOLID // Задать тип линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты GraLine(oPS, { X0, Y_MaxW-LY }, { X_MaxW, Y_MaxW-LY } ) // Нарисовать линию вверху дендрограммы GraLine(oPS, { X0, Y0 }, { X_MaxW, Y0 } ) // Нарисовать линию внизу дендрограммы GraLine(oPS, { IndentLeft+mMaxlen+140, Y0 }, { IndentLeft+mMaxlen+140, Y_MaxW-LY } ) // Нарисовать вертикальную линию в конце надписей GraLine(oPS, { IndentLeft+mMaxlen+141, Y0 }, { IndentLeft+mMaxlen+141, Y_MaxW-LY } ) // Нарисовать вертикальную линию в конце надписей aAttrM := ARRAY( GRA_AM_COUNT ) // Массив для атрибутов маркеров aAttrM [ GRA_AM_SYMBOL ] := GRA_MARKSYM_DOT GraSetAttrMarker( oPS, aAttrM ) FOR j=1 TO LEN(aPixelX) x = mMinX+(aPixelX[j]-mMinX)*mMaxXScale IF aPixelY[j] < mYbluered aAttrM [ GRA_AM_COLOR ] := GraMakeRGBColor({ 255, 0, 0}) // Задать цвет точки RED ELSE aAttrM [ GRA_AM_COLOR ] := GraMakeRGBColor({ 0, 0, 255}) // Задать цвет точки BLUE ENDIF GraSetAttrMarker( oPS, aAttrM ) DO CASE CASE mLineWidth = 1 GraMarker( oPS, { x, aPixelY[j] } ) CASE mLineWidth = 2 GraMarker( oPS, { x, aPixelY[j]-1 } ) GraMarker( oPS, { x, aPixelY[j] } ) GraMarker( oPS, { x, aPixelY[j]+1 } ) ENDCASE NEXT *********************************************** * SetPixel(hDC1, 300,300, AutomationTranslateColor(GraMakeRGBColor({ 255, 0, 0}),.f.) ) ***** Нарисовать шкалу расстояний объединения ****************** aUrRazl := {} aXkoord := {} SELECT TreeAtr DBGOTOP() DO WHILE .NOT. EOF() IF LEN(ALLTRIM(NameAtr_Sh)) > 0 AADD(aUrRazl, Ur_razl) AADD(aXkoord, X_koord) ENDIF DBSKIP(1) ENDDO ASORT(aUrRazl) ASORT(aXkoord) * LB_Warning(aUrRazl) * MsgBox(STR(n)) // ########################## n = LEN(aUrRazl) Drazl = ( aUrRazl[n] - aUrRazl[1] ) / 9 //########################## Dxkrd = ( aXkoord[n] - aXkoord[1] ) / 9 DO CASE CASE mFontSize = 1 oFont := XbpFont():new():create("6.Arial") CASE mFontSize = 2 oFont := XbpFont():new():create("8.Arial") CASE mFontSize = 3 oFont := XbpFont():new():create("10.Arial") CASE mFontSize = 4 oFont := XbpFont():new():create("12.Arial") OTHERWISE oFont := XbpFont():new():create("8.Arial") ENDCASE GraSetFont( oPS ,oFont ) aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты aAttrM := ARRAY( GRA_AM_COUNT ) // Массив для атрибутов маркеров aAttrM [ GRA_AM_SYMBOL ] := GRA_MARKSYM_DOT aAttrM [ GRA_AM_COLOR ] := GraMakeRGBColor({ 255, 128, 128}) // Задать цвет точки GraSetAttrMarker( oPS, aAttrM ) GraStringAt( oPS, { IndentLeft, LY-20 }, 'МЕЖКЛАСТЕРНЫЕ РАССТОЯНИЯ:' ) FOR j = 2 TO 11 x = IndentLeft+mMaxlen+141+(j-1)*Dxkrd*mMaxXScale GraStringAt( oPS, { x, LY-20 }, ALLTRIM(STR(ROUND((j-1)*Drazl,0),4)) ) // Надпись расстояния FOR y=Y0 TO Y_MaxW-LY STEP 3 // Рисование вертикальной пуктирной линии mPixelXY = STR(x,15)+STR(y,15) IF ASCAN(aPixelXY, mPixelXY) = 0 GraMarker( oPS, { x, y } ) ENDIF NEXT NEXT *********************************************** aAttr [ GRA_AL_COLOR ] := BD_BLACK // Задать цвет линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_SOLID // Задать тип линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты GraLine(oPS, { X0, Y_MaxW-LY }, { X_MaxW, Y_MaxW-LY } ) // Нарисовать линию вверху дендрограммы GraLine(oPS, { X0, Y0 }, { X_MaxW, Y0 } ) // Нарисовать линию внизу дендрограммы GraLine(oPS, { IndentLeft+mMaxlen+140, Y0 }, { IndentLeft+mMaxlen+140, Y_MaxW-LY } ) // Нарисовать вертикальную линию в конце надписей GraLine(oPS, { IndentLeft+mMaxlen+141, Y0 }, { IndentLeft+mMaxlen+141, Y_MaxW-LY } ) // Нарисовать вертикальную линию в конце надписей ***** Легенда ********************************* DO CASE CASE mFontSize = 1 oFont := XbpFont():new():create("6.Arial") CASE mFontSize = 2 oFont := XbpFont():new():create("8.Arial") CASE mFontSize = 3 oFont := XbpFont():new():create("10.Arial") CASE mFontSize = 4 oFont := XbpFont():new():create("12.Arial") OTHERWISE oFont := XbpFont():new():create("8.Arial") ENDCASE GraSetFont( oPS ,oFont ) aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты * StrFile(mClustAtr, '_ClustAtr-'+STRTRAN(STR(mNumMod,2),' ','0')+'.txt') // Запись текстового файла _ClustAtr-##.txt, где ##-номер модели mClustAtr = FileStr('_ClustAtr-'+STRTRAN(STR(mNumMod,2),' ','0')+'.txt') // Считывание текстового файла _ClustAtr-##.txt, где ##-номер модели AxName = "КЛАСТЕРНАЯ ФОРМУЛА: "+mClustAtr GraStringAt( oPS, { 20, LY-65 }, AxName ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_DARKRED GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты AxName = "Форма создана: "+DTOC(DATE())+"-"+TIME() GraStringAt( oPS, { X_MaxW - 300, LY-45 }, AxName ) ********************************************************* oFont := XbpFont():new():create("16.Times Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := BD_SILVER aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты AyName = '(С) Универсальная когнитивная аналитическая система "Эйдос-Х++"' aTxtPar = DC_GraQueryTextbox(AyName, oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов aMatrix := GraInitMatrix() IF LEN(AyName) < 70 // Длина наименования оси Y меньше высоты изображения aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraRotate( oPS, aMatrix, 90, { X_MaxW-30, Y0+Y_MaxW/2-LY }, GRA_TRANSFORM_ADD ) // <<<########## oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) // <<<########## GraStringAt( oPS, { X_MaxW-30, Y0+Y_MaxW/2-LY }, AyName ) // Надпись оси Y ELSE // Писать наименование с начала изображения aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraRotate( oPS, aMatrix, 90, { X_MaxW-30, 10 }, GRA_TRANSFORM_ADD ) // <<<########## oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) // <<<########## GraStringAt( oPS, { X_MaxW-30, 10 }, AyName ) // Надпись оси Y ENDIF ****** Не получается отключить режим вращения изображения ****** Вместо отключения можно докрутить до 360 градусов aMatrix := GraInitMatrix() // <<<########## GraRotate( oPS, aMatrix, 0, {X_MaxW, Y_MaxW}, GRA_TRANSFORM_REPLACE ) // <<<########## oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) // <<<########## ********* Записать файл изображения в папке AtrClustTree DC_Impl(oScrn2) IF mPar = 'Screen' DIRCHANGE(M_PathAppl+"\AtrClustTree\") // Перейти в папку AtrClustTree cFileName = "ClustAtr"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+".bmp" ERASE(cFileName) DC_Scrn2ImageFile( oStatic1, cFileName ) ENDIF IF mPar = 'File' ****** Запись полноразмерного графического файла в папку: M_PathAppl+"\AtrClustTree\" DIRCHANGE(M_PathAppl+"\AtrClustTree\") // Перейти в папку AtrClustTree cFileName = "ClustAtr"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+".jpg" ERASE(cFileName) oBMP:SaveFile(cFileName,XBPBMP_FORMAT_JPG) IF nWidth > 1800 FullView( cFileName, "по верху", 65 ) // Визуализация полноразмерного файла на мониторе высокого разрешения ELSE ****** Формирование с помощью bmp2bmp() и отображение масштабированного изображения aNewSize := {nWidth,nHeight-29} // Новый размер изображения (еще немного уменьшается, чтобы не рисовать по панели задач) oBMP:loadFile(cFileName) // Загрузка полноразмерного изображения oRet := BMP2BMP(oBMP,aNewSize) // Масштабирование изображения cFileNameScale = SUBSTR(cFileName,1,AT(".jpg",cFileName)-1)+"_scaled.jpg" ERASE(cFileNameScale) oRet:saveFile(cFileNameScale,XBPBMP_FORMAT_JPG) // Запись масштабированного графического файла в в папку приложения для визуализации FullView( cFileNameScale, "по верху", 0 ) // Визуализация масштабированного графического файла на мониторе ограниченного разрешения ENDIF ENDIF ***************************************************************************************** ********* ВЫВОД ГРАФИКА ИЗМЕНЕНИЙ МЕЖКЛАСТЕРНЫХ РАССТОЯНИЙ ****************************** ***************************************************************************************** oScrn2 := DC_WaitOn('Немного подождите! Идет формирование изображения в памяти и его масштабирование',,,,,,,,,,,.F.) ****** Текущая папка: c:\Aidos-X\AID_DATA\A0000001\System\AtrClustTree\ * DIRCHANGE(M_PathAppl) DIRCHANGE('..') ****** Сброс области рисования графика изменения межкластерных расстояний nColor = GraMakeRGBColor({ 255, 255, 255}) GraSetColor( oPS, nColor, nColor ) GraBox( oPS, { 0, 0 }, { X_MaxW, Y_MaxW }, GRA_FILL ) ***** Заголовок ******************************** oFont := XbpFont():new():create("20.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraStringAt( oPS, { X_MaxW/2, Y_MaxW-25 }, 'ИЗМЕНЕНИЕ МЕЖКЛАСТЕРНЫХ РАССТОЯНИЙ ПРИ КОГНИТИВНОЙ КЛАСТЕРИЗАЦИИ ПРИЗНАКОВ В МОДЕЛИ: "'+UPPER(Ar_Model[mNumMod])+'"') oFont := XbpFont():new():create("18.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) IF LEN(ALLTRIM(M_NameAppl)) < 70 GraStringAt( oPS, { X_MaxW/2, Y_MaxW-50 }, "Приложение: "+'"'+ALLTRIM(M_NameAppl)+'"' ) ELSE GraStringAt( oPS, { X_MaxW/2, Y_MaxW-50 }, '"'+ALLTRIM(M_NameAppl)+'"' ) ENDIF SELECT TreeAtr SET FILTER TO HIERARCHY > 0 * INDEX ON STR(Ur_razlIsh,15,7) TO ('TreeAtr') INDEX ON STR(Ur_razl ,15,7) TO ('TreeAtr') // Сортировка в соответствии с исправленным уровнем различий mNumClust := {} // Массив номеров кластеров mDisClust := {} // Массив исходных межкластерных расстояний aUrRazl := {} // Массив исходных межкластерных расстояний DBGOTOP() DO WHILE .NOT. EOF() AADD(mNumClust, NUM_PP) * AADD(mDisClust, Ur_razlIsh) * AADD(aUrRazl , Ur_razlIsh) AADD(mDisClust, Ur_razl ) AADD(aUrRazl , Ur_razl ) DBSKIP(1) ENDDO Dx = 100 Dy = Y0 Kx = (X_MaxW-2*Dx)/n // Нормирование по X Ky = (Y_MaxW-2*LY)/(aUrRazl[n]-aUrRazl[1]) // Нормирование по Y aAttr [ GRA_AL_COLOR ] := BD_BLACK // Задать цвет линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_SOLID // Задать тип линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты GraLine(oPS, { Dx, Y_MaxW-LY }, { X_MaxW-Dx, Y_MaxW-LY } ) // Линия вверху графика GraLine(oPS, { Dx, Y0 }, { X_MaxW-Dx, Y0 } ) // Ось X GraLine(oPS, { Dx, Y0 }, { Dx, Y_MaxW-LY } ) // Ось Y GraLine(oPS, { X_MaxW-Dx, Y0 }, { X_MaxW-Dx, Y_MaxW-LY } ) // Правая граница графика **** Пунктирные линии по значениям X // ############################# aAttrM := ARRAY( GRA_AM_COUNT ) // Массив для атрибутов маркеров aAttrM [ GRA_AM_SYMBOL ] := GRA_MARKSYM_DOT aAttrM [ GRA_AM_COLOR ] := GraMakeRGBColor({ 255, 128, 128}) // Задать цвет точки GraSetAttrMarker( oPS, aAttrM ) j=1 DBGOTOP() DO WHILE .NOT. EOF() j++ x = Dx + (j-1)*Kx FOR y=Y0 TO Y_MaxW-LY STEP 3 // Рисование вертикальной пунктирной линии GraMarker( oPS, { x, y } ) NEXT DBSKIP(1) ENDDO ***** Рисование графика межкластерных расстояний *************************************************** ***** Сделать рисование линий двух цветов, внутри посветлее, а снаружи потемнее (эффект объема) ***** для этого рисовать от внешних частей линии к внутренним уменьшающейся толщиной линии и более светлым цветом ПОВЕРХ РАНЕЕ НАРИСОВАННОГО aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DOT aAttr [ GRA_AL_COLOR ] := aColor[181] // Задать цвет снаружи линии aAttr [ GRA_AL_WIDTH ] := 5 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты j=1 DBGOTOP() DBSKIP(1) DO WHILE .NOT. EOF() j++ x1 = Dx+(j-1)*Kx y1 = Dy+(aUrRazl[j-1]-aUrRazl[1])*Ky x2 = Dx+(j )*Kx y2 = Dy+(aUrRazl[j ]-aUrRazl[1])*Ky GraLine(oPS, { x1,y1 }, { x2,y2 } ) DBSKIP(1) ENDDO aAttr [ GRA_AL_COLOR ] := aColor[108] // Задать цвет внутри линии aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты j=1 DBGOTOP() DBSKIP(1) DO WHILE .NOT. EOF() j++ x1 = Dx+(j-1)*Kx y1 = Dy+(aUrRazl[j-1]-aUrRazl[1])*Ky x2 = Dx+(j )*Kx y2 = Dy+(aUrRazl[j ]-aUrRazl[1])*Ky GraLine(oPS, { x1,y1 }, { x2,y2 } ) DBSKIP(1) ENDDO aAttr [ GRA_AL_COLOR ] := aColor[180] // Задать цвет внутри линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты j=1 DBGOTOP() DBSKIP(1) DO WHILE .NOT. EOF() j++ x1 = Dx+(j-1)*Kx y1 = Dy+(aUrRazl[j-1]-aUrRazl[1])*Ky x2 = Dx+(j )*Kx y2 = Dy+(aUrRazl[j ]-aUrRazl[1])*Ky GraLine(oPS, { x1,y1 }, { x2,y2 } ) DBSKIP(1) ENDDO ***** Надписи значений по осям X // Написать здесь номера кластеров в том же порядке, в каком в таблице на рисунке DO CASE CASE mFontSize = 1 oFont := XbpFont():new():create("6.Arial") CASE mFontSize = 2 oFont := XbpFont():new():create("8.Arial") CASE mFontSize = 3 oFont := XbpFont():new():create("10.Arial") CASE mFontSize = 4 oFont := XbpFont():new():create("12.Arial") OTHERWISE oFont := XbpFont():new():create("8.Arial") ENDCASE GraSetFont( oPS ,oFont ) aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты j=1 DBGOTOP() DBSKIP(1) DO WHILE .NOT. EOF() j++ x = Dx + (j-1)*Kx GraStringAt( oPS, { x, LY-20 }, ALLTRIM(STR(mNumClust[j-1],4)) ) DBSKIP(1) ENDDO j++ x = Dx + (j-1)*Kx GraStringAt( oPS, { x, LY-20 }, ALLTRIM(STR(mNumClust[j-1],4)) ) **** Надписи по оси Y и пунктир oFont := XbpFont():new():create("12.Arial") GraSetFont( oPS ,oFont ) aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты Ky = (Y_MaxW-2*LY) / 9 // Нормировочный коэффициент для координат Zy = (mDisClust[n]-mDisClust[1])/9 FOR j = 1 TO 10 x = Dx - 60 y = Y0 + (j-1)*Ky GraStringAt( oPS, { x, y }, ALLTRIM(STR(mDisClust[1]+(j-1)*Zy,15,2)) ) FOR x=Dx TO X_MaxW-Dx STEP 3 // Рисование горизонтальной пунктирной линии GraMarker( oPS, { x, y } ) NEXT NEXT ***** Легенда ****************************************** oFont := XbpFont():new():create("10.Arial Bold") GraSetFont( oPS ,oFont ) aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты ********************************************************* ***** Вывод таблички с данными о кластерах ************** ********************************************************* DBGOBOTTOM() s = 1 y = Y_MaxW-LY-9 //###################### * aTxtPar = DC_GraQueryTextbox(ALLTRIM(NAMEAtr_FU), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов mNameClustFu = FileStr(M_PathAppl+"\AtrClustTree\NameAtrF"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+"-"+STRTRAN(STR(KodAtrNew,5)," ","0")+".txt") // Считывание текстового файла NameAtrF-##-#####.txt, где ##-номер модели, #####-KodAtrNew aTxtPar = DC_GraQueryTextbox(ALLTRIM(mNameClustFu), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов aTxtPar[1] = IF(aTxtPar[1] <= 1300, aTxtPar[1], 1300) // Если межкластерные расстояния не помещаются из-за длинных наименований кластеров - все равно их писать поверх mMaxlen = MAX(mMaxlen, aTxtPar[1]) GraStringAt( oPS, { Dx*1.5 , y }, '№' ) GraStringAt( oPS, { Dx*1.5+40, y }, 'Наим.кластера в кодах исх.признаков' ) DO CASE CASE mFontSize = 1 oFont := XbpFont():new():create("6.Arial") GraStringAt( oPS, { Dx*1.5+100+aTxtPar[1], y }, 'Расстояние между кластерами' ) CASE mFontSize = 2 oFont := XbpFont():new():create("8.Arial") GraStringAt( oPS, { Dx*1.5+150+aTxtPar[1], y }, 'Расстояние между кластерами' ) CASE mFontSize = 3 oFont := XbpFont():new():create("10.Arial") GraStringAt( oPS, { Dx*1.5+250+aTxtPar[1], y }, 'Расстояние между кластерами' ) CASE mFontSize = 4 oFont := XbpFont():new():create("12.Arial") GraStringAt( oPS, { Dx*1.5+450+aTxtPar[1], y }, 'Расстояние между кластерами' ) OTHERWISE oFont := XbpFont():new():create("8.Arial") GraStringAt( oPS, { Dx*1.5+150+aTxtPar[1], y }, 'Расстояние между кластерами' ) ENDCASE GraSetFont( oPS ,oFont ) aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты * aTxtPar = DC_GraQueryTextbox(ALLTRIM(NAMEAtr_FU), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов mNameClustFu = FileStr(M_PathAppl+"\AtrClustTree\NameAtrF"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+"-"+STRTRAN(STR(KodAtrNew,5)," ","0")+".txt") // Считывание текстового файла NameAtrF-##-#####.txt, где ##-номер модели, #####-KodAtrNew aTxtPar = DC_GraQueryTextbox(ALLTRIM(mNameClustFu), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов aTxtPar[1] = IF(aTxtPar[1] <= 1300, aTxtPar[1], 1300) // Если межкластерные расстояния не помещаются из-за длинных наименований кластеров - все равно их писать поверх mMaxlen = MAX(mMaxlen, aTxtPar[1]) mInterval = (Y_MaxW - 2 * LY - 10) / (LEN(aClustAtrNum) + 1) // Межстрочный интервал в пикселях. Сделать его расчет * 10, чтобы текст не шел по рамке mInterval = IF( mInterval < aTxtPar[2]+3, mInterval, aTxtPar[2]+3 ) // Если межстрочный интервал большой, т.к. мало кластеров, то делать его по размеру шрифта, а иначе вписывать таблицу в форму y = y - 5 DBGOTOP() DO WHILE .NOT. EOF() y = y - mInterval GraStringAt( oPS, { Dx*1.5 , y }, ALLTRIM(STR(NUM_PP,4)) ) * GraStringAt( oPS, { Dx*1.5+40 , y }, ALLTRIM(NAMEAtr_FU) ) mNameClustFu = FileStr(M_PathAppl+"\AtrClustTree\NameAtrF"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+"-"+STRTRAN(STR(KodAtrNew,5)," ","0")+".txt") // Считывание текстового файла NameAtrF-##-#####.txt, где ##-номер модели, #####-KodAtrNew GraStringAt( oPS, { Dx*1.5+40 , y }, ALLTRIM(mNameClustFu) ) DO CASE CASE mFontSize = 1 GraStringAt( oPS, { Dx*1.5+100+aTxtPar[1], y }, ALLTRIM(STR(UR_RAZL,15,2)) ) CASE mFontSize = 2 GraStringAt( oPS, { Dx*1.5+150+aTxtPar[1], y }, ALLTRIM(STR(UR_RAZL,15,2)) ) CASE mFontSize = 3 GraStringAt( oPS, { Dx*1.5+250+aTxtPar[1], y }, ALLTRIM(STR(UR_RAZL,15,2)) ) CASE mFontSize = 4 GraStringAt( oPS, { Dx*1.5+450+aTxtPar[1], y }, ALLTRIM(STR(UR_RAZL,15,2)) ) OTHERWISE GraStringAt( oPS, { Dx*1.5+150+aTxtPar[1], y }, ALLTRIM(STR(UR_RAZL,15,2)) ) ENDCASE DBSKIP(1) ENDDO oFont := XbpFont():new():create("10.Arial Bold") GraSetFont( oPS ,oFont ) aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты y = y - 20 SET ORDER TO DO CASE CASE mFontSize = 1 oFont := XbpFont():new():create("6.Arial") CASE mFontSize = 2 oFont := XbpFont():new():create("8.Arial") CASE mFontSize = 3 oFont := XbpFont():new():create("10.Arial") CASE mFontSize = 4 oFont := XbpFont():new():create("12.Arial") OTHERWISE oFont := XbpFont():new():create("8.Arial") ENDCASE GraSetFont( oPS ,oFont ) aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты * StrFile(mClustAtr, '_ClustAtr-'+STRTRAN(STR(mNumMod,2),' ','0')+'.txt') // Запись текстового файла _ClustAtr-##.txt, где ##-номер модели mClustAtr = FileStr('_ClustAtr-'+STRTRAN(STR(mNumMod,2),' ','0')+'.txt') // Считывание текстового файла _ClustAtr-##.txt, где ##-номер модели AxName = "КЛАСТЕРНАЯ ФОРМУЛА: "+mClustAtr GraStringAt( oPS, { 20, LY-65 }, AxName ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_DARKRED GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты AxName = "Форма создана: "+DTOC(DATE())+"-"+TIME() GraStringAt( oPS, { X_MaxW - 300, LY-45 }, AxName ) ***** Надпись наименования шкалы X oFont := XbpFont():new():create("12.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты AxName = 'Номера кластеров' aTxtPar = DC_GraQueryTextbox(AxName, oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов IF LEN(AxName) < 140 // Длина наименования оси X меньше ширины изображения aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraStringAt( oPS, { X_MaxW/2, LY-45}, AxName ) // Надпись оси Х ELSE aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraStringAt( oPS, { 50, LY-45}, AxName ) // Надпись оси Х ENDIF ***** Надпись наименования шкалы Y (с поворотом на 90 градусов) oFont := XbpFont():new():create("12.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты AyName = 'Межкластерные расстояния' aTxtPar = DC_GraQueryTextbox(AyName, oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов aMatrix := GraInitMatrix() IF LEN(AyName) < 70 // Длина наименования оси Y меньше высоты изображения aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraRotate( oPS, aMatrix, 90, { 15, Y0+Y_MaxW/2-LY }, GRA_TRANSFORM_ADD ) // <<<########## oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) // <<<########## GraStringAt( oPS, { 15, Y0+Y_MaxW/2-LY }, AyName ) // Надпись оси Y ELSE // Писать наименование с начала изображения aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraRotate( oPS, aMatrix, 90, { 15, 10 }, GRA_TRANSFORM_ADD ) // <<<########## oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) // <<<########## GraStringAt( oPS, { 15, 10 }, AyName ) // Надпись оси Y ENDIF ********************************************************* oFont := XbpFont():new():create("16.Times Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := BD_SILVER aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты AyName = '(С) Универсальная когнитивная аналитическая система "Эйдос-Х++"' aTxtPar = DC_GraQueryTextbox(AyName, oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов aMatrix := GraInitMatrix() IF LEN(AyName) < 70 // Длина наименования оси Y меньше высоты изображения aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraRotate( oPS, aMatrix, 90, { X_MaxW-40, Y0+Y_MaxW/2-LY }, GRA_TRANSFORM_ADD ) // <<<########## oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) // <<<########## GraStringAt( oPS, { X_MaxW-40, Y0+Y_MaxW/2-LY }, AyName ) // Надпись оси Y ELSE // Писать наименование с начала изображения aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraRotate( oPS, aMatrix, 90, { X_MaxW-40, 10 }, GRA_TRANSFORM_ADD ) // <<<########## oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) // <<<########## GraStringAt( oPS, { X_MaxW-40, 10 }, AyName ) // Надпись оси Y ENDIF ****** Не получается отключить режим вращения изображения ****** Вместо отключения можно докрутить до 360 градусов aMatrix := GraInitMatrix() // <<<########## GraRotate( oPS, aMatrix, 0, {X_MaxW, Y_MaxW}, GRA_TRANSFORM_REPLACE ) // <<<########## oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) // <<<########## ********* Рамка рисунка ******************************** aAttr [ GRA_AL_COLOR ] := BD_BLACK // Задать цвет линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_SOLID // Задать тип линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты GraLine(oPS, { Dx, Y_MaxW-LY }, { X_MaxW-Dx, Y_MaxW-LY } ) // Линия вверху графика GraLine(oPS, { Dx, Y0 }, { X_MaxW-Dx, Y0 } ) // Ось X GraLine(oPS, { Dx, Y0 }, { Dx, Y_MaxW-LY } ) // Ось Y GraLine(oPS, { X_MaxW-Dx, Y0 }, { X_MaxW-Dx, Y_MaxW-LY } ) // Правая граница графика ********* Записать файл изображения в папке AtrClustTree DC_Impl(oScrn2) IF mPar = 'Screen' DIRCHANGE(M_PathAppl+"\AtrClustTree\") // Перейти в папку AtrClustTree cFileName = "ClustAtrDist"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+".bmp" ERASE(cFileName) DC_Scrn2ImageFile( oStatic1, cFileName ) ENDIF IF mPar = 'File' ****** Запись полноразмерного графического файла в папку: M_PathAppl+"\AtrClustTree\" * DC_ASave(mNumMod , "_NumMod.arx") mNumMod = DC_ARestore("_NumMod.arx") DIRCHANGE(M_PathAppl+"\AtrClustTree\") // Перейти в папку AtrClustTree cFileName = "ClustAtrDist"+"-"+STRTRAN(STR(mNumMod,2)," ","0")+".jpg" ERASE(cFileName) oBMP:SaveFile(cFileName,XBPBMP_FORMAT_JPG) IF nWidth > 1800 FullView( cFileName, "по верху", 65 ) ELSE ****** Формирование с помощью bmp2bmp() и отображение масштабированного изображения aNewSize := {nWidth,nHeight-29} // Новый размер изображения (еще немного уменьшается, чтобы не рисовать по панели задач) oBMP:loadFile(cFileName) // Загрузка полноразмерного изображения oRet := BMP2BMP(oBMP,aNewSize) // Масштабирование изображения cFileNameScale = SUBSTR(cFileName,1,AT(".jpg",cFileName)-1)+"_scaled.jpg" ERASE(cFileNameScale) oRet:saveFile(cFileNameScale,XBPBMP_FORMAT_JPG) // Запись масштабированного графического файла в в папку приложения для визуализации FullView( cFileNameScale, "по верху", 0 ) // Визуализация масштабированного графического файла на мониторе ограниченного разрешения ENDIF ENDIF ****** Текущая папка: c:\Aidos-X\AID_DATA\A0000001\System\AtrClustTree\ * DIRCHANGE(M_PathAppl) DIRCHANGE('..') RETURN NIL ****************************************************************************************** FUNCTION F5_15() LB_Warning(L('Сейчас будут показаны HELP различных режимов'), L('(C) Система "Эйдос"')) F6_1() Help_LW13() Help_OiRo() Help12() Help13() Help13web() Help14() Help15() Help21() Help21Serv() Help21win1() Help21win2() Help22() Help231() Help2321() Help2322dbf() Help2322xls() Help2323() Help2324() Help2326() Help2327() Help2328() Help35() Help371() Help374() Help375() Help376() Help377() Help378() Help411() Help41311() Help4131a() Help4131b() Help4132a() Help4132b() Help4136() Help4161() Help4162() Help4163() Help4164() Help4165() Help4166() Help421() Help422() Help4223() Help423() Help431() Help4323() Help433() Help448() Help449() Help44A() Help44B() Help47() Help48() Help48CognFun() Help513() Help69() HelpASCAimages() HelpLW209() SaveLangDB() // Создание и запись русской и не русской языковых баз данных на основе языковых массивов F7() LB_Warning(L('Информация из всех help`s занесена в русскую языковую базу'), L('(C) Система "Эйдос"')) RETURN NIL ****************************************************************************************** ******** Запись скриншота активного окна в виде файла. ******** Joined: Thu Jan 28, 2010 10:59 am, Posts: 667, Location: Berlin, Germany, Tom ******* http://bb.donnay-software.com/donnay/viewtopic.php?f=2&t=2401&sid=4855442dd13ea455a60bad9915ac4054 ****************************************************************************************** FUNCTION SaveScreenAsFile(mXSize,mYSize,cFileName) // hand over filename you want to use LOCAL oClipBoard, oPicture, nResolution := 30 DC_Scrn2Clipboard() oClipBoard := XbpClipBoard():new():create() oClipBoard:open() oPicture := oClipBoard:GetBuffer(XBPCLPBRD_BITMAP) *IF ::oClipBoard:open() * aFormats := ::oClipBoard:queryFormats() * IF ASCAN( aFormats, XBPCLPBRD_BITMAP ) > 0 oBuffer := ::oClipBoard:getBuffer( XBPCLPBRD_BITMAP ) // cut out part of bitmap oBMP := CutOutBMP( oBuffer, ::aoChild,mXSize,mYSize ) * ENDIF *ENDIF oClipBoard:Close() oPicture:SaveFile(cFileName,XBPBMP_FORMAT_JPG,nResolution) RETURN File(cFileName) ****************************************************************************************** FUNCTION CutOutBMP( oBuffer, aoChild,nOutSizeX,nOutSizeY ) // Jimmy LOCAL oOutBMP := XBPBITMAP() :New() :Create() LOCAL oMain := GetApplication() LOCAL oTargetPS := XBPPRESSPACE() :new() :create() *LOCAL nOutSizeX := SP_BMPxSize() *LOCAL nOutSizeY := SP_BMPySize() LOCAL aPos := { 0, 0 } LOCAL aSize := { 0, 0 } LOCAL aSize1 := { 0, 0 } nCYCAPTION := GetSystemMetrics( SM_CYCAPTION ) nCXBORDER := GetSystemMetrics( SM_CXBORDER ) nCYBORDER := GetSystemMetrics( SM_CYBORDER ) nCXDLGFRAME := GetSystemMetrics( SM_CXDLGFRAME ) nCYDLGFRAME := GetSystemMetrics( SM_CYDLGFRAME ) nCXPADDEDBORDER := GetSystemMetrics( SM_CXPADDEDBORDER ) // Pos / Size of Windows aPos := aoChild[ CH_LOGO ] :CurrentPos() aSize := aoChild[ CH_ANZEIG ] :CurrentSize() // parent of WMP // need to adjust position "inside" frame aPos[ 1 ] += 10 // oAnzeig aPos[ 2 ] += 10 // reduce bottom Size with statusbar aSize1 := aoChild[ CH_STATBAR ] :CurrentSize() aPos[ 2 ] += aSize1[ 2 ] // adjust Border wide aPos[ 1 ] += SP_CXBORDER() aPos[ 2 ] += SP_CYBORDER() // adjust Frame wide aPos[ 1 ] += SP_CXDLGFRAME() aPos[ 2 ] += SP_CYDLGFRAME() // still 1 Pixel missing aPos[ 1 ] += 1 aPos[ 2 ] += 1 IF OnOSVersion() > 5 // Vista-Win7 DWM Aero * aPos[1] += SP_CXPADDEDBORDER() // Border Padding ? * aPos[2] += SP_CXPADDEDBORDER() ENDIF * ------------------------------------------------------ * oOutBMP:presSpace( oTargetPS ) oOutBMP:make( nInSizeX, nInSizeY ) oBuffer:Draw( oTargetPS, ; // oTargetPS { 0, 0, nOutSizeX, nOutSizeY }, ; // aTargetRect { aPos[1], aPos[2], aPos[1] + aSize[1], aPos[2] + aSize[2] }, ; // aSourceRect GRA_BLT_ROP_SRCCOPY, ; // nRasterOP GRA_BLT_ROP_* GRA_BLT_BBO_IGNORE ) // nCompress GRA_BLT_BBO_* Sleep( 0 ) oTargetPS:destroy() Sleep( 0 ) oTargetPS := NIL RETURN oOutBMP ****************************************************************************************** FUNCTION SP_CYCAPTION( nValue ) // Caption height IF( PCOUNT() > 0, nCYCAPTION := nValue, NIL ) RETURN nCYCAPTION FUNCTION SP_CXBORDER( nValue ) // Border wide IF( PCOUNT() > 0, nCXBORDER := nValue, NIL ) RETURN nCXBORDER FUNCTION SP_CYBORDER( nValue ) // Border height IF( PCOUNT() > 0, nCYBORDER := nValue, NIL ) RETURN nCYBORDER FUNCTION SP_CXDLGFRAME( nValue ) // Dialog X-Frame IF( PCOUNT() > 0, nCXDLGFRAME := nValue, NIL ) RETURN nCXDLGFRAME FUNCTION SP_CYDLGFRAME( nValue ) // Dialog Y-Frame IF( PCOUNT() > 0, nCYDLGFRAME := nValue, NIL ) RETURN nCYDLGFRAME FUNCTION SP_CXPADDEDBORDER( nValue ) // Border Padding IF( PCOUNT() > 0, nCXPADDEDBORDER := nValue, NIL ) RETURN nCXPADDEDBORDER FUNCTION OnOSVersion() LOCAL cVersion := OS( OS_VERSION ) LOCAL nVersion := 0 LOCAL nPosi nPosi := AT( ".", cVersion ) IF nPosi > 0 nVersion := VAL( SUBSTR( cVersion, 1, nPosi - 1 ) ) ENDIF RETURN nVersion ************************************************************************************************** ******** 5.16. Минимизация инсталляции системы. Удаление из текущей инсталляции системы локальных ******** лабораторных работ, базы лемматизации, всех языковых баз, кроме текущей, а также CygWin, ******** обеспечивающей on-line генерацию языковых баз. В результате минимизации системы rar-архив ******** папки с системой будет уже не более 217 Мб, а около 45 Мб. ************************************************************************************************** FUNCTION F5_16() Running(.T.) IF .NOT. Flag_SysAdmin LB_Warning(L("Эта функция доступна только Сисадмину")) ELSE CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций oScr := DC_WaitOn(L('5.16. Минимизация инсталляции системы'),,,,,,,,,,,.F.) DIRCHANGE(Disk_dir) ** Удалить все языковые базы данных ************** N_All = ADIR("*lang*.*") PRIVATE aFileNameAll[N_All] ADIR("*lang*.*",aFileNameAll) // Имена ВСЕХ языковые базы данных FOR j=1 TO LEN(aFileNameAll) ERASE(aFileNameAll[j]) NEXT ** Создать все языковые базы данных ************** PUBLIC aLang_ru := {} // Массив для поиска русских текстовых элементов PUBLIC aLang_xx := {} // Массив для поиска нерусских текстовых элементов PUBLIC aNumUses := {} // Число использований j-го текстового элемента CreateDBLang() IF FILE('Lemma.dbf') ERASE('Lemma.dbf') ENDIF IF FILE('Lemma.ntx') ERASE('Lemma.ntx') ENDIF ZapDir('cygwin', .T.) DIRCHANGE(ALLTRIM(Disk_dir)+"\AID_DATA\") * ZapDir('Inp_data', .T.);DIRMAKE("Inp_data") ZapDir('LabWorks', .T.);DIRMAKE("LabWorks") * ZapDir('Screenshots', .T.);DIRMAKE("Screenshots") DIRCHANGE(Disk_dir) DC_Impl(oScr) aMess := {} AADD(aMess,L('5.16. Минимизация инсталляции системы завершена успешно! Было произведено удаление из текущей инсталляции системы "Эйдос"')) AADD(aMess,L('локальных лабораторных работ, базы лемматизации, всех языковых баз. В результате минимизации rar-архив папки с системой ')) AADD(aMess,L('будет уже не около 120 Мб, а примерно 40 Мб. При этом удалении ранее установленные приложения не затрагиваются. ')) AADD(aMess,L('Для удаления всех приложений служит специальный режим 1.11. ')) AADD(aMess,L('')) AADD(aMess,L('Все удаленное входит в полную инсталляцию, которую можно скачать с сайта автора: http://lc.kubagro.ru/aidos/_Aidos-X.htm ')) LB_Warning(aMess) ENDIF ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW Running(.F.) RETURN NIL ****************************************************************************************** FUNCTION Print_Window( nWindow, cFileName ) *LOCAL oInput := INPUT():New() // ot4xb Structure LOCAL nSize := oInput:_sizeof_() LOCAL nRet := 0 nWindow := IIF( EMPTY( nWindow ), 0, 1 ) // 0 is entire screen, 1 is active window sleep( 10 ) // deprecated, does not work under Windows 10 keybd_Event( VK_SNAPSHOT,nWindow,0,0) oInput:type := INPUT_KEYBOARD oInput:ki:wVk := VK_SNAPSHOT oInput:ki:wScan := nWindow oInput:ki:dwFlags := 0 oInput:ki:dwExtraInfo := 0 // now use SendInput API Function * nRet := @user32:SendInput( 1, oInput, nSize ) oInput:SaveFile(cFileName,XBPBMP_FORMAT_JPG,600) oInput:Close() RETURN nRet ************************************************************************************************************************************ ******** 4.1.9. Подготовка результатов распознавания в форме CSV-файлов в стандарте http://kaggle.com. ******** Данный режим предполагает, что: 1) в модели 2 класса; 2) результаты распознавания во всех моделях уже получены в режиме 3.5 ************************************************************************************************************************************ FUNCTION F4_1_9() Running(.T.) ********************************************************************** ******* Провести проверки на: ******* - наличие приложения; ******* - 2 класса в модели; ****** - наличие результатов распознавания во всех моделях; ****** - числовой результат распознавания; ******* с выдачей соответствующих сообщение. ******* Если все нормально - переход на выполнение. ******* Спросить сколько знаков после запятой включать. ******* Сообщить о том, что возможно нужно поменять название 1-го поля ********************************************************************** *********************************************** ******* Провести проверки на наличие приложения *********************************************** PUBLIC M_PathAppl := "", M_NameAppl := "", mFlagErr := .F., mFlagAppl :=.F. IF .NOT. FILE("Appls.dbf") mFlagErr = .T. // Выдать сообщение об ошибке и вернуться в главное меню aMess := {} AADD(aMess, L('Отсутствует текущее приложение !')) AADD(aMess, L('Надо создать его в режиме 2.3.2.2,')) AADD(aMess, L('1.3, 2.3.2.1 или в другом!')) LB_Warning(aMess, L('(C) System "Aidos-X++"' )) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW Running(.F.) RETURN NIL ELSE CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Appls EXCLUSIVE NEW SELECT Appls DBGOTOP() DO WHILE .NOT. EOF() IF LEN(ALLTRIM(By_default)) > 0 REPLACE By_default WITH "W" M_PathAppl = ALLTRIM(Path_Appl) // Путь на текущее приложение M_NameAppl = ALLTRIM(Name_Appl) mFlagAppl =.T. // Текущее приложение существует, его имя: M_NameAppl, путь на него: M_PathAppl EXIT ENDIF DBSKIP(1) ENDDO ENDIF IF mFlagAppl =.F. // Текущего приложения не существует mFlagErr = .T. // Выдать сообщение об ошибке и вернуться в главное меню aMess := {} AADD(aMess, L('Отсутствует текущее приложение !')) AADD(aMess, L('Надо создать его в режиме 2.3.2.2,')) AADD(aMess, L('1.3, 2.3.2.1 или в другом!')) LB_Warning(aMess, L('(C) System "Aidos-X++"' )) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW Running(.F.) RETURN NIL ENDIF ********************************************** ******* Провести проверки на 2 класса в модели ********************************************** DIRCHANGE(M_PathAppl) // Путь на текущее приложение CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций // <<<===############################################### line 49587 USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() IF N_Cls <> 2 mFlagErr = .T. // Выдать сообщение об ошибке и вернуться в главное меню aMess := {} AADD(aMess, L('В приложении:')) AADD(aMess, L(' ')) AADD(aMess, L('Наименование:')+' '+M_NameAppl) AADD(aMess, L('Путь:')+' '+M_PathAppl) AADD(aMess, L(' ')) AADD(aMess, ALLTRIM(STR(N_Cls))+' '+L('классов.')) AADD(aMess, L('А должно быть 2 (на Каггл бинарное распознавание)')) LB_Warning(aMess, L('(C) System "Aidos-X++"' )) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW Running(.F.) RETURN NIL ENDIF ****************************************************************************** ******* Провести проверки на наличие результатов распознавания во всех моделях ****************************************************************************** Ar_Model := {"Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } aRsp2 := {} FOR mNumModel = 1 TO LEN(Ar_Model) mNameRsp2i = 'Rsp2i_'+Ar_Model[mNumModel] mNameRsp2k = 'Rsp2k_'+Ar_Model[mNumModel] // ##################### mFlagRsp2 = .F. USE (mNameRsp2i) EXCLUSIVE NEW;mReccount_i = RECCOUNT() USE (mNameRsp2k) EXCLUSIVE NEW;mReccount_k = RECCOUNT() IF (.NOT. FILE(mNameRsp2i+'.dbf') .OR. .NOT. FILE(mNameRsp2k+'.dbf') ) .OR. (mReccount_i * mReccount_k) = 0 mFlagErr = .T. // Выдать сообщение об ошибке и вернуться в главное меню aMess := {} AADD(aMess, L('В приложении:')) AADD(aMess, L(' ')) AADD(aMess, L('Наименование:')+' '+M_NameAppl) AADD(aMess, L('Путь:')+' '+M_PathAppl) AADD(aMess, L(' ')) AADD(aMess, L('нет результатов распознавания во всех моделях и со всеми инт.критериями.')) AADD(aMess, L(' ')) AADD(aMess, L('Надо провести распознавание в режиме 3.5.')) LB_Warning(aMess, L('(C) System "Aidos-X++"' )) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW Running(.F.) RETURN NIL ENDIF NEXT **************************************************************************** ******* Провести проверки на то, что результат распознавания является числом **************************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() SELECT Classes DBGOTOP() DO WHILE .NOT. EOF() IF AT('{', Name_cls) * AT('}', Name_cls) = 0 mFlagErr = .T. // Выдать сообщение об ошибке и вернуться в главное меню aMess := {} AADD(aMess, L('В приложении:')) AADD(aMess, L(' ')) AADD(aMess, L('Наименование:')+' '+M_NameAppl) AADD(aMess, L('Путь:')+' '+M_PathAppl) AADD(aMess, L(' ')) AADD(aMess, L('классы должны быть интервальными числовыми значениями')) AADD(aMess, L('(классификационная шкала должна быть числовой!)')) LB_Warning(aMess, L('(C) System "Aidos-X++"' )) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW Running(.F.) RETURN NIL ENDIF DBSKIP(1) ENDDO ****************************************************** ******* Спросить сколько знаков после запятой включать ****************************************************** mDeci = 1 @0,0 DCSAY L('Задайте число знаков после запятой: ') GET mDeci PICTURE "##" SAYSIZE 0 DCREAD GUI FIT ADDBUTTONS TITLE L('4.1.9. Подготовка результатов для http://kaggle.com') mDeci = IF(mDeci<=15,mDeci,15) oScr := DC_WaitOn(L('4.1.9. Подготовка результатов распознавания в форме CSV-файлов стандарта http://kaggle.com'),,,,,,,,,,,.F.) ******* Удалить старые версии файлов ****** mCountF = ADIR("Kaggle*.*") // Кол-во файлов для Kaggle IF mCountF > 0 PRIVATE aFileN[mCountF], aFileS[mCountF] // Имена и размеры файлов ADIR("Kaggle_*.DBF", aFileN, aFileS) FOR j=1 TO mCountF ERASE(aFileN[j]) NEXT ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() IF N_Cls = 2 SELECT Classes mNameCls1 = ALLTRIM(Name_cls) DBSKIP(1) mNameCls2 = ALLTRIM(Name_cls) ***** Структура создаваемой базы *********** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций Ar_Model := {"Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } aRsp2i := {} aRsp2k := {} aKaggle_i := {} aKaggle_k := {} FOR mNumModel = 1 TO LEN(Ar_Model) mNameRsp2i = 'Rsp2i_'+Ar_Model[mNumModel] mNameRsp2k = 'Rsp2k_'+Ar_Model[mNumModel] // ##################### IF FILE(mNameRsp2i+'.dbf') .AND. FILE(mNameRsp2k+'.dbf') AADD(aRsp2i , mNameRsp2i) AADD(aRsp2k , mNameRsp2k) AADD(aKaggle_i, 'Kaggle_'+Ar_Model[mNumModel]+'i') AADD(aKaggle_k, 'Kaggle_'+Ar_Model[mNumModel]+'k') ENDIF NEXT IF LEN(aRsp2i) * LEN(aRsp2k) > 0 mMaxLen = -999 FOR ik = 1 TO LEN(aRsp2i) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (aRsp2i[ik]) EXCLUSIVE NEW SELECT (aRsp2i[ik]) DBGOTOP() DO WHILE .NOT. EOF() mMaxLen = MAX(mMaxLen, LEN(ALLTRIM(Name_obj))) DBSKIP(1) ENDDO NEXT FOR ik = 1 TO LEN(aRsp2k) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (aRsp2k[ik]) EXCLUSIVE NEW SELECT (aRsp2k[ik]) DBGOTOP() DO WHILE .NOT. EOF() mMaxLen = MAX(mMaxLen, LEN(ALLTRIM(Name_obj))) DBSKIP(1) ENDDO NEXT aStructure := { { "id" , "C",mMaxLen, 0},; // 1 id фрагмента текста из тестовой выборки { "ProbN1" , "N", 15, 7},; // 2 Нормированная (итоговая) релевантность объекта с классом 1 { "ProbN2" , "N", 15, 7},; // 3 Нормированная (итоговая) релевантность объекта с классом 2 { "Prob1" , "N", 15, 7},; // 4 Релевантность объекта с классом 1 = mKorr1 - mKorr2 { "Prob2" , "N", 15, 7},; // 5 Релевантность объекта с классом 2 = mKorr2 - mKorr1 { "UrSx_Cls1", "N", 15, 7},; // 6 Ур.сходства объекта с классом 1, который дает система Эйдос { "UrSx_Cls2", "N", 15, 7} } // 7 Ур.сходства объекта с классом 2, который дает система Эйдос FOR mNumModel = 1 TO LEN(Ar_Model) mNameRsp2i = 'Rsp2i_'+Ar_Model[mNumModel] mNameRsp2k = 'Rsp2k_'+Ar_Model[mNumModel] // ################ IF FILE(mNameRsp2i+'.dbf') DbCreate( 'Kaggle_'+Ar_Model[mNumModel]+'i', aStructure ) ENDIF IF FILE(mNameRsp2k+'.dbf') DbCreate( 'Kaggle_'+Ar_Model[mNumModel]+'k', aStructure ) ENDIF NEXT FOR ik = 1 TO LEN(aRsp2i) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (aRsp2i[ik]) EXCLUSIVE NEW INDEX ON NAME_OBJ+NAME_CLS TO (aRsp2i[ik]) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (aRsp2i[ik]) INDEX (aRsp2i[ik]) EXCLUSIVE NEW USE (aKaggle_i[ik]) EXCLUSIVE NEW mKorr1Max = -9999 // Max.знач.ур.сходства с классом 1 mKorr1Min = +9999 // Min.знач.ур.сходства с классом 1 mKorr2Max = -9999 // Max.знач.ур.сходства с классом 2 mKorr2Min = +9999 // Min.знач.ур.сходства с классом 2 mClass1Sum = 0 mClass2Sum = 0 SELECT (aRsp2i[ik]) DBGOTOP() mIdErr = '' // Отсутствующие id mIdOld = VAL(Name_obj) DO WHILE .NOT. EOF() mID = ALLTRIM(Name_obj) mKorr1 = Sum_inf // ################ DBSKIP(1) mKorr2 = Sum_inf // ################ mClass1Sum = mClass1Sum + mKorr1 mClass2Sum = mClass2Sum + mKorr2 // mKorr1 уровень сходства с классом: "есть описание суицида" // mKorr2 уровень сходства с классом: "нет описания суицида" SELECT (aKaggle_i[ik]) APPEND BLANK mProb1 = mKorr1 - mKorr2 // Не знаю как лучше. Раньше думал, что в зависмости от суммы, но теперь не знаю. Может быть брать из той колонки, для котрой выше ср.кв.откл.? mProb2 = mKorr2 - mKorr1 REPLACE id WITH mID REPLACE prob1 WITH mProb1 REPLACE prob2 WITH mProb2 REPLACE UrSx_Cls1 WITH mKorr1 REPLACE UrSx_Cls2 WITH mKorr2 mKorr1Max = MAX(mKorr1Max, mProb1) mKorr1Min = MIN(mKorr1Min, mProb1) mKorr2Max = MAX(mKorr2Max, mProb2) mKorr2Min = MIN(mKorr2Min, mProb2) SELECT (aRsp2i[ik]) DBSKIP(1) ENDDO ****** Сделать нормировку prob к 1-0 SELECT (aKaggle_i[ik]) DBGOTOP() DO WHILE .NOT. EOF() REPLACE ProbN1 WITH (Prob1 - mKorr1Min) / (mKorr1Max - mKorr1Min) // Нормированная (итоговая) релевантность объекта с классом 1 REPLACE ProbN2 WITH (Prob2 - mKorr2Min) / (mKorr2Max - mKorr2Min) // Нормированная (итоговая) релевантность объекта с классом 2 DBSKIP(1) ENDDO NEXT FOR ik = 1 TO LEN(aRsp2k) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (aRsp2k[ik]) EXCLUSIVE NEW INDEX ON NAME_OBJ+NAME_CLS TO (aRsp2k[ik]) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (aRsp2k[ik]) INDEX (aRsp2k[ik]) EXCLUSIVE NEW USE (aKaggle_k[ik]) EXCLUSIVE NEW mKorr1Max = -9999 // Max.знач.ур.сходства с классом 1 mKorr1Min = +9999 // Min.знач.ур.сходства с классом 1 mKorr2Max = -9999 // Max.знач.ур.сходства с классом 2 mKorr2Min = +9999 // Min.знач.ур.сходства с классом 2 mClass1Sum = 0 mClass2Sum = 0 SELECT (aRsp2k[ik]) DBGOTOP() mIdErr = '' // Отсутствующие id mIdOld = VAL(Name_obj) DO WHILE .NOT. EOF() mID = ALLTRIM(Name_obj) mKorr1 = Korr // ################ DBSKIP(1) mKorr2 = Korr // ################ mClass1Sum = mClass1Sum + mKorr1 mClass2Sum = mClass2Sum + mKorr2 // mKorr1 уровень сходства с классом: 1 // mKorr2 уровень сходства с классом: 2 SELECT (aKaggle_k[ik]) APPEND BLANK mProb1 = mKorr1 - mKorr2 mProb2 = mKorr2 - mKorr1 REPLACE id WITH mID REPLACE prob1 WITH mProb1 REPLACE prob2 WITH mProb2 REPLACE UrSx_Cls1 WITH mKorr1 REPLACE UrSx_Cls2 WITH mKorr2 mKorr1Max = MAX(mKorr1Max, mProb1) mKorr1Min = MIN(mKorr1Min, mProb1) mKorr2Max = MAX(mKorr2Max, mProb2) mKorr2Min = MIN(mKorr2Min, mProb2) SELECT (aRsp2k[ik]) DBSKIP(1) ENDDO SELECT (aKaggle_k[ik]) DBGOTOP() DO WHILE .NOT. EOF() REPLACE ProbN1 WITH (Prob1 - mKorr1Min) / (mKorr1Max - mKorr1Min) // Нормированная (итоговая) релевантность объекта с классом 1 REPLACE ProbN2 WITH (Prob2 - mKorr2Min) / (mKorr2Max - mKorr2Min) // Нормированная (итоговая) релевантность объекта с классом 2 DBSKIP(1) ENDDO NEXT ENDIF ENDIF mCountF = ADIR("Kaggle_*.DBF") // Кол-во TXT-файлов IF mCountF > 0 PRIVATE aFileName[mCountF], aFileSize[mCountF] // Имена и размеры файлов ADIR("Kaggle_*.DBF", aFileName, aFileSize) FOR ff=1 TO mCountF mFileName = SUBSTR(aFileName[ff], 1, AT('.',aFileName[ff])-1) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mFileName) EXCLUSIVE NEW SELECT (mFileName) ********** Открыть процесс печати выходной формы set device to printer;set printer on;set printer to (mFileName+'_1.csv');set console off // Можно брать в другой файл из ProbN1 ??'SK_ID_CURR,TARGET' DBGOTOP() DO WHILE .NOT. EOF() ?ALLTRIM(ID)+','+ALLTRIM(STR(ROUND(ProbN1,mDeci))) // Можно брать в другой файл из ProbN1 DBSKIP(1) ENDDO ********** Закрыть процесс печати выходной формы Set device to screen;Set printer off;Set printer to;Set console on ********** Открыть процесс печати выходной формы set device to printer;set printer on;set printer to (mFileName+'_2.csv');set console off // Можно брать в другой файл из ProbN1 ??'SK_ID_CURR,TARGET' DBGOTOP() DO WHILE .NOT. EOF() ?ALLTRIM(ID)+','+ALLTRIM(STR(ROUND(ProbN2,mDeci))) // Можно брать в другой файл из ProbN1 DBSKIP(1) ENDDO ********** Закрыть процесс печати выходной формы Set device to screen;Set printer off;Set printer to;Set console on NEXT DC_Impl(oScr) aMess := {} AADD(aMess,L('4.1.9. Подготовка результатов распознавания в форме CSV-файлов стандарта http://kaggle.com завершена успешно!')) AADD(aMess,L('')) AADD(aMess,L('Результаты распознавания находятся в папке: "'+M_PathAppl+'" в файлах:')) AADD(aMess,L('')) AADD(aMess,L('Kaggle_Inf1i_1.csv, Kaggle_Inf2i_1.csv, Kaggle_Inf3i_1.csv, Kaggle_Inf4i_1.csv, Kaggle_Inf5i_1.csv, Kaggle_Inf6i_1.csv, Kaggle_Inf7i_1.csv, Kaggle_Prc1i_1.csv, Kaggle_Prc2i_1.csv')) AADD(aMess,L('Kaggle_Inf1i_2.csv, Kaggle_Inf2i_2.csv, Kaggle_Inf3i_2.csv, Kaggle_Inf4i_2.csv, Kaggle_Inf5i_2.csv, Kaggle_Inf6i_2.csv, Kaggle_Inf7i_2.csv, Kaggle_Prc1i_2.csv, Kaggle_Prc2i_2.csv')) AADD(aMess,L('')) AADD(aMess,L('Kaggle_Inf1k_1.csv, Kaggle_Inf2k_1.csv, Kaggle_Inf3k_1.csv, Kaggle_Inf4k_1.csv, Kaggle_Inf5k_1.csv, Kaggle_Inf6k_1.csv, Kaggle_Inf7k_1.csv, Kaggle_Prc1k_1.csv, Kaggle_Prc2k_1.csv')) AADD(aMess,L('Kaggle_Inf1k_2.csv, Kaggle_Inf2k_2.csv, Kaggle_Inf3k_2.csv, Kaggle_Inf4k_2.csv, Kaggle_Inf5k_2.csv, Kaggle_Inf6k_2.csv, Kaggle_Inf7k_2.csv, Kaggle_Prc1k_2.csv, Kaggle_Prc2k_2.csv')) AADD(aMess,L('')) AADD(aMess,L('Если в модели бинарной классификации получены результаты: {Xi}, обеспечивающие достоверность (A), то при замене (Xi => 1-Xi) для всех i будет получена достоверность (1-A)')) AADD(aMess,L('Например, если в модели Kaggle_Inf3i_1.csv была получена ROC-достоверность 0.337, то в модели Kaggle_Inf3i_2.csv она будет 0.662.')) AADD(aMess,L('')) AADD(aMess,L('PS. Проверьте наименование полей в CSV-файлах. Они могут отличаться в разных задачах.')) LB_Warning(aMess) ENDIF DC_Impl(oScr) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW Running(.F.) RETURN NIL ****************************************************************************************** Function CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций ****************************************************************************************** LOCAL bError , aWorkareas , x, y bError := ErrorBlock( {|e| Break(e)} ) aWorkAreas := workspacelist() y := len(aWorkAreas) for x = 1 to y BEGIN SEQUENCE (aWorkAreas[x])->(DbClearRelation()) (aWorkAreas[x])->(DbCloseArea()) ENDSEQUENCE next ErrorBlock(bError) bError := nil Return nil ******************************************************************* ******** Масштбалирование bmp-изображения от Джимми ******************************************************************* FUNCTION BMP2BMP( oBMP, aIcoSize ) LOCAL oTiny LOCAL oPS LOCAL oRet LOCAL nBits LOCAL nPlanes LOCAL nBGClr LOCAL aRGB IF aIcoSize[ 2 ] > 0 nBits := oBMP:bits nPlanes := oBMP:planes nBGClr := oBMP:getDefaultBgColor() oPS := XBPPRESSPACE():new():Create() // Alaska-2.0 oTiny := XBPBITMAP() :new():Create() IF nBGClr = 16777216 aRGB := GraGetRGBIntensity(nBGClr) oTiny:transparentClr := GraMakeRGBColor(aRGB) ELSE oTiny:transparentClr := oBMP:getDefaultBgColor() ENDIF IF nBits > 1 .AND. nPlanes > 1 oTiny:Make( aIcoSize[ 1 ], aIcoSize[ 2 ], nPlanes, nBits ) ELSE oTiny:Make( aIcoSize[ 1 ], aIcoSize[ 2 ] ) ENDIF oTiny:presSpace( oPS ) IF aIcoSize[ 2 ] > oBMP:ySize oBMP:Draw( oPS, { 0, 0, aIcoSize[1], aIcoSize[2] },,, GRA_BLT_BBO_IGNORE ) ELSE oBMP:Draw( oPS, { 0, 0, aIcoSize[1], aIcoSize[2] },,, 4 ) ENDIF oRet := oTiny ELSE oRet := oBMP ENDIF RETURN oRet ****************************************************************************************** /* * This procedure displays an image file in a separate window * mPar = "по центру" или "по верху", mOffset - смещение в пикселях по вертикали * nTimeout = Время задержки после показа изображения */ ****************************************************************************************** PROCEDURE FullView( cFile, mPar, mOffset ) LOCAL oDlg, oImage, oPS, aSize, aPos LOCAL lBGClr := XBPSYSCLR_TRANSPARENT /* * Only bitmap and meta files are supported */ IF cFile <> NIL .AND. ; ( ".BMP" $ Upper( cFile ) .OR. ; ".EMF" $ Upper( cFile ) .OR. ; ".GIF" $ Upper( cFile ) .OR. ; ".JPG" $ Upper( cFile ) .OR. ; ".PNG" $ Upper( cFile ) .OR. ; ".MET" $ Upper( cFile ) ) /* * Create hidden dialog window */ oDlg := XbpDialog():new( AppDesktop(),,,{100,100} ) oDlg:taskList := .F. oDlg:visible := .F. oDlg:title := cFile oDlg:sizeRedraw := .T. oDlg:close := {|mp1,mp2,obj| obj:destroy() } oDlg:alwaysOnTop := .T. // Выводить изображение на переднем плане (Джимми) oDlg:create() /* * Create a presentation space and connect it with the device * context of :drawingArea */ oPS := XbpPresSpace():new():create( oDlg:drawingArea:winDevice() ) IF ".BMP" $ Upper( cFile ) .OR. ; ".GIF" $ Upper( cFile ) .OR. ; ".JPG" $ Upper( cFile ) .OR. ; ".PNG" $ Upper( cFile ) /* * File contains a bitmap. Limit the window size to a range * between 16x16 pixel and the screen resolution */ oImage := XbpBitmap():new():create( oPS ) oImage:loadFile( cFile ) IF oImage:transparentClr <> GRA_CLR_INVALID lBGClr := XBPSYSCLR_DIALOGBACKGROUND ENDIF *************** ЗДЕСЬ ВЗЯТЬ ОПРЕДЕЛЕННЫЕ ВЫШЕ РАЗМЕРЫ ИЗОБРАЖЕНИЯ <<<===########################## aSize := { oImage:xSize, oImage:ySize } aSize[1] := Max( 16, Min( aSize[1], AppDeskTop():currentSize()[1] ) ) aSize[2] := Max( 16, Min( aSize[2], AppDeskTop():currentSize()[2] ) ) aSize := oDlg:calcFrameRect( {0,0, aSize[1], aSize[2]} ) oDlg:setSize( {aSize[3], aSize[4]} ) /* * The window must react to xbeP_Paint to redraw the bitmap */ oDlg:drawingarea:paint := {|x,y,obj| x:=obj:currentSize(), ; oImage:draw( oPS, {0, 0, x[1], x[2]}, ; {0, 0, oImage:xSize, oImage:ySize},,; GRA_BLT_BBO_IGNORE), Sleep(0.1) } ELSE /* * Display a meta file. It has no size definition for the image */ oImage := XbpMetafile():new():create() oImage:load( cFile ) aSize := { 600, 400 } oDlg:setSize( aSize ) oDlg:drawingarea:paint := {|x,y,obj| x:=obj:currentSize(), ; oImage:draw( oPS, {0, 0, x[1], x[2]}),; Sleep(0.1) } lBGClr := XBPSYSCLR_DIALOGBACKGROUND ENDIF /* * Set the background color for the dialog's drawingarea. * Per default, the transparent color is used to avoid * flicker during refreshs. For transparent images and * metafiles, however, color gray is set instead, see above. * This is done to prevent bits of the desktop from being * visible in transparent areas of the bitmap/metafile image. * Alternatively, transparency could be explicitly switched * off for bitmapped images. */ oDlg:drawingArea:SetColorBG( lBGClr ) /* * Display the window centered on the desktop */ DO CASE CASE mPar = "по верху" AlignWindow( oDlg, mOffset ) CASE mPar = "по центру" aPos:= CenterPos( oDlg:currentSize(), AppDesktop():currentSize() ) oDlg:setPos( aPos ) ENDCASE oDlg:show() SetAppFocus( oDlg ) * ------------------------------------------------------------- * * Правильная реакция на Esc от Джимми * ------------------------------------------------------------- * * IF nTimeout = 'No pause' * oDlg:destroy() // Можно просто не запускать процедуру показа изображения FullView() * ELSE nEvent := 0 DO WHILE nEvent != xbeP_Close nEvent := APPEVENT( @mp1, @mp2, @oXbp ) IF nEvent == xbeP_Keyboard .AND. mp1 == xbeK_ESC oDlg:destroy() Exit ELSE oXbp:HandleEvent( nEvent, mp1, mp2 ) ENDIF ENDDO * ENDIF * ------------------------------------------------------------- * ENDIF RETURN ****************************************************************************************** ******** Выравнивание вывода в FullView() по верхнему краю без панели задач ************** ****************************************************************************************** FUNCTION AlignWindow( oDlg, mOffset ) LOCAL aCoords := DC_GetWorkArea(), nBottom, nLeft nBottom := AppDeskTop():currentSize()[2] - aCoords[4] nLeft := AppDeskTop():currentSize()[1]/2 - oDlg:currentSize()[1]/2 oDlg:setPos({nLeft,nBottom+mOffset}) RETURN nil ************************************************************************************************************ ******** Если исполнимый модуль существует и его контрольная сумма совпадает, то запустить его на исполнение ************************************************************************************************************ FUNCTION LC_RunShell(cFile, mCheckSum, FunctionName) // Имя функции задается только в случае, если cFile = "__AIDOS-PY.exe" *Running(.T.) *CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы Эйдос * MsgBox(Disk_dir) CrLf = CHR(13)+CHR(10) // Конец строки (записи) IF FILE(Disk_dir+'\'+cFile) IF FILECHECK(Disk_dir+'\'+cFile) = mCheckSum IF cFile = "__AIDOS-PY.exe" CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы * USE PathGrAp EXCLUSIVE NEW * USE Appls EXCLUSIVE NEW * USE Users EXCLUSIVE NEW Running(.F.) IF .NOT. FILE('EVENTS_PYTHON.LOG') mPython = DTOC(DATE())+'-'+TIME()+' '+L('Первый запуск:')+' "'+cFile+'"'+CrLf StrFile(ALLTRIM(mPython), 'EVENTS_PYTHON.LOG') ENDIF * COPY FILE ("Appls.dbf") TO ("Appls_py.dbf") * StrFile(mFTP, '_FTP.txt') * mFTP = FileStr('_FTP.txt') ***** Ожидание завершения работы модуля "__AIDOS-PY.exe", запущенного предыдущий раз ******* oScr := DC_WaitOn(L('Идет подготовка к запуску мастера загрузки мастера инициализации модуля: __AIDOS-PY.exe. Немного подождите!'),,,,,,,,,,,.F.) * DO WHILE 'модуль "__AIDOS-PY.exe" завершил работу и можно запускать его еще раз' = FileStr('Python_function_to_run.txt') DO WHILE 'the module "__AIDOS-PY.exe" completed the work and you can run it again' = FileStr('Python_function_to_run.txt') MILLISEC(1000) // Значит еще идет выполнение 'модуля "__AIDOS-PY.exe" ***** Записать наименование запускаемой функции в файл 'Python_function_to_run.txt' StrFile(ALLTRIM(FunctionName), 'Python_function_to_run.txt') ENDDO DC_Impl(oScr) DO CASE CASE FunctionName = "url_py" * RunShell("",Disk_dir+'\'+cFile,.T.,.T.) // Программа "__AIDOS-PY.exe" запускается в фоновом режиме (асинхронно, резидентно) и на заднем плане и ход основной программы продолжается RunShell("",Disk_dir+'\'+cFile,.F.,.F.) // Программа "__AIDOS-PY.exe" запускается не в фоновом режиме (синхронно, не резидентно) ход основной программы не продолжается, пока не завершится "__AIDOS-PY.exe" OTHERWISE RunShell("",Disk_dir+'\'+cFile,.F.,.F.) // Программа "__AIDOS-PY.exe" запускается не в фоновом режиме (синхронно, не резидентно) ход основной программы не продолжается, пока не завершится "__AIDOS-PY.exe" ENDCASE ***** Записать в файл 'Python_function_to_run.txt' информацию о том, что модуль "__AIDOS-PY.exe" завершил работу и можно запускать его еще раз * StrFile('модуль "__AIDOS-PY.exe" завершил работу и можно запускать его еще раз', 'Python_function_to_run.txt') StrFile('the module "__AIDOS-PY.exe" completed the work and you can run it again', 'Python_function_to_run.txt') StrFile(FileStr('EVENTS_PYTHON.LOG')+DTOC(DATE())+'-'+TIME()+' '+L('Запуск функции:')+' "'+ALLTRIM(FunctionName)+'"'+CrLf, 'EVENTS_PYTHON.LOG') ELSE RunShell("",Disk_dir+'\'+cFile,.F.) // Чтобы процесс не бежал дальше, пока ImageResize.exe не закончится ENDIF ELSE aMess := {} AADD(aMess, L('Исполнимый модуль: "')+cFile+'" '+L('заменен или поврежден, возможно вирусами.')) AADD(aMess, L('Поэтому он не может быть запущен на исполнение. Для получения этого модуля')) AADD(aMess, L('скачайте и установите новую версию системы "Эйдос" с сайта автора:')) AADD(aMess, L('Установочные файлы системы "Эйдос": https://lc.kubagro.ru/Installation_Eidos.php')) AADD(aMess, L('- полная инсталляция: http://lc.kubagro.ru/Aidos-X.exe')) AADD(aMess, L('- только обновления: http://lc.kubagro.ru/Downloads.exe')) AADD(aMess, L('Ошибочная контрольная сумма=')+ALLTRIM(STR(mCheckSum,19))) // <<<===################# AADD(aMess, L('Правильная контрольная сумма=')+ALLTRIM(STR(FILECHECK(Disk_dir+'\'+cFile),19))) // <<<===################# LB_Warning(aMess) ENDIF ELSE aMess := {} AADD(aMess, L('Исполнимый модуль: "')+cFile+'" '+L('в текущей папке системы "Эйдос" отсутствует.')) AADD(aMess, L('Для его получения скачайте и установите новую версию системы "Эйдос" с сайта автора:')) AADD(aMess, L('- полная инсталляция (около 500 Мб): http://lc.kubagro.ru/Aidos-X.exe')) AADD(aMess, L('- только обновления (около 100 Мб): http://lc.kubagro.ru/Downloads.exe')) LB_Warning(aMess) ENDIF *CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций *Running(.F.) RETURN nil ********************************************************************************************************************************* ******** Если исполнимый модуль существует и его контрольная сумма совпадает, то запустить его на исполнение ******** Программа запускается в фоновом режиме (асинхронно, резидентно) и на заднем плане и ход основной программы продолжается ********************************************************************************************************************************* FUNCTION LC_RunShellTT(cFile, mCheckSum) *Running(.T.) *CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы Эйдос * MsgBox(Disk_dir) IF FILE(Disk_dir+'\'+cFile) IF FILECHECK(Disk_dir+'\'+cFile) = mCheckSum ERASE('Python_function_to_run.txt') RunShell("",Disk_dir+'\'+cFile,.T.,.T.) // Программа запускается в фоновом режиме (асинхронно, резидентнол) и на заднем плане и ход основной программы продолжается ELSE aMess := {} AADD(aMess, L('Исполнимый модуль: "')+cFile+'" '+L('заменен или поврежден, возможно вирусами.')) AADD(aMess, L('Поэтому он не может быть запущен на исполнение. Для получения этого модуля')) AADD(aMess, L('скачайте и установите новую версию системы "Эйдос" с сайта автора:')) AADD(aMess, L('- полная инсталляция (около 500 Мб): http://lc.kubagro.ru/Aidos-X.exe')) AADD(aMess, L('- только обновления (около 100 Мб): http://lc.kubagro.ru/Downloads.exe')) AADD(aMess, L('Ошибочная контрольная сумма=')+ALLTRIM(STR(mCheckSum,19))) // <<<===################# AADD(aMess, L('Правильная контрольная сумма=')+ALLTRIM(STR(FILECHECK(Disk_dir+'\'+cFile),19))) // <<<===################# LB_Warning(aMess) ENDIF ELSE aMess := {} AADD(aMess, L('Исполнимый модуль: "')+cFile+'" '+L('в текущей папке системы "Эйдос" отсутствует.')) AADD(aMess, L('Для его получения скачайте и установите новую версию системы "Эйдос" с сайта автора:')) AADD(aMess, L('- полная инсталляция (около 500 Мб): http://lc.kubagro.ru/Aidos-X.exe')) AADD(aMess, L('- только обновления (около 100 Мб): http://lc.kubagro.ru/Downloads.exe')) LB_Warning(aMess) ENDIF *CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций *Running(.F.) RETURN nil ************************************************************************************************************************************************************ ******** Если исполнимый модуль существует и его контрольная сумма совпадает, то запустить заданную в 'Python_function_to_run.txt' функцию его на исполнение ************************************************************************************************************************************************************ FUNCTION LC_RunShellAidosPy(mCheckSum, FunctionName) *Running(.T.) *CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы Эйдос * MsgBox(Disk_dir) cFile = '__AIDOS-PY.exe' CrLf = CHR(13)+CHR(10) // Конец строки (записи) * oScr := DC_WaitOn(L('Идет загрузка модуля: "')+cFile+L('" для запуска функции:')+' "'+FunctionName+L('". Немного подождите!'),,,,,,,,,,,.F.) IF .NOT. FILE('EVENTS_PYTHON.LOG') mPython = DTOC(DATE())+'-'+TIME()+' '+L('Первый запуск:')+' "'+cFile+'"'+CrLf StrFile(ALLTRIM(mPython), 'EVENTS_PYTHON.LOG') ENDIF mPython = FileStr('EVENTS_PYTHON.LOG') IF FILE(Disk_dir+'\'+cFile) IF FILECHECK(Disk_dir+'\'+cFile) = mCheckSum * DC_Impl(oScr) mPython = mPython + DTOC(DATE())+'-'+TIME()+' '+L('Запуск функции:')+' "'+ALLTRIM(FunctionName)+'"'+CrLf ***** Записать наименование запускаемой функции в файл 'Python_function_to_run.txt' StrFile(ALLTRIM(FunctionName), 'Python_function_to_run.txt') * ***** Поместить наименование запускаемой функции в буфер обмена * oClipBoard := XbpClipboard():new():create() * oClipBoard:open() * oClipboard:clear() * oClipBoard:setBuffer(FunctionName,XBPCLPBRD_TEXT) * oClipBoard:close() * oClipBoard:destroy() * RunShell("",Disk_dir+'\'+cFile,.F.) // Чтобы процесс не бежал дальше, пока ImageResize.exe не закончится * Программа '__AIDOS-PY.exe' уже запущена ранее один раз на запуск системы "Эйдос" с помощью LC_RunShellTT в фоновом режиме (асинхронно, резидентно) и на заднем плане и ход основной программы продолжается ELSE * DC_Impl(oScr) mPython = mPython + DTOC(DATE())+'-'+TIME()+' '+L('Функция:')+' '+ALLTRIM(FunctionName)+' '+L('не запущена, CRC Error файла:')+' '+cFile+CrLf aMess := {} AADD(aMess, L('Исполнимый модуль: "')+cFile+'" '+L('заменен или поврежден, возможно вирусами.')) AADD(aMess, L('Поэтому он не может быть запущен на исполнение. Для получения этого модуля')) AADD(aMess, L('скачайте и установите новую версию системы "Эйдос" с сайта автора:')) AADD(aMess, L('- полная инсталляция (около 500 Мб): http://lc.kubagro.ru/Aidos-X.exe')) AADD(aMess, L('- только обновления (около 100 Мб): http://lc.kubagro.ru/Downloads.exe')) AADD(aMess, L('Ошибочная контрольная сумма=')+ALLTRIM(STR(mCheckSum,19))) // <<<===################# AADD(aMess, L('Правильная контрольная сумма=')+ALLTRIM(STR(FILECHECK(Disk_dir+'\'+cFile),19))) // <<<===################# LB_Warning(aMess) ENDIF ELSE * DC_Impl(oScr) AADD(aMess, L('Исполнимый модуль: "')+cFile+'" '+L('отсуствует в текущей папке системы:')+' '+Disk_dir+CrLf) aMess := {} AADD(aMess, L('Исполнимый модуль: "')+cFile+'" '+L('в текущей папке системы "Эйдос" отсутствует.')) AADD(aMess, L('Для его получения скачайте и установите новую версию системы "Эйдос" с сайта автора:')) AADD(aMess, L('- полная инсталляция (около 500 Мб): http://lc.kubagro.ru/Aidos-X.exe')) AADD(aMess, L('- только обновления (около 100 Мб): http://lc.kubagro.ru/Downloads.exe')) LB_Warning(aMess) ENDIF StrFile(ALLTRIM(mPython), 'EVENTS_PYTHON.LOG') *CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций *Running(.F.) RETURN nil ****************************************************************************************** ******** Три базы данных распознаваемой выборки: Rso_Zag.dbf, Rso_Kcl.dbf, Rso_Kpr.dbf ******** преобразуются в одну базу данных: Rso_all.dbf. По структуре эта база данных очень ******** сходна с базами статистических и системно-когнитивных моделей, т.е. строки в ней ******** соответствуют градациям описательных шкал (признакам), а колонки - объектам рас- ******** познаваемой выборки, в ячейках - число встреч данного признака у данного объекта. ****************************************************************************************** FUNCTION F5_3() Running(.T.) oScr := DC_WaitOn(L('Формирование базы распознаваемой выборки в стиле статистических и системно-когнитивных моделей'),,,,,,,,,,,.F.) DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Attributes EXCLUSIVE NEW;N_Gos = RECCOUNT() USE Rso_Zag EXCLUSIVE NEW;N_Obj = RECCOUNT() SELECT Attributes aAtrName := {} mLenAtrName = 33 DO WHILE .NOT. EOF() mAN = ALLTRIM(Name_atr) AADD(aAtrName, mAN) mLenAtrName = MAX(mLenAtrName, LEN(mAN)) DBSKIP(1) ENDDO ********** Rsp_it#.dbf уровень сходства объекта с классом: k-корреляция, i-сумма информации aStructure := { { "Kod_atr" , "N", 15, 0},; // 1 { "Name_atr" , "C",mLenAtrName, 0} } // 2 FOR j=1 TO MIN(N_Obj, 2035) FieldName = "Obj"+ALLTRIM(STR(j,15)) AADD(aStructure, { FieldName , "N", 15, 7 }) NEXT DbCreate( "Rso_all.dbf", aStructure ) ***** Переиндексация CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rso_Zag EXCLUSIVE NEW INDEX ON STR(Kod_Obj,19) TO Roz_kod CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rso_Kcl EXCLUSIVE NEW INDEX ON STR(Kod_Obj,19) TO Roc_kod CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rso_Kpr EXCLUSIVE NEW INDEX ON STR(Kod_Obj,19) TO Rop_kod CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rso_Zag INDEX Roz_kod EXCLUSIVE NEW;N_Obj = RECCOUNT() USE Rso_Kcl INDEX Roc_kod EXCLUSIVE NEW USE Rso_Kpr INDEX Rop_kod EXCLUSIVE NEW USE Rso_All EXCLUSIVE NEW SELECT Rso_All FOR j=1 TO LEN(aAtrName) APPEND BLANK REPLACE Kod_atr WITH j REPLACE Name_atr WITH aAtrName[j] NEXT APPEND BLANK;REPLACE Name_atr WITH "Сумма" APPEND BLANK;REPLACE Name_atr WITH "Среднее" APPEND BLANK;REPLACE Name_atr WITH "Ср.кв.откл." // Цикл по объектам распознаваемой выборки и их распознавание ======================================== M_NObj = 0 SELECT Rso_zag SET ORDER TO 1 DBGOTOP() PRIVATE Ar_Lok[N_Gos] DO WHILE .NOT. EOF() // Цикл по объектам распознаваемой выборки M_KodObj = Kod_obj // Сброс массива-локатора кодов признаков распознаваемого объекта AFILL(Ar_Lok,0) M_SumLok = 0 // Сумма 1 и 0 массива-локатора SELECT Rso_Kpr;SET ORDER TO 1;T=DBSEEK(STR(M_KodObj,19)) IF T ******** Цикл по признакам одного объекта DO WHILE M_KodObj = Kod_obj .AND. .NOT. EOF() FOR j=2 TO 8 M_Kpr = FIELDGET(j) IF 0 < M_Kpr .AND. M_Kpr <= N_Gos // Проверка на корректность кода признака // Если признак указан у объкта несколько раз, значит он у него и встречается несколько раз, // например буква "о" в слове "молоко" встречатся 3 раза Ar_Lok[M_Kpr] = Ar_Lok[M_Kpr] + 1 ++M_SumLok // Сумма 1 и 0 массива-локатора ENDIF NEXT DBSKIP(1) ENDDO ENDIF ***** Расчет среднего и дисперсии массива-локатора M_SrObj = M_SumLok/N_Gos // Среднее 1 и 0 массива-локатора M_DiObj = 0 // Дисперсия 1 и 0 массива-локатора FOR i=1 TO N_Gos M_DiObj = M_DiObj + ( M_SrObj - Ar_Lok[i]) ^ 2 NEXT M_DiObj = SQRT( M_DiObj / (N_Gos - 1)) // Дорасчет дисперсии 1 и 0 массива-локатора SELECT Rso_All FOR j=1 TO LEN(aAtrName) DBGOTO(j) FIELDPUT(M_KodObj+2, Ar_Lok[j]) NEXT DBGOTO(N_Gos+1);FIELDPUT(M_KodObj+2, M_SumLok) DBGOTO(N_Gos+2);FIELDPUT(M_KodObj+2, M_SrObj) DBGOTO(N_Gos+3);FIELDPUT(M_KodObj+2, M_DiObj) SELECT Rso_zag DBSKIP(1) ENDDO * // НОРМИРОВКА уровней сходства Korr и Sum_inf r 100% в БД Rasp * // и подсчет количества различных уровней схдства * // для верно и ошибочно идентифицированных объектов (сделать в Rso_All в Excel) * SELECT Rasp * INDEX ON STR(ABS(Korr) ,12,7) TO Rsp_korr * INDEX ON STR(ABS(Sum_inf),19,7) TO Rsp_sinf * CLOSE Rasp * USE Rasp INDEX Rsp_korr, Rsp_sinf EXCLUSIVE NEW * SELECT Rasp * SET ORDER TO 1;DBGOBOTTOM();M_MaxKorr = ABS(Korr) * SET ORDER TO 2;DBGOBOTTOM();M_MaxSinf = ABS(Sum_inf) * SELECT Rasp * SET ORDER TO * DBGOTOP() * DO WHILE .NOT. EOF() * REPLACE Korr WITH Korr /M_MaxKorr*100 * REPLACE Sum_inf WITH Sum_Inf/M_MaxSinf*100 * DBSKIP(1) * ENDDO DC_Impl(oScr) LB_Warning('Матрица: "Rso_All" успешно создана!') ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW Running(.F.) RETURN nil **************************************************************************************************************************** ****************************************************************************************** DLLFUNCTION InternetGetConnectedState( @nFlags, nReserved ) USING STDCALL FROM WinInet.Dll ****************************************************************************************** *********** Функции для определения разрешения монитора от Джимми ************************ DLLFUNCTION GetDC( nHWND ) USING STDCALL FROM USER32.DLL DLLFUNCTION ReleaseDC( nHWND, nHDC ) USING STDCALL FROM USER32.DLL DLLFUNCTION GetDeviceCaps( nHWND, nIndex ) USING STDCALL FROM GDI32.DLL ****************************************************************************************** *Вы можете загрузить свой собственный шрифт при запуске с этим. *cFont := '.\fonts\thisismyfont.ttf' // subfolder fonts contains the font *DllCall ("GDI32.DLL", DLL_STDCALL, "AddFontResourceA", cFont) *Где cFont содержит путь и имя шрифта. *Перед закрытием приложения вы можете использовать это: *DllCall ("GDI32.DLL", DLL_STDCALL, "RemoveFontResourceA", cFont) ****************************************************************************************** *Hi, *You can put all the needed fonts is a subfolder of your application. Then load them when you start. *Code: ************************* FUNCTION InstallFonts() // <<<===################################ ************************* Local i , cFont, aList := DIRECTORY(Disk_dir+"\AID_DATA\Fonts\*.ttf") aMess := {} IF LEN(aList) = 0 * AADD(aMess,'') * AADD(aMess,'') * AADD(aMess, L('При попытке загрузки собственных шрифтов системы "Эйдос" из папки:')) * AADD(aMess, Disk_dir+"\AID_DATA\Fonts\ "+L('обнаружено, что они отсутствуют !!! ')) * AADD(aMess,'') * AADD(aMess, L('Для исправления ситуации необходимо скачать файл обновлений шрифтов')) * AADD(aMess, 'http://lc.kubagro.ru/Fonts.exe'+' '+L('с сайта разработчика и развернуть обновления ')) * AADD(aMess, L('в папке с системой:')+' '+Disk_dir+'\ '+L('с заменой всех файлов, а затем запустить')) * AADD(aMess, L('систему как обычно.')) * AADD(aMess,'') * AADD(aMess, L('Если MS Windows русифицирована, то делать все это не нужно, т.к. все будет')) * AADD(aMess, L('работать нормально и со стандартными шрифтами MS Windows.')) * AADD(aMess,'') * AADD(aMess,'') AADD(aMess,'') AADD(aMess,'') AADD(aMess, L('When trying to download your own fonts of the Eidos system from the folder:')) AADD(aMess, Disk_dir+"\AID_DATA\Fonts\ "+L('it is found that they are missing!!!')) AADD(aMess,'') AADD(aMess, L('To fix the situation, you need to download the font update file')) AADD(aMess, 'http://lc.kubagro.ru/Fonts.exe'+' '+L("from the developer's website and deploy updates")) AADD(aMess, L('in the system folder:')+' '+Disk_dir+'\ '+L('with the replacement of all files, and then run')) AADD(aMess, L('the system as usual.')) AADD(aMess,'') AADD(aMess, L('If MS Windows is Russified, then you do not need to do all this, because everything')) AADD(aMess, L('will be work fine with standard MS Windows fonts.')) AADD(aMess,'') AADD(aMess,'') * LB_Warning(aMess,L('(C°) Система "Эйдос"')) ELSE oScr := DC_WaitOn(L('Идет установка собственных шрифтов системы "Эйдос". Немного подождите !!!'),,,,,,,,,,,.F.) FOR i := 1 TO LEN(aList) cFont := Disk_dir+"\AID_DATA\Fonts\"+aList[i][F_NAME] DllCall("GDI32.DLL", DLL_STDCALL, "AddFontResourceA", cFont ) **** SendMessage(HWND_BROADCAST,WM_FONTCHANGE,0,0) NEXT DC_Impl(oScr) ENDIF RETURN (aMess) *It is also a good idea to remove them when you close your application. *Code: ************************ FUNCTION RemoveFonts() ************************ Local i , cFont, nGo , nteller := 1, aList := DIRECTORY(Disk_dir+"\AID_DATA\Fonts\*.ttf") IF LEN(aList) > 0 oScr := DC_WaitOn(L('Идет освобождение собственных шрифтов системы "Эйдос". Немного подождите !!!'),,,,,,,,,,,.F.) FOR i := 1 TO len(aList) cFont := Disk_dir+"\AID_DATA\Fonts\"+aList[i][F_NAME] nTeller := 1 nGo := 999 DO WHILE nGo > 0 .AND. nTeller < 20 // try up to 20 times to remove is the result 'ngo' is bigger than nul. nGo := DllCall("GDI32.DLL", DLL_STDCALL, "RemoveFontResourceA", cFont ) nTeller ++ ENDDO NEXT DC_Impl(oScr) ENDIF RETURN NIL *The nGo and Counter system is because you can't remove if the font is still in use. For example, if you application was started twice, and you want to close one session. With the counter (nTeller) it is tried up to 20 times. *_________________ *Best regards, * *Chris. *www.aboservice.be ****************************************************************************************** ******** Функция преобразования SCV => XLS ****************************************************************************************** FUNCTION CsvXls(cCsvFile, cExcelFile) oScr := DC_WaitOn(L('Идет конвертирование файла:')+' '+cCsvFile+' '+L('в файл:')+' '+cExcelFile+L('Немного подождите!!!'),,,,,,,,,,,.F.) *#DEFINE xlWorkbookNormal -4143 oExcel := CreateObject("Excel.Application") *cCsvFile := 'workbook.csv' *cExcelFile := 'workbook.xls' cPassword := nil oBook := oExcel:Workbooks:Open(cCsvFile) oBook:SaveAs(cExcelFile,xlWorkbookNormal,cPassword) oBook:close() oBook:destroy() oExcel:Quit() oExcel:Destroy() DC_Impl(oScr) RETURN NIL ****************************************************************************************** FUNCTION ExcelInstalled() oExcel := CreateObject("Excel.Application") IF Empty( oExcel ) IF lCSVFallBack DCMSGBOX 'Excel is not installed. Create CSV file instead?' YESNO TO lStatus IF lStatus RETURN DC_Array2CSV(cExcelFile,aData) ELSE RETURN .f. ENDIF ELSE DC_WinAlert( "Excel is not installed" ) ENDIF RETURN .f. ENDIF RETURN NIL ****************************************************************************************** ******** Вычисление коэффициентов полинома n-й степени *********************************** ****************************************************************************************** **FUNCTION Main *FUNCTION Main_otl() * LOCAL n * *** Присвоить массивам параметрически заданные значения отображаемой функции * aArg := {} * aVal := {} * FOR j=1 TO FCOUNT() * DBGOTO(1);AADD(aArg, FIELDGET(j)) * DBGOTO(2);AADD(aVal, FIELDGET(j)) * NEXT * aPoints := {} * FOR p=1 TO LEN(aArg) * AADD(aPoints, {aArg[p], aVal[p]}) * NEXT * ******** Вычисление точек полинома n-й степени ***************** * aArgPoli := {} * aValPoli := {} * set device to printer;set printer on;set printer to ("zing.txt");set console off // Открыть процесс печати выходной формы * FOR p := 0 TO LEN(aArg)+1 STEP 0.1 * mValPoli = InterPolate(aPoints, p) * ?p, mValPoli * AADD(aArgPoli, p) * AADD(aValPoli, mValPoli) * NEXT p * Set device to screen;Set printer off;Set printer to;Set console on // Закрыть процесс печати выходной формы *RETURN NIL ****************************************************************************************** FUNCTION InterPolate(xyPairs,x) LOCAL n := Len(xyPairs) LOCAL result := 0 LOCAL term LOCAL i,j FOR i := 1 TO n term := xyPairs[i][2] FOR j := 1 TO n IF (i # j) term := term*(x-xyPairs[j][1])/(xyPairs[i][1]-xyPairs[j][1]) // что за x? ENDIF NEXT j result += term NEXT i RETURN result ****************************************************************************************** ******** Функция отображает строку mMess aSay[mPTVnumb] с процентом исполнения, ******** но только в том случае, если с момента последнего отображения ******** прошло больше чем 0,1 секунды или уже 100% исполнения ****************************************************************************************** FUNCTION PercTimeVisio(mPTVnumb, mPTVmess, mPTVnALL, Regim) ****************************************************************************************** ***** Пример затравки и применения *CLOSE ALL *USE Obi_Zag EXCLUSIVE NEW *SELECT Obi_Zag *N_Obj = RECCOUNT() // №1, N_Obj ################################ *mNumPP = 0 *N_ALL = N_Obj ** №1 *mMess = L('5/8: Расчет модели "ABS". Стадия исполнения:') *PUBLIC T1 := (DOY(DATE())-1)*86400+SECONDS() // Время предыдущей индикации процесса исполнения *PUBLIC T2 := (DOY(DATE())-1)*86400+SECONDS()+1 // Текущее время (1-й раз оно заметно больше T1 чтобы было отображение) *PUBLIC T1tp := T1 *PUBLIC T2tp := T2 *DBGOTOP() *DO WHILE .NOT. EOF() // Начало цикла по объектам обучающей выборки T2 = (DOY(DATE())-1)*86400+SECONDS() // Текущее время mNumPP = IF(mNumPP+1<=mPTVnALL, ++mNumPP, mNumPP) IF T2 - T1 > 0.1 .OR. mNumPP = N_ALL // Время в секундах или 100% IF Regim <> '3_7_9' aSay[mPTVnumb]:SetCaption(mPTVmess+' '+ALLTRIM(STR(mNumPP/mPTVnALL*100,15,7))+'%') ENDIF T1 = T2 ENDIF * DBSKIP(1) *ENDDO RETURN NIL ****************************************************************************************** ******** Рисование прошлых и будущих сценариев *** ****************************************************************************************** FUNCTION DrawScenarios(mPar) mPause = 2 @0,0 DCGROUP oGroup1 CAPTION L('Что делать с изображениями?') SIZE 50, 3.7 @1.0, 2 DCRADIO mPause VALUE 1 PROMPT L('Показывать изображения и записывать') PARENT oGroup1 @2.0, 2 DCRADIO mPause VALUE 2 PROMPT L('Только записывать файлы изображений') PARENT oGroup1 ****** Задать № сценария, с которого начинать ****************** <<<===############################## mNumScen = 1 @ 4, 0 DCGROUP oGroup2 CAPTION L('Задайте № сценария, с которого начинать' ) SIZE 50, 2.5 @ 1, 2 DCGET mNumScen PICTURE "#########" PARENT oGroup2 DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; OPTIONS GetOptions ; ADDBUTTONS; MODAL ; TITLE L('Рисование прошлых и будущих сценариев') ***************************************************************** IF lExit ** Button Ok ELSE ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** ** Выдать сообщение и восстановить среду f2_1win2() или f2_2() DO CASE CASE mPar = 'Cls' CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Class_Sc INDEX ON Kod_ClSc TO Class_Sc CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Gr_ClSc NEW INDEX ON Kod_ClSc TO Gr_ClSc CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Class_Sc INDEX Class_Sc EXCLUSIVE NEW USE Gr_ClSc INDEX Gr_ClSc EXCLUSIVE NEW CASE mPar = 'Atr' ********** Среда f2_2() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Opis_Sc INDEX ON Kod_OpSc TO Opis_Sc CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Gr_OpSc NEW INDEX ON Kod_OpSc TO Gr_OpSc CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Obi_Kpr EXCLUSIVE NEW USE Rso_Kpr EXCLUSIVE NEW USE Opis_Sc INDEX Opis_Sc EXCLUSIVE NEW USE Gr_OpSc INDEX Gr_OpSc EXCLUSIVE NEW ENDCASE RETURN NIL ENDIF ***************************************************************** // Определить фактическое кол-во точек в сценарии * DIGITF-FUTURE5-DIGITF-FUTURE5-3,2,4,4,2 // Код объекта расп.выборки=8, наименование=7, код класса=340. Искать справа на лево первую встречу "-" * 123456789012345678901234567890123456789 * 10 20 30 CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DO CASE CASE mPar = 'Cls' USE Classes EXCLUSIVE NEW SET FILTER TO AT('-FUTURE',Name_cls) > 0 COUNT TO mNRec * MsgBox(STR(mNRec)) CASE mPar = 'Atr' USE Attributes EXCLUSIVE NEW SET FILTER TO AT('-PAST',Name_atr) > 0 COUNT TO mNRec * MsgBox(STR(mNRec)) ENDCASE IF mNRec = 0 ** Выдать сообщение и восстановить среду f2_1win2() или f2_2() DO CASE CASE mPar = 'Cls' CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Class_Sc INDEX ON Kod_ClSc TO Class_Sc CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Gr_ClSc NEW INDEX ON Kod_ClSc TO Gr_ClSc CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Class_Sc INDEX Class_Sc EXCLUSIVE NEW USE Gr_ClSc INDEX Gr_ClSc EXCLUSIVE NEW CASE mPar = 'Atr' ********** Среда f2_2() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Opis_Sc INDEX ON Kod_OpSc TO Opis_Sc CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Gr_OpSc NEW INDEX ON Kod_OpSc TO Gr_OpSc CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Obi_Kpr EXCLUSIVE NEW USE Rso_Kpr EXCLUSIVE NEW USE Opis_Sc INDEX Opis_Sc EXCLUSIVE NEW USE Gr_OpSc INDEX Gr_OpSc EXCLUSIVE NEW ENDCASE LB_Warning('Сценарный метод АСК-анализа не используется!', L('(C) Система "Эйдос"')) RETURN NIL ENDIF DO CASE CASE mPar = 'Cls' oScr := DC_WaitOn(L('Идет подготовка к визуализации прогнозных сценариев. Немного подождите!!!'),,,,,,,,,,,.F.) mLN = -9999999 N_PointsScenario = -99999999 DBGOTOP() DO WHILE .NOT. EOF() mNameCls = ALLTRIM(Name_cls) IF AT("FUTURE", mNameCls) > 0 Pos = RAT('-', mNameCls) mNameScen = SUBSTR(mNameCls, Pos+1, LEN(mNameCls)-Pos) N_PointsScenario = MAX(N_PointsScenario, NUMTOKEN(mNameScen, ',')) // Фактическое кол-во точек в сценарии, <<<===###### НАДО НАЙТИ МАКСИМАЛЬНОЕ ЗНАЧЕНИЕ ДЛЯ ВСЕХ СЦЕНАРИЕВ * MsgBox('"'+mNameCls+'", "'+mNameScen+'", '+ALLTRIM(STR(N_PointsScenario))) ENDIF mLN = MAX(mLN, LEN(ALLTRIM(Name_cls))) DBSKIP(1) ENDDO CASE mPar = 'Atr' oScr := DC_WaitOn(L('Идет подготовка к визуализации прошлых сценариев. Немного подождите!!!'),,,,,,,,,,,.F.) mLN = -9999999 N_PointsScenario = -99999999 DBGOTOP() DO WHILE .NOT. EOF() mNameAtr = ALLTRIM(Name_atr) IF AT("PAST", mNameAtr) > 0 Pos = RAT('-', mNameAtr) mNameScen = SUBSTR(mNameAtr, Pos+1, LEN(mNameAtr)-Pos) N_PointsScenario = MAX(N_PointsScenario, NUMTOKEN(mNameScen, ',')) // Фактическое кол-во точек в сценарии, <<<===###### НАДО НАЙТИ МАКСИМАЛЬНОЕ ЗНАЧЕНИЕ ДЛЯ ВСЕХ СЦЕНАРИЕВ * MsgBox('"'+mNameAtr+'", "'+mNameScen+'", '+ALLTRIM(STR(N_PointsScenario))) ENDIF mLN = MAX(mLN, LEN(ALLTRIM(Name_atr))) DBSKIP(1) ENDDO ENDCASE *** Создать БД DrawScen ****************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций aStructure := { { "Num" , "N", 19, 0 },; // Порядковый номер сценария после ранжирования по уровню сходства { "Kod" , "N", 19, 0 },; // Код класса-сценария, т.е. градации классификационной шкалы { "Name" , "C",255, 0 },; // Наименование классификационной шкалы"-" + наименование градации классификационной шкалы { "Kod_Sc", "N", 19, 0 } } // Код классификационной шкалы FOR j=1 TO N_PointsScenario // <<<===############# надо брать максимальное число точек по всем сценариям mFieldName = "KBC"+ALLTRIM(STR(j,5)) // Код базового класса AADD(aStructure, { mFieldName , "N", 5, 0 }) NEXT FOR j=1 TO N_PointsScenario mFieldName = "AVR"+ALLTRIM(STR(j,5)) // Среднее значение числового диапазона базового класса (для рисования и взвешенного усреднения) AADD(aStructure, { mFieldName , "N", 19, 7 }) NEXT DbCreate( "DrawScen.dbf" , aStructure ) // БД будущих сценариев // Заполнить БД для построения диаграммы * MsgBox(STR(mKodObj)) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций *** Когда известен фактический сценарий, то надо его тоже отобразить и посчитать корреляцию между прогнозом и фактом <<<===################### ******** Создание БД и массива для составной (гладкой) кривой Безье **************************** ******** Все записи должны быть полностью заполнены aStructure := { { "Xp_AVR" , "N", 19, 7 }, ; // 1. Xp_AVR=Xf_AVR предыдущей записи (в 1-й записи = X1) { "Yp_AVR" , "N", 19, 7 }, ; // 1. Yp_AVR=Yf_AVR предыдущей записи (в 1-й записи = Y1) { "X1" , "N", 19, 7 }, ; // 2. 1-я опорная точка { "Y1" , "N", 19, 7 }, ; // 2. 1-я опорная точка { "X2" , "N", 19, 7 }, ; // 3. 2-я опорная точка { "Y2" , "N", 19, 7 }, ; // 3. 2-я опорная точка { "Xf_AVR" , "N", 19, 7 }, ; // 4. Xf_AVR=(X2_текущей записи + X1_следующей записи)/2 (в последней записи = X2) { "Yf_AVR" , "N", 19, 7 } } // 4. Yf_AVR=(Y2_текущей записи + Y1_следующей записи)/2 (в последней записи = Y2) DbCreate( 'Points.dbf', aStructure ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW USE DrawScen EXCLUSIVE NEW USE Class_Sc EXCLUSIVE NEW USE Opis_Sc EXCLUSIVE NEW USE Points EXCLUSIVE NEW DO CASE CASE mPar = 'Cls' SELECT Classes SET FILTER TO AT('-FUTURE',Name_cls) > 0 .AND. AT('-Point',Name_cls) = 0 CASE mPar = 'Atr' SELECT Attributes SET FILTER TO AT('-PAST' ,Name_atr) > 0 .AND. AT('-Point',Name_atr) = 0 ENDCASE DBGOTOP() DO WHILE .NOT. EOF() // Цикл по сценариям ********************************************************************************** DO CASE CASE mPar = 'Cls' mKod = Kod_cls mKodSc = Kod_ClSc // Код шкалы mNameSc = ALLTRIM(Name_cls) CASE mPar = 'Atr' mKod = Kod_atr mKodSc = Kod_OpSc // Код шкалы mNameSc = ALLTRIM(Name_atr) ENDCASE * DIGITF-FUTURE5-DIGITF-FUTURE5-3,2,4,4,2 // Код объекта расп.выборки=8, наименование=7, код класса=340. Искать справа на лево первую встречу "-" * 123456789012345678901234567890123456789 * 10 20 30 mPos = RAT('-', mNameSc) mNameScen = SUBSTR(mNameSc, mPos+1, LEN(mNameSc)-mPos) N_PointsScenario = NUMTOKEN(mNameScen, ',') // Фактическое кол-во точек в сценарии * MsgBox(STR(Pos)+STR(N_PointsScenario)+' "'+mNameScen+'"') IF N_PointsScenario = 0 // Это сценарий? EXIT ELSE * aStructure := { { "Xp_AVR" , "N", 19, 7 }, ; // 1. Xp_AVR=Xf_AVR предыдущей записи (в 1-й записи = X1) * { "Yp_AVR" , "N", 19, 7 }, ; // 1. Yp_AVR=Yf_AVR предыдущей записи (в 1-й записи = Y1) * { "X1" , "N", 19, 7 }, ; // 2. 1-я опорная точка * { "Y1" , "N", 19, 7 }, ; // 2. 1-я опорная точка * { "X2" , "N", 19, 7 }, ; // 3. 2-я опорная точка * { "Y2" , "N", 19, 7 }, ; // 3. 2-я опорная точка * { "Xf_AVR" , "N", 19, 7 }, ; // 4. Xf_AVR=(X2_текущей записи + X1_следующей записи)/2 (в последней записи = X2) * { "Yf_AVR" , "N", 19, 7 } } // 4. Yf_AVR=(Y2_текущей записи + Y1_следующей записи)/2 (в последней записи = Y2) * DbCreate( 'Points.dbf', aStructure ) aKodBC := {} // Код базового класса aAvr := {} // Среднее значение числового диапазона базового класса (для рисования и взвешенного усреднения) // Проверять, если все значения aAvr тождественные, то заменять их на самих себя + очень малый шум (в последних знаках) // Иначе не работает сглаживание полиномами и сплайнами FOR k=1 TO N_PointsScenario // Разделитель между кодами mKCls = VAL(TOKEN(mNameScen, ',', k)) AADD(aKodBC, mKCls) * MsgBox(STR(mKCls)) NEXT mRecno = RECNO() DO CASE CASE mPar = 'Cls' SELECT Classes SET FILTER TO AT('-FUTURE',Name_cls) > 0 CASE mPar = 'Atr' SELECT Attributes SET FILTER TO AT('-PAST',Name_atr) > 0 ENDCASE FOR k=1 TO LEN(aKodBC) DBGOTO(aKodBC[k]) * DIGITF-1/5-{1.0, 2.6} DO CASE CASE mPar = 'Cls' mNm = ALLTRIM(Name_cls) mKd = Kod_cls CASE mPar = 'Atr' mNm = ALLTRIM(Name_atr) mKd = Kod_atr ENDCASE mPos = RAT('-{', mNm)+1 // Ищем справа на лево первую встречу '-{' mName = SUBSTR(mNm, mPos+1, LEN(mNm)-mPos) mName = STRTRAN(mName, '{','') mName = STRTRAN(mName, '}','') * MsgBox(STR(k)+' '+STR(aKodBC[k])+' '+TOKEN(mName, ',', 1)+' '+VALTYPE(TOKEN(mName, ',', 1))+' '+TOKEN(mName, ',', 2)+' '+VALTYPE(TOKEN(mName, ',', 2))) // Числовая шкала mMin = VAL(TOKEN(mName, ',', 1)) mMax = VAL(TOKEN(mName, ',', 2)) mAvrGrInt = mMin + ( mMax - mMin ) / 2 // Текстовая шкала IF ABS(mMin) + ABS(mMax) + ABS(mAvrGrInt) = 0 mMin = mKd mMax = mKd mAvrGrInt = mKd ENDIF * MsgBox(mNmCls+' '+STR(mMin,7,3)+STR(mMax,7,3)+STR(mAvrGrInt,7,3)) AADD(aAvr, mAvrGrInt) // Самим посчитать mAvrGrInt из наименования класса <<<===################# REPLACE Min_GrInt WITH mMin REPLACE Max_GrInt WITH mMax REPLACE Avr_GrInt WITH mAvrGrInt NEXT // Проверять, если все значения aAvr тождественные, то заменять их на самих себя + очень малый шум (в 2 последних знаках). Иначе не работает сглаживание полиномами Безье mFlag = .T. FOR j=1 TO LEN(aAvr)-1 IF aAvr[j] <> aAvr[j+1] mFlag = .F. EXIT ENDIF NEXT IF mFlag FOR j=1 TO LEN(aAvr) aAvr[j] = aAvr[j] + RANDOM()%(aAvr[j]*0.000001) // <<<===################## ошибка NEXT ENDIF ** Когда известен фактический сценарий, то надо его тоже отобразить и посчитать корреляцию между прогнозом и фактом <<<===################### SELECT DrawScen APPEND BLANK REPLACE Num WITH RECNO() REPLACE Kod WITH mKod REPLACE Name WITH mNameSc REPLACE Kod_Sc WITH mKodSc FOR j=1 TO LEN(aKodBC) mFieldName = "KBC"+ALLTRIM(STR(j,5)) // Код базового класса REPLACE &mFieldName WITH aKodBC[j] // <<<===########################## Когда сценарии с разным числом точек, то выдает ошибку на следующей точке, после минимальной mFieldName = "Avr"+ALLTRIM(STR(j,5)) // Среднее значение числового диапазона базового класса (для рисования и взвешенного усреднения) REPLACE &mFieldName WITH aAvr[j] NEXT ENDIF DO CASE CASE mPar = 'Cls' SELECT Classes SET FILTER TO AT('-FUTURE',Name_cls) > 0 .AND. AT('-Point',Name_cls) = 0 CASE mPar = 'Atr' SELECT Attributes SET FILTER TO AT('-PAST' ,Name_atr) > 0 .AND. AT('-Point',Name_atr) = 0 ENDCASE DBGOTO(mRecno) DBSKIP(1) ENDDO DC_Impl(oScr) ************************************************************************************************* ****** Отобразить и записать (сохранить в виде графических файлов) все будущие сценарии, ****** только сплайны Безье, как самые лучшие, ломанные линии и полиномы просто нет смысла делать ************************************************************************************************* *** Найти минимальные и максимальные значения по всем сценариям и по каждому сценарию <<<===################################### ****** Поиск макс и мин значений аргумента и функции ****** X_MinA = 1 // Минимальное значение X аргумента X_MaxA = N_PointsScenario // Максимальное значение Y аргумента Y_MinF = +99999999 // Минимальное значение Y функции Y_MaxF = -99999999 // Максимальное значение Y функции SELECT DrawScen DBGOTOP() mNScenMin = Kod_sc DBGOBOTTOM() mNScenMax = Kod_sc PRIVATE aY_MinF[mNScenMax];AFILL(aY_MinF, +99999999) PRIVATE aY_MaxF[mNScenMax];AFILL(aY_MaxF, -99999999) SELECT DrawScen DBGOTOP() DO WHILE .NOT. EOF() // Цикл по частным сценариям (в конце 2 строки отображать по-другому) <<<===######################## FOR j=1 TO N_PointsScenario mFieldName = "Avr"+ALLTRIM(STR(j,5)) // Среднее значение числового диапазона базового класса (для рисования и взвешенного усреднения) Y_MinF = MIN(Y_MinF, &mFieldName) Y_MaxF = MAX(Y_MaxF, &mFieldName) aY_MinF[Kod_sc] = MIN(aY_MinF[Kod_sc], &mFieldName) // В DrawScenario вместо Y_MinF и Y_MaxF использовать aY_MinF[Kod_sc] и aY_MaxF[Kod_sc] <<<===####### aY_MaxF[Kod_sc] = MAX(aY_MaxF[Kod_sc], &mFieldName) NEXT DBSKIP(1) ENDDO ************************************************************************************************************** ** РИСОВАНИЕ КРИВОЙ БЕЗЬЕ ************************************************************************************ ************************************************************************************************************** ****** Определение минимального числа разрядов для записи наименования сценария SELECT DrawScen DBGOBOTTOM() mKodScalMax = Kod_sc mKodScenMax = Kod mNRKodScal = LEN(ALLTRIM(STR(Kod_sc))) // Число разрядов в максимальном коде шкалы mNRKodScen = LEN(ALLTRIM(STR(Kod))) // Число разрядов в максимальном коде сценария ****** Цикл по будущим сценариям ******************************* PUBLIC X_MaxW := 1800, Y_MaxW := 900 // Размер графического окна для отображения когнитивных диаграмм в пикселях PUBLIC nXSize := 1800 PUBLIC nYSize := 900 SELECT DrawScen SET FILTER TO mNumScen <= Kod DBGOTOP();DBGOBOTTOM();DBGOTOP() DO WHILE .NOT. EOF() oScr := DC_WaitOn(L('Немного подождите! Идет формирование изображения в памяти и его масштабирование. Шкала-сценарий:')+' ['+ALLTRIM(STR(Kod_sc))+'/'+ALLTRIM(STR(mKodScalMax))+'-'+ALLTRIM(STR(Kod))+'/'+ALLTRIM(STR(mKodScenMax))+']',,,,,,,,,,,.F.) // Create new bitmap with given size oPS := XBPPRESSPACE() :new() :Create() oBMP := XBPBITMAP() :New() :Create() * oBMP:Make( nXSize, nYSize, nPlanes, nBits ) oBMP:Make( nXSize, nYSize ) oBMP:presSpace( oPS ) // here your GRA* Code **** Закрасить фон прямоугольника *************** * GraSetColor( oPS, GRA_CLR_WHITE, GRA_CLR_WHITE ) GraSetColor( oPS, BD_LIGHTGREY, BD_LIGHTGREY ) GraBox( oPS, { 0, 0 }, { nXSize, nYSize }, GRA_FILL ) *######################################################################################################################################## DrawScenario(oPS, Kod, Name, Kod_Sc, N_PointsScenario, mPar) // Графическая функция <<<===####### *######################################################################################################################################## *My image original, my image scaled SELECT DrawScen * mNRKodScal = LEN(ALLTRIM(STR(Kod_sc))) * mNRKodScen = LEN(ALLTRIM(STR(Kod))) DO CASE CASE mPar = 'Cls' ****** Запись полноразмерного графического файла в папку: M_PathAppl+"\FutureScenarios\" DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения IF FILEDATE("FutureScenarios",16) = CTOD("//") DIRMAKE("FutureScenarios") aMess := {} AADD(aMess, L('В папке текущего приложения: "'+UPPER(ALLTRIM(M_PathAppl))+'"')) AADD(aMess, L('не было директории "FutureScenarios" для будущих сценариев и она была создана!')) AADD(aMess, L('В эту папку записываются исходные изображения высокого качества (без масштабирования)')) LB_Warning(aMess, L('2.1. Классификационные шкалы и градации' )) ENDIF DIRCHANGE(M_PathAppl+"\FutureScenarios\") // Перейти в папку Futurecenarios cFileName = 'FutureScen'+'-'+ALLTRIM(STRTRAN(STR(Kod_sc,mNRKodScal),' ','0'))+'-'+ALLTRIM(STRTRAN(STR(Kod,mNRkodScen),' ','0'))+'-Splain.jpg' CASE mPar = 'Atr' ****** Запись полноразмерного графического файла в папку: M_PathAppl+"\PastScenarios\" DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения IF FILEDATE("PastScenarios",16) = CTOD("//") DIRMAKE("PastScenarios") aMess := {} AADD(aMess, L('В папке текущего приложения: "'+UPPER(ALLTRIM(M_PathAppl))+'"')) AADD(aMess, L('не было директории "PastScenarios" для прошлых сценариев и она была создана!')) AADD(aMess, L('В эту папку записываются исходные изображения высокого качества (без масштабирования)')) LB_Warning(aMess, L('2.2. Описательные шкалы и градации' )) ENDIF DIRCHANGE(M_PathAppl+"\PastScenarios\") // Перейти в папку Futurecenarios cFileName = 'PastScen'+'-'+ALLTRIM(STRTRAN(STR(Kod_sc,mNRKodScal),' ','0'))+'-'+ALLTRIM(STRTRAN(STR(Kod,mNRKodScen),' ','0'))+'-Splain.jpg' ENDCASE ERASE(cFileName) oBMP:SaveFile(cFileName,XBPBMP_FORMAT_JPG) IF nWidth > 1800 IF mPause = 1 FullView( cFileName, "по верху", 65 ) // Визуализация полноразмерного файла на мониторе высокого разрешения ENDIF ELSE ****** Формирование с помощью bmp2bmp() и отображение масштабированного изображения aNewSize := {nWidth,nHeight-29} // Новый размер изображения (еще немного уменьшается, чтобы не рисовать по панели задач) oBMP:loadFile(cFileName) // Загрузка полноразмерного изображения oRet := BMP2BMP(oBMP,aNewSize) // Масштабирование изображения cFileNameScale = SUBSTR(cFileName,1,AT(".jpg",cFileName)-1)+"_scaled.jpg" ERASE(cFileNameScale) oRet:saveFile(cFileNameScale,XBPBMP_FORMAT_JPG) // Запись масштабированного графического файла в в папку приложения для визуализации IF mPause = 1 FullView( cFileNameScale, "по верху", 0 ) // Визуализация масштабированного графического файла на мониторе ограниченного разрешения ENDIF ENDIF DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения DC_Impl(oScr) SELECT DrawScen DBSKIP(1) ENDDO ** Выдать сообщение и восстановить среду f2_1win2() или f2_2() DO CASE CASE mPar = 'Cls' CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Class_Sc INDEX ON Kod_ClSc TO Class_Sc CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Gr_ClSc NEW INDEX ON Kod_ClSc TO Gr_ClSc CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Class_Sc INDEX Class_Sc EXCLUSIVE NEW USE Gr_ClSc INDEX Gr_ClSc EXCLUSIVE NEW LB_Warning(L('Визуализация будущих сценариев завершена успешно!'), L('(C) Система "Эйдос"')) CASE mPar = 'Atr' ********** Среда f2_2() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Opis_Sc INDEX ON Kod_OpSc TO Opis_Sc CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Gr_OpSc NEW INDEX ON Kod_OpSc TO Gr_OpSc CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Obi_Kpr EXCLUSIVE NEW USE Rso_Kpr EXCLUSIVE NEW USE Opis_Sc INDEX Opis_Sc EXCLUSIVE NEW USE Gr_OpSc INDEX Gr_OpSc EXCLUSIVE NEW LB_Warning(L('Визуализация прошлых сценариев завершена успешно!'), L('(C) Система "Эйдос"')) ENDCASE RETURN NIL ******************************************************************************* ******** Отображение будущего или прошлого сценария спланами Безье *** ******************************************************************************* FUNCTION DrawScenario(oPS, mKodScen, mNameScen, mKodSc, N_PointsScenario, mPar) * PRIVATE X0 := 75 PRIVATE X0 := 115 * PRIVATE Y0 := 75 // Начало координат по осям X и Y с учетом места для легенды PRIVATE Y0 := 100 // Начало координат по осям X и Y с учетом места для легенды * PRIVATE W_Wind := X_MaxW - X0 - 25 // Ширина окна для самого графика PRIVATE W_Wind := X_MaxW - X0 - 35 // Ширина окна для самого графика PRIVATE H_Wind := Y_MaxW - Y0 - 110 // Высота окна для самого графика PRIVATE mNX := 10, mNY := 10 // Кол-во меток и надписей по осям X и Y PRIVATE Kx := W_Wind / ( X_MaxA-X_MinA ) // Коэффициент масштабирования по оси X: преобразует аргумент функции в номер пикселя по оси X * PRIVATE Ky := H_Wind / ( Y_MaxF-Y_MinF ) // Коэффициент масштабирования по оси Y: преобразует значение функции в номер пикселя по оси Y PRIVATE Ky := H_Wind / ( aY_MaxF[mKodSc]-aY_MinF[mKodSc] ) // Коэффициент масштабирования по оси Y: преобразует значение функции в номер пикселя по оси Y PRIVATE Y0A := IF(Y_MinF > 0, Y0, Y0+ABS(Y_MinF)*Ky) // Позиция оси X на оси Y **** Написать заголовок диаграммы ***************************************************************************************************************************** aFonts := XbpFont():new():list() // Все доступные шрифты oFont := XbpFont():new():create("18.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты DO CASE CASE mPar = 'Cls' mTitle = L('ПРОГНОЗИРУЕМЫЕ БУДУЩИЕ СЦЕНАРИИ - КЛАССЫ') CASE mPar = 'Atr' mTitle = L('ПРОШЛЫЕ СЦЕНАРИИ - ЗНАЧЕНИЯ ФАКТОРОВ') ENDCASE aTxtPar = DC_GraQueryTextbox(mTitle, oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox("Длина текста в пикселях="+ALLTRIM(STR(aTxtPar[1]))+". Высота текста в пикселях="+ALLTRIM(STR(aTxtPar[2]))) GraStringAt( oPS, { X_MaxW/2, Y_MaxW-25 }, mTitle) DO CASE CASE mPar = 'Cls' cFileName = 'FutureScen'+'-'+ALLTRIM(STR(mKodSc))+'-'+ALLTRIM(STR(mKodScen))+'-Splain.jpg' cNameScen = L('Будущий сценарий:')+' ['+ALLTRIM(STR(mKodSc))+'-'+ALLTRIM(STR(mKodScen))+']-'+ALLTRIM(mNameScen)+'. '+L('Сплайны Безье') CASE mPar = 'Atr' cFileName = 'PastScen' +'-'+ALLTRIM(STR(mKodSc))+'-'+ALLTRIM(STR(mKodScen))+'-Splain.jpg' cNameScen = L('Прошлый сценарий:')+' ['+ALLTRIM(STR(mKodSc))+'-'+ALLTRIM(STR(mKodScen))+']-'+ALLTRIM(mNameScen)+'. '+L('Сплайны Безье') ENDCASE ***************************************************************************************************** ******* Сделать такой шрифт, чтобы надпись помещалась в 1700 пикселях ******************************* mNumFont=ROUND(-12.994*LOG(40+LEN(cNameScen))+81.704,0) // Получено в MS Excel из логарифмического тренда (y=-12,994Ln(x)+81,704) зависимости размера шрифта mNumFont от кол-ва символов в заголовке LEN(cNameScen) mNumFont=IF(mNumFont=12,11,mNumFont) // 12-й шрифт почему-то вообще не отображается mFont = ALLTRIM(STR(mNumFont))+'.Arial Bold' oFont := XbpFont():new():create(mFont) GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraStringAt( oPS, { X_MaxW/2, Y_MaxW-52 }, cNameScen ) ******* Можно использовать во всех заголовках в графических формах ********************************** ***************************************************************************************************** oFont := XbpFont():new():create("14.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты IF LEN(ALLTRIM(M_NameAppl)) < 70 GraStringAt( oPS, { X_MaxW/2, Y_MaxW-80 }, "Приложение: "+'"'+ALLTRIM(M_NameAppl)+'"' ) ELSE GraStringAt( oPS, { X_MaxW/2, Y_MaxW-80 }, '"'+ALLTRIM(M_NameAppl)+'"' ) ENDIF *************************************************************************************************************************************************************** oFont := XbpFont():new():create("10.Arial") GraSetFont( oPS ,oFont ) aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты ***** Закрасить фон прямоугольника *************** GraSetColor( oPS, aColor[98] , aColor[98] ) GraBox( oPS, { X0, Y0 }, { X0+W_Wind, Y0+H_Wind }, GRA_FILL ) GraSetColor( oPS, aColor[222] , aColor[222] ) *** Закрасить области между метками на оси X ***** DX = ( X_MaxA-X_MinA ) / mNX // Диапазон значений x, через которое ставить метку GraSetColor( oPS, aColor[99], aColor[99] ) j = 0 FOR X=X_MinA TO X_MaxA STEP 2*DX j = j + 2 X1 = X0 + ( j - 1 ) * DX * Kx X2 = X0 + ( j ) * DX * Kx GraBox( oPS, { X1, Y0 }, { X2, Y0 + H_Wind }, GRA_FILL ) NEXT GraSetColor( oPS, aColor[222], aColor[222] ) *** Сделать сетку и надписать метки на оси X ********************* DX = ( X_MaxA-X_MinA ) / mNX // Диапазон значений x, через которое ставить метку j = 0 FOR X=X_MinA TO X_MaxA STEP DX ++j X1 = X0 + ( j - 1 ) * DX * Kx GraMarker ( oPS, { X1, Y0 } ) aTxtPar = DC_GraQueryTextbox(ALLTRIM(STR(X,15,1)), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox(STR(aTxtPar[1])+" "+STR(aTxtPar[2])) GraStringAt( oPS, { X1-aTxtPar[1]/2, Y0-25 }, ALLTRIM(STR(X,15,1)) ) GraLine ( oPS, { X1, Y0 }, {X1, Y0+H_Wind} ) // Нарисовать пунктирную линию уровня x NEXT j = mNX X1 = X0 + j * DX * Kx GraMarker ( oPS, { X1, Y0 } ) aTxtPar = DC_GraQueryTextbox(ALLTRIM(STR(X_MaxA,15,1)), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox(STR(aTxtPar[1])+" "+STR(aTxtPar[2])) GraStringAt( oPS, { X1-aTxtPar[1]/2, Y0-25 }, ALLTRIM(STR(X_MaxA,15,1)) ) GraLine ( oPS, { X1, Y0 }, {X1, Y0+H_Wind} ) // Нарисовать пунктирную линию уровня x *** Сделать сетку и надписать метки на оси Y ********************* * DY = ( Y_MaxF-Y_MinF ) / mNY // Диапазон значений Y, через которое ставить метку DY = ( aY_MaxF[mKodSc]-aY_MinF[mKodSc] ) / mNY // Диапазон значений Y, через которое ставить метку j = 0 * FOR Y=Y_MinF TO Y_MaxF STEP DY FOR Y=aY_MinF[mKodSc] TO aY_MaxF[mKodSc] STEP DY ++j Y1 = Y0 + ( j - 1 ) * DY * Ky GraMarker ( oPS, { X0 , Y1 } ) aTxtPar = DC_GraQueryTextbox(ALLTRIM(STR(Y,15,1)), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox(STR(aTxtPar[1])+" "+STR(aTxtPar[2])) GraStringAt( oPS, { X0-80, Y1-aTxtPar[2]/2 }, ALLTRIM(STR(Y,15,2)) ) GraLine ( oPS, { X0 , Y1 }, {X0+W_Wind, Y1} ) // Нарисовать пунктирную линию уровня Y NEXT j = mNY Y1 = Y0 + j * DY * Ky GraMarker ( oPS, { X0 , Y1 } ) aTxtPar = DC_GraQueryTextbox(ALLTRIM(STR(Y_MaxF,15,1)), oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox(STR(aTxtPar[1])+" "+STR(aTxtPar[2])) * GraStringAt( oPS, { X0-80, Y1-aTxtPar[2]/2 }, ALLTRIM(STR(Y_MaxF,15,2)) ) GraStringAt( oPS, { X0-80, Y1-aTxtPar[2]/2 }, ALLTRIM(STR(aY_MaxF[mKodSc],15,2)) ) GraLine ( oPS, { X0 , Y1 }, {X0+W_Wind, Y1} ) // Нарисовать пунктирную линию уровня Y ***** Нарисовать оси координат ******************* aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 2 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты GraLine( oPS, {X0 , Y0A }, {X0+W_Wind, Y0A } ) // Нарисовать ось X GraLine( oPS, {X0 , Y0 }, {X0 , Y0+H_Wind} ) // Нарисовать границу рамки изображения слева это и есть ось Y GraLine( oPS, {X0 , Y0 }, {X0+W_Wind, Y0 } ) // Нарисовать границу рамки изображения внизу параллельно оси X GraLine( oPS, {X0 , Y0+H_Wind}, {X0+W_Wind, Y0+H_Wind} ) // Нарисовать границу рамки изображения вверху параллельно оси X GraLine( oPS, {X0+W_Wind, Y0 }, {X0+W_Wind, Y0+H_Wind} ) // Нарисовать границу рамки изображения справа параллельно оси Y aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DOT aAttr [ GRA_AL_COLOR ] := 1 // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты *************************************************************************************************************************************************************** *** Присвоить массивам параметрически заданные значения отображаемой функции aArg := {} aVal := {} FOR j=1 TO N_PointsScenario mFieldName = "Avr"+ALLTRIM(STR(j,5)) // Среднее значение числового диапазона базового класса (для рисования и взвешенного усреднения) AADD(aArg, j) // % от общего числа признаков AADD(aVal, &mFieldName) // % от общей значимости NEXT **************************************************************************** SELECT Points;ZAP ******** В массивах aArg и aVal должно быть четное число элементов N_Points = LEN(aArg) * MsgBox(STR(N_Points)) IF N_Points - 2*INT(N_Points/2) > 0 ***** Найти ближйшее к N_Points большее четное число N_Add = N_Points DO WHILE N_Add <> 2 * INT(N_Add/2) N_Add++ ENDDO *** Добавить в массивы aArg и aVal столько элементов, чтобы их число было четное FOR j=1 TO N_Add - N_Points AADD(aArg, aArg[N_Points]) AADD(aVal, aVal[N_Points]) NEXT ENDIF N_Points = LEN(aArg) * MsgBox(STR(N_Points)) SELECT Points ****** Обработка ошибки ****************** bError := ErrorBlock( {|e| Break(e)} ) // установить новый кодовый блок обработки ошибок BEGIN SEQUENCE // код нормального исполнения *** код нормального исполнения FOR j=1 TO LEN(aArg) STEP 2 APPEND BLANK f=3 FOR i=j TO j+1 FIELDPUT(f, aArg[i]) // Сделать обработку ошибок. Рекомендовать выбрать более крупную единицу измерения <<<===############## f=f+2 NEXT f=4 FOR i=j TO j+1 FIELDPUT(f, aVal[i]) // Сделать обработку ошибок. Рекомендовать выбрать более крупную единицу измерения <<<===############## f=f+2 NEXT NEXT RECOVER // код обработки ошибки * CASE mPar = 'Cls' * mTitle = L('ПРОГНОЗИРУЕМЫЕ БУДУЩИЕ СЦЕНАРИИ - КЛАССЫ') * CASE mPar = 'Atr' * mTitle = L('ПРОШЛЫЕ СЦЕНАРИИ - ЗНАЧЕНИЯ ФАКТОРОВ') DC_Impl(oScr) aMess := {} AADD(aMess, L('При расчете координат точек сценария возникла ошибка, обусловленная тем, ')) // НАПРИМЕР AADD(aMess, L('средние значения числовых диапазонов')+' '+IF(mPar='Cls','классов','факторов')+' '+L('оказались слишком большими числами.')) AADD(aMess, L('НЕОБХОДИМО в файле исходных данных: "Inp_data.xls(x)" выбрать такие единицы')) AADD(aMess, L('измерения, чтобы в колонках не было чрезмерно больших чисел с целой частью ')) AADD(aMess, L('больше 11 разрядов, а затем заново ввести данные в систему в режиме 2.3.2.2 ')) AADD(aMess, L('или в другом автоматизированном программном интерфейсе (API) !!! ')) LB_Warning(aMess) * ADS_SERVER_QUIT() QUIT ENDSEQUENCE ErrorBlock( bError ) // переустановить старый кодовый ****************************************** ****** Дорасчет координат вставленных точек SELECT Points DBGOTOP() DO WHILE .NOT. EOF() mRecno = RECNO() mX2 = X2 mY2 = Y2 DBSKIP(1) mX1 = X1 mY1 = Y1 DBGOTO(mRecno) REPLACE Xf_Avr WITH (mX2+mX1)/2 REPLACE Yf_Avr WITH (mY2+mY1)/2 DBSKIP(1) ENDDO DBGOBOTTOM() // Последняя усредненная точка mX2 = X2 mY2 = Y2 REPLACE Xf_Avr WITH mX2 REPLACE Yf_Avr WITH mY2 ********* Дублирование координат вставленных точек из предыдущих записей в последующие DBGOTOP() DO WHILE .NOT. EOF() mXp_Avr = Xf_Avr mYp_Avr = Yf_Avr DBSKIP(1) REPLACE Xp_Avr WITH mXp_Avr REPLACE Yp_Avr WITH mYp_Avr ENDDO DBGOTOP() // Первая усредненная точка REPLACE Xp_Avr WITH X1 REPLACE Yp_Avr WITH Y1 *** Цикл визуализации сплайнов Безье ************************************************* SELECT Points PRIVATE aPoints[4, 2] // Массив для частной кривой Безье: 4 точки (X,Y) b-сплайна DBGOTOP() DO WHILE .NOT. EOF() ***** Рисование маркеров и отрезков прямых *************************************************** aColLine := {} // Цвета линии от внешней части к внутренней AADD(aColLine, 123) // WIDTH=9 AADD(aColLine, 181) // WIDTH=7 AADD(aColLine, 110) // WIDTH=5 AADD(aColLine, 108) // WIDTH=3 AADD(aColLine, 180) // WIDTH=1 FOR mLine = 1 TO 20 N_Col = 1 + ROUND(mLine/5,0) // Номер цвета aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := aColor[aColLine[N_Col]] // Фиолетовые разной яркости aAttr [ GRA_AL_WIDTH ] := 16 - N_Col * 3 // Задать толщину линии сценария, соответствующую цвету graSetAttrLine( oPS, aAttr ) // Установить атрибуты SELECT Points PRIVATE aPoints[4, 2] // Массив для частной кривой Безье: 4 точки (X,Y) b-сплайна DBGOTOP() DO WHILE .NOT. EOF() b=0 FOR j=1 TO 7 STEP 2 b++ aPoints[b, 1] = X0 + (FIELDGET(j) -X_MinA) * Kx * aPoints[b, 2] = Y0 + (FIELDGET(j+1)-Y_MinF) * Ky aPoints[b, 2] = Y0 + (FIELDGET(j+1)-aY_MinF[mKodSc]) * Ky NEXT graSetAttrLine( oPS, aAttr ) // установить атрибуты GraSpline( oPS, aPoints, .F. ) // НАРИСОВАТЬ ЧАСТНУЮ КРИВУЮ БЕЗЬЕ <<<===########### DBSKIP(1) ENDDO ************************************ Конец отображения кривой Безье *********************** NEXT DBSKIP(1) ENDDO * ********* ОТЛАДКА ПОДБОРА РАЗМЕРА ШРИФТА В ЗАВИСИМОСТИ ОТ ДЛИНЫ ЗАГОЛОВКА ******************************************************* * cNameScen = '' * n=0 * FOR j=1 TO 300 * IF n+1 <= 9 * n++ * ELSE * n=0 * ENDIF * cNameScen = cNameScen + ALLTRIM(STR(n)) * NEXT * cNameScen = cNameScen + "#" * oFont := XbpFont():new():create("18.Arial Bold") * GraSetFont(oPS , oFont) // установить шрифт * aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_LEFT // Выравнивание символов по горизонтали по левому краю * GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты * d=40 * oFont := XbpFont():new():create("18.Arial Bold");GraSetFont(oPS , oFont);GraStringAt( oPS, { 10, Y_MaxW- 1*d }, "18."+cNameScen ) * oFont := XbpFont():new():create("17.Arial Bold");GraSetFont(oPS , oFont);GraStringAt( oPS, { 10, Y_MaxW- 2*d }, "17."+cNameScen ) * oFont := XbpFont():new():create("16.Arial Bold");GraSetFont(oPS , oFont);GraStringAt( oPS, { 10, Y_MaxW- 3*d }, "16."+cNameScen ) * oFont := XbpFont():new():create("15.Arial Bold");GraSetFont(oPS , oFont);GraStringAt( oPS, { 10, Y_MaxW- 4*d }, "15."+cNameScen ) * oFont := XbpFont():new():create("14.Arial Bold");GraSetFont(oPS , oFont);GraStringAt( oPS, { 10, Y_MaxW- 5*d }, "14."+cNameScen ) * oFont := XbpFont():new():create("13.Arial Bold");GraSetFont(oPS , oFont);GraStringAt( oPS, { 10, Y_MaxW- 6*d }, "13."+cNameScen ) * oFont := XbpFont():new():create("12.Arial Bold");GraSetFont(oPS , oFont);GraStringAt( oPS, { 10, Y_MaxW+ 7*d }, "12."+cNameScen ) * oFont := XbpFont():new():create("11.Arial Bold");GraSetFont(oPS , oFont);GraStringAt( oPS, { 10, Y_MaxW- 8*d }, "11."+cNameScen ) * oFont := XbpFont():new():create("10.Arial Bold");GraSetFont(oPS , oFont);GraStringAt( oPS, { 10, Y_MaxW- 9*d }, "10."+cNameScen ) * oFont := XbpFont():new():create(" 9.Arial Bold");GraSetFont(oPS , oFont);GraStringAt( oPS, { 10, Y_MaxW-10*d }, " 9."+cNameScen ) * oFont := XbpFont():new():create(" 8.Arial Bold");GraSetFont(oPS , oFont);GraStringAt( oPS, { 10, Y_MaxW-11*d }, " 8."+cNameScen ) * oFont := XbpFont():new():create(" 7.Arial Bold");GraSetFont(oPS , oFont);GraStringAt( oPS, { 10, Y_MaxW-12*d }, " 7."+cNameScen ) * oFont := XbpFont():new():create(" 6.Arial Bold");GraSetFont(oPS , oFont);GraStringAt( oPS, { 10, Y_MaxW-13*d }, " 6."+cNameScen ) * ********* ОТЛАДКА ПОДБОРА РАЗМЕРА ШРИФТА В ЗАВИСИМОСТИ ОТ ДЛИНЫ ЗАГОЛОВКА ******************************************************* ****** Надписи координатных осей ********************************* oFont := XbpFont():new():create("13.Arial Bold") GraSetFont( oPS ,oFont ) AxName = L("Шкала времени на период прогнозирования=")+' '+ ALLTRIM(STR(N_PointsScenario)) GraStringAt( oPS, { X0+W_Wind/2-8*LEN(AxName)/2, Y0-45 }, AxName ) // Надпись оси Х * MsgBox(cFileName) cFile = Disk_dir+'\'+cFileName aTxtPar = DC_GraQueryTextbox(cFile, oFont) // {101,16} Определяет длину и высоту текста в пикселях для некоторых шрифтов * MsgBox(STR(aTxtPar[1])+" "+STR(aTxtPar[2])) mPosX = X0+W_Wind-aTxtPar[1]-200 GraStringAt( oPS, { mPosX, Y0-45 }, cFile ) // Полное наименование файла GraStringAt( oPS, { mPosX, Y0-65 }, DTOC(DATE())+'-'+TIME() ) // Время создания файла DO CASE CASE mPar = 'Cls' SELECT Class_sc DBGOTO(mKodSc) mNameSc = ALLTRIM(Name_ClSc) CASE mPar = 'Atr' SELECT Opis_Sc DBGOTO(mKodSc) mNameSc = ALLTRIM(Name_OpSc) ENDCASE AyName = L("Значение шкалы:")+' "'+mNameSc+'"' // Написать название шкалы aMatrix := GraInitMatrix() GraRotate( oPS, aMatrix, 90, { X0-105, Y0+H_Wind/2-8*LEN(AyName)/2 }, GRA_TRANSFORM_ADD ) oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) GraStringAt( oPS, { X0-105, Y0+H_Wind/2-8*LEN(AyName)/2 }, AyName ) // Надпись оси Y ****** Не получается отключить режим вращения изображения ****** Вместо отключения можно докрутить до 360 градусов X_Max := 1800 Y_Max := 850 // Размер графического окна для самого графика в пикселях aMatrix := GraInitMatrix() // <<<########## GraRotate( oPS, aMatrix, 0, {900, 425}, GRA_TRANSFORM_REPLACE ) // <<<########## oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) // <<<########## RETURN NIL *************************************************************************************************** ******** Преобразование файла: Inp_data.csv в Inp_data.dbf на Питоне. Проверено на 1.3 млн. записей *************************************************************************************************** FUNCTION CsvDbfConv() ************************************************************************************************************************************ ******* Определение имен, типов и длин полей, а для числовых полей и числа знаков после запятой, для создания Inp_data.dbf ********* ************************************************************************************************************************************ PUBLIC Disk_name := DISKNAME() PUBLIC Cur_dir := CURDIR() PUBLIC Disk_dir := Disk_name+":\"+Cur_dir // Путь на папку с системой IF .NOT. FILE(Disk_dir+'\AID_DATA\Inp_data\Inp_data.csv') LB_Warning('В папке:'+' '+Disk_dir+'\AID_DATA\Inp_data\'+' '+'должен быть файл:'+' '+'"Inp_data.csv"', '(C) Система "Эйдос"') RETURN(.F.) ENDIF oTR := HBTextReader( Disk_dir+'\AID_DATA\Inp_data\Inp_data.csv' ) // per Funktion cZeile := oTR:GetLine() // Пропуск строки с наименованиями полей oTR:Destroy() * MsgBox(cZeile) IF NUMTOKEN(cZeile, ',') = 0 LB_Warning('На самом деле файл: '+' '+Disk_dir+'\AID_DATA\Inp_data\Inp_data.csv'+' не является CSV файлом', '(C) Система "Эйдос"') RETURN(.F.) ENDIF aFieldName := {} FOR j=1 TO NUMTOKEN(cZeile, ',') AADD(aFieldName, ALLTRIM(STRTRAN(TOKEN(cZeile, ',', j),'"',''))) NEXT nField := LEN(aFieldName) **** Создание и запись файла наим.класс.и опис.шкал и градаций: "Inp_name.txt" для API 2.3.2.2 ********* CrLf = CHR(13)+CHR(10) // Конец строки (записи) String = aFieldName[2] + CrLf // Наименования объектов не включаем, т.к. это не шкала. Все остальные колонки со 3-й по последнюю включаем IF nField > 2 FOR j=3 TO nField String = String + aFieldName[j] + IF(j DBF на Питоне ******************************* LC_RunShell("__AIDOS-PY.exe", 717400306, "csv_to_dbf_py") // Мой вариант на Питоне в системе __AIDOS-PY.exe. Работает в десятки или сотни раз быстрее, чем на xBase++ RETURN(.T.) ******************************************************************************** ******************************************************************************** ****************************************************************************************** ******** Преобразование файла: Inp_data.csv в Inp_data.dbf. Проверено на 4 млн. записей ****************************************************************************************** *FUNCTION MAIN() FUNCTION CsvDbfConv_old() local nZeile := 0 local cZeile := "" local nSize, nBytes := 0 local nDauer, cFile, oTR * Running(.T.) ************************************************************************************************************************************ ******* Определение имен, типов и длин полей, а для числовых полей и числа знаков после запятой, для создания Inp_data.dbf ********* ************************************************************************************************************************************ DC_IconDefault(1000) PUBLIC Disk_name := DISKNAME() PUBLIC Cur_dir := CURDIR() PUBLIC Disk_dir := Disk_name+":\"+Cur_dir // Путь на папку с системой DIRCHANGE(Disk_dir+'\AID_DATA\Inp_data\') // Перейти в папку: ..\AID_DATA\Inp_data\ cFile := "Inp_data.csv" IF .NOT. FILE(cFile) LB_Warning('В папке:'+' '+Disk_dir+'\AID_DATA\Inp_data\'+' '+'должен быть файл:'+' '+'"Inp_data.csv"', '(C) Система "Эйдос"') RETURN NIL ENDIF oTR := HBTextReader( cFile ) // per Funktion cZeile := oTR:GetLine() // Пропуск строки с наименованиями полей oTR:Destroy() aFieldName := {} FOR j=1 TO NUMTOKEN(cZeile, ',') AADD(aFieldName, ALLTRIM(STRTRAN(TOKEN(cZeile, ',', j),'"',''))) NEXT nField := LEN(aFieldName) **** Создание и запись файла наим.класс.и опис.шкал и градаций: "Inp_name.txt" для API 2.3.2.2 ********* CrLf = CHR(13)+CHR(10) // Конец строки (записи) String = aFieldName[2] + CrLf // Наименования объектов не включаем, т.к. это не шкала. Все остальные колонки со 3-й по последнюю включаем IF nField > 2 FOR j=3 TO nField String = String + aFieldName[j] + IF(j DBF конвертер системы "Эйдос"'; PARENT @oDialog ; FIT ; EXIT ; MODAL oDialog:show() *********************************************************************************************************************** mMess = '1/2-Определение в файле "Inp_data.csv" имен полей, их длин и типов данных в них:'+' ' * mMess = '2/2-Создание файла "Inp_data.dbf" и перенос в него данных из файла "Inp_data.csv":'+' ' nZeile = 0 oTR := HBTextReader( cFile ) // per Funktion cZeile := oTR:GetLine() // Пропуск строки с наименованиями полей DO WHILE ! oTR:EOF() nZeile++ cZeile := oTR:GetLine() // aktuelle Zeile einlesen, Zeiger intern auf n"chste Zeile setzen ! FOR j=1 TO nField aFieldVal[j] = ALLTRIM(TOKEN(cZeile, ',', j)) NEXT * MsgBox(cZeile) *** Если в поле хотя бы раз встретилось текстовое значение, то оно имеет тип данных "текстовое" *** Числовой тип данных только если все значения числовые (или пробел). PRIVATE aFlagIsNumber[nField] AFILL(aFlagIsNumber, .T.) // Флаг = .T., если число FOR j=1 TO nField IF aFieldType[j] = 'N' mValS = ALLTRIM(aFieldVal[j]) mLenVal = LEN(mValS) IF mLenVal > 0 *** Идентификация не числа ************* FOR i=1 TO mLenVal mASC = ASC(SUBSTR(mValS,i,1)) // ASCII-код i-го символа // Если хотя бы один символ из значения поля имеют код не цифры: 0123456789, // не "+", не "-", не ".", то это не число DO CASE CASE 48 = mASC // 0 CASE 49 = mASC // 1 CASE 50 = mASC // 2 CASE 51 = mASC // 3 CASE 52 = mASC // 4 CASE 53 = mASC // 5 CASE 54 = mASC // 6 CASE 55 = mASC // 7 CASE 56 = mASC // 8 CASE 57 = mASC // 9 CASE 43 = mASC // + CASE 45 = mASC // - CASE 46 = mASC // . * CASE 32 = mASC // пробел OTHERWISE * MsgBox(STR(j)+' '+mValS+STR(i)+SUBSTR(mValS,i,1)) // Иногда в CSV-файлах могут быть числа с плавающей запятой. Они считаются текстом из-за "e" aFlagIsNumber[j] = .F. // Флаг = .T., если число EXIT ENDCASE NEXT ENDIF IF aFlagIsNumber[j] // <<<===################ mPos = AT('.',mValS) IF mPos > 0 aFieldDeci[j] = mLenVal-mPos ENDIF ELSE aFieldType[j] = 'C' ENDIF ENDIF aFieldSize[j] = MAX(aFieldSize[j], mLenVal) // <<<===################ NEXT mNumPP = nZeile lOk = Time_Progress (++Time_Progress, 2*N_ALL, oProgress, lOk ) PercTimeVisio(1, mMess, N_ALL) // Индикация процесса исполнения ENDDO oTR:Destroy() mMess = '2/2-Создание файла "Inp_data.dbf" и перенос в него данных из файла "Inp_data.csv":'+' ' **** Создание DBF для данных из CSV-файла ******** * LB_Warning(aFieldName, '(C) Система "Эйдос"') * LB_Warning(aFieldType, '(C) Система "Эйдос"') * LB_Warning(aFieldSize, '(C) Система "Эйдос"') * LB_Warning(aFieldDeci, '(C) Система "Эйдос"') mLen = LEN(ALLTRIM(STR(nZeile)))+1 aStructure := { { 'RecNumber', 'N', mLen, 0 } } // 1-е поле с номером записи FOR j=1 TO nField AADD(aStructure, { aFieldName[j], aFieldType[j], aFieldSize[j], aFieldDeci[j] }) NEXT DbCreate( 'Inp_data', aStructure ) ****** Преобразование CSV => DBF ******************************* CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Inp_data EXCLUSIVE NEW mRecSize = RECSIZE() // Определить размер одной записи БД Inp_data.dbf m2Gb = 2 * 2 ^ 30 // 2 Gb oTR := HBTextReader( cFile ) // per Funktion cZeile := oTR:GetLine() // Пропуск строки с наименованиями полей nZeile = 0 DO WHILE ! oTR:EOF() cZeile := oTR:GetLine() // aktuelle Zeile einlesen, Zeiger intern auf n"chste Zeile setzen ! FOR j=1 TO nField mFieldVal = ALLTRIM(TOKEN(cZeile, ',', j)) IF aFieldType[j] = 'N' aFieldVal [j] = VAL(mFieldVal) ELSE aFieldVal [j] = ALLTRIM(mFieldVal) ENDIF NEXT mFlag2Gb = .F. nZeile++ IF mRecSize * (nZeile+1) > m2Gb // Базу больше 2 Гб не записывать или записывать в дургие файлы: Inp_data-###.dbf mFlag2Gb = .T. EXIT ELSE APPEND BLANK FIELDPUT(1, nZeile) FOR j=1 TO nField FIELDPUT(1+j, aFieldVal[j]) NEXT ENDIF mNumPP = nZeile lOk = Time_Progress (++Time_Progress, 2*N_ALL, oProgress, lOk ) PercTimeVisio(2, mMess, N_ALL) // Индикация процесса исполнения ENDDO lOk = Time_Progress (2*N_ALL, 2*N_ALL, oProgress, lOk ) oTR:Destroy() CLOSE ALL DIRCHANGE(Disk_dir) // Перейти в папку с исп.модулем системы Эйдос IF mFlag2Gb Mess = 'Конвертация CSV => DBF прервана, т.к. "Inp_data.dbf" мог стать > 2 Гб' ELSE Mess = 'Преобразование: CSV => DBF завершено полностью! "Inp_data.dbf" < 2 Гб' ENDIF LB_Warning(Mess, '(C) Система "Эйдос"') * Running(.T.) // Чтобы не могли запустить какой-нибудь режим пока висит окно окончания работы oSay97:SetCaption(Mess) oSay97:SetCaption(oSay97:Caption) oButton:SetCaption('&Ok') // Деструктурирование окна отображения графического Progress-bar oButton:activate := {||PostAppEvent(xbeP_Close,,,oDialog)} //<<<<<< Add This DC_AppEvent( @lOk ) * MILLISEC(1000) oDialog:Destroy() * Running(.F.) RETURN NIL ******************************************************************************** ******************************************************************************** *#endif * Klasse zum sequentiellen Einlesen groЯer Dateien * Da die BlockgrцЯe auf 4 KB begrenzt ist, kann man auch einfach die Zeilen ausschneiden. #include "Fileio.ch" function HBTextReader( cFile ) local oTR := HBTxtReader():new( cFile ) return oTR CLASS HBTxtReader PROTECTED: VAR nH VAR nLastError VAR IsEOF // Buffer hat beim Einlesen EOF erreicht, Zeilen kцnnen noch da sein ! VAR cRest VAR nBufferBytes // Anzahl der gelesenen Byte im Buffer VAR cCRLF, nLenCRLF // Unix/Linux nur chr(10) = 1 Byte, Windows chr(13)+chr(10) = 2 Byte VAR Line METHOD ReadBuffer EXPORTED: METHOD Init METHOD Destroy METHOD GetLine METHOD GoTop METHOD FSize METHOD FError METHOD ErrMsg METHOD EOF METHOD IsCrLf METHOD IsUnix METHOD IsMac INLINE METHOD RecNo ; RETURN ::line INLINE METHOD LenCrLf ; RETURN ::nLenCRLF METHOD FileType ENDCLASS METHOD HBTxtReader:Init( cFileName ) // Цffnet die Datei zum Lesen ::nLastError := 0 ::cRest := "" ::nBufferBytes := 0 ::Line := 0 ::nH := fopen( cFileName , FO_READ + FO_SHARED ) if ::nH = -1 ::nLastError := FError() ::IsEOF := .t. else ::IsEOF := .f. ::ReadBuffer() do case case chr(13)+chr(10) $ ::cRest // Windows etc. ::cCRLF := chr(13)+chr(10) ::nLenCRLF := 2 case chr(10) $ ::cRest // Unix ::cCRLF := chr(10) ::nLenCRLF := 1 case chr(13) $ ::cRest // Mac ::cCRLF := chr(13) ::nLenCRLF := 1 end endif RETURN SELF METHOD HBTxtReader:Destroy() if ::nH <> -1 FClose(::nH) ::nH := -1 endif ::cRest := "" RETURN SELF METHOD HBTxtReader:ReadBuffer() local cBuffer, nBufferLen, nBytes if ::nH > -1 nBufferLen := 4096 cBuffer := space(nBufferLen) nBytes := FRead( ::nH, @cBuffer, nBufferLen) cBuffer := StrTran(cBuffer,chr(26)," ") ::nBufferBytes += nBytes if nBufferLen = nBytes // mitten in Datei ::cRest += cBuffer else ::cRest += left(cBuffer,nBytes) ::IsEOF := .t. if FError() <> 0 ::nLastError := FError() endif endif cBuffer := "" endif Return METHOD HBTxtReader:GetLine() local nPosCRLF local cLine := "" do while ! ::cCRLF $ ::cRest .and. ! ::IsEof // Buffer einlesen, bis wir neue Zeilen haben oder die Datei gelesen wurde ::ReadBuffer() enddo nPosCRLF := at( ::cCRLF, ::cRest) if nPosCRLF > 0 // es gibt noch eine komplette Zeile, zur?ckgeben und k?rzen cLine := left(::cRest,nPosCRLF-1) ::cRest := substr(::cRest,nPosCRLF+::nLenCRLF) else cLine := ::cRest ::cRest := "" endif ::Line++ return cLine METHOD HBTxtReader:GoTop() if ::nH <> -1 FSeek(::nH, 0 , FS_SET ) endif ::cRest := "" // zwingt zum neu einlesen ::Line := 0 ::ReadBuffer() return NIL METHOD HBTxtReader:FSize() local nSize := 0 if ::nH <> -1 nSize := FSize(::nH) endif RETURN nSize METHOD HBTxtReader:FError() RETURN ::nLastError METHOD HBTxtReader:EOF() RETURN ::IsEOF .and. empty(::cRest) METHOD HBTxtReader:IsCrLf() RETURN (::cCRLF == chr(13)+chr(10)) METHOD HBTxtReader:IsUnix() RETURN (::cCRLF == chr(10)) METHOD HBTxtReader:IsMac() RETURN (::cCRLF == chr(13)) METHOD HBTxtReader:ErrMsg() RETURN DosErrorMessage(::nLastError) METHOD HBTxtReader:FileType() local cTxt := "" do case case ::IsCrLf() cTxt := "CRLF" case ::IsUnix() cTxt := "UNIX/Linux" case ::IsMac() cTxt := "MAC" end return cTxt ****************************************************************************************** FUNCTION LC_BrowPres() aPres := ; { { XBP_PP_COL_HA_FGCLR, GRA_CLR_WHITE },; // Header FG Color { XBP_PP_COL_HA_BGCLR, GRA_CLR_DARKGRAY },; // Header BG Color { XBP_PP_COL_FA_FGCLR, GRA_CLR_YELLOW },; // Footer FG Color { XBP_PP_COL_FA_BGCLR, GRA_CLR_DARKGRAY },; // Footer BG Color { XBP_PP_COL_DA_ROWSEPARATOR, XBPCOL_SEP_DOTTED },; // Row Sep { XBP_PP_COL_DA_COLSEPARATOR, XBPCOL_SEP_DOTTED },; // Col Sep { XBP_PP_COL_HA_ALIGNMENT, XBPALIGN_LEFT },; // Header alignment { XBP_PP_COL_DA_ROWHEIGHT, 20 },; // Row Height { XBP_PP_COL_DA_CELLHEIGHT, 20 } } // Cell Height RETURN(aPres) ****************************************************************************************** ************************************************************************************************************* ******** 3.7.9. Корректировка экспертных оценок: объект => класс ******** В данном итерационном режиме в обучающая выборка корректируется на основе результатов распознавания: ******** меняется принадлежность объекта к классу с экспертной на полученную с помощью модели. ******** Процесс прекращается, когда менять ничего не надо, т.к. все совпадает или результат не улучшается ************************************************************************************************************* FUNCTION F3_7_9() LOCAL GetList[0] Running(.T.) IF ApplChange("F3_7_9()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF *** Что делать, если много классификационных шкал? Менять только один код за один раз **** АЛГОРИТМ: ********************************************************************************************** *** 1. Проверить наличие всех необходимых для работы БД. Если чего-то не хватает - выдать сообщение о том, какие режимы надо выполнить. *** 2. Задать текущую модель и интегральный критерий, с которым проводить распознавание. Сообщить, что распознавание будет осуществляться на GPU. *** 3. Формировать БД по результатам итераций с заменами кодов классов: *** Номер итерации, Код объекта, наименование объекта, старый код класса, наименование старого класса, новый код класса, наименование нового класса *** 4. Есть ли необходимость в корректировках, т.е. есть ли ложно-положительные решения? *** 5. Начало цикла итераций ********************* *** 6. Замена кодов классов в обучающей выборке с заданных изначально (экспертным путем) на полученные в результате распознавания в модели *** 7. Синтез модели на GPU с диалогом *** 8. Распознавание на GPU с диалогом *** 9. Есть еще необходимость в корректировках, т.е. есть ли ложно-положительные решения? *** 10. Конец цикла итераций ********************* *** 11. Синтез и верифкация всех моделей в режиме 3.5 ******************************************* *** 12. Сообщение о конце итераций и пути на БД с выходными результатами, выход. ************************************************************************************************************* *** 1. Проверить наличие всех необходимых для работы БД. Если чего-то не хватает - выдать сообщение о том, какие режимы надо выполнить. IF .NOT. FILE("Obi_Zag.dbf") // БД заголовков обучающей выборки aMess := {} AADD(amess, L('Отсутствует обучающая выборка!')) AADD(amess, L('Необходимо создать приложение!')) LB_Warning(aMess, L('(C) Система "Эйдос"')) Running(.F.) RETURN NIL ENDIF IF .NOT. FILE("Abs.txt") .OR.; // БД абс.частот .NOT. FILE("Prc1.txt") .OR.; // БД процентных распределений .NOT. FILE("Prc2.txt") .OR.; .NOT. FILE("Inf1.txt") .OR.; // БЗ-1 .NOT. FILE("Inf2.txt") .OR.; .NOT. FILE("Inf3.txt") .OR.; .NOT. FILE("Inf4.txt") .OR.; .NOT. FILE("Inf5.txt") .OR.; .NOT. FILE("Inf6.txt") .OR.; .NOT. FILE("Inf7.txt") LB_Warning(L("Проведите синтез и верификацию моделей в режиме 3.5!")) // <<<===################ вызвать функцию 3_5() Running(.F.) RETURN NIL ENDIF IF .NOT. FILE("Rasp.dbf") // БД заголовков обучающей выборки aMess := {} AADD(amess, L('Отсутствуют результаты распознавания!')) AADD(amess, L('Необходимо выполнить распознавание в режиме 4.1.2!')) LB_Warning(aMess, L('(C) Система "Эйдос"')) Running(.F.) RETURN NIL ENDIF *** 2. Задать текущую модель и интегральный критерий, с которым проводить распознавание. Сообщить, что распознавание будет осуществляться на GPU. ******************************************************************************************* ****** 0. Задать текущую стат.модель или модель знаний и интегральный критерий ******************************************************************************************* ****** Задание на расчет баз знаний IF FILE("_CalcInf.arx") // Файл с информацией о том, какие модели были рассчитаны ранее aCalcInf = DC_ARestore("_CalcInf.arx") ELSE LB_Warning(L("Необходимо выполнить расчет баз знаний в режиме 3.5.!")) Running(.F.) RETURN NIL ENDIF IF .NOT. FILE("EventsKO.dbf") LB_Warning(L("Этот режим работает только если для ввода данных был использован API-2.3.2.2!")) Running(.F.) RETURN NIL ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Class_Sc EXCLUSIVE NEW;N_ClSc = RECCOUNT() IF N_ClSc > 1 LB_Warning(L("В настоящее время данный режим реализован только для моделей с одной классификационной шкалой!")) Running(.F.) RETURN NIL ENDIF IF FILE("_CurrInf.arx") // Файл с информацией о том, какая модель задана текущей M_CurrInf = DC_ARestore("_CurrInf.arx") ELSE DC_ASave(M_CurrInf, "_CurrInf.arx") ENDIF ********** Заменять старый код класса на новый только если он относится к той же классификационной шкале <<<===################## *CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций *USE Class_Sc EXCLUSIVE NEW *SELECT Class_Sc *mNClsSc = RECCOUNT() *IF mNClsSc > 1 * LB_Warning(L("Данный режим применим только к моделям с 1-й классификационной шкалой!")) * Running(.F.) * RETURN NIL *ENDIF mNumIntKr = 1 mVarObrab = 1 mDelIstFP = 1 ****** Задание текущей модели @ 0,0 DCGROUP oGroup1 CAPTION L('Статистические и системно-когнитивные модели: ') SIZE 91,13.5 @14,0 DCGROUP oGroup2 CAPTION L('Интегральный критерий для распознавания: ') SIZE 91, 3.5 @18,0 DCGROUP oGroup3 CAPTION L('Итерационный алгоритм корректировки экспертных оценок:') SIZE 91, 4.5 @23,0 DCGROUP oGroup4 CAPTION L('ПОСЛЕ итераций УДАЛЯТЬ из обучающей выборки неустраненные источники ложно-положительных решений?') SIZE 91, 3.5 @27,0 DCGROUP oGroup5 CAPTION L('Предупреждение: ') SIZE 91, 4.5 @ 1,1 DCSAY L('Статистические базы:' ) PARENT oGroup1 @ 2,3 DCRADIO M_CurrInf VALUE 1 PROMPT L('1. ABS - частный критерий: количество встреч сочетаний: "класс-признак" у объектов обуч.выборки') PARENT oGroup1 EDITPROTECT {|| .NOT. aCalcInf[ 1] } HIDE {|| .NOT. aCalcInf[ 1] } @ 3,3 DCRADIO M_CurrInf VALUE 2 PROMPT L('2. PRC1 - частный критерий: усл. вероятность i-го признака среди признаков объектов j-го класса ') PARENT oGroup1 EDITPROTECT {|| .NOT. aCalcInf[ 2] } HIDE {|| .NOT. aCalcInf[ 2] } @ 4,3 DCRADIO M_CurrInf VALUE 3 PROMPT L('3. PRC2 - частный критерий: условная вероятность i-го признака у объектов j-го класса ') PARENT oGroup1 EDITPROTECT {|| .NOT. aCalcInf[ 3] } HIDE {|| .NOT. aCalcInf[ 3] } @ 5.2,1 DCSAY L('Системно-когнитивные модели (Базы знаний):' ) PARENT oGroup1 @ 6,3 DCRADIO M_CurrInf VALUE 4 PROMPT L('4. INF1 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC1 ') PARENT oGroup1 EDITPROTECT {|| .NOT. aCalcInf[ 4] } HIDE {|| .NOT. aCalcInf[ 4] } @ 7,3 DCRADIO M_CurrInf VALUE 5 PROMPT L('5. INF2 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC2 ') PARENT oGroup1 EDITPROTECT {|| .NOT. aCalcInf[ 5] } HIDE {|| .NOT. aCalcInf[ 5] } @ 8,3 DCRADIO M_CurrInf VALUE 6 PROMPT L('6. INF3 - частный критерий: Xи-квадрат, разности между фактическими и ожидаемыми абс.частотами ') PARENT oGroup1 EDITPROTECT {|| .NOT. aCalcInf[ 6] } HIDE {|| .NOT. aCalcInf[ 6] } @ 9,3 DCRADIO M_CurrInf VALUE 7 PROMPT L('7. INF4 - частный критерий: ROI (Return On Investment); вероятности из PRC1 ') PARENT oGroup1 EDITPROTECT {|| .NOT. aCalcInf[ 7] } HIDE {|| .NOT. aCalcInf[ 7] } @10,3 DCRADIO M_CurrInf VALUE 8 PROMPT L('8. INF5 - частный критерий: ROI (Return On Investment); вероятности из PRC2 ') PARENT oGroup1 EDITPROTECT {|| .NOT. aCalcInf[ 8] } HIDE {|| .NOT. aCalcInf[ 8] } @11,3 DCRADIO M_CurrInf VALUE 9 PROMPT L('9. INF6 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC1 ') PARENT oGroup1 EDITPROTECT {|| .NOT. aCalcInf[ 9] } HIDE {|| .NOT. aCalcInf[ 9] } @12,3 DCRADIO M_CurrInf VALUE 10 PROMPT L('10.INF7 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC2 ') PARENT oGroup1 EDITPROTECT {|| .NOT. aCalcInf[10] } HIDE {|| .NOT. aCalcInf[10] } @ 1,3 DCRADIO mNumIntKr VALUE 1 PROMPT L('1. Сумма знаний ') PARENT oGroup2 @ 2,3 DCRADIO mNumIntKr VALUE 2 PROMPT L('2. Резонанс знаний') PARENT oGroup2 // <<<===################# Добавить HELP (pdf на основе статьи) mStr = L('Помощь') @ 1.3, 60 DCPUSHBUTTON CAPTION mStr SIZE LEN(mStr)+10, 1.5 ACTION {||Help379(), DC_GetRefresh(GetList)} PARENT oGroup2 TOOLTIP L('Помощь по режиму 3.7.9') @ 1,3 DCRADIO mVarObrab VALUE 1 PROMPT L('1. ВО ВРЕМЯ итераций ЗАМЕНЯТЬ экспертный код класса на код по модели без удаления наблюдений. ') PARENT oGroup3 @ 2,3 DCRADIO mVarObrab VALUE 2 PROMPT L('2. ВО ВРЕМЯ итераций УДАЛЯТЬ из обучающей выборки наблюдения-источники ложно-положительных решений') PARENT oGroup3 @ 3,3 DCRADIO mVarObrab VALUE 3 PROMPT L('3. ВО ВРЕМЯ итераций ДОБАВЛЯТЬ в класс.шкалы и обуч.выборку классы для ложно-положительных решений') PARENT oGroup3 * ПОСЛЕ итераций УДАЛЯТЬ из обучающей выборки неустраненные источники ложно-положительных решений @ 1,3 DCRADIO mDelIstFP VALUE 1 PROMPT L('1. Удалять ') PARENT oGroup4 @ 2,3 DCRADIO mDelIstFP VALUE 2 PROMPT L('2. Не удалять ') PARENT oGroup4 @ 1,3 DCSAY L('Так как процесс итерационный и может занимать много времени, то и синтез моделей, и распознавание будет') PARENT oGroup5 @ 2,3 DCSAY L('осуществляться на графическом процессоре (GPU). Если при обращении к графическому процессору возникает ') PARENT oGroup5 @ 3,3 DCSAY L('ошибка, то, по-видимому, видеокарта не NVIDIA и не поддерживает OpenGL. ') PARENT oGroup5 DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; OPTIONS GetOptions ; ADDBUTTONS; MODAL ; TITLE L('3.7.9. Корректировка экспертных оценок: объект => класс') ******************************************************************** IF lExit ** Button Ok ELSE ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ******************************************************************** * MsgBox(STR(M_CurrInf)) *** 3. Формировать БД по результатам итераций с заменами кодов классов: *** Номер итерации, Код объекта, наименование объекта, старый код класса, наименование старого класса, новый код класса, наименование нового класса aStructure := { { "Num_iter" , "N", 8, 0 }, ; { "Kod_object", "N", 8, 0 }, ; { "NameObject", "C", 65, 0 }, ; { "KodClsOld" , "N", 8, 0 }, ; // Заменять старый код класса на новый только если он относится к ТОЙ ЖЕ же классификационной шкале <<<===################## { "NameClsOld", "C", 65, 0 }, ; { "KodClScOld", "N", 8, 0 }, ; { "Int_krit" , "N", 15, 7 }, ; { "KodClsNew" , "N", 8, 0 }, ; { "NameClsNew", "C", 65, 0 }, ; { "KodClScNew", "N", 8, 0 } } DbCreate( 'EditExperts', aStructure ) *** Создать начальную базу результатов итераций CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rsp_it1i EXCLUSIVE NEW USE Rsp_it1k EXCLUSIVE NEW USE Classes EXCLUSIVE NEW USE Gr_ClSc EXCLUSIVE NEW USE ObI_Kcl EXCLUSIVE NEW USE EditExperts EXCLUSIVE NEW aNAME_GRCS := {} SELECT Gr_ClSc DBGOTOP() DO WHILE .NOT. EOF() AADD(aNAME_GRCS, ALLTRIM(NAME_GRCS)) DBSKIP(1) ENDDO *** 4. Есть ли необходимость в корректировках, т.е. есть ли ложно-положительные решения? ******* DO CASE CASE mNumIntKr = 1 // Сумма знаний SELECT Rsp_it1i SET FILTER TO SUM_INFA > 0 .AND. LEN(ALLTRIM(Fakt)) = 0 CASE mNumIntKr = 2 // Резонанс знаний SELECT Rsp_it1k SET FILTER TO KORRA > 0 .AND. LEN(ALLTRIM(Fakt)) = 0 ENDCASE DBGOTOP();DBGOBOTTOM();DBGOTOP() COUNT TO mNRec1 mNRec2 = -1 mFlag = 0 IF mNRec2 = 0 mFlag1 = 1 // Вообще нет ложно-положительных решений или их количество не меняется в итерациях ELSE mFlag1 = 2 // Ложно-положительные решения есть и их количество mNRec1 ENDIF mFlag2 = mFlag1 *** 5. Начало цикла итераций ********************* <<<===############################################## mNumIter = 0 DO WHILE mFlag2 = 2 // Цикл до тех пор, пока количество ложно-положительных решений не станет равным 0 и