// (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 или их число не перестанет уменьшаться oScr := DC_WaitOn(L('Корректировка экспертных оценок на основе модели. Итерация №')+' '+ALLTRIM(STR(++mNumIter))+'. '+L('Количество ложно-положительных решений:')+' '+ALLTRIM(STR(mNRec1)),,,,,,,,,,,.F.) DO CASE CASE mNumIntKr = 1 // Сумма знаний SELECT Rsp_it1i SET FILTER TO DBGOTOP() DO WHILE .NOT. EOF() IF SUM_INFA > 0 .AND. LEN(ALLTRIM(Fakt)) = 0 mKodObj = KOD_OBJ mNameObj = NAME_OBJ mKodClsNew = KOD_CLSA mNameClsNew = NAME_CLSA mIntKrit = SUM_INFA SELECT ObI_Kcl // А если классов много? Тогда найти в БД ObI_Kcl код класса mKodClsOld = DBGOTO(mKodObj) mKodClsOld = FIELDGET(2) SELECT Classes DBGOTO(mKodClsOld) mNameClsOld = ALLTRIM(NAME_CLS) mKodClScOld = KOD_CLSC DBGOTO(mKodClsNew) mKodClScNew = KOD_CLSC SELECT EditExperts APPEND BLANK REPLACE Num_iter WITH mNumIter REPLACE Kod_object WITH mKodObj REPLACE NameObject WITH mNameObj REPLACE KodClsOld WITH mKodClsOld REPLACE NameClsOld WITH mNameClsOld REPLACE KodClScOld WITH mKodClScOld REPLACE Int_krit WITH mIntKrit REPLACE KodClsNew WITH mKodClsNew REPLACE NameClsNew WITH mNameClsNew REPLACE KodClScNew WITH mKodClScNew ENDIF SELECT Rsp_it1i DBSKIP(1) ENDDO CASE mNumIntKr = 2 // Резонанс знаний SELECT Rsp_it1k SET FILTER TO DBGOTOP() DO WHILE .NOT. EOF() IF KORRA > 0 .AND. LEN(ALLTRIM(Fakt)) = 0 mKodObj = KOD_OBJ mNameObj = NAME_OBJ mKodClsNew = KOD_CLSA mNameClsNew = NAME_CLSA mIntKrit = KORRA SELECT ObI_Kcl // А если классов много? Тогда найти в БД ObI_Kcl код класса mKodClsOld = DBGOTO(mKodObj) mKodClsOld = FIELDGET(2) SELECT Classes DBGOTO(mKodClsOld) mNameClsOld = ALLTRIM(NAME_CLS) mKodClScOld = KOD_CLSC DBGOTO(mKodClsNew) mKodClScNew = KOD_CLSC SELECT EditExperts APPEND BLANK REPLACE Num_iter WITH mNumIter REPLACE Kod_object WITH mKodObj REPLACE NameObject WITH mNameObj REPLACE KodClsOld WITH mKodClsOld REPLACE NameClsOld WITH mNameClsOld REPLACE KodClScOld WITH mKodClScOld REPLACE Int_krit WITH mIntKrit REPLACE KodClsNew WITH mKodClsNew REPLACE NameClsNew WITH mNameClsNew REPLACE KodClScNew WITH mKodClScNew ENDIF SELECT Rsp_it1k DBSKIP(1) ENDDO ENDCASE CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW USE Class_Sc EXCLUSIVE NEW;N_ClSc = RECCOUNT() USE Opis_Sc EXCLUSIVE NEW;N_OpSc = RECCOUNT() USE Gr_ClSc EXCLUSIVE NEW USE Rsp_it1i EXCLUSIVE NEW USE Rsp_it1k EXCLUSIVE NEW USE EventsKO EXCLUSIVE NEW USE EditExperts EXCLUSIVE NEW *** 6. ЗАМЕНА кодов классов в обучающей выборке с заданных изначально (экспертным путем) на: *** - полученные в результате распознавания в модели; 1. ВО ВРЕМЯ итераций ЗАМЕНЯТЬ экспертный кода класса на код по модели без удаления наблюдений. ') *** - 0; 2. ВО ВРЕМЯ итераций УДАЛЯТЬ из обучающей выборки наблюдения-источники ложно-положительных решений') *** - на добавленные в класс.шкалы и обуч.выборку классы; 3. ВО ВРЕМЯ итераций ДОБАВЛЯТЬ в класс.шкалы и обуч.выборку классы для ложно-положительных решений') *** - 0; 4. П О С Л Е итераций УДАЛИТЬ из обучающей выборки неустраненные источн.ложно-положительных решений *** Если классификационных шкал много, то заменять код в той же классификационной шкале <<<===################## aRecDel := {} SELECT EditExperts DBGOTOP() DO WHILE .NOT. EOF() mNUM_ITER = NUM_ITER mKOD_OBJECT = KOD_OBJECT mNAMEOBJECT = NAMEOBJECT mKODCLSOLD = KODCLSOLD mNAMECLSOLD = NAMECLSOLD mKODCLSCOLD = KODCLSCOLD mINT_KRIT = INT_KRIT mKODCLSNEW = KODCLSNEW mNAMECLSNEW = NAMECLSNEW mKODCLSCNEW = KODCLSCNEW * IF mKODCLSOLD <> mKODCLSNEW .AND. mNAMECLSOLD = mNAMECLSNEW // Заменять старый код класса на новый только если они разные и относятся к ОДНОЙ И ТОЙ ЖЕ же классификационной шкале <<<===################## SELECT EventsKO DBGOTO(mKOD_OBJECT) IF mVarObrab = 1 // 1. Во время итераций ЗАМЕНЯТЬ экспертный код класса на код по модели без удаления наблюдений (экспертные оценки считать шумом) FOR j=1 TO N_ClSc IF FIELDGET(1+j) = mKODCLSOLD // Найти в БД EventsKO старый код класса FIELDPUT(1+j, mKodClsNew) // Заменить старый код класса на новый ENDIF NEXT ENDIF IF mVarObrab = 2 // 2. Во время итераций УДАЛЯТЬ из обучающей выборки наблюдения-источники ложно-положительных решений (экспертные оценки считать отсутствием данных) FOR j=1 TO N_ClSc IF FIELDGET(1+j) = mKODCLSOLD // Найти в БД EventsKO старый код класса FIELDPUT(1+j, 0) // Заменить старый код класса на 0 IF ASCAN(aRecDel, mKOD_OBJECT) = 0 AADD (aRecDel, mKOD_OBJECT) ENDIF ENDIF NEXT ENDIF IF mVarObrab = 3 // 3. ВО ВРЕМЯ итераций ДОБАВЛЯТЬ в класс.шкалы и обуч.выборку классы для ложно-положительных решений (экспертные оценки считать верными) SELECT Gr_ClSc DBGOTO(mKODCLSOLD) mNameGrClScOld = ALLTRIM(NAME_GRCS) mNameGrClScNew = mNameGrClScOld+'-it='+ALLTRIM(STR(mNUM_ITER)) mPos = ASCAN(aNAME_GRCS, mNameGrClScNew) IF mPos > 0 mKodCls = mPos ELSE AADD( aNAME_GRCS, mNameGrClScNew) mKodCls = LEN(aNAME_GRCS) SELECT Gr_ClSc APPEND BLANK REPLACE KOD_CLSC WITH mKODCLSCOLD REPLACE KOD_GRCS WITH mKodCls REPLACE NAME_GRCS WITH mNameGrClScNew SELECT Class_Sc DBGOTO(mKODCLSCOLD) mNameClSc = UPPER(ALLTRIM(NAME_CLSC)) REPLACE KODGR_MAX WITH mKodCls SELECT Classes APPEND BLANK REPLACE Kod_cls WITH mKodCls REPLACE Name_cls WITH mNameClSc+'-'+mNameGrClScNew REPLACE Kod_ClSc WITH mKODCLSCOLD ENDIF SELECT EventsKO FIELDPUT(2, mKodCls) ENDIF * ENDIF SELECT EditExperts DBSKIP(1) ENDDO EventsObi() // Преобразовать EventsKO.dbf в обучающую выборку: Obi_Zag.dbf, ObI_Kcl.dbf, Obi_Kpr.dbf *** 7. Синтез модели на GPU с диалогом ************************************************** F3_5('GPU','Sint','3.7.9') // Сделать, чтобы можно было задавать конкретную модель для синтеза и верификации в параметрах *** 8. Распознавание на GPU без диалога ************************************************* F4_1_2(M_CurrInf,.F.,"3_7_9","GPU",1,1) // Провести распознавание в текущей модели (без диалога, но с отображением стадии исполнения) включить Model_rec.exe в состав F4_1_2 <===####### *** 10. Конец цикла итераций ********************* <<<===################### CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW USE ObI_Kcl EXCLUSIVE NEW USE EditExperts EXCLUSIVE NEW DO CASE CASE mNumIntKr = 1 // Сумма знаний USE Rsp_it1i EXCLUSIVE NEW SELECT Rsp_it1i // SET FILTER TO SUM_INFA > 0 .AND. LEN(ALLTRIM(Fakt)) = 0 CASE mNumIntKr = 2 // Резонанс знаний // <<<===############ ИСПЛЬЗОВАТЬ ДРУГУЮ ПЕРЕМЕННУЮ, НЕ mIntKrit USE Rsp_it1k EXCLUSIVE NEW SELECT Rsp_it1k SET FILTER TO KORRA > 0 .AND. LEN(ALLTRIM(Fakt)) = 0 ENDCASE DBGOTOP();DBGOBOTTOM();DBGOTOP() COUNT TO mNRec2 IF LEN(aRecDel) > 0 mNRec2 = LEN(aRecDel) ENDIF mFlag = 0 IF mNRec2 = 0 .OR. mNRec1 = mNRec2 mFlag2 = 1 // Вообще нет ложно-положительных решений или их количество не меняется в итерациях ELSE mFlag2 = 2 // Ложно-положительные решения есть и их количество mNRec2 mNRec1 = mNRec2 ENDIF DC_Impl(oScr) ENDDO *** 4. ПОСЛЕ итераций УДАЛЯТЬ из обучающей выборки неустраненные источники ложно-положительных решений. IF mDelIstFP = 1 CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE EditExperts EXCLUSIVE NEW USE EventsKO EXCLUSIVE NEW aKodObj := {} SELECT EditExperts DBGOBOTTOM() mNumbIter = NUM_ITER DO WHILE .NOT. BOF() IF KODCLSOLD <> KODCLSNEW IF ASCAN(aKodObj, KOD_OBJECT) = 0 AADD (aKodObj, KOD_OBJECT) ENDIF ENDIF IF mNumbIter <> NUM_ITER EXIT ENDIF DBSKIP(-1) ENDDO SELECT EventsKO FOR j=1 TO LEN(aKodObj) DBGOTO(aKodObj[j]) FOR i=1 TO N_ClSc FIELDPUT(1+i, 0) NEXT NEXT EventsObi() // Преобразовать EventsKO.dbf в обучающую выборку: Obi_Zag.dbf, ObI_Kcl.dbf, Obi_Kpr.dbf ENDIF *** Сделать текстовую выходную форму или БД по результатам анализа БД EditExperts.DBF <<<===########################################## *** Преобразовать БД EditExperts.DBF в EditExperts.xls CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций COPY FILE ("EditExperts.DBF") TO ("EditExperts.xls") *** 11. Синтез и верифкация всех моделей в режиме 3.5 ******************************************* *F3_5('GPU','SintRec','3.7.9') // Сделать, чтобы можно было задавать конкретную модель для синтеза и верификации в параметрах *** 12. Сообщение о конце итераций и пути на БД с выходными результатами, выход.***************** aMess := {} DO CASE CASE mFlag1 = 1 // Вообще нет ложно-положительных решений AADD(aMess, L('Корректировка экспертных оценок о принадлежности объектов классам ')) AADD(aMess, L(' не требуется, так как все положительные решения истинные! ')) CASE mFlag1 = 2 // Ложно-положительные решения есть и их количество mNRec AADD(aMess, L('Процесс корректировки (замены) экспертных оценок о принадлежности ')) AADD(aMess, L('объектов к классам на полученные с помощью модели успешно завершен!')) AADD(aMess, L('Результаты:')+' '+M_PathAppl+'\EditExperts.xls') ENDCASE 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 RETURN NIL ************************************************************************************************** ************************************************************************************************** ******** Преобразовать EventsKO.dbf в обучающую выборку: Obi_Zag.dbf, ObI_Kcl.dbf, Obi_Kpr.dbf *** ************************************************************************************************** FUNCTION EventsObi() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE EventsKO EXCLUSIVE NEW USE Obi_Zag EXCLUSIVE NEW;ZAP USE Obi_Kcl EXCLUSIVE NEW;ZAP USE Obi_Kpr EXCLUSIVE NEW;ZAP SELECT EventsKO DBGOTOP() DO WHILE .NOT. EOF() M_KodObj = RECNO() M_NameObj = ALLTRIM(FIELDGET(1)) A_KodCls := {} FOR j=1 TO N_ClSc AADD(A_KodCls, FIELDGET(1+j)) NEXT A_KodAtr := {} FOR j=1 TO N_OpSc AADD(A_KodAtr, FIELDGET(1+N_ClSc+j)) NEXT ****** Запись обучающей выборки SELECT Obi_Zag APPEND BLANK REPLACE Kod_obj WITH M_KodObj REPLACE Name_obj WITH M_NameObj REPLACE Date WITH DTOC(DATE()) REPLACE Time WITH TIME() *** Занести массив кодов классов в БД ObI_Kcl SELECT Obi_Kcl APPEND BLANK REPLACE Kod_Obj WITH M_KodObj IF LEN(A_KodCls) > 0 k=1 FOR j=1 TO LEN(A_KodCls) IF k <= 4 FIELDPUT(1+k++,A_KodCls[j]) ELSE k=1 APPEND BLANK REPLACE Kod_Obj WITH M_KodObj FIELDPUT(1+k++,A_KodCls[j]) ENDIF NEXT ENDIF *** Занести массив кодов признаков в БД ObI_Kpr SELECT Obi_Kpr APPEND BLANK REPLACE Kod_Obj WITH M_KodObj IF LEN(A_KodAtr) > 0 k=1 FOR j=1 TO LEN(A_KodAtr) IF k <= 7 FIELDPUT(1+k++,A_KodAtr[j]) ELSE k=1 APPEND BLANK REPLACE Kod_Obj WITH M_KodObj FIELDPUT(1+k++,A_KodAtr[j]) ENDIF NEXT ENDIF SELECT EventsKO DBSKIP(1) ENDDO RETURN NIL ********************************************************************************************************** ******** Помощь по режиму 3.7.9 ********************************************************************************************************** FUNCTION Help379() DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы cFile = "_Help379.pdf" IF .NOT. FILE(cFile) Mess = L('В папке с исполнимым модулем системы нет файла: "#"') Mess = STRTRAN(Mess, "#", cFile) LB_Warning(Mess) ENDIF // Проверить контрольную сумму файла и если она не совпадает // выдать сообщение о том, что файл поврежден (чтобы было невозможно заменить графический файл). IF FILECHECK(cFile) = 116748806 * DC_PrintPreviewAcrobat( '_Help379.pdf', 'Help режима: 3.7.9. Корректировка экспертных оценок: объект => класс' ) 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 IF ApplChange("") // Перейти в папку выбранного приложения или выйти из системы LB_Warning(L("Необходимо задать (выбрать) хотя бы одно текущее приложение !!!")) Running(.F.) RETURN NIL ENDIF RETURN NIL ********************************************************************************************************** ******** Пересоздать базу данных запусков системы "Эйдос" ********************************************************************************************************** FUNCTION RecreateDB() LOCAL oHC LOCAL cResult LOCAL GetList[0], GetOptions, oWebBrowser Razrab() RETURN NIL *** Цикл по базе данных запусков системы Эйдос: Visitors.DBF. Взять из БД дату и время обращения и IP-адрес. *** Оcтальное узнать на: http://ip-api.com/csv/71.39.117.6 и записать в другую БД такой же структуры *** NUM DATE TIME IP_ADDRESS DOMAIN COUNTRY OKRUG REGION CITY POSTCODE TIMEZONE LATITUDE LONGITUDE GEONAMEID NIPADDRESS *** 1 09.12.2016 17:31:18 71.39.117.6 US United States ID Idaho Boise 83703 America/Boise 43,71 -116,00 0 *** 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 *** success,United States,US,ID,Idaho,Boise,83707,43.615,-116.202,America/Boise,CenturyLink,"CenturyLink, Inc","AS209 CenturyLink Communications, LLC",71.39.117.6 *** 1 2 3 4 5 6 7 8 9 10 11 12 13 *** 1 09.12.2016 17:31:18 71.39.117.6 US United States ID Idaho Boise 83703 America/Boise 43,71 -116,00 0 *** 2 09.12.2016 17:31:51 71.39.117.6 US United States ID Idaho Boise 83703 America/Boise 43,71 -116,00 0 *** 3 09.12.2016 17:33:15 71.39.117.6 US United States ID Idaho Boise 83703 America/Boise 43,71 -116,00 0 *** 4 09.12.2016 17:45:53 176.59.52.241 RU Russia MOW Moscow Moscow 101194 Europe/Moscow 55,75 38,00 0 * http://ip-api.com/#71.39.117.6 * http://bb.donnay-software.com/donnay/phpbb3/viewtopic.php?f=2&t=1278&p=6809&hilit=DC_ReadHtml#p6809 * http://www.alaska-software.com/download/showSection.cxp?section=400 * cResponse := LoadFromURL( 'http://ip-api.com/#71.39.117.6' ) * cResponse := LoadFromURL( 'http://ip-api.com/json/71.39.117.6' ) * cResponse := LoadFromURL( 'http://ip-api.com/xml/71.39.117.6' ) * cResponse := LoadFromURL( 'http://ip-api.com/csv/71.39.117.6' ) // <<<===################ самый удобный вариант вывода * cResponse := LoadFromURL( 'http://ip-api.com/line/71.39.117.6' ) * cResponse := LoadFromURL( 'http://ip-api.com/php/71.39.117.6' ) SELECT Visitors;mNRec = RECCOUNT() COPY STRUCTURE TO Temp.dbf USE Temp EXCLUSIVE NEW;ZAP ****************************************************************************************************************************** Wsego = mNRec + 3000 Time_Progress = 0 // Начало отсчета времени для прогнозирования длительности исполнения 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 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 ; // Кол-во обновлений изображения (в функции самой регулируеся обновление изображений через 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 L('Пересоздание базы данных запусков системы "Эйдос" в мире'); PARENT @oDialog ; FIT ; EXIT ; MODAL oDialog:show() ****************************************************************************************************************************** aSay[ 1]:SetCaption(L('1/4. Геолокация каждого 1-го обращения к системе "Эйдос" по IP-адресу в БД: "Visitors.DBF"')) SELECT Visitors aIPADDRESS := {} // IP, по которым уже определены геоданные aIPMumRec := {} // Номер записи в БД Temp.dbf, в которой есть геоданные по данному IP DBGOTOP() DO WHILE .NOT. EOF() mNum = NUM mDATE = DATE mTIME = TIME mIPADDRESS = IP_ADDRESS *** http://ip-api.com/csv/71.39.117.6 *** NUM DATE TIME IP_ADDRESS DOMAIN COUNTRY OKRUG REGION CITY POSTCODE TIMEZONE LATITUDE LONGITUDE GEONAMEID NIPADDRESS *** 1 09.12.2016 17:31:18 71.39.117.6 US United States ID Idaho Boise 83703 America/Boise 43,71 -116,00 0 *** 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 *** success,United States,US,ID,Idaho,Boise,83707,43.615,-116.202,America/Boise,CenturyLink,"CenturyLink, Inc","AS209 CenturyLink Communications, LLC",71.39.117.6 *** 1 2 3 4 5 6 7 8 9 10 11 12 13 SELECT Temp APPEND BLANK REPLACE NUM WITH mNum REPLACE DATE WITH mDATE REPLACE TIME WITH mTIME REPLACE IP_ADDRESS WITH mIPADDRESS IF ASCAN(aIPADDRESS, mIPADDRESS) = 0 // Записывать информацию геолокации только при 1-й встрече IP-адреса. // Если IP уже встречался, то нет смысла узнавать по нему информацию геолокации, обращаясь к серверу, легче взять в БД AADD (aIPADDRESS, mIPADDRESS) AADD (aIPMumRec , RECNO()) cResponse := LoadFromURL( 'http://ip-api.com/csv/'+ALLTRIM(mIPADDRESS) ) * success,Russia,RU,MOW,Moscow,Moscow,,55.7569,37.7007,Europe/Moscow,Corbina Broadband Sovam,,AS3216 PJSC Vimpelcom,2.95.13.30 cResponse = STRTRAN(cResponse,',,',',unknown,') REPLACE DOMAIN WITH TOKEN(cResponse, ',', 3) REPLACE COUNTRY WITH TOKEN(cResponse, ',', 2) REPLACE OKRUG WITH TOKEN(cResponse, ',', 4) REPLACE REGION WITH TOKEN(cResponse, ',', 5) REPLACE CITY WITH TOKEN(cResponse, ',', 6) REPLACE POSTCODE WITH TOKEN(cResponse, ',', 7) REPLACE TIMEZONE WITH TOKEN(cResponse, ',',10) REPLACE LATITUDE WITH VAL(TOKEN(cResponse, ',', 8)) REPLACE LONGITUDE WITH VAL(TOKEN(cResponse, ',', 9)) IF LATITUDE = 0 REPLACE LATITUDE WITH LATITUDE + 0.0011 ENDIF IF LONGITUDE = 0 REPLACE LONGITUDE WITH LONGITUDE + 0.0011 ENDIF * http://simplemaps.com/data/world-cities // База данных географических координат городов * http://simplemaps.com/static/data/world-cities/basic/simplemaps_worldcities_basicv1.75.zip ***** Если в базе данных географических координат городов по странам есть географические координаты города, то заменить на них координаты, полученные путем геолокации mCITY = ALLTRIM(CITY) mCOUNTRY = ALLTRIM(COUNTRY) SELECT WorldCities;SET ORDER TO 1;T=DBSEEK(SUBSTR(mCITY,1,aLenF[ 8])) // <<<===################################################### IF T mLat = lat mLng = Lng SELECT Temp REPLACE LATITUDE WITH mLat REPLACE LONGITUDE WITH mLng ENDIF SLEEP(100) ENDIF * IF mNum > 10 * EXIT * ENDIF *** Отображение стадии и прогноза времени исполнения lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) SELECT Visitors DBSKIP(1) ENDDO * LB_Warning(aIPADDRESS) * LB_Warning(aIPMumRec) aSay[ 1]:SetCaption(aSay[ 1]:caption+L(" - Готово ")) aSay[ 2]:SetCaption(L('2/4. Заполнение в БД "Temp.DBF" геоданных по всем IP-адресам, как по 1-й встрече каждого IP')) SELECT Temp DBGOTOP() DO WHILE .NOT. EOF() mIPADDRESS = IP_ADDRESS IF LATITUDE * LONGITUDE = 0 .OR. LEN(ALLTRIM(COUNTRY)) = 0 // Надо заполнить параметры геолокации mNum = RECNO() **** Взять данные для заполнения параметров геолокации в записи, в которой данный IP встретился впервые mPos = ASCAN(aIPADDRESS, mIPADDRESS) mRec = aIPMumRec[mPos] * MsgBox(mIPADDRESS+STR(mPos)+STR(mRec)) DBGOTO(mRec) aR := {} FOR j=5 TO 13 AADD(aR, FIELDGET(j)) NEXT DBGOTO(mNum) FOR j=5 TO 13 FIELDPUT(j, aR[j-4]) NEXT ENDIF *** Отображение стадии и прогноза времени исполнения Time_Progress = Time_Progress + 1000/Wsego lOk = Time_Progress (Time_Progress, Wsego, oProgress, lOk ) DBSKIP(1) ENDDO aSay[ 2]:SetCaption(aSay[ 2]:caption+L(" - Готово ")) aSay[ 3]:SetCaption(L('3/4. Копирование базы данных "Temp.dbf" в базу данных "Visitors.DBF"')) SELECT Visitors;ZAP SELECT Temp DBGOTOP() DO WHILE .NOT. EOF() aR := {} FOR j=1 TO 13 AADD(aR, FIELDGET(j)) NEXT SELECT Visitors APPEND BLANK FOR j=1 TO 13 FIELDPUT(j, aR[j]) NEXT *** Отображение стадии и прогноза времени исполнения Time_Progress = Time_Progress + 1000/Wsego lOk = Time_Progress (Time_Progress, Wsego, oProgress, lOk ) SELECT Temp DBSKIP(1) ENDDO aSay[ 3]:SetCaption(aSay[ 3]:caption+L(" - Готово ")) aSay[ 4]:SetCaption(L('4/4. Формирование файла: "test_strings.txt" из БД "Visitors.dbf" и запись его на FTP-сервер')) **** Формирование текстового файла для WEB-сервера и запись его на WEB-сервер по FTP SELECT Visitors 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 *** Отображение стадии и прогноза времени исполнения Time_Progress = Time_Progress + 1000/Wsego lOk = Time_Progress (Time_Progress, Wsego, oProgress, lOk ) DBSKIP(1) ENDDO 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 oScrn2 := DC_WaitOn( L('Запись на FTP-сервер исправленной БД: "test_strings.txt" с информацией о запусках системы "Эйдос-Х++"' ),,,,,,,,,,,.F.) ********************************************************************************************************** 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 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) aSay[ 4]:SetCaption(aSay[ 4]:caption+L(" - Готово ")) CLOSE Temp ERASE("Temp.dbf") SELECT Visitors DBGOTO(RECCOUNT()-25) * LB_Warning(L('Пересоздание базы данных запусков системы "Эйдос" в мире успешно завершено !!!')) oSay97:SetCaption(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 ****************************************************************************************************************** ******** Лаб.раб.№ 4.02: АСК-анализ текстового контента сайтов, найденных по запросам из текстового файла ******** Алгоритм: ******** 0. Проверка Internet и файла запросов: ../Aid_data/Inp_data/Request.txt. ******** 1. Начальный диалог задания параметров ******** 2. Скачивает файл запросов: ../Aid_data/Inp_data/Request.txt, если он есть (кодировка DOS-TXT OEM866). ******** 3. Организует цикл по строкам этого файла Request.txt. ******** 4. Берет текст строки в качестве запроса к поисковой системе ##### (сама система выбирается в диалоге). ******** 5. Открывает первые ## сайтов в ответе поисковой системы (количество сайтов ## задается в диалоге). ******** 6. Текстовый контент каждого сайта, найденного поисковой системой, ДОБАВЛЯЕТ в текстовый файл: ******** В качестве имени файла использовать сам запрос&'-####', где #### - номер запроса (номер строки файла ******** Request.txt), если запрос достаточно короткий (< 64 символов) и после замены ' ' на '_'. ******** Для ввода данных файлов отчетов <Запрос>-####.txt в систему "Эйдос" используется API-2.3.2.1. ****************************************************************************************************************** FUNCTION LabWork32() LOCAL GetList := {}, aPres, oBrowse, oToolBar, aColors, bColor, GetOptions, oEventsKO, bItems, n:=0 Local oHttp, oResponse, cColor *Razrab() ******** 0. Проверка Internet и файла запросов: ../Aid_data/Inp_data/Request.txt. n=0 IF InternetGetConnectedState( @n, 0 ) == 0 LB_Warning(L('Нет соединения с Internet, что необходимо для данного режима!'), L('(C) Система "Эйдос-Х++"' )) RETURN NIL ENDIF * DIRCHANGE(Disk_dir+"\AID_DATA\Inp_data\") IF .NOT. File(Disk_dir+"\AID_DATA\Inp_data\"+"Requests.txt") LB_Warning(L('В папке:')+' '+Disk_dir+'/AID_DATA/Inp_data/'+' '+L('должен быть файл запросов: "Requests.txt"!'), L('(C) Система "Эйдос-Х++"' )) RETURN NIL ENDIF ******** 1. Начальный диалог задания параметров * Информация о результатах завершения перекодирования в файле: 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') mNumbeSites = 3 @1.00, 1 DCGROUP oGroup1 CAPTION 'Сколько сайтов по одному запросу анализировать?' SIZE 62.0, 2.5 @1.15, 2 DCSAY "Количество сайтов:" PARENT oGroup1 @1.00,20 DCSAY "" GET mNumbeSites PICTURE "####" PARENT oGroup1 mAddTxt = 1 @4.00, 1 DCGROUP oGroup2 CAPTION 'Объединять контент сайтов, найденных по запросу?' SIZE 62.0, 3.5 @1.00, 2 DCRADIO mAddTxt VALUE 1 PROMPT 'Да' PARENT oGroup2 @2.00, 2 DCRADIO mAddTxt VALUE 2 PROMPT 'Нет' PARENT oGroup2 @0.6, 39 DCPUSHBUTTON CAPTION L('Help') SIZE LEN(L('Transcoder TXT-files')), 1.5 ACTION {||Help2321()} PARENT oGroup1 @1.2, 39 DCPUSHBUTTON CAPTION L('Transcoder TXT-files') SIZE LEN(L('Transcoder TXT-files')), 1.5 ACTION {||LC_RunShell("recoder-v3-1-0.exe",1332681493)} PARENT oGroup2 DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; OPTIONS GetOptions ; ADDBUTTONS; TITLE L('Лаб.раб.№ 4.02: АСК-анализ текстового контента сайтов') *************************************************** IF lExit ** Button Ok ELSE RETURN NIL ENDIF *************************************************** ******** 2. Скачивает файл запросов: ../Aid_data/Inp_data/Request.txt, если он есть (кодировка DOS-TXT OEM866). CrLf = CHR(13)+CHR(10) // Конец строки (записи) mLcBuf = ALLTRIM(FILESTR(Disk_dir+"\AID_DATA\Inp_data\"+"Requests.txt")) // Загрузка файла mLcBuf = STRTRAN(mLcBuf, CrLf, CHR(13)) * MsgBox(mLcBuf) ******** 3. Организует цикл по строкам этого файла Request.txt. FOR ww=1 TO NUMTOKEN(mLcBuf, CHR(13)) // Цикл по абзацам ******** 4. Берет текст строки в качестве запроса к поисковой системе ##### (сама система выбирается в диалоге). mParagraph = ALLTRIM(TOKEN(mLcBuf, CHR(13), ww)) * MsgBox(mParagraph) ***** Получить текст с сайта ********* *cURL = 'http://lc.kubagro.ru/' *cResponse := LoadFromURL( cURL ) *cResponse := DC_ReadHtml ( cURL ) *StrFile(cResponse, '_MySite.txt') // Запись текстового файла с именем _MySite.txt ************************************** * mParagraph = STRTRAN(mParagraph,' ','%20') * http://www.google.com/search?q=Евгений Вениаминович Луценко * http://www.google.com/search?q=%D0%9B%D1%83%D1%86%D0%B5%D0%BD%D0%BA%D0%BE+%D0%95%D0%B2%D0%B3%D0%B5%D0%BD%D0%B8%D0%B9+%D0%92%D0%B5%D0%BD%D0%B8%D0%B0%D0%BC%D0%B8%D0%BD%D0%BE%D0%B2%D0%B8%D1%87 * cFile := LoadFromURL('http://yandex.ru/search/?text='+mParagraph) // Считывает в текстовую переменную результат поискового запроса: mParagraph * cFile := LoadFromURL('http://yandex.ru/search/?text='+mParagraph) // Считывает в текстовую переменную результат поискового запроса: mParagraph * cFile := LoadFromURL('https://yandex.ru/search/?text=%D0%BB%D1%83%D1%86%D0%B5%D0%BD%D0%BA%D0%BE+%D0%B5%D0%B2%D0%B3%D0%B5%D0%BD%D0%B8%D0%B9+%D0%B2%D0%B5%D0%BD%D0%B8%D0%B0%D0%BC%D0%B8%D0%BD%D0%BE%D0%B2%D0%B8%D1%87') // Считывает в текстовую переменную результат поискового запроса: mParagraph * cFile := LoadFromURL('http://www.google.com/search?q=%D0%9B%D1%83%D1%86%D0%B5%D0%BD%D0%BA%D0%BE+%D0%95%D0%B2%D0%B3%D0%B5%D0%BD%D0%B8%D0%B9+%D0%92%D0%B5%D0%BD%D0%B8%D0%B0%D0%BC%D0%B8%D0%BD%D0%BE%D0%B2%D0%B8%D1%87') // Считывает в текстовую переменную результат поискового запроса: mParagraph cXmlText := LoadFromURL('http://www.google.com/search?q='+mParagraph) // Считывает в текстовую переменную результат поискового запроса: mParagraph MsgBox(cXmlText) * cXmlText := DC_Xml2ObjectTree('http://www.google.com/search?q='+mParagraph,.t.) nXMLDoc := XMLDocOpenString(cXmlText) * MsgBox(nXMLDoc) StrFile(nXMLDoc, Disk_dir+'\AID_DATA\Inp_data\_Site-'+ALLTRIM(STR(ww))+'.txt') // Запись текстового файла с именем _Site-#.txt в папку: \AID_DATA\Inp_data\ * MsgBox(cFile) * cFile := DC_ReadHtml('https://yandex.ru/search/?text=%D0%BB%D1%83%D1%86%D0%B5%D0%BD%D0%BA%D0%BE+%D0%B5%D0%B2%D0%B3%D0%B5%D0%BD%D0%B8%D0%B9+%D0%B2%D0%B5%D0%BD%D0%B8%D0%B0%D0%BC%D0%B8%D0%BD%D0%BE%D0%B2%D0%B8%D1%87') // Считывает в текстовую переменную результат поискового запроса: mParagraph * MsgBox(cFile) ******** 5. Открывает первые ## сайтов в ответе поисковой системы (количество сайтов ## задается в диалоге). ******** 6. Текстовый контент каждого сайта, найденного поисковой системой, ДОБАВЛЯЕТ в текстовый файл: ******** В качестве имени файла использовать сам запрос&'-####', где #### - номер запроса (номер строки файла ******** Request.txt), если запрос достаточно короткий (< 64 символов) и после замены ' ' на '_'. NEXT ******** Для ввода данных файлов отчетов <Запрос>-####.txt в систему "Эйдос" используется API-2.3.2.1. RETURN NIL *1. BeautifulSoup: Библиотека Python для извлечения данных из HTML и XML файлов. Ссылка: https://www.crummy.com/software/BeautifulSoup/ *2. Scrapy: Мощный фреймворк Python для извлечения данных из веб-сайтов. Ссылка: https://scrapy.org/ *3. Google Search API: API от Google, который позволяет получать результаты поиска Google по ключевым словам. Ссылка: https://developers.google.com/custom-search *4. Twitter API: API от Twitter, который позволяет получать твиты и другую информацию из Twitter по ключевым словам или аккаунтам. Ссылка: https://developer.twitter.com/en/docs/twitter-api *5. News API: Сервис, предоставляющий доступ к новостям и статьям из различных источников по ключевым словам. Ссылка: https://newsapi.org/ *6. Google Trends: Инструмент от Google, который предоставляет данные о популярности запросов по ключевым словам. Ссылка: https://trends.google.com/trends *7. Google Alerts: Сервис от Google, который позволяет получать уведомления о новых упоминаниях ключевых слов в поиске Google. Ссылка: https://www.google.com/alerts *8. Brand24: Инструмент для мониторинга упоминаний бренда и ключевых слов в социальных сетях и веб-сайтах. Ссылка: https://www.brand24.com/ *9. Mention: Инструмент для отслеживания упоминаний бренда и ключевых слов в социальных сетях, блогах и новостных источниках. Ссылка: https://mention.com/ *10. Scrapy: Фреймворк Python для автоматизированного сбора данных с веб-сайтов. Ссылка: https://scrapy.org/ *Пожалуйста, обратите внимание, что эти ссылки могут изменяться со временем *********************************************************************************************************** ******** Программа на Питоне url_py.exe, запускающая сайт, адрес которого в файле: url_py.txt' *********************************************************************************************************** FUNCTION LC_RunUrl(mUrl) n=0 IF InternetGetConnectedState( @n, 0 ) == 0 LB_Warning(L('На данном компьютере нет доступа к Internet !'),'C° Система "Эйдос"') ELSE DO CASE CASE OSVER() = ' 6. 1' // Windows 7 ShellOpenFile( mUrl ) // Решение от Regan Cawkwell CASE OSVER() = ' 6. 2' // Windows 10 StrFile(mUrl, 'url_py.txt') * LC_RunShell("url_py.exe",198633941) // Мой вариант на Питоне * LC_RunShellAidosPy(717400306, "url_py") // Мой вариант на Питоне в системе __AIDOS-PY.exe * LC_RunShell("__AIDOS-PY.exe", 717400306, "url_py") // Мой вариант на Питоне в системе __AIDOS-PY.exe LC_RunShell("__url_py.exe", 1061128944, "url_py") OTHERWISE StrFile(mUrl, 'url_py.txt') * LC_RunShell("url_py.exe",198633941) // Мой вариант на Питоне * LC_RunShellAidosPy(717400306, "url_py") // Мой вариант на Питоне в системе __AIDOS-PY.exe * LC_RunShell("__AIDOS-PY.exe", 717400306, "url_py") // Мой вариант на Питоне в системе __AIDOS-PY.exe LC_RunShell("__url_py.exe", 1061128944, "url_py") ENDCASE ENDIF RETURN NIL *********************************************************************************************************** ******** 6.2. Ссылки на патенты, монографии и статьи по системе *********************************************************************************************************** FUNCTION F6_2() Running(.T.) DCSETFONT TO '10.Helv Bold' * DC_SpawnURL( 'http://lc.kubagro.ru/index_aidos.php', .T., .T. ) // Решение Роджера. Не работает под Windows-8, а в 7 и 10 работает но не всегда <<<===################## * ShellOpenFile( 'http://lc.kubagro.ru/index_aidos.php' ) // Решение от Regan Cawkwell , не работает * * Использование маленькой программы на Питоне url_py.exe для обращения к по Internet-адресу, находящемуся в файле: url_py.txt. РАБОТАЕТ * StrFile('http://lc.kubagro.ru/index_aidos.php', 'url_py.txt') * LC_RunShell("url_py.exe",198633941) // Мой вариант на Питоне * LC_RunShellAidosPy(717400306, "url_py") // Мой вариант на Питоне в системе __AIDOS-PY.exe * StrFile("url_py", 'Python_function_to_run.txt') * LC_RunShell("__AIDOS-PY.exe", 717400306) // Мой вариант на Питоне в системе __AIDOS-PY.exe s=0 h=1.2 w=124 d=1.4 @ s,1 DCPUSHBUTTON CAPTION L('1. Сайт автора и разработчика АСК-анализа и системы "Эйдос" проф.Е.В.Луценко ') SIZE w, h ACTION {||LC_RunUrl('http://lc.kubagro.ru')} ;s=s+d @ s,1 DCPUSHBUTTON CAPTION L('2. Патенты, научные монографии, учебные пособия и научные статьи ') SIZE w, h ACTION {||LC_RunUrl("http://lc.kubagro.ru/aidos/index.htm")} ;s=s+d @ s,1 DCPUSHBUTTON CAPTION L('3. Статьи в Научном журнале КубГАУ ') SIZE w, h ACTION {||LC_RunUrl("http://ej.kubagro.ru/a/viewaut.asp?id=11")} ;s=s+d @ s,1 DCPUSHBUTTON CAPTION L('4. Научные статьи и другие публикации в РИНЦ ') SIZE w, h ACTION {||LC_RunUrl("http://elibrary.ru/author_items.asp?authorid=123162")} ;s=s+d @ s,1 DCPUSHBUTTON CAPTION L('5. Страничка в ResearchGate по АСК-анализу и системе "Эйдос" ') SIZE w, h ACTION {||LC_RunUrl("https://www.researchgate.net/profile/Eugene_Lutsenko")};s=s+d @ s,1 DCPUSHBUTTON CAPTION L('6. Скачать ВСЕ статьи Е.В.Луценко из Научн.журн.КубГАУ (>2Гб) ') SIZE w, h ACTION {||DownloadArticles()} ;s=s+d Xb2NetKey() // <<<===################# oScr := DC_WaitOn('Идет проверка наличия интернета и FTP доступа к Эйдос-облаку. Немного подождите!!!',,,,,,,,,,,.F.) 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) LB_Warning(L('Нет соединения с FTP-сервером обновлений системы "Эйдос" или нет авторизации'), L('(C°) Система "Эйдос-Х++"' )) ELSE DC_Impl(oScr) oFtp:curDir("public_html") aFileUpd := oFtp:Directory("Aidos-X.exe") IF LEN(aFileUpd) > 0 mSizeUpd = aFileUpd[1,F_SIZE] / (1024^2) // Мб mDateUpd = aFileUpd[1,F_WRITE_DATE] mTimeUpd = aFileUpd[1,F_WRITE_TIME] @ s,1 DCPUSHBUTTON CAPTION L('7. Скачать полный архив системы "Эйдос" версии от: ')+' '+DTOC(mDateUpd)+':'+mTimeUpd+'; (~'+ALLTRIM(STR(mSizeUpd,15,1))+' Мб)' SIZE w, h ACTION {||LC_RunUrl("http://lc.kubagro.ru/Aidos-X.exe")} ;s=s+d ENDIF aFileUpd := oFtp:Directory("a-min.rar") IF LEN(aFileUpd) > 0 mSizeUpd = aFileUpd[1,F_SIZE] / (1024^2) // Мб mDateUpd = aFileUpd[1,F_WRITE_DATE] mTimeUpd = aFileUpd[1,F_WRITE_TIME] @ s,1 DCPUSHBUTTON CAPTION L('8. Скачать минимальную инсталляцию системы "Эйдос" версии от: ')+' '+DTOC(mDateUpd)+':'+mTimeUpd+'; (~'+ALLTRIM(STR(mSizeUpd,15,1))+' Мб)' SIZE w, h ACTION {||LC_RunUrl("http://lc.kubagro.ru/a-min.rar")} ;s=s+d ENDIF aFileUpd := oFtp:Directory("Downloads.exe") IF LEN(aFileUpd) > 0 mSizeUpd = aFileUpd[1,F_SIZE] / (1024^2) // Мб mDateUpd = aFileUpd[1,F_WRITE_DATE] mTimeUpd = aFileUpd[1,F_WRITE_TIME] @ s,1 DCPUSHBUTTON CAPTION L('9. Скачать актуальное обновление системы "Эйдос" до версии от: ')+' '+DTOC(mDateUpd)+':'+mTimeUpd+'; (~'+ALLTRIM(STR(mSizeUpd,15,1))+' Мб)' SIZE w, h ACTION {||LC_RunUrl("http://lc.kubagro.ru/Downloads.exe")} ;s=s+d*1.5 ENDIF aFileUpd := oFtp:Directory("Fonts.exe") IF LEN(aFileUpd) > 0 d=0.8 @ s,1 DCSAY L('10. Если вы хотите, чтобы система "Эйдос" использовала не стандартные шрифты MS Windows, а свои собственные,') SAYSIZE 0;s=s+d @ s,1 DCSAY L('(встроенные), то надо скачать самораспаковывающийся архив шрифтов "Эйдос", кликнув по кнопке ниже, а затем ') SAYSIZE 0;s=s+d @ s,1 DCSAY L('разархивировать его в папку с исполнимым модулем системы "Эйдос" так, чтобы в ней возникла папка "Fonts". ') SAYSIZE 0;s=s+d @ s,1 DCSAY L('Такая потребность может возникнуть, если вы используете неруссифицированную версию MS Windows. В этом ') SAYSIZE 0;s=s+d @ s,1 DCSAY L('случае из-за отсутствия некоторого шрифта, используемого системой "Эйдос" в пользовательском интерфейсе ') SAYSIZE 0;s=s+d @ s,1 DCSAY L('на месте русских символов могут оказаться вопросики или непонятные символы, как при ошибочной кодировке. ') SAYSIZE 0;s=s+d*1.5 d=1.4 mSizeUpd = aFileUpd[1,F_SIZE] / (1024^2) // Мб mDateUpd = aFileUpd[1,F_WRITE_DATE] mTimeUpd = aFileUpd[1,F_WRITE_TIME] @ s,1 DCPUSHBUTTON CAPTION L('10. Скачать встроенные шрифты системы "Эйдос" версии от: ')+' '+DTOC(mDateUpd)+':'+mTimeUpd+'; (~'+ALLTRIM(STR(mSizeUpd,15,1))+' Мб)' SIZE w, h ACTION {||LC_RunUrl("http://lc.kubagro.ru/Fonts.exe")} ;s=s+d*1.5 ENDIF aFileUpd := oFtp:Directory("___START_AIDOS-X.exe") IF LEN(aFileUpd) = 0 LB_Warning(L('Похоже, что доступ к FTP-серверу отсутствует'), L('(C°) Система "Эйдос-Х++"')) ELSE mSizeUpd = aFileUpd[1,F_SIZE] / (1024) // Кб mDateUpd = aFileUpd[1,F_WRITE_DATE] mTimeUpd = aFileUpd[1,F_WRITE_TIME] @ s,1 DCPUSHBUTTON CAPTION L('11. Скачать стартовый файл системы "Эйдос": "___START_AIDOS-X.exe" версии от: ')+' '+DTOC(mDateUpd)+':'+mTimeUpd+'; (~'+ALLTRIM(STR(mSizeUpd,15,1))+' Кб)' SIZE w, h ACTION {||LC_RunUrl("http://lc.kubagro.ru/___START_AIDOS-X.exe")};s=s+d ENDIF aFileUpd := oFtp:Directory("Sheet_changes.docx") IF LEN(aFileUpd) = 0 LB_Warning(L('Похоже, что доступ к FTP-серверу отсутствует'), L('(C°) Система "Эйдос-Х++"')) ELSE mSizeUpd = aFileUpd[1,F_SIZE] / (1024) // Кб mDateUpd = aFileUpd[1,F_WRITE_DATE] mTimeUpd = aFileUpd[1,F_WRITE_TIME] @ s,1 DCPUSHBUTTON CAPTION L('12. Скачать docx-файл значимых обновлений системы "Эйдос" за период: 31.08.2012 ')+'-'+DTOC(mDateUpd)+ '; (~'+ALLTRIM(STR(mSizeUpd,15,1))+' Кб)' SIZE w, h ACTION {||LC_RunUrl("http://lc.kubagro.ru/Sheet_changes.doc")} ;s=s+d ENDIF ENDIF oFtp:disconnect() @ s,1 DCPUSHBUTTON CAPTION L('13. Видео-занятия проф.Е.В.Луценко по АСК-анализу и системе "Эйдос" в ФГБОУ ВО КубГАУ и КубГУ ') SIZE w, h ACTION {||LC_RunUrl("http://lc.kubagro.ru/Video_lessons_by_Prof.E.V.Lutsenko/Catalog.php")} ;s=s+d @ s,1 DCPUSHBUTTON CAPTION L('14. Видео-занятия проф.Е.В.Луценко по АСК-анализу и системе "Эйдос" в ФГАОУ ВО "ПНИПУ" (2021) ') SIZE w, h ACTION {||LC_RunUrl("https://bigbluebutton.pstu.ru/rooms/w3y-2ir-ukd-bqn/join")};s=s+d @ s,1 DCPUSHBUTTON CAPTION L('15. Видео-занятия проф.Е.В.Луценко по АСК-анализу и системе "Эйдос" в ФГАОУ ВО "ПНИПУ" (2022) ') SIZE w, h ACTION {||LC_RunUrl("https://bigbluebutton.pstu.ru/rooms/3kc-n8a-gon-tjz/join")};s=s+d @ s,1 DCPUSHBUTTON CAPTION L('15. Видео-занятия проф.Е.В.Луценко по АСК-анализу и системе "Эйдос" в ФГАОУ ВО "ПНИПУ" (2024) ') SIZE w, h ACTION {||LC_RunUrl("https://bigbluebutton.pstu.ru/rooms/3kc-n8a-gon-tjz/join")};s=s+d @ s,1 DCPUSHBUTTON CAPTION L('15. Видео-занятия проф.Е.В.Луценко по АСК-анализу и системе "Эйдос" в ФГАОУ ВО "ПНИПУ" (2025) ') SIZE w, h ACTION {||LC_RunUrl("https://bigbluebutton.pstu.ru/rooms/o2h-74v-nsj-cuw/join")};s=s+d @ s,1 DCPUSHBUTTON CAPTION L('16. Чатбот по АСК-анализу и системе "Эйдос" (:он еще очень мало знает, а когда не знает, то нагло врет:) ') SIZE w, h ACTION {||LC_RunUrl("https://ora.ai/eugene-lutsenko/aidos")} ;s=s+d @ s,1 DCPUSHBUTTON CAPTION L('17. Актуальный каталог интеллектуальных облачных Эйдос-приложений, которые можно установить в режиме 1.3 ') SIZE w, h ACTION {||LC_RunUrl("http://lc.kubagro.ru/Source_data_applications/WebAppls.html")};s=s+d DCREAD GUI FIT TITLE L('6.2. Ссылки на патенты, литературу, обновление системы, группа в ResearchGate и т.п.') Running(.F.) RETURN nil *********************************************************************************************************** *********************************************************************************************************** ******** 6.2. Ссылки на патенты, монографии и статьи по системе *********************************************************************************************************** FUNCTION F6_2old() Running(.T.) DCSETFONT TO '10.Helv Bold' s=0 d=0.8 @ s,1 DCSAY L('1. САЙТ АВТОРА АСК-АНАЛИЗА И ИНТЕЛЛЕКТУАЛЬНОЙ СИСТЕМЫ "ЭЙДОС":') SAYSIZE 0 ;s=s+d @ s,1 DCSAY L('http://lc.kubagro.ru') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://lc.kubagro.ru', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} ;s=s+d*2 @ s,1 DCSAY L('2. ПАТЕНТЫ, НАУЧНЫЕ МОНОГРАФИИ И УЧЕБНЫЕ ПОСОБИЯ:') SAYSIZE 0 ;s=s+d @ s,1 DCSAY L('http://lc.kubagro.ru/aidos/index.htm') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://lc.kubagro.ru/aidos/index.htm', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} ;s=s+d*2 @ s,1 DCSAY L('3. НАУЧНЫЕ СТАТЬИ И ДРУГИЕ ПУБЛИКАЦИИ В НАУЧНОМ ЖУРНАЛЕ И В РИНЦ:') SAYSIZE 0 ;s=s+d @ s,1 DCSAY L('http://ej.kubagro.ru/a/viewaut.asp?id=11') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://ej.kubagro.ru/a/viewaut.asp?id=11', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} ;s=s+d @ s,1 DCSAY L('http://elibrary.ru/author_items.asp?authorid=123162') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://elibrary.ru/author_items.asp?authorid=123162', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} ;s=s+d*1.5 @ s,1 DCPUSHBUTTON CAPTION L('4. Скачать все публикации проф.Е.В.Луценко из Научного журнала КубГАУ (> 2 Гб)') SIZE w, 1.8 ACTION {||DownloadArticles()} ;s=s+d*3 @ s,1 DCSAY L('5. ПОЛНЫЙ АРХИВ СИСТЕМЫ "ЭЙДОС" С ПРИЛОЖЕНИЯМИ (>150 МБ):') SAYSIZE 0 ;s=s+d @ s,1 DCSAY L('http://lc.kubagro.ru/Aidos-X.exe') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://lc.kubagro.ru/Aidos-X.exe', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} ;s=s+d*2 @ s,1 DCSAY L('6. МИНИМАЛЬНАЯ ИНСТАЛЛЯЦИЯ СИСТЕМЫ "ЭЙДОС" (>60 МБ):') SAYSIZE 0 ;s=s+d @ s,1 DCSAY L('http://lc.kubagro.ru/a-min.rar') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://lc.kubagro.ru/a-min.rar', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} ;s=s+d*2 @ s,1 DCSAY L('7. АКТУАЛЬНОЕ ТЕКУЩЕЕ ОБНОВЛЕНИЕ СИСТЕМЫ "ЭЙДОС" (ПАТЧ) (> 20 МБ)') SAYSIZE 0 ;s=s+d @ s,1 DCSAY L('http://lc.kubagro.ru/Downloads.exe') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://lc.kubagro.ru/Downloads.exe', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} ;s=s+d*2 @ s,1 DCSAY L('8. Если вы хотите, чтобы система <Эйдос> использовала не стандартные шрифты MS Windows, а свои собственные,') SAYSIZE 0 ;s=s+d @ s,1 DCSAY L('то надо скачать самораспаковывающийся архив (118 Мб) шрифтов <Эйдос> по прямой ссылке, приведенной ниже, ') SAYSIZE 0 ;s=s+d @ s,1 DCSAY L('а затем разархивировать этот файл в папку с исполнимым модулем системы <Эйдос>. Такая потребность может ') SAYSIZE 0 ;s=s+d @ s,1 DCSAY L('у вас возникнуть, если вы используете неруссифицированную версию MS Windows. В этом случае из-за отсутствия') 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('http://lc.kubagro.ru/Fonts.exe') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://lc.kubagro.ru/Fonts.exe', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} ;s=s+d*2 @ s,1 DCSAY L('9. СКАЧАТЬ СТАРТОВЫЙ ФАЙЛ СИСТЕМЫ "ЭЙДОС": "___START_AIDOS-X.exe" (400 КБ)') SAYSIZE 0 ;s=s+d @ s,1 DCSAY L('http://lc.kubagro.ru/___START_AIDOS-X.exe ') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://lc.kubagro.ru/___START_AIDOS-X.exe ', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} ;s=s+d*2 @ s,1 DCSAY L('10. ИНФОРМАЦИЯ ОБ ОБНОВЛЕНИЯХ СИСТЕМЫ "ЭЙДОС" ЗА ВСЕ ВРЕМЯ (doc-файл 600 Кб)') SAYSIZE 0 ;s=s+d @ s,1 DCSAY L('http://lc.kubagro.ru/Sheet_changes.doc') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://lc.kubagro.ru/Sheet_changes.doc', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} ;s=s+d*2 @ s,1 DCSAY L('11. СТРАНИЧКА И ЛАБОРАТОРИИ В RESEARCHGATE ПО АСК-АНАЛИЗУ И СИСТЕМЕ "ЭЙДОС"') SAYSIZE 0 ;s=s+d @ s,1 DCSAY L('https://www.researchgate.net/profile/Eugene_Lutsenko') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'https://www.researchgate.net/profile/Eugene_Lutsenko', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} ;s=s+d @ s,1 DCSAY L('https://www.researchgate.net/lab/Eugene-Lutsenko-Lab-Eugene-Veniaminovich-Lutsenko') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'https://www.researchgate.net/lab/Eugene-Lutsenko-Lab-Eugene-Veniaminovich-Lutsenko', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} ;s=s+d*2 @ s,1 DCSAY L('12. ВИДЕО-ЗАНЯТИЯ ПРОФ.Е.В.ЛУЦЕНКО ПО АСК-АНАЛИЗУ И СИСТЕМЕ "ЭЙДОС"') SAYSIZE 0 ;s=s+d @ s,1 DCSAY L('http://lc.kubagro.ru/Video_lessons_by_Prof.E.V.Lutsenko/Catalog.php') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://lc.kubagro.ru/Video_lessons_by_Prof.E.V.Lutsenko/Catalog.php', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} ;s=s+d @ s,1 DCSAY L('13. ЧАТБОТ ПО АСК-АНАЛИЗУ И СИСТЕМЕ "ЭЙДОС" (:многого не знает и тогда выдумывает и врет:)') SAYSIZE 0 ;s=s+d @ s,1 DCSAY L('https://ora.ai/eugene-lutsenko/aidos') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'https://ora.ai/eugene-lutsenko/aidos', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} ;s=s+d*2 DCREAD GUI FIT TITLE L('6.2. Ссылки на патенты, литературу, обновление системы, группа в ResearchGate и т.п.') Running(.F.) RETURN nil *********************************************************************************************************** ******** 6.7. Запуск программы формирования логотипов мультимоделей *********************************************************************************************************** FUNCTION F6_7() Running(.T.) * RUN("_6_7.exe") ******** Проверять контрольную сумму программы и в _6_7.exe и других местах тоже ############################ * RunShell("","_6_7.exe",.T.) LC_RunShell("_6_7.exe", 38953662) Running(.F.) RETURN NIL ************************* ******** Выход из системы ************************* FUNCTION F7() SaveLangDB() // Запись языковых баз RemoveFonts() // Отключение шрифтов, назависимых от Windows CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * ADS_SERVER_QUIT() QUIT RETURN NIL ******************************************************************************************************************************* ******** 6.3. Развитый алгоритм принятия решений в интеллектуальных системах управления на основе АСК-анализа и системы "Эйдос" ******************************************************************************************************************************* FUNCTION F6_3() DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы cFile = "Advanced_decision-making_algorithm_for_ASK-analysis.pdf" IF .NOT. FILE(cFile) Mess = L('В папке с исполнимым модулем системы нет файла: "#"') Mess = STRTRAN(Mess, "#", cFile) LB_Warning(Mess) ENDIF // Проверить контрольную сумму файла и если она не совпадает // выдать сообщение о том, что файл поврежден (чтобы было невозможно заменить графический файл). IF FILECHECK(cFile) = 26510151 // <<<===############### * DC_PrintPreviewAcrobat( cFile, '6.3. Развитый алгоритм принятия решений АСК-анализа' ) RunShell(cFile,"SumatraPDF-3.4.5-32.exe",.T.) ELSE Mess = L('Файл: "#" поврежден (CRC=$) и не может быть отображен!') Mess = STRTRAN(Mess, "#", cFile) Mess = STRTRAN(Mess, "$", ALLTRIM(STR(FILECHECK(cFile),19))) // Отображение контрольной суммы файла LB_Warning(Mess) ENDIF RETURN NIL **************************************************************************************************************** ******** 6.4. Порядок преобразования данных в информацию, а ее в знания ******** В режиме раскрывается соотношение содержания понятий: "Данные", "Информация" и "Знания", ******** а также последовательность преобразования данных в информацию, а ее в знания в системе "Эйдос-Х++" ******** с указанием имен баз данных и ссылками на основные публикации по этим вопросам' **************************************************************************************************************** FUNCTION F6_4() DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы cFile = "_DataInfCogn.pdf" IF .NOT. FILE(cFile) Mess = L('В папке с исполнимым модулем системы нет файла: "#"') Mess = STRTRAN(Mess, "#", cFile) LB_Warning(Mess) ELSE // Проверить контрольную сумму файла и если она не совпадает // выдать сообщение о том, что файл поврежден (чтобы было невозможно заменить графический файл). IF FILECHECK(cFile) = 88764747 // <<<===############### * DC_PrintPreviewAcrobat( cFile, '6.4. Последовательность обработки данных, информации и знаний в системе "Эйдос-Х++"' ) RunShell(cFile,"SumatraPDF-3.4.5-32.exe",.T.) ELSE Mess = L('Файл: "#" поврежден (CRC=$) и не может быть отображен!') Mess = STRTRAN(Mess, "#", cFile) Mess = STRTRAN(Mess, "$", ALLTRIM(STR(FILECHECK(cFile),19))) // Отображение контрольной суммы файла LB_Warning(Mess) ENDIF ENDIF RETURN NIL ********************************************************************************************************** ******** 6.5. Графическая заставка системы "Эйдос-12.5" ********************************************************************************************************** FUNCTION F6_5() Running(.T.) cFile = "_TITUL125.GIF" IF .NOT. FILE(cFile) Mess = L('В папке с исполнимым модулем системы нет файла: "#"') Mess = STRTRAN(Mess, "#", cFile) LB_Warning(Mess) ENDIF // Проверить контрольную сумму файла и если она не совпадает // выдать сообщение о том, что файл поврежден (чтобы было невозможно заменить графический файл). IF FILECHECK(cFile) = 2200845 FullView( cFile, "по центру", 0 ) ELSE Mess = ('Графический файл: "#" поврежден и не может быть отображен!') Mess = STRTRAN(Mess, "#", cFile) * Mess = STRTRAN(Mess, "#", ALLTRIM(STR(FILECHECK(cFile),19))) // Отображение контрольной суммы файла LB_Warning(Mess) ENDIF Running(.F.) RETURN NIL ********************************************************************************************************** ******** 6.6. Roger Donnay, Professional Developer, Developer eXPress++ ********************************************************************************************************** FUNCTION F6_6() Running(.T.) cFile = "_Roger.jpg" IF .NOT. FILE(cFile) Mess = L('В папке с исполнимым модулем системы нет файла: "#"') Mess = STRTRAN(Mess, "#", cFile) LB_Warning(Mess) ENDIF // Проверить контрольную сумму файла и если она не совпадает // выдать сообщение о том, что файл поврежден (чтобы было невозможно заменить графический файл). IF FILECHECK(cFile) = 9087979 FullView( cFile, "по центру", 0 ) ELSE Mess = L('Графический файл: "#" поврежден и не может быть отображен!') Mess = STRTRAN(Mess, "#", cFile) * Mess = STRTRAN(Mess, "#", ALLTRIM(STR(FILECHECK(cFile),19))) // Отображение контрольной суммы файла LB_Warning(Mess) ENDIF Running(.F.) RETURN NIL ********************************************************************************************************** ******** 6.8. Свидетельства РосПатента РФ на систему "Эйдос" ********************************************************************************************************** FUNCTION F6_8() Running(.T.) * cFile = "_2012619610.jpg" * IF .NOT. FILE(cFile) * Mess = L('В папке с исполнимым модулем системы нет файла: "#"') * Mess = STRTRAN(Mess, "#", cFile) * LB_Warning(Mess) * ENDIF * // Проверить контрольную сумму файла и если она не совпадает * // выдать сообщение о том, что файл поврежден (чтобы было невозможно заменить графический файл). * IF FILECHECK(cFile) = 8312874 * FullView( cFile, "по центру", 0 ) * ELSE * Mess = L('Графический файл: "#" поврежден и не может быть отображен!') * Mess = STRTRAN(Mess, "#", cFile) ** Mess = STRTRAN(Mess, "#", ALLTRIM(STR(FILECHECK(cFile),19))) // Отображение контрольной суммы файла * LB_Warning(Mess) * ENDIF cFile = "_CertRosPatSysAidos.pdf" IF .NOT. FILE(cFile) Mess = L('В папке с исполнимым модулем системы нет файла: "#"') Mess = STRTRAN(Mess, "#", cFile) LB_Warning(Mess) ENDIF // Проверить контрольную сумму файла и если она не совпадает // выдать сообщение о том, что файл поврежден (чтобы было невозможно заменить графический файл). IF FILECHECK(cFile) = 1093634864 * DC_PrintPreviewAcrobat( cFile, '6.8. Свидетельства РосПатента РФ на систему "Эйдос"' ) 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 Running(.F.) RETURN NIL *********************************************************************************************************** ******** 1.9. Прописывание путей по фактическому положению ******** Доступно только сисадмину. Определяет фактическое месторасположение системы и приложений ******** и прописывает пути на них в БД: PathGrAp.DBF и Appls.dbf, ******** а также восстанавливает имена приложений в Appls.dbf на данные им при их создании *********************************************************************************************************** FUNCTION F1_9() Running(.T.) IF .NOT. Flag_SysAdmin LB_Warning(L("Эта функция доступна только Сисадмину")) ELSE M_PathAppls = ALLTRIM(Disk_dir)+"\AID_DATA\" DIRCHANGE(M_PathAppls) PRIVATE aAppls := Directory("A0*.*","D") GenDbfPaths() GenDbfAppls() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Appls EXCLUSIVE NEW FOR j=1 TO LEN(aAppls) Appls->(DBAPPEND()) Appls->Kod_AdmApp := 2 Appls->Kod_Appl := j Appls->Date := DTOC(DATE()) Appls->Time := TIME() Appls->Path_Appl := M_PathAppls+aAppls[ j, F_NAME ]+"\System\" // Считать M_NameAppl с диска из папки приложения, если он есть, а если нет - присвоить наименование, // и записать его в Appls.dbf DIRCHANGE(Appls->Path_Appl) IF .NOT. FILE("_NameAppl.arx") M_NameAppl = "Приложение № "+ALLTRIM(STR(j,19)) ELSE M_NameAppl = DC_ARestore("_NameAppl.arx") ENDIF // Записать M_NameAppl на диск в папку приложения DC_ASave(M_NameAppl, "_NameAppl.arx") DIRCHANGE(M_PathAppls) Appls->Name_Appl := M_NameAppl NEXT Appls->(DBGOTOP()) Appls->By_Default := "W" LB_Warning(L("Пути на фактическое расположение системы и приложений прописаны, имена приложений восстановлены!"), L("Сообщение о завершении операции") ) ENDIF ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL *********************************************************************************************************** ******** 1.11. Удаление всех приложений и пользователей ******** Доступно только сисадмину. Определяет фактическое месторасположение системы и приложений ******** и удаляет все директории приложений с поддиректориями и всеми файлами в них, ******** а затем пересоздает и переиндексирует БД: PathGrAp.DBF, Appls.dbf и Users.dbf' *********************************************************************************************************** FUNCTION F1_11() Running(.T.) IF .NOT. Flag_SysAdmin LB_Warning(L("Эта функция доступна только Сисадмину")) ELSE // Сначала удалить ВСЕ папки с приложениями, используя путь на фактическое расположение БД AID_DATA, // а потом пересоздать БД: PathGrAp.DBF, Appls.dbf и Users.dbf // Запомнить текущее положение системы в БД PathSystem.dbf CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций aStructure := { { "PathSystem", "C", 250, 0 } } DbCreate( 'PathSystem', aStructure ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE PathSystem EXCLUSIVE NEW;ZAP APPEND BLANK REPLACE PathSystem WITH Disk_dir // Сначала удалить ВСЕ папки с приложениями, используя путь на фактическое расположение БД AID_DATA, // а потом пересоздать БД: PathGrAp.DBF, Appls.dbf и Users.dbf Zap_Appls() * Zap_InpData() // Содержимое папки Inp_data удалаять при удалении приложения GenDbfPaths() GenDbfUsers() aMess := {} AADD(aMess, L('Была произведена локализация системы, т.е. удалены все приложения')) AADD(aMess, L('и пользователи и прописаны пути по фактическому положению системы')) AADD(aMess, L('т.к. система впервые запущена в папке: "'+ALLTRIM(Disk_dir)+'\"' )) LB_Warning(aMess, L('1.11. Локализация системы "Эйдос" в папке') ) ENDIF ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL *********************************************************************************************************** ******** 1.10. Инсталляция ActiveX на данном компьютере ******** Доступно только сисадмину. Устанавливает ActiveX: RMChart.ocx на данном копьютере *********************************************************************************************************** FUNCTION F1_10() Running(.T.) *IF .NOT. Flag_SysAdmin * LB_Warning(L("Эта функция доступна только Сисадмину")) *ELSE * aMess := {} * DO CASE * CASE OSVER() = "3.1" * AADD(aMess, L('На комьютере установлена MS Windows NT 3.1')) * CASE OSVER() = "3.5" * AADD(aMess, L('На комьютере установлена MS Windows NT 3.5')) * CASE OSVER() = "3.51" * AADD(aMess, L('На комьютере установлена MS Windows NT 3.51') * CASE OSVER() = "4.0" * AADD(aMess, L('На комьютере установлена MS Windows NT 4.0')) * CASE OSVER() = "5.0" * AADD(aMess, L('На комьютере установлена MS Windows 2000')) * CASE OSVER() = "5.1" * AADD(aMess, L('На комьютере установлена MS Windows XP')) * CASE OSVER() = "5.2" * AADD(aMess, L('На комьютере установлена MS Server 2003')) * ENDCASE * IF LEN(aMess) > 0 * AADD(aMess, L('А для работы профессиональной графики нужна:' )) * AADD(aMess, L('MS Windows Vista / MS Windows Server 2008 или')) // OSVER() = "6.0" * AADD(aMess, L('MS Windows 7 / MS Windows Server 2008 R2' )) // OSVER() = "6.1" * LB_Warning(aMess, L('Сообщение о неудачном завершении операции')) * RETURN NIL * ENDIF * IF FILE("RMChart.ocx") ** RunShell("","c:\Windows\System32\regsvr32.exe RMChart.ocx",.F.) ** Run("c:\Windows\System32\regsvr32.exe RMChart.ocx") * Run("regsvr32.exe RMChart.ocx") * ELSE * LB_Warning(L("ActiveX: RMChart.ocx отсутствует в текущей папке. Обратитесь к разработчику !"), L("Сообщение о неудачном завершении операции") ) * ENDIF *ENDIF Running(.F.) RETURN NIL *********************************************************************************************************** *IF .NOT. Flag_SysAdmin * LB_Warning(L("Эта функция доступна только сисадмину")) *ELSE *ENDIF *********************************************************************************************************** ******** 1.3. Диспетчер приложений (xdemo.exe, FUNCTION XSample_130(): sample 4, OneToMany2) *********************************************************************************************************** FUNCTION F1_3() LOCAL GetList := {}, GetOptions, oBrowUser, oBrowApp, bApp, bItems, lCancelled := .F. Running(.T.) IF Flag_SysAdmin .OR. Flag_AdmAppl ELSE LB_Warning(L("Эта функция доступна только Сисадмину и Администраторам приложений")) Running(.F.) RETURN NIL ENDIF IF FILE("Users.dbf") // БД администраторов приложений и паролей доступа к ним: Users.dbf ** Переиндексировать БД Users.dbf, ** если не хватает хотя бы одного какого-нибудь индексного массива IF FILE("Use_kod.ntx" ).AND.; FILE("Use_name.ntx").AND.; FILE("Use_LPAA.ntx").AND.; FILE("Use_LPus.ntx").AND.; FILE("Use_dreg.ntx") ELSE GenNtxUsers() ENDIF ELSE GenDbfUsers() ENDIF IF FILE("Appls.dbf") // БД администраторов приложений и паролей доступа к ним: Users.dbf ** Переиндексировать БД Appls.dbf, ** если не хватает хотя бы одного какого-нибудь индексного массива IF .NOT. FILE("App_kapl.ntx").OR.; .NOT. FILE("App_kapp.ntx").OR.; .NOT. FILE("App_name.ntx").OR.; .NOT. FILE("App_crea.ntx") GenNtxAppls() ENDIF ELSE GenDbfAppls() ENDIF dbeSetDefault('DBFNTX') 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() aSave_adds := DC_DataSave() // Сохранение вычислительной среды (открытые и текущие БД и индексы) /* ----- Create ToolBar ----- */ mStr1 = L("Помощь" );mStr1Len = LEN(mStr1) mStr2 = L("Добавить пустое приложение" );mStr2Len = LEN(mStr2) mStr3 = L("Добавить лабораторную работу" );mStr3Len = LEN(mStr3) mStr4 = L("Скачать приложение из облака" );mStr4Len = LEN(mStr4) mStr5 = L("Записать приложение в облако" );mStr5Len = LEN(mStr5) mStr6 = L("Скопировать текущее приложение");mStr6Len = LEN(mStr6) mStr7 = L("Удалить текущее приложение" );mStr7Len = LEN(mStr7) d = 2 n = 1.5 mL = 15 mK = 0.3 @ 27.5, 0 DCGROUP oGroup1 CAPTION L(' ') SIZE 171, 3.0 @ 1, 1 DCPUSHBUTTON CAPTION mStr1 SIZE mStr1Len+(mL-mStr1Len)*mK+n, 1.5 ACTION {||Help13() , DC_GetRefresh(GetList)} PARENT oGroup1 TOOLTIP L('Помощь по режиму 1.3') @ 1, DCGUI_COL+d DCPUSHBUTTON CAPTION mStr2 SIZE mStr2Len+(mL-mStr2Len)*mK+n, 1.5 ACTION {||ADD_ZAPPL(L("Название приложения нужно ввести вручную в режиме 1.3.")), DC_GetRefresh(GetList)} PARENT oGroup1 TOOLTIP L('Добавить пустое приложение') @ 1, DCGUI_COL+d DCPUSHBUTTON CAPTION mStr3 SIZE mStr3Len+(mL-mStr3Len)*mK+n+3, 1.5 ACTION {||AddsAppls() , DC_GetRefresh(GetList)} PARENT oGroup1 TOOLTIP L('Добавить учебное приложение с локального компьютера') FONT '9.Arial Bold' @ 1, DCGUI_COL+d DCPUSHBUTTON CAPTION mStr4 SIZE mStr4Len+(mL-mStr4Len)*mK+n, 1.5 ACTION {||LoadAppCloud(), DC_GetRefresh(GetList)} PARENT oGroup1 TOOLTIP L('Скачать приложение из облака (DownLoad): с WEB-сервера системы "Эйдос"') @ 1, DCGUI_COL+d DCPUSHBUTTON CAPTION mStr5 SIZE mStr5Len+(mL-mStr5Len)*mK+n, 1.5 ACTION {||SaveAppCloud(), DC_GetRefresh(GetList)} PARENT oGroup1 TOOLTIP L('Записать приложение в облако (UpLoad): на WEB-сервер системы "Эйдос"') @ 1, DCGUI_COL+d DCPUSHBUTTON CAPTION mStr6 SIZE mStr6Len+(mL-mStr6Len)*mK+n, 1.5 ACTION {||Copy_rec1_3() , DC_GetRefresh(GetList)} PARENT oGroup1 TOOLTIP L('Создать новое приложение и скопировать в него все БД текущего') @ 1, DCGUI_COL+d DCPUSHBUTTON CAPTION mStr7 SIZE mStr7Len+(mL-mStr7Len)*mK+n, 1.5 ACTION {||Del_Appl() , DC_GetRefresh(GetList)} PARENT oGroup1 TOOLTIP L('Удалить текущее приложение') *@ 27.5, 0 DCTOOLBAR oToolBar SIZE 171, 1.5 *d = 1 *DCADDBUTTON CAPTION L('Помощь' ; * SIZE LEN(L("Помощь"))+3, 1.5 ; * ACTION {||Help13(), DC_GetRefresh(GetList)} ; * PARENT oToolBar ; * TOOLTIP L('Помощь по режиму 1.3') **** Функции, доступные только сисадмину и администратору приложения *IF Flag_SysAdmin .OR. Flag_AdmAppl * @ DCGUI_ROW, DCGUI_COL + d DCPUSHBUTTON CAPTION L('Добавить пустое приложение') ; * SIZE LEN(L("Добавить пустое приложение"))-2, 1.5 ; * ACTION {||ADD_ZAPPL(L("Пустое приложение. Его название можно поменять вручную")), DC_GetRefresh(GetList)}; * PARENT oToolBar ; * TOOLTIP L('Добавить пустое приложение') * @ DCGUI_ROW, DCGUI_COL + d DCPUSHBUTTON CAPTION L('Добавить лабораторную работу') ; * SIZE LEN(L("Добавить лабораторную работу"))+2, 1.5 ; * ACTION {||AddsAppls(), DC_GetRefresh(GetList)} ; * FONT '9.Arial Bold' ; * PARENT oToolBar ; * TOOLTIP L('Добавить учебное приложение с локального компьютера') * @ DCGUI_ROW, DCGUI_COL + d DCPUSHBUTTON CAPTION L('Скачать приложение из облака') ; * SIZE LEN(L("Скачать приложение из облака"))-1, 1.5 ; * ACTION {||LoadAppCloud(), DC_GetRefresh(GetList)} ; * PARENT oToolBar ; * TOOLTIP L('Скачать приложение из облака (DownLoad): с WEB-сервера системы "Эйдос"') * @ DCGUI_ROW, DCGUI_COL + d DCPUSHBUTTON CAPTION L('Записать приложение в облако') ; * SIZE LEN(L("Записать приложение в облако"))-2, 1.5 ; * ACTION {||SaveAppCloud(), DC_GetRefresh(GetList)} ; * PARENT oToolBar ; * TOOLTIP L('Записать приложение в облако (UpLoad): на WEB-сервер системы "Эйдос"') * @ DCGUI_ROW, DCGUI_COL + d DCPUSHBUTTON CAPTION L('Сдублировать текущее приложение') ; * SIZE LEN(L("Скопировать текущее приложение"))-1, 1.5 ; * ACTION {||Copy_rec1_3(), DC_GetRefresh(GetList)} ; * PARENT oToolBar ; * TOOLTIP L('Создать новое приложение и скопировать в него все БД текущего') * @ DCGUI_ROW, DCGUI_COL + d DCPUSHBUTTON CAPTION L('Удалить текущее приложение') ; * SIZE LEN(L("Удалить текущее приложение"))-1, 1.5 ; * ACTION {||Del_Appl(), DC_GetRefresh(GetList)} ; * PARENT oToolBar ; * TOOLTIP L('Удалить текущее приложение') *ENDIF /* ----- Create browse-1 ----- */ bApp := {|| APPLS->(DC_SetScope(0,USERS->Kod_AdmApp)), ; APPLS->(DC_SetScope(1,USERS->Kod_AdmApp)), ; APPLS->(DC_DbGoTop()), ; oBrowApp:refreshAll() } IF Flag_SysAdmin @ 1, 0 DCBROWSE oBrowUser ALIAS 'USERS' SIZE 48.9,26 ; EDIT xbeBRW_ItemSelected MODE DCGUI_BROWSE_EDITDOWN ; // Редактирование БД Users NOSOFTTRACK ; HEADLINES 3 ; // Кол-во строк в заголовке (перенос строки - ";") SCOPE ; ITEMMARKED {|| Eval(bApp), ; DC_GetRefresh(GetList,, ; DCGETREFRESH_TYPE_EXCLUDE,{GETLIST_BROWSE}) } DCSETPARENT oBrowUser DCBROWSECOL FIELD USERS->Kod_AdmApp HEADER L('Код;адм.;приложения' ) WIDTH 4 PROTECT {|| .T. } DCBROWSECOL FIELD USERS->Name_AdmAp HEADER L('Ф.И.О.адм.приложения' ) WIDTH 24 DCBROWSECOL FIELD USERS->Login_AdmA HEADER L('Login;адм.;приложения') WIDTH 10 DCBROWSECOL FIELD USERS->Passw_AdmA HEADER L('Password;адм.;прилож.') WIDTH 10 DCBROWSECOL FIELD USERS->Passw_User HEADER L('Password;пользователя') WIDTH 10 DCBROWSECOL FIELD USERS->Date HEADER L('Дата;регистрации' ) WIDTH 5 PROTECT {|| .T. } DCBROWSECOL FIELD USERS->Time HEADER L('Время;регистрации' ) WIDTH 5 PROTECT {|| .T. } ELSE @ 1, 0 DCBROWSE oBrowUser ALIAS 'USERS' SIZE 48.9,26 ; PRESENTATION LC_BrowPres() ; // Только просмотр БД Users HEADLINES 3 ; // Кол-во строк в заголовке (перенос строки - ";") NOSOFTTRACK ; SCOPE ; ITEMMARKED {|| Eval(bApp), ; DC_GetRefresh(GetList,, ; DCGETREFRESH_TYPE_EXCLUDE,{GETLIST_BROWSE}) } DCSETPARENT oBrowUser DCBROWSECOL FIELD USERS->Kod_AdmApp HEADER L('Код;адм.;приложения' ) WIDTH 4 PROTECT {|| .T. } DCBROWSECOL FIELD USERS->Name_AdmAp HEADER L('Ф.И.О.адм.приложения') WIDTH 24 ENDIF /* ----- Create browse-2 ----- */ DCSETPARENT TO @ 1,51 DCBROWSE oBrowApp ALIAS 'APPLS' SIZE 120,26 ; EDIT xbeBRW_ItemSelected MODE DCGUI_BROWSE_EDITDOWN ; HEADLINES 3 ; // Кол-во строк в заголовке (перенос строки - ";") NOSOFTTRACK ; SCOPE ; ITEMMARKED bItems; COLOR {||IIF(LEN(ALLTRIM(APPLS->By_default))=0, {nil,GRA_CLR_WHITE}, {nil,aColor[153]})} DCSETPARENT oBrowApp IF Flag_SysAdmin DCBROWSECOL FIELD APPLS->Kod_AdmApp HEADER L('Код;адм.;приложения' ) WIDTH 4 PROTECT {|| .T. } DCBROWSECOL FIELD APPLS->Kod_Appl HEADER L('Код;приложения' ) WIDTH 4 PROTECT {|| .T. } DCBROWSECOL FIELD APPLS->By_default HEADER L('Признак;выбора;приложения' ) WIDTH 1 DCBROWSECOL FIELD APPLS->Name_Appl HEADER L('Наименование приложения' ) WIDTH 60 DCBROWSECOL FIELD APPLS->Date HEADER L('Дата;создания;приложения' ) WIDTH 5 PROTECT {|| .T. } DCBROWSECOL FIELD APPLS->Time HEADER L('Время;создания;приложения' ) WIDTH 5 PROTECT {|| .T. } DCBROWSECOL FIELD APPLS->Path_Appl HEADER L('Путь на папку с приложением') WIDTH 40 ELSE DCBROWSECOL FIELD APPLS->Kod_Appl HEADER L('Код;приложения' ) WIDTH 4 PROTECT {|| .T. } DCBROWSECOL FIELD APPLS->By_default HEADER L('Признак;выбора;приложения' ) WIDTH 1 DCBROWSECOL FIELD APPLS->Name_Appl HEADER L('Наименование приложения' ) WIDTH 60 DCBROWSECOL FIELD APPLS->Date HEADER L('Дата;создания;приложения' ) WIDTH 5 PROTECT {|| .T. } DCBROWSECOL FIELD APPLS->Time HEADER L('Время;создания;приложения' ) WIDTH 5 PROTECT {|| .T. } ENDIF DCGETOPTIONS SAYFONT '10.Helv Bold' TABSTOP AUTORESIZE IF Flag_SysAdmin cTitle = L('1.3. Диспетчер приложений (режим СисАдмина)') ELSE cTitle = L('1.3. Диспетчер приложений (режим Администратора приложений)') ENDIF DCREAD GUI ; FIT ; OPTIONS GetOptions ; MODAL ; TITLE cTitle ; EVAL {|o|SetAppFocus(oBrowUser:GetColumn(1))} ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ****** END OF EXAMPLE *********************** ************************************************************************************************** FUNCTION Help13() aHelp := {} AADD(aHelp, L('Помощь по режиму: "1.3. ДИСПЕТЧЕР ПРИЛОЖЕНИЙ". ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Это подсистема администрирования приложений. Она предназначена для создания новых приложений, как пустых, так и на основе учебных ')) AADD(aHelp, L('примеров (лабораторных работ), имеющихся в системе локально или в облаке (на web-сервере автора), а также для выбора приложения ')) AADD(aHelp, L('для работы из уже имеющихся и удаления приложения. Выбор приложения для работы осуществляется путем отметки его любым символом. ')) AADD(aHelp, L('Администратор приложения может выбирать для работы только созданные им приложения. Если таким способом отмечено несколько ')) AADD(aHelp, L('приложений, то используется первое по порядку. Удалять любые приложения разрешается только сисадмину, а Администратору приложений ')) AADD(aHelp, L('- только те, которые он сам создал. Как создать собственные приложения описано в инструкции для учащихся в п.2. на сайте автора. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Порядок работы в системе описан в режиме 6.4 и включает следующие этапы: ')) AADD(aHelp, L(' 1. Ввести исходные данные в систему в режиме 2.3.2.2. Файл исходных данных Inp_data.xls должен быть в папке: ../AID_DATA/INP_DATA/.')) AADD(aHelp, L(' 2. Посмотреть на классификационные шкалы и градации в режиме 2.1. ')) AADD(aHelp, L(' 3. Посмотреть на описательные шкалы и градации в режиме 2.2. ')) AADD(aHelp, L(' 4. Посмотреть на обучающую выборку в режиме 2.3.1. ')) AADD(aHelp, L(' 5. Запустить режим синтеза и верификации моделей с параметрами по умолчанию (режим 3.5). ')) AADD(aHelp, L(' 6. Посмотреть сформированные модели в режиме 5.5. ')) AADD(aHelp, L(' 7. Посмотреть достоверность моделей в режиме 3.4. Посмотреть частотные распределения числа истинных и ложных положительных ')) AADD(aHelp, L(' и отрицательных решений при различных уровнях сходства. ')) AADD(aHelp, L(' 8. Сделать текущей наиболее достоверную модель (в режиме 5.6). ')) AADD(aHelp, L(' 9. Решить задачу идентификации в наиболее достоверной модели в режиме 4.1.2. ')) AADD(aHelp, L('10. Посмотреть результаты идентификации в режимах 4.1.3. ')) AADD(aHelp, L('11. Решить задачу поддерки принятия решений в упрощенном варианте (режим 4.4.8) ')) AADD(aHelp, L('12. Провести исследование наиболее достоверной модели в 4-й подсистеме. ')) AADD(aHelp, L('13. Решить задачу поддерки принятия решений в развитом варианте (режим 6.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-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 MODAL TITLE L('Помощь по режиму: 1.3. (C) Система "ЭЙДОС-X++"') RETURN NIL ************************************************************************************************** ******************************************************************** ******** Создать новое пустое приложение ******** и добавить запись с информацией о нем в конец БД Appls.dbf ******** и сделать новое приложение текущим ******** Новое приложение создавать по пути на группу приложений ### ******************************************************************** FUNCTION ADD_ZAPPL(M_NameAppl) aSave_adds := DC_DataSave() // Сохранение вычислительной среды (открытые и текущие БД и индексы) * DC_DataRest( aSave_adds ) // Восстановление вычислительной среды (открытые и текущие БД и индексы) DIRCHANGE(Disk_dir) // использовать путь на группу приложений // Удалить отметку предыдущих преложений как текущих CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Appls EXCLUSIVE NEW SELECT Appls DBGOTOP() DO WHILE .NOT. EOF() REPLACE By_default WITH " " DBSKIP(1) ENDDO // Создать запись нового приложения и отметить его как текущее APPEND BLANK REPLACE Kod_AdmApp WITH M_KodAdmAppls REPLACE Kod_Appl WITH RECNO() REPLACE By_default WITH "W" REPLACE Name_Appl WITH ALLTRIM(M_NameAppl) REPLACE Date WITH DTOC(DATE()) REPLACE Time WITH TIME() // Имя папки с данным приложением в папке со всеми приложениями M_PuthAppl = "A"+STRTRAN(STR(RECNO(),7)," ","0") // Полный путь на основную папку конкретного приложения // а в ней могут быть еще папки для итераций или частных моделей // с разными параметрами, например, с разным числом градаций в шкалах * MsgBox(M_ApplsPath) REPLACE Path_Appl WITH ALLTRIM(M_ApplsPath)+"\"+ALLTRIM(M_PuthAppl)+"\System\" IF FILEDATE(M_ApplsPath,16) = CTOD("//") DIRMAKE(M_ApplsPath) ENDIF DIRCHANGE(M_ApplsPath) IF FILEDATE(M_PuthAppl,16) = CTOD("//") DIRMAKE(M_PuthAppl) ENDIF DIRCHANGE(M_PuthAppl) IF FILEDATE("System",16) = CTOD("//") DIRMAKE("System") ENDIF // Перейти в папку приложения и записать файл с его наименованием DIRCHANGE(Appls->Path_Appl) DC_ASave(M_NameAppl, "_NameAppl.arx") DIRCHANGE(Disk_dir) * aSave_adds := DC_DataSave() // Сохранение вычислительной среды (открытые и текущие БД и индексы) * DC_DataRest( aSave_adds ) // Восстановление вычислительной среды (открытые и текущие БД и индексы) 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(("Этот режим доступен только после авторизации в режиме 1.1 !!!")) RETURN NIL ENDCASE *DBGOTOP();DBGOBOTTOM();DBGOTOP() USE APPLS INDEX APPLS EXCLUSIVE NEW SELECT Appls RETURN(UPPER(ALLTRIM(M_ApplsPath))+"\"+UPPER(ALLTRIM(M_PuthAppl))+"\System\") ************************************************************************************************** FUNCTION HelpLW209() aHelp := {} AADD(aHelp, L('Что такое RND-модель? ')) AADD(aHelp, L(' ')) AADD(aHelp, L('RND-модель - это модель, в которой принадлежность объектов обучающей выборки к классам является случайной, ')) AADD(aHelp, L('как и признаки объектов. Для генерации случайных кодов классов и признаков используется числовой генератор ')) AADD(aHelp, L('равномерно распределенных случайных чисел. При автоматическом определении параметров RND-модели на основе ')) AADD(aHelp, L('текущей модели количество классов, признаков и объектов обучающей выборки в RND-модели будет таким же, как ')) AADD(aHelp, L('в текущей модели. Среднее количество классов, к которым относится объект обучающей выборки и среднее коли- ')) AADD(aHelp, L('чество признаков у него также будет совпадать с этими характеристиками объектов обуч.выборки текущей модели. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Зачем создается и исследуется RND-модель? ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Информацию об объектах обучающей выборки текущей модели можно считать суммой полезной информации о них ')) AADD(aHelp, L('(полезный сигнал) и шума. В RND-модели вся информация представляет собой шум. Поэтому сравнение этих моделей, ')) AADD(aHelp, L('не отличающихся перечисленными параметрами, позволяет оценить влияние значимой информации и шума на результаты,')) AADD(aHelp, L('в частности убедиться в наличии самой этой значимой информации, т.е. закономерностей в предметной области, а ')) AADD(aHelp, L('также оценить эффективность различных стат.моделей и моделей знаний и интегральных критериев для выявления и ')) AADD(aHelp, L('исследования этой значимой информации, знаний и закономерностей. При увеличении объема обучающей выборки в RND-')) AADD(aHelp, L('модели вероятность верной идентификации стремится к вероятности случайного угадывания, а в реальной модели к ')) AADD(aHelp, L('некоторому пределу, превосходящему вероятность случайного угадывания и характеризующему эффективность модели ')) AADD(aHelp, L('и целесообразность ее применения. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Если при установке данной лабораторной работы уже есть текущее приложение, то оно автоматически исследуется ')) AADD(aHelp, L('и параметры RND-модели определяется в результате этого исследования. Если же приложения отсутствуют, то ото- ')) AADD(aHelp, L('бражается таблица, в которой пользователь может задать количество и характеристики формируемых приложений. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Чтобы исследовать зависимость достоверности RND-модели от объема обучающей выборки (или других параметров) ')) AADD(aHelp, L('необходимо задать: ')) AADD(aHelp, L('- начальные параметры моделей; ')) AADD(aHelp, L('- шаг изменения начальных параметров в итерациях; ')) AADD(aHelp, L('- число циклов (итераций), т.е. число приложений с различными объемами выборки, которые надо создать; ')) AADD(aHelp, L('- кликнуть по кнопке: "Пересчитать параметры"; ')) AADD(aHelp, L('- если все устраивает, то кликнуть по кнопке: "Выход на расчет RND-приложений" и нажать ESC. ')) 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 MODAL TITLE L('Помощь по лабораторной работе 2.09. (C) Система "ЭЙДОС-X++"') RETURN NIL ************************************************************************************************** ********************** FUNCTION RecalcParam() DBGOTO(8);mNumberCycles=FIELDGET(3) FOR pp=1 TO 7 DBGOTO(pp) REPLACE FinalValue WITH InitValue + StepChang * ( mNumberCycles - 1 ) NEXT DBGOTOP() RETURN NIL ******** FUNCTION OutputCalc() PUBLIC mFlagExit := .F. RETURN NIL ************************************************************************************************************** FUNCTION PointChart(Parametr) * Param = "Unif" * Param = "Norm" PRIVATE aAttr // Массив атрибутов отображаемых линий PRIVATE nEvent, mp1, mp2, oXbp // Переменные анализа событий SELECT Inp_data N_Znach = RECCOUNT() // Кол-во значений в графиках PRIVATE aVal[N_Znach] // Массив значений функции PRIVATE aArg[N_Znach] // Массив значений аргумента *** Присвоить массивам параметрически заданные значения отображаемой функции j = 0 DBGOTOP() DO WHILE .NOT. EOF() ++j DO CASE CASE Parametr = "Unif" aVal[j] = FUNCT_TUNI CASE Parametr = "Norm" aVal[j] = FUNCT_TNOR ENDCASE aArg[j] = ARGUMENT DBSKIP(1) ENDDO DO CASE CASE Parametr = "Unif" @0, 0 DCSAY L("ТОЧЕЧНАЯ ДИАГРАММА ЭМПИРИЧЕСКИХ ЗНАЧЕНИЙ СВИП-СИГНАЛА С АДДИТИВНЫМ РАВНОМЕРНЫМ ШУМОМ") FONT ("22.HelveticalBold") SIZE 0 CASE Parametr = "Norm" @0, 0 DCSAY L("ТОЧЕЧНАЯ ДИАГРАММА ЭМПИРИЧЕСКИХ ЗНАЧЕНИЙ СВИП-СИГНАЛА С АДДИТИВНЫМ ГАУССОВСКИМ ШУМОМ") FONT ("22.HelveticalBold") SIZE 0 ENDCASE @ 2,1 DCSTATIC TYPE XBPSTATIC_TYPE_RECESSEDBOX SIZE 148,39 ; // Размер окна для отображения графика OBJECT oStatic; EVAL {|| _PresSpace13(oStatic, N_Znach, aArg, aVal) } DCREAD GUI ; TITLE L("Исследование зашумленных когнитивных функций на примере свип-сигнала"); // Надпись на окне графика FIT ; BUTTONS DCGUI_BUTTON_EXIT RETURN NIL ************************************************* STATIC FUNCTION _PresSpace13( oStatic, N_Znach, aArg, aVal ) LOCAL oPS, oDevice PUBLIC X_MaxW := 1024, Y_MaxW := 768 // Размер графического окна в пикселях 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_DotChart( oPS, N_Znach, aArg, aVal ) } RETURN NIL ******************************************************* STATIC FUNCTION LC_DotChart(oPS, N_Znach, aArg, aVal ) ****** Поиск макс и мин значений функции Y_MinF = +99999999 // Минимальное значение Y отображаемой функции Y_MaxF = -99999999 // Максимальное значение Y отображаемой функции FOR x=1 TO LEN(aVal) Y_MinF = MIN(Y_MinF, aVal[x]) Y_MaxF = MAX(Y_MaxF, aVal[x]) NEXT ****** Поиск макс и мин значений аргумента aArgUniq := {} // Уникальные значения аргумента X_MinA = +99999999 // Минимальное значение Y отображаемой функции X_MaxA = -99999999 // Максимальное значение Y отображаемой функции FOR x=1 TO LEN(aArg) X_MinA = MIN(X_MinA, aArg[x]) X_MaxA = MAX(X_MaxA, aArg[x]) IF ASCAN(aArgUniq, aArg[x]) = 0 AADD (aArgUniq, aArg[x]) ENDIF NEXT N_aArgUniq = LEN(aArgUniq) // Кол-во уникальных значений аргумента PRIVATE X0 := 75 PRIVATE Y0 := 165 // Начало координат по осям X и Y с учетом места для легенды PRIVATE W_Wind := X_MaxW - X0 // Ширина окна для самого графика PRIVATE H_Wind := Y_MaxW - Y0 // Высота окна для самого графика PRIVATE NX := 10, NY := 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 ***** Закрасить фон прямоугольника *************** 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 = LEN(aArgUniq)/NX // Диапазон значений x, через которое ставить метку GraSetColor( oPS, aColor[99], aColor[99] ) FOR x=1 TO LEN(aArgUniq) STEP 2*DX GraBox( oPS, { X0 + x*Kx, Y0 }, { X0 + (x+DX)*Kx, Y0 + H_Wind }, GRA_FILL ) NEXT GraSetColor( oPS, aColor[222], aColor[222] ) *** Сделать сетку и надписать метки на оси X ********************* DX = LEN(aArgUniq) /NX // Диапазон значений x, через которое ставить метку FOR j=1 TO LEN(aArgUniq) STEP DX x = aArgUniq[j] nX := X0 + x*Kx GraMarker ( oPS, { nX, Y0 } ) GraStringAt( oPS, { nX, Y0-25 }, ALLTRIM(STR(x,19,1)) ) GraLine( oPS, { nX, Y0 }, {nX, Y0+H_Wind} ) // Нарисовать пунктирную линию уровня x NEXT x = aArgUniq[N_aArgUniq] nX := X0 + x*Kx GraMarker ( oPS, { nX, Y0 } ) GraStringAt( oPS, { nX, Y0-25 }, ALLTRIM(STR(x,19,1)) ) GraLine( oPS, { nX, Y0 }, {nX, Y0+H_Wind} ) // Нарисовать пунктирную линию уровня x *** Сделать сетку и надписать метки на оси Y ********************* DY = (Y_MaxF-Y_MinF+1)/NY // Диапазон значений y, через которое ставить метку FOR y = Y_MinF TO Y_MaxF STEP DY nY := Y0A + y*Ky GraMarker ( oPS, { X0 , nY } ) GraStringAt( oPS, { X0-45, nY }, ALLTRIM(STR(y,19,3)) ) GraLine( oPS, { X0 , nY }, {X0+W_Wind, nY} ) // Нарисовать пунктирную линию уровня y NEXT nY := Y0A + Y_MaxF*Ky GraMarker ( oPS, { X0 , nY } ) GraStringAt( oPS, { X0-45, nY }, ALLTRIM(STR(y,19,3)) ) GraLine( oPS, { X0 , nY }, {X0+W_Wind, nY} ) // Нарисовать пунктирную линию уровня y ***** Рисование маркеров *************************************************** aAttr := Array( GRA_AM_COUNT ) // Создать массив атрибутов aAttr[ GRA_AM_COLOR ] := aColor[17] // Задать цвет маркера aAttr[ GRA_AM_SYMBOL ] := GRA_MARKSYM_DOT // Задать стиль маркера GraSetAttrMarker( oPS, aAttr ) // Установить атрибуты FOR j=1 TO LEN(aArg) X := X0 + aArg[j] * Kx Y := Y0A + aVal[j] * Ky GraMarker( oPS, { X, Y } ) NEXT ***** Нарисовать оси координат ********************************** 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 = -60 // Смщение вниз относительно нуля 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 - 15 ***** Закрасить фон прямоугольника *************** GraSetColor( oPS, aColor[129] , aColor[129] ) GraBox( oPS, { X1, Y1 }, { X2, Y2 }, GRA_FILL) GraSetColor( oPS, aColor[222] , aColor[222] ) GraLine( oPS, {X1, Y1 }, {X2, Y1 } ) // Нарисовать ось X GraLine( oPS, {X1, Y1 }, {X1, Y2 } ) // Нарисовать ось Y GraLine( oPS, {X1, Y2 }, {X2, Y2 } ) // Нарисовать границу рамки изображения вверху параллельно оси X GraLine( oPS, {X2, Y1 }, {X2, Y2 } ) // Нарисовать границу рамки изображения справа параллельно оси Y ***** сделать надписи значений параметров aAttr[ GRA_AL_COLOR ] := aColor[17] // Задать цвет линии aAttr[ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты * aParLW15[ 1] = Arg_MinV // Начальное значение аргумента * aParLW15[ 2] = Arg_MaxV // Конечное значение аргумента * aParLW15[ 3] = Arg_Delta // Шаг изменения аргумента X1 := X0 + 20 Y1 := Y0 + Offset - Interval X2 := X1 + 190 Y2 := Y0 + Offset - 1 * Interval GraStringAt( oPS, { X1, Y2-4 }, "Начальное значение аргумента:") GraStringAt( oPS, { X2, Y2-4 }, ALLTRIM(STR(Arg_MinV,15))) Y2 := Y0 + Offset - 2 * Interval GraStringAt( oPS, { X1, Y2-4 }, "Конечное значение аргумента:") GraStringAt( oPS, { X2, Y2-4 }, ALLTRIM(STR(Arg_MaxV,15))) Y2 := Y0 + Offset - 3 * Interval GraStringAt( oPS, { X1, Y2-4 }, "Шаг изменения аргумента:") GraStringAt( oPS, { X2, Y2-4 }, ALLTRIM(STR(Arg_Delta,15,7))) Y2 := Y0 + Offset - 4 * Interval * aParLW13[ 4] = Ampl // Начальная ампилитуда свип-сигнала * aParLW13[ 5] = Chast // Начальная частота свип-сигнала * aParLW13[ 6] = Faza // Фаза свип-сигнала * aParLW13[ 7] = KZat_Ampl // Коэффициент затухания амплитуды * aParLW13[ 8] = KZat_Chast // Коэффициент затухания частоты X1 := X2 + 110 Y1 := Y0 + Offset - Interval X2 := X1 + 220 Y2 := Y0 + Offset - 1 * Interval GraStringAt( oPS, { X1, Y2-4 }, "Начальная ампилитуда свип-сигнала:") GraStringAt( oPS, { X2, Y2-4 }, ALLTRIM(STR(Ampl,15))) Y2 := Y0 + Offset - 2 * Interval GraStringAt( oPS, { X1, Y2-4 }, "Начальная частота свип-сигнала:") GraStringAt( oPS, { X2, Y2-4 }, ALLTRIM(STR(Chast,15))) Y2 := Y0 + Offset - 3 * Interval GraStringAt( oPS, { X1, Y2-4 }, "Фаза свип-сигнала:") GraStringAt( oPS, { X2, Y2-4 }, ALLTRIM(STR(Faza,15))) Y2 := Y0 + Offset - 4 * Interval GraStringAt( oPS, { X1, Y2-4 }, "Коэффициент затухания амплитуды:") GraStringAt( oPS, { X2, Y2-4 }, ALLTRIM(STR(KZat_Ampl,15,7))) Y2 := Y0 + Offset - 5 * Interval GraStringAt( oPS, { X1, Y2-4 }, "Коэффициент возрастания частоты:") GraStringAt( oPS, { X2, Y2-4 }, ALLTRIM(STR(KZat_Chast,15,7))) * *** Параметры гауссовского шума * aParLW13[ 9] = Mean // Среднее значение * aParLW13[10] = Sigma // Средне-квадратичное отклонение * aParLW13[11] = N_Izmer // Количество измерений знач.функции X1 := X2 + 100 Y1 := Y0 + Offset - Interval X2 := X1 + 225 Y2 := Y0 + Offset - 1 * Interval GraStringAt( oPS, { X1, Y2-4 }, "Среднее значение шума:") GraStringAt( oPS, { X2, Y2-4 }, ALLTRIM(STR(Mean,15))) Y2 := Y0 + Offset - 2 * Interval GraStringAt( oPS, { X1, Y2-4 }, "Амплитуда шума:") GraStringAt( oPS, { X2, Y2-4 }, ALLTRIM(STR(Sigma,15))) Y2 := Y0 + Offset - 3 * Interval GraStringAt( oPS, { X1, Y2-4 }, "Количество измерений знач.функции:") GraStringAt( oPS, { X2, Y2-4 }, ALLTRIM(STR(N_Izmer,15,7))) ****** Надписи координатных осей ********************************* oFont := XbpFont():new():create("13.ArialBold") GraSetFont( oPS ,oFont ) AxName = "Ось X: Значения аргумента функции" GraStringAt( oPS, { X0+W_Wind/2-8*LEN(AxName)/2, Y0-45 }, AxName ) // Надпись оси Х AyName = "Ось Y: Значения функции" 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 RETURN NIL ************************************************************************************************************** * Для формирования очередного числа последовательности используются различные алгебраические преобразования. * Одним из первых программных ГСЧ является метод средин квадратов, предложенный в 1946 г. Дж. фон Нейманом. * Этот ГСЧ формирует следующий элемент последовательности на основе предыдущего путем возведения его в квадрат * и выделения средних цифр полученного числа. Например, мы хотим получить 10-значное число и предыдущее число * равнялось 5772156649. Возводим его в квадрат и получаем 33317792380594909201; значит, следующим числом будет * 7923805949. Очевидным недостатком этого метода является зацикливание в случае, если очередное число будет * равно нулю. Кроме того, существуют и другие сравнительно короткие циклы. ************************************************************************************************************** ******** Программа генерации случайных чисел по модифицированному алгоритму Дж. фон Неймана ******** с внешним источником энтропии при запуске, в качестве которого используется значение таймера FUNCTION LC_RANDOM(r) r = ABS(VAL(SUBSTR(STR(SIN(DTOR(SQRT(ABS(LOG((1+r)^2))))),23,21),7,9)))/1000000000 DO WHILE r=0 r = ABS(VAL(SUBSTR(STR(SIN(DTOR(SQRT(ABS(LOG((1+r)^2))))),23,21),7,9)))/1000000000 ENDDO RETURN(r) ************************************************************************************************** FUNCTION Help_LW13() aHelp := {} AADD(aHelp, L('Данный режим предназначен для подготовки баз данных, позволяющих ')) AADD(aHelp, L('исследовать зашумленные когнитивные функции на примере затухающего ')) AADD(aHelp, L('свип-сигнала, т.е. гармонического сигнала с изменяющейся частотой. ')) AADD(aHelp, L('Параметры затухания и изменения частоты задаются в диалоге, как и ')) AADD(aHelp, L('характеристики шума. Шум используется гауссовский, т.е. подчиняющийся')) AADD(aHelp, L('нормальному распределению. После выполнения данного режима необходимо')) AADD(aHelp, L('выполнить режим 2.3.2.2 с параметрами "по умолчанию", которые также ')) AADD(aHelp, L('формируются в данном режиме. Затем надо выполнить режимы 3.4 и 4.5. ')) 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 MODAL TITLE L('Помощь по лабораторной работе 2.04.') RETURN NIL ************************************************************************************************** ********************************************************************************************************* ******** Создать новое приложение, скопировать все файлы текущего приложения в новое, сделать его текущим ********************************************************************************************************* FUNCTION Copy_rec1_3() oScr := DC_WaitOn(L('Создано новое приложение и в него копируются файлы текущего приложения. Немного подождите!!!'),,,,,,,,,,,.F.) N_All = ADIR(M_PathAppl + "*.*") PRIVATE aFileNameAll[N_All] ADIR(M_PathAppl + "*.*", aFileNameAll ) // Имена ВСЕХ файлов в папке текущего приложения (без папок) ASORT(aFileNameAll) M_NameAppl = ALLTRIM(M_NameAppl)+L("-копия") // Наименование текущего приложения M_NewAppl = ADD_ZAPPL(M_NameAppl) // Создать новое приложение на основе текущего FOR j=1 TO LEN(aFileNameAll) Name_SS = M_PathAppl + aFileNameAll[j] Name_DD = M_NewAppl + aFileNameAll[j] * LB_Warning(L("Источник: "+Name_SS+", приемник: "+Name_DD) COPY FILE (Name_SS) TO (Name_DD) NEXT IF ApplChange("") // Перейти в папку выбранного приложения или выйти из системы LB_Warning(L("Необходимо задать (выбрать) хотя бы одно текущее приложение !!!")) Running(.F.) RETURN NIL ENDIF DBGOTOP() DC_Impl(oScr) RETURN NIL ******** Удалить папку с БД текущего приложения ******** и запись о нем в БД Appls.dbf ******** Использовать рекурсию ZapDir() FUNCTION Del_Appl() // Найти текущее приложение M_Recno = -1 SELECT Appls DBGOTOP() DO WHILE .NOT. EOF() IF LEN(ALLTRIM(By_default)) > 0 M_Recno = RECNO() M_Name = ALLTRIM(Name_Appl) DELETE EXIT ENDIF DBSKIP(1) ENDDO // Удалить папку с БД удаляемого приложения IF M_Recno > 0 // Текущее приложение найдено ZapDir(STRTRAN(ALLTRIM(Path_Appl),"\System\",""),.T.) LB_Warning(L('Приложение: "'+M_Name+'" успешно удалено!'), L("Сообщение о завершении операции" )) ELSE LB_Warning(L("Ни одно из приложений не задано текущим !")) ENDIF SELECT Appls PACK RETURN NIL ****************************************************************************************************** ******** Удалить все приложения и информацию о них в текущей папке системы ******** 1. Найти в папке AID_DATA текущей папки системы все дирректории с именами: "A0*" и удалить их ******** 2. Пересоздать БД Appls.dbf ******** Использовать рекурсию ZapDir() ****************************************************************************************************** FUNCTION Zap_Appls() DIRCHANGE(ALLTRIM(Disk_dir)+"\AID_DATA\") PRIVATE aAppls := Directory("A0*.*","D") FOR j=1 TO LEN(aAppls) ZapDir(aAppls[ j, F_NAME ], .T.) NEXT ZapDir("Screenshots", .T.) DIRMAKE("Screenshots") DIRCHANGE(Disk_dir) GenDbfAppls() RETURN NIL ******************************************* ******** Удалить все файле в папке Inp_data ******************************************* FUNCTION Zap_InpData() * DIRCHANGE(ALLTRIM(Disk_dir)+"\AID_DATA\Inp_data\") * N_All = ADIR("*.*") * PRIVATE aFileNameAll[N_All] * ADIR("*.*",aFileNameAll) // Имена ВСЕХ файлов в папке Inp_data * FOR j=1 TO LEN(aFileNameAll) * ERASE(aFileNameAll[j]) * NEXT * DIRCHANGE(Disk_dir) DIRCHANGE(ALLTRIM(Disk_dir)+"\AID_DATA\") ZapDir('Inp_data', .T.);DIRMAKE("Inp_data") ZapDir('Screenshots', .T.);DIRMAKE("Screenshots") DIRCHANGE(Disk_dir) RETURN NIL ************************************************************************************ // Рекурсивное удаление непустой дирректории с непустыми поддиректориями от Auge_Ohr ************************************************************************************ *#include "Directry.ch" *#include "common.ch" *PROCEDURE Main() * ZapDir("C:\WORK\AID_DATA",.T.) *RETURN PROCEDURE ZapDir(cDir,lRecursive) LOCAL aFiles := Directory(cDir+"\"+"*.*","DHS") LOCAL iMax := LEN(aFiles) LOCAL i DEFAULT lRecursive TO .F. FOR i := 1 TO iMax IF aFiles[ i, F_ATTR ] = "D" IF aFiles[ i, F_NAME ] = "." .OR. ; aFiles[ i, F_NAME ] = ".." ELSE ZapDir(cDir+"\"+aFiles[ i, F_NAME],lRecursive) RemoveDir(cDir+"\"+aFiles[ i, F_NAME]) ENDIF ELSE FERASE(cDir+"\"+aFiles[ i, F_NAME]) ENDIF NEXT RemoveDir(cDir) RETURN ************************************************************************************ *********************************************************************************************************** ******** Генерация БД Appls.dbf ************* *********************************************************************************************************** FUNCTION GenDbfAppls() * aSaveGenDbf := DC_DataSave() DIRCHANGE(Disk_dir) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций ********* Создать БД Appls.dbf и ее индексные массивы cFileName := "Appls.dbf" aStructure := { { "Kod_AdmApp", "N", 8, 0 }, ; { "Kod_Appl" , "N", 8, 0 }, ; { "By_default", "C", 1, 0 }, ; { "Name_Appl" , "C",250, 0 }, ; { "Date" , "C", 10, 0 }, ; { "Time" , "C", 8, 0 }, ; { "Path_Appl" , "C",250, 0 } } DbCreate( cFileName, aStructure ) GenNtxAppls() * DC_DataRest( aSaveGenDbf ) RETURN NIL ******** Генерация индексных массивов БД Appls.dbf ************* FUNCTION GenNtxAppls() aSaveGN1 := DC_DataSave() IF .NOT. FILE("Appls.dbf") GenDbfAppls() ENDIF *USE Appls INDEX App_kapl, App_kapp, App_name, App_crea EXCLUSIVE NEW * 1 2 3 4 CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Appls EXCLUSIVE NEW INDEX ON STR(Kod_AdmApp,8) TO App_kapl INDEX ON STR(Kod_appl,8) TO App_kapp INDEX ON Name_appl TO App_name INDEX ON CTOD(Date) TO App_crea CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DC_DataRest( aSaveGN1 ) RETURN NIL ******** Генерация БД Users.dbf ************* FUNCTION GenDbfUsers() aSaveGenDbf := DC_DataSave() DIRCHANGE(Disk_dir) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций ********* Создать БД Users.dbf и ее индексные массивы cFileName := "Users.dbf" aStructure := { { "Kod_AdmApp", "N", 8, 0 }, ; { "Name_AdmAp", "C", 35, 0 }, ; { "Login_AdmA", "C", 10, 0 }, ; { "Passw_AdmA", "C", 10, 0 }, ; { "Passw_User", "C", 10, 0 }, ; { "ColorSchem", "C", 23, 0 }, ; { "Date" , "C", 10, 0 }, ; { "Time" , "C", 8, 0 } } DbCreate( cFileName, aStructure ) GenNtxUsers() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Users INDEX Use_kod, Use_name, Use_LPAA, Use_LPus, Use_dreg EXCLUSIVE NEW * 1 2 3 4 5 Zap_db1_2() DC_DataRest( aSaveGenDbf ) RETURN NIL ******** Генерация индексных массивов БД Users.dbf ************* FUNCTION GenNtxUsers() *aSaveGN2 := DC_DataSave() IF .NOT. FILE("Users.dbf") RETURN NIL ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций *USE Users INDEX Use_kod, Use_name, Use_LPAA, Use_LPus, Use_dreg EXCLUSIVE NEW * 1 2 3 4 5 CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Users EXCLUSIVE NEW INDEX ON STR(Kod_AdmApp,8) TO Use_kod INDEX ON Name_AdmAp TO Use_name INDEX ON Login_AdmA+Passw_AdmA TO Use_LPAA INDEX ON "USER"+Passw_User TO Use_LPus INDEX ON Date TO Use_dreg CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций *DC_DataRest( aSaveGN2 ) RETURN NIL ******** Генерация БД PathGrAp.dbf ************* FUNCTION GenDbfPaths() aSaveGenDbf := DC_DataSave() DIRCHANGE(Disk_dir) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций ********* Создать БД PathGrAp.dbf и ее индексные массивы cFileName := "PathGrAp" aStructure := { { "Kod_GrApps", "N", 8, 0 }, ; { "By_default", "C", 1, 0 }, ; { "NameGrApps", "C",250, 0 }, ; { "PathGrApps", "C",250, 0 }, ; { "Date" , "C", 10, 0 }, ; { "Time" , "C", 8, 0 } } DbCreate( cFileName, aStructure ) GenNtxPaths() M_ApplsPath := ALLTRIM(Disk_dir)+"\AID_DATA" CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * USE PathGrAp INDEX Path_kod, PathDefa, PathName, PathCrea EXCLUSIVE NEW * * 1 2 3 4 USE PathGrAp EXCLUSIVE NEW APPEND BLANK REPLACE Kod_GrApps WITH 1 REPLACE By_default WITH "W" REPLACE NameGrApps WITH "Базовая группа приложений (по умолчанию)" REPLACE PathGrApps WITH M_ApplsPath REPLACE Date WITH DTOC(DATE()) REPLACE Time WITH TIME() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DC_DataRest( aSaveGenDbf ) RETURN(M_ApplsPath) ******** Генерация индексных массивов БД Paths.dbf ************* FUNCTION GenNtxPaths() aSaveGN3 := DC_DataSave() IF .NOT. FILE("PathGrAp.dbf") GenDbfPaths() ENDIF *USE PathGrAp INDEX Path_kod, PathDefa, PathName, PathCrea EXCLUSIVE NEW * 1 2 3 4 CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE PathGrAp EXCLUSIVE NEW INDEX ON STR(Kod_GrApps,8) TO Path_kod INDEX ON By_default TO PathDefa INDEX ON NameGrApps TO PathName INDEX ON CTOD(Date) TO PathCrea CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DC_DataRest( aSaveGN3 ) RETURN NIL ******** Генерация БД Classes.dbf ************* FUNCTION GenDbfClass(mUpDate) aSaveGenDbf2 := DC_DataSave() * Flag = .F. * IF .NOT. FILE("Classes.dbf") * Flag = .T. * ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций cFileName := "Classes.dbf" IF .NOT. FILE(cFileName) mUpDate = .F. ENDIF aStructure := { { "Kod_cls" , "N", 15, 0 }, ; // Код класса, т.е. градации классификационной шкалы { "Name_cls" , "C",250, 0 }, ; // Наименование класса, т.е. классификационной шкалы+"-"+градации классификационной шкалы { "Kod_ClSc" , "N", 15, 0 }, ; // Код классификационной шкалы { "N_ChrClSc", "N", 3, 0 }, ; // Количество символов в наименовании классификационной шкалы { "Min_GrInt", "N", 19, 7 }, ; // Минимальная граница интервала (значение) { "Max_GrInt", "N", 19, 7 }, ; // Максимальная граница интервала (значение) { "Avr_GrInt", "N", 19, 7 }, ; // Среднее значение интервала { "Int_inf" , "N", 19, 7 }, ; { "Sum_ii" , "N", 19, 7 }, ; { "Sii_perc" , "N", 19, 7 }, ; { "Rang" , "N", 15, 0 }, ; { "Abs" , "N", 15, 0 }, ; { "Perc_fiz" , "N", 19, 7 }, ; { "Universal", "N", 19, 7 }, ; { "Date" , "C", 10, 0 }, ; { "Time" , "C", 8, 0 } } IF mUpdate DC_DBFILE( DC_SETDCLIP(),cFileName, ,,,'DBFNTX',, aStructure) ELSE DbCreate( cFileName, aStructure ) ENDIF GenNtxClass() // Если БД Classes вообще нет, то создать ее (эта БД есть всегда) * IF Flag CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Class_Sc EXCLUSIVE NEW USE Gr_ClSc EXCLUSIVE NEW USE Classes EXCLUSIVE NEW;ZAP SELECT Gr_ClSc DBGOTOP() cScrn := DC_WaitOn(L('Пересоздание базы данных классификационных шкал и градаций: "Classes.dbf"'),,,,,,,,,,,.F.) DO WHILE .NOT. EOF() mKodClSc = Kod_ClSc mKodGrCS = Kod_GrCS mNameGrCS = DelZeroNameGr(Name_GrCS) SELECT Classes DBGOTO(mKodGrCS) mIntInf = Int_Inf mAbs = Abs mPercFiz = Perc_fiz SELECT Class_Sc DBGOTO(mKodClSc) mNameClSc = Name_ClSc REPLACE Int_Inf WITH mIntInf REPLACE Abs WITH mAbs REPLACE Perc_fiz WITH mPercFiz // Если в названии градации уже включено наим.шкалы, то повторно не включать его IF AT(mNameClSc, UPPER(mNameGrCS)) = 0 mName = UPPER(ALLTRIM(mNameClSc))+"-"+ALLTRIM(mNameGrCS) ELSE mName = mNameGrCS ENDIF SELECT Classes APPEND BLANK REPLACE Kod_cls WITH mKodGrCS REPLACE Name_cls WITH mName REPLACE Kod_ClSc WITH mKodClSc // Код класс.шкалы REPLACE N_ChrClSC WITH LEN(ALLTRIM(mNameClSc)) // Кол-во символов в наим.класс.шкалы SELECT Gr_ClSc DBSKIP(1) ENDDO CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Class_Sc EXCLUSIVE NEW USE Gr_ClSc EXCLUSIVE NEW USE Classes EXCLUSIVE NEW MinMaxGrClSc() DC_Impl(cScrn) * ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DC_DataRest( aSaveGenDbf2 ) RETURN NIL ******** Генерация индексных массивов БД Classes.dbf ************* FUNCTION GenNtxClass() IF .NOT. FILE("Classes.dbf") GenDbfClass(.F.) ENDIF *USE Classes INDEX Cls_kod, Cls_name, Cls_ini, Cls_abs EXCLUSIVE NEW CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW INDEX ON STR(Kod_cls,19) TO Cls_kod INDEX ON Name_cls TO Cls_name INDEX ON STR(99999999.9999999-Int_Inf,19, 7) TO Cls_ini INDEX ON STR(Abs,19) TO Cls_abs CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций RETURN NIL ******** Генерация БД Attributes.dbf ************* FUNCTION GenDbfAttr(mUpDate) aSaveGenDbf := DC_DataSave() // Если БД Attributes вообще нет, то создать ее * Flag = .F. * IF .NOT. FILE("Attributes.dbf") Flag = .T. * ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций cFileName := "Attributes.dbf" IF .NOT. FILE(cFileName) mUpDate = .F. ENDIF aStructure := { { "Kod_atr" , "N", 15, 0 }, ; // Код признака, т.е. градации описательной шкалы { "Name_atr" , "C",250, 0 }, ; // Наименование признака, т.е. описательной шкалы+"-"+градации описательной шкалы { "Kod_OpSc" , "N", 15, 0 }, ; // Код описательной шкалы { "N_ChrOpSc", "N", 3, 0 }, ; // Количество символов в наименовании описательной шкалы { "Min_GrInt", "N", 19, 7 }, ; // Минимальная граница интервала (значение) { "Max_GrInt", "N", 19, 7 }, ; // Максимальная граница интервала (значение) { "Avr_GrInt", "N", 19, 7 }, ; // Среднее значение интервала { "Int_inf" , "N", 19, 7 }, ; { "Sum_ii" , "N", 19, 7 }, ; { "Sii_perc" , "N", 19, 7 }, ; { "Rang" , "N", 15, 0 }, ; { "Abs" , "N", 15, 0 }, ; { "Perc_fiz" , "N", 19, 7 }, ; { "Universal", "N", 19, 7 }, ; { "Date" , "C", 10, 0 }, ; { "Time" , "C", 8, 0 } } IF mUpdate DC_DBFILE( DC_SETDCLIP(),cFileName, ,,,'DBFNTX',, aStructure) ELSE DbCreate( cFileName, aStructure ) ENDIF GenNtxAttr() // Создать БД Attributes * IF Flag **************************************************************************************************** *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 **************************************************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Opis_Sc EXCLUSIVE NEW USE Gr_OpSc EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW;ZAP SELECT Gr_OpSc DBGOTOP() cScrn := DC_WaitOn(L('Пересоздание базы данных описательных шкал и градаций: "Attributes.dbf"'),,,,,,,,,,,.F.) DO WHILE .NOT. EOF() mKodOpSc = Kod_OpSc mKodGrOS = Kod_GrOS mNameGrOS = Name_GrOS mIntInf = Int_Inf mAbs = Abs mPercFiz = Perc_fiz SELECT Opis_Sc DBGOTO(mKodOpSc) mNameOpSc = Name_OpSc // Если в названии градации уже включено наим.шкалы, то повторно не включать его IF AT(mNameOpSc, UPPER(mNameGrOS)) = 0 mName = UPPER(ALLTRIM(mNameOpSc))+"-"+ALLTRIM(mNameGrOS) ELSE mName = mNameGrOS ENDIF SELECT Attributes APPEND BLANK REPLACE Kod_atr WITH mKodGrOS REPLACE Name_atr WITH mName REPLACE Kod_OpSc WITH mKodOpSc // Код опис.шкалы REPLACE N_ChrOpSC WITH LEN(ALLTRIM(mNameOpSc)) // Кол-во символов в наим.опис.шкалы REPLACE Int_Inf WITH mIntInf REPLACE Abs WITH mAbs REPLACE Perc_fiz WITH mPercFiz SELECT Gr_OpSc DBSKIP(1) ENDDO CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Opis_Sc EXCLUSIVE NEW USE Gr_OpSc EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW MinMaxGrOpSc() // <<<===################################################## DC_Impl(cScrn) * ENDIF * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DC_DataRest( aSaveGenDbf ) RETURN NIL ******** Генерация индексных массивов БД Attributes.dbf ************* FUNCTION GenNtxAttr() aSaveGN4 := DC_DataSave() IF .NOT. FILE("Attributes.dbf") GenDbfAttr(.F.) ENDIF *USE Attributes INDEX Atr_kod, Atr_name, Atr_ini, Atr_abs EXCLUSIVE NEW CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Attributes EXCLUSIVE NEW INDEX ON STR(Kod_atr,19) TO Atr_kod INDEX ON Name_atr TO Atr_name INDEX ON STR(99999999.9999999-Int_Inf,19, 7) TO Atr_ini INDEX ON STR(Abs,19) TO Atr_abs CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DC_DataRest( aSaveGN4 ) RETURN NIL ***************************************************************** ******** Перейти в папку выбранного приложения ******** Номер запускаемого режима, вида: mRegimOpen= "2.3.2.2()" ***************************************************************** FUNCTION ApplChange(mOpenFunct) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** * CloseAllWindows() // Закрыть все окна CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы mApplsPath = STRTRAN(M_ApplsPath,"\AID_DATA","") // Папка, на которую в БД прописан путь, как на папку с базами данных приложений mDiskDir = DISKNAME()+":\"+CURDIR() // Папка, в которой фактически находится система IF .NOT. FILE("PathGrAp.DBF") GenDbfPaths() ENDIF IF .NOT. FILE("Users.DBF") GenDbfUsers() ENDIF IF .NOT. FILE("Appls.DBF") GenDbfAppls() ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE PathGrAp EXCLUSIVE NEW;N_GrAp = RECCOUNT() USE Appls EXCLUSIVE NEW;N_Appls = RECCOUNT() USE Users EXCLUSIVE NEW;N_Users = RECCOUNT() * LB_Warning(CURDIR());LB_Warning(STR(N_Appls,19)) * MsgBox(STR(N_GrAp)) 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 // Если не сисадмин, то сделать фильтрацию по приложениям авторизованного администратора приложения // или администратора приложения, пароль для пользователей которого задан пользователем // Flag_SysAdmin := .F., M_KodSysAdmin := 0 // Flag_AdmAppl := .F., M_KodAdmAppls := 0 // Flag_User := .F., M_KodAdmAppls := 0 IF Flag_AdmAppl = .T. .OR. Flag_User = .T. SET FILTER TO M_KodAdmAppls = Kod_AdmApp * DBGOTOP();DBGOBOTTOM();DBGOTOP() ENDIF 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 IF LEN(ALLTRIM(M_PathAppl)) = 0 SELECT Users DBGOTOP() DO WHILE .NOT. EOF() IF M_KodAdmAppls = Kod_AdmApp M_NameAdmAppl = UPPER(ALLTRIM(Name_AdmAp)) EXIT ENDIF DBSKIP(1) ENDDO Mess = L("В диспетчере приложений 1.3 [#] не задал путь на текущее приложение!!!") Mess = STRTRAN(Mess, "#", M_NameAdmAppl) LB_Warning(Mess) Running(.F.) RETURN(.T.) ENDIF DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы // Записать M_NameAppl на диск * M_NameAppl = DC_ARestore("_NameAppl.arx") DC_ASave(M_NameAppl, "_NameAppl.arx") // Записать M_PathAppl на диск * M_PathAppl = DC_ARestore("_PathAppl.arx") DC_ASave(M_PathAppl, "_PathAppl.arx") DIRCHANGE(M_PathAppl) // Записать M_NameAppl на диск * M_NameAppl = DC_ARestore("_NameAppl.arx") DC_ASave(M_NameAppl, "_NameAppl.arx") // Записать M_PathAppl на диск * M_PathAppl = DC_ARestore("_PathAppl.arx") DC_ASave(M_PathAppl, "_PathAppl.arx") ************ Формирование минимального и максимального кодов градаций классификационных и описательных шкал * MinMaxGrClSc() * MinMaxGrOpSc() RETURN(.F.) *********************************************************************************************************** ******** 2.2. Описательные шкалы и градации (xdemo.exe, FUNCTION XSample_130(): sample 4, OneToMany2) *********************************************************************************************************** FUNCTION F2_2() LOCAL GetList := {}, GetOptions, oBrowUser, oBrowApp, bApp, bItems Running(.T.) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF ApplChange("2.2()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF IF FILE("_CurrInf.arx") // Файл с информацией о том, какая модель задана текущей M_CurrInf = DC_ARestore("_CurrInf.arx") ELSE DC_ASave(M_CurrInf, "_CurrInf.arx") ENDIF IF FILE("Opis_Sc.dbf") // БД описательных шкал ** Переиндексировать БД Opis_Sc.dbf, ** если не хватает хотя бы одного какого-нибудь индексного массива IF .NOT. FILE("Ops_kod.ntx" ).OR.; .NOT. FILE("Ops_name.ntx").OR.; .NOT. FILE("Ops_ini.ntx" ).OR.; .NOT. FILE("Ops_abs.ntx" ) GenNtxOpSc() ENDIF ELSE GenDbfOpSc(.F.) ENDIF IF FILE("Gr_OpSc.dbf") // БД градаций описательных шкал ** Переиндексировать БД Gr_OpSc.dbf, ** если не хватает хотя бы одного какого-нибудь индексного массива IF .NOT. FILE("Gos_kod.ntx" ).OR.; .NOT. FILE("Gos_name.ntx").OR.; .NOT. FILE("Gos_ini.ntx" ).OR.; .NOT. FILE("Gos_abs.ntx" ) GenNtxGrOpSc() ENDIF ELSE GenDbfGrOpSc(.F.) ENDIF ********** Проверка числа полей в БД Opis_Sc.dbf и приведение к новому числу полей старых БД *** aStructure := { { "KOD_OpSc" , "N", 15, 0 }, ; // 1 { "NAME_OpSc" , "C",250, 0 }, ; // 2 { "INT_INF" , "N", 19, 7 }, ; // 3 { "SUM_II" , "N", 19, 7 }, ; // 4 { "SII_PERC" , "N", 19, 7 }, ; // 5 { "RANG" , "N", 15, 0 }, ; // 6 { "ABS" , "N", 15, 0 }, ; // 7 { "PERC_FIZ" , "N", 19, 7 }, ; // 8 { "Sum_ZnGr" , "N", 19, 7 }, ; // 9 { "N_GrOpSc" , "N", 15, 0 }, ; // 10 { "KodGr_min" , "N", 15, 0 }, ; // 11 Минимальный код градаций описательной шкалы { "KodGr_max" , "N", 15, 0 }, ; // 12 Максимальный код градаций описательной шкалы { "N_combinat", "N", 15, 0 }, ; // 13 Число комбинаций различных сочетаний значений факторов { "Date" , "C", 10, 0 }, ; // 14 { "Time" , "C", 8, 0 } } // 15 CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Opis_Sc EXCLUSIVE NEW SELECT Opis_Sc IF .NOT. DC_IsStru( aStructure ) *IF FCOUNT() = 14 // Если БД Opis_Sc старая (в новой 15 полей) oScr := DC_WaitOn(L('БД Opis_Sc.dbf приводится в соответствие с новой структурой. Немного подождите!!!'),,,,,,,,,,,.F.) DC_StruUpdate( aStructure ) // Обновить структуру БД с сохранением данных DC_Impl(oScr) ENDIF ************************************************************************************************ dbeSetDefault('DBFNTX') ********** Среда 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 /* ----- Create ToolBar 2 ----- */ *@ 27.5, 1 DCTOOLBAR oToolBar SIZE 130, 1.5 @ 29.5, 1 DCTOOLBAR oToolBar SIZE 150, 1.5 DCADDBUTTON CAPTION L('Помощь') ; SIZE LEN(L("Помощь"))+2 ; ACTION {||Help22(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Помощь по режиму 2.2') ** Функции, доступные только сисадмину и администратору приложения IF Flag_SysAdmin .OR. Flag_AdmAppl DCADDBUTTON CAPTION L('Доб.шкалу') ; SIZE LEN(L("Доб.шкалу"))+1 ; ACTION {||Add_rec2_2s(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Добавить шкалу') DCADDBUTTON CAPTION L('Доб.град.шкалы') ; SIZE LEN(L("Доб.град.шкалы")) ; ACTION {||Add_rec2_2g(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Добавить градацию шкалы') DCADDBUTTON CAPTION L('Копир.шкалу') ; SIZE LEN(L("Копир.шкалу")) ; ACTION {||Copy_rec2_2s(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Копировать шкалу') DCADDBUTTON CAPTION L('Копир.град.шкалы') ; SIZE LEN(L("Копир.град.шкалы"))-1 ; ACTION {||Copy_rec2_2g(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Копировать градацию шкалы') DCADDBUTTON CAPTION L('Копир.шкалу с град.') ; SIZE LEN(L("Копир.шкалу с град."))-3 ; ACTION {||Copy_rec2_2s(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Копир.шкалу с град.') DCADDBUTTON CAPTION L('Удал.шкалу с град.') ; SIZE LEN(L("Удал.шкалу с град."))-3 ; ACTION {||Del_rec2_2s(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Удалалить шкалу с градациями') DCADDBUTTON CAPTION L('Удал.град.шкалы') ; SIZE LEN(L("Удал.град.шкалы"))-1 ; ACTION {||Del_rec2_2g(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Удалить градацию шкалы') DCADDBUTTON CAPTION L('Перекодировать') ; SIZE LEN(L("Перекодировать")) ; ACTION {||Recode2_2sg(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Перекодировать') DCADDBUTTON CAPTION L('Очистить') ; SIZE LEN(L("Очистить"))+1 ; ACTION {||Zap_2_2sg(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Очистить базу данных') DCADDBUTTON CAPTION L('Графики прошлых сценариев') ; SIZE LEN(L("Графики прошлых сценариев"))-1 ; ACTION {||DrawScenarios('Atr'), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Отображение и запись в виде файлов графиков прошлых сценариев (сценариев значений факторов)') ENDIF /* ----- Create browse-1 ----- */ bScale := {|| Gr_OpSc->(DC_SetScope(0,Opis_Sc->KOD_OpSc)), ; Gr_OpSc->(DC_SetScope(1,Opis_Sc->KOD_OpSc)), ; Gr_OpSc->(DC_DbGoTop()), ; oBrowGrSc:refreshAll() } *@1, 0 DCBROWSE oBrowScale ALIAS 'Opis_Sc' SIZE 48,26 ; @1, 0 DCBROWSE oBrowScale ALIAS 'Opis_Sc' SIZE 58,28 ; EDIT xbeBRW_ItemSelected MODE DCGUI_BROWSE_EDITDOWN ; // Редактирование БД Opis_Sc NOSOFTTRACK ; SCOPE ; ITEMMARKED {|| Eval(bScale), ; DC_GetRefresh(GetList,, ; DCGETREFRESH_TYPE_EXCLUDE,{GETLIST_BROWSE}) } DCSETPARENT oBrowScale DCBROWSECOL FIELD Opis_Sc->KOD_OpSc HEADER L('Код шкалы' ) WIDTH 1 PROTECT {|| .T. } DCBROWSECOL FIELD Opis_Sc->NAME_OpSc HEADER L('Наименование описательной шкалы') WIDTH 28 DCBROWSECOL FIELD Opis_Sc->INT_INF HEADER L('Информативность' ) WIDTH 1 /* ----- Create browse-2 ----- */ DCSETPARENT TO *@ 1,50 DCBROWSE oBrowGrSc ALIAS 'Gr_OpSc' SIZE 82,26 ; @ 1,60 DCBROWSE oBrowGrSc ALIAS 'Gr_OpSc' SIZE 92,28 ; EDIT xbeBRW_ItemSelected MODE DCGUI_BROWSE_EDITDOWN ; NOSOFTTRACK ; SCOPE ; ITEMMARKED bItems; COLOR {||IIF(2*INT(Gr_OpSc->KOD_GrOS/2)==Gr_OpSc->KOD_GrOS,nil,{nil,GraMakeRGBColor({230,252,213})})} // Вывод строки цветом RGB ********************* * 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)) ********************* * mPosR1 = AT('{', Gr_OpSc->NAME_GrOS)+1 * mPosR2 = AT('{', Gr_OpSc->NAME_GrOS)+3 * mPosG1 = AT('{', Gr_OpSc->NAME_GrOS)+5 * mPosG2 = AT('{', Gr_OpSc->NAME_GrOS)+7 * mPosB1 = AT('{', Gr_OpSc->NAME_GrOS)+9 * mPosB2 = AT('{', Gr_OpSc->NAME_GrOS)+11 * mRed = VAL(SUBSTR(Gr_OpSc->NAME_GrOS, AT('{', Gr_OpSc->NAME_GrOS)+1, AT('{', Gr_OpSc->NAME_GrOS)+ 3-AT('{', Gr_OpSc->NAME_GrOS)+1+1)) * mGreen = VAL(SUBSTR(Gr_OpSc->NAME_GrOS, AT('{', Gr_OpSc->NAME_GrOS)+5, AT('{', Gr_OpSc->NAME_GrOS)+ 7-AT('{', Gr_OpSc->NAME_GrOS)+5+1)) * mBlue = VAL(SUBSTR(Gr_OpSc->NAME_GrOS, AT('{', Gr_OpSc->NAME_GrOS)+9, AT('{', Gr_OpSc->NAME_GrOS)+11-AT('{', Gr_OpSc->NAME_GrOS)+9+1)) ********************* DCSETPARENT oBrowGrSc DCBROWSECOL FIELD Gr_OpSc->KOD_GrOS HEADER L('Код градации' ) WIDTH 1 PROTECT {|| .T. }; COLOR {||IIF(AT('SPECTRINTERV:',Opis_Sc->NAME_OpSc)=0,nil,{nil,GraMakeRGBColor({VAL(SUBSTR(Gr_OpSc->NAME_GrOS, AT('{', Gr_OpSc->NAME_GrOS)+1, AT('{', Gr_OpSc->NAME_GrOS)+ 3-AT('{', Gr_OpSc->NAME_GrOS)+1+1)),VAL(SUBSTR(Gr_OpSc->NAME_GrOS, AT('{', Gr_OpSc->NAME_GrOS)+5, AT('{', Gr_OpSc->NAME_GrOS)+ 7-AT('{', Gr_OpSc->NAME_GrOS)+5+1)),VAL(SUBSTR(Gr_OpSc->NAME_GrOS, AT('{', Gr_OpSc->NAME_GrOS)+9, AT('{', Gr_OpSc->NAME_GrOS)+11-AT('{', Gr_OpSc->NAME_GrOS)+9+1))})})} // Вывод поля цветом RGB DCBROWSECOL FIELD Gr_OpSc->NAME_GrOS HEADER L('Наименование градации описательной шкалы') WIDTH 48.5 DCBROWSECOL FIELD Gr_OpSc->INT_INF HEADER L('Информативность' ) WIDTH 1 DCBROWSECOL FIELD Gr_OpSc->ABS HEADER L('N объектов об.выб.(абс)' ) WIDTH 3 DCBROWSECOL FIELD Gr_OpSc->PERC_FIZ HEADER L('N объектов об.выб.(%)' ) WIDTH 3 DCGETOPTIONS SAYFONT '10.Helv Bold' TABSTOP AUTORESIZE cTitle = L('2.2. Описательные шкалы и градации. Текущая модель: "')+UPPER(Ar_Model[M_CurrInf])+'"' DCREAD GUI ; FIT ; OPTIONS GetOptions ; MODAL ; TITLE cTitle ; EVAL {|o|SetAppFocus(oBrowScale:GetColumn(1))} GenDbfAttr(.F.) // Пересоздать БД описательных шкал и градаций ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ****** END OF EXAMPLE *********************** ************************************************************************************************** FUNCTION Help22() aHelp22 := DC_DataSave() // Сохранение вычислительной среды (открытые и текущие БД и индексы) *DC_DataRest( aHelp22 ) // Восстановление вычислительной среды (открытые и текущие БД и индексы) *SELECT Opis_sc Opis_sc->(DBGOTOP()) REPLACE Opis_sc->N_COMBINAT WITH Opis_sc->N_GROPSC mNCombinat = Opis_sc->N_COMBINAT mNCombinatOld = mNCombinat mFlagError = .F. Opis_sc->(DBSKIP(1)) DO WHILE .NOT. Opis_sc->(EOF()) bError := ErrorBlock( {|e| Break(e)} ) // установить новый кодовый блок обработки ошибок BEGIN SEQUENCE REPLACE Opis_sc->N_COMBINAT WITH Opis_sc->N_GROPSC * mNCombinat mNCombinat = Opis_sc->N_COMBINAT mNCombinatOld = mNCombinat RECOVER mFlagError = .T. EXIT // код обработки ошибок ENDSEQUENCE ErrorBlock( bError ) // переустановить старый кодовый блок Opis_sc->(DBSKIP(1)) ENDDO aHelp := {} AADD(aHelp, L('Режим: "2.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('- [Очистить]: удалить все описательные шкалы и градации. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Текущей является шкала или градация, на которой установлен курсор. ')) AADD(aHelp, L(' ')) IF mNCombinatOld > 0 mNCombinat = mNCombinatOld mDay = mNCombinat/(24*60*60) mYear = mDay/365.24219878 IF mFlagError AADD(aHelp, L('Количество сочетаний значений всех факторов >')+' '+ALLTRIM(STR(mNCombinat))+L('. Если при принятии решений')) AADD(aHelp, L('путем многовариантного прогнозирования на один прогноз результатов действия некоторого ')) AADD(aHelp, L('сочетания значений факторов тратить 1 секунду, то на все прогнозирование уйдет >')+' '+ALLTRIM(STR(mYear,19))+' '+L('лет.')) ELSE AADD(aHelp, L('Количество сочетаний значений всех факторов =')+' '+ALLTRIM(STR(mNCombinat))+L('. Если при принятии решений')) AADD(aHelp, L('путем многовариантного прогнозирования на один прогноз результатов действия некоторого ')) IF mDay < 365.24219878 AADD(aHelp, L('сочетания значений факторов тратить 1 секунду, то на все прогнозирование уйдет =')+' '+ALLTRIM(STR(mDay, 19,2))+' '+L('дней.')) ELSE AADD(aHelp, L('сочетания значений факторов тратить 1 секунду, то на все прогнозирование уйдет =')+' '+ALLTRIM(STR(mYear,19,2))+' '+L('лет.')) ENDIF ENDIF ENDIF mHelpMax = -999;FOR h=1 TO LEN(aHelp);mHelpMax = MAX(mHelpMax, LEN(ALLTRIM(aHelp[h])));NEXT @0,0 DCGROUP oGroup1 CAPTION L(' ') SIZE mHelpMax-15, LEN(aHelp)-0.5 s=1;d=0.9;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++"') *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 *SELECT Opis_Sc *aHelp22 := DC_DataSave() // Сохранение вычислительной среды (открытые и текущие БД и индексы) DC_DataRest( aHelp22 ) // Восстановление вычислительной среды (открытые и текущие БД и индексы) RETURN NIL ************************************************************************************************** ******** Сортировка по заданному столбцу в режиме 1.3. (xdemo.exe FUNCTION XDemo_4 ( oDialog, lMDI, lGui )) FUNCTION Sort2_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_REC2_2s() // Проверить является ли БД Opis_Sc текущей и если нет - выдать сообщение и выйти M_Kod = Kod_OpSc SELECT Opis_Sc DELETE PACK SELECT Gr_OpSc DELETE FOR M_Kod = Kod_OpSc PACK SELECT Opis_Sc RETURN NIL ******** Удалить текущую градацию FUNCTION DEL_REC2_2g() // Проверить является ли БД Gr_OpSc текущей и если нет - выдать сообщение и выйти DELETE PACK RETURN NIL ******** Скопировать описательную шкалу FUNCTION COPY_REC2_2S() SELECT Opis_Sc 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 RECNO() RETURN NIL ******** Скопировать градацию описательной шкалы FUNCTION COPY_REC2_2G() SELECT Gr_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_GrOS WITH RECNO() RETURN NIL ******** Скопировать описательную шкалу со всеми градациями FUNCTION COPY_REC2_2SG() LOCAL Getlist := {}, oProgress, oDialog SELECT Opis_Sc 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 RECNO() M_KodOS_New = Kod_OpSc SELECT Gr_OpSc 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 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() RETURN NIL ******** Добавить шкалу в конец БД FUNCTION Add_rec2_2s() SELECT Opis_Sc APPEND BLANK REPLACE Kod_OpSc WITH RECNO() RETURN NIL ******** Добавить градацию шкалы в конец БД FUNCTION Add_rec2_2g() SELECT Opis_Sc M_KodOpSc = Kod_OpSc SELECT Gr_OpSc APPEND BLANK REPLACE Kod_OpSc WITH M_KodOpSc REPLACE Kod_GrOS WITH RECNO() // Сформировать количество градаций данной шкалы на момент добавления записи RETURN NIL ******** Очистить БД FUNCTION ZAP_2_2SG() SELECT Opis_Sc;ZAP SELECT Gr_OpSc;ZAP RETURN NIL ******** Перекодировать БД описательных шкал и градаций, обучающей и распознаваемой выборки FUNCTION RECODE2_2SG() LOCAL Getl := {}, oProgr, oDial aSaveRECODE2_2SG := DC_DataSave() SELECT Gr_OpSc;N_Gos = RECCOUNT() SELECT Obi_Kpr;N_Okp = RECCOUNT() SELECT Rso_Kpr;N_Rkp = RECCOUNT() Mess = L('2.2. Перекодирование описательных шкал и градаций, обуч.и расп.выборки') @ 4,5 DCPROGRESS oProgr SIZE 80,1.1 MAXCOUNT RecCount() COLOR GRA_CLR_BLUE PERCENT EVERY 100 DCREAD GUI TITLE Mess PARENT @oDial FIT EXIT oDial:show() nMax = 3*N_Gos+N_Okp+N_Rkp nTime = 0 SELECT Gr_OpSc INDEX ON STR(Kod_OpSc,19)+STR(Kod_GrOS,19) TO Gos_kos aKodGOS_Old := {} aKodGOS_New := {} M_KodGrOS = 0 DBGOTOP() Flag = .F. DC_GetProgress(oProgr,0,nMax) DO WHILE .NOT. EOF() AADD(aKodGOS_Old, Kod_GrOS) AADD(aKodGOS_New, ++M_KodGrOS) IF Kod_GrOS <> M_KodGrOS Flag = .T. // Необходимо перекодирование ENDIF DC_GetProgress(oProgr, ++nTime, nMax) DBSKIP(1) ENDDO IF .NOT. Flag LB_Warning(L("В перекодировании нет необходимости!"), L("Информационное сообщение" )) ELSE // Перекодирование описательных шкал и градаций и сортировка БД градаций описательных шкал SELECT Gr_OpSc SET ORDER TO DBGOTOP() DO WHILE .NOT. EOF() Pos = ASCAN(aKodGOS_Old, Kod_GrOS) IF Pos > 0 REPLACE Rang WITH aKodGOS_New[Pos] ENDIF DC_GetProgress(oProgr, ++nTime, nMax) DBSKIP(1) ENDDO DbSort( "Temp.dbf", {"Rang" } ) // Физическая сортировка БД по составному ключу SELECT Gr_OpSc USE Temp EXCLUSIVE NEW DBGOTOP() DO WHILE .NOT. EOF() M_Recno = RECNO() M_Rang = Rang M_KodGrOS = Kod_GrOS a := {} FOR j=1 TO FCOUNT() AADD(a, FIELDGET(j)) NEXT SELECT Gr_OpSc DBGOTO(M_Recno) FOR j=1 TO LEN(a) FIELDPUT(j, a[j]) NEXT REPLACE Kod_GrOS WITH M_Rang REPLACE Rang WITH M_KodGrOS DC_GetProgress(oProgr, ++nTime, nMax) SELECT Temp DBSKIP(1) ENDDO CLOSE Temp SELECT Gr_OpSc INDEX ON Kod_OpSc TO Gr_OpSc // Перекодирование обучающей выборки SELECT Obi_Kpr DBGOTOP() DO WHILE .NOT. EOF() FOR j=2 TO FCOUNT() Pos = ASCAN(aKodGOS_Old, FIELDGET(j)) IF Pos > 0 FIELDPUT(j, aKodGOS_New[Pos]) ENDIF NEXT DC_GetProgress(oProgr, ++nTime, nMax) DBSKIP(1) ENDDO // Перекодирование распознаваемой выборки SELECT Rso_Kpr DBGOTOP() DO WHILE .NOT. EOF() FOR j=2 TO FCOUNT() Pos = ASCAN(aKodGOS_Old, FIELDGET(j)) IF Pos > 0 FIELDPUT(j, aKodGOS_New[Pos]) ENDIF NEXT DC_GetProgress(oProgr, ++nTime, nMax) DBSKIP(1) ENDDO ENDIF DC_GetProgress(oProgr,nMax,nMax) oDial:Destroy() DC_DataRest( aSaveRECODE2_2SG ) RETURN NIL // Информационное сообщение *LB_Warning(Mess) *LB_Inform("Ура! Получилось!") // Сообщение об ошибке *LB_Warning(L("Нет папки! Создайте!", "Сообщение об ошибке" ) * GenDbfClSc(.F.) // Классификационные шкалы ######### * GenDbfGrClSc(.F.) // Градации классификационных шкал ######### * GenDbfClass(.F.) // Классификационные шкалы и градации * GenDbfOpSc(.F.) // Описательные шкалы * GenDbfGrOpSc(.F.) // Градации описательных шкал * GenDbfAttr(.F.) // Описательные шкалы и градации ######### ******** Генерация БД описательных шкал FUNCTION GenDbfOpSc(mUpdate) aSaveGenDbf := DC_DataSave() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций cFileName := "Opis_Sc.dbf" IF .NOT. FILE(cFileName) mUpDate = .F. ENDIF aStructure := { { "KOD_OpSc" , "N", 15, 0 }, ; { "NAME_OpSc" , "C",250, 0 }, ; { "INT_INF" , "N", 19, 7 }, ; { "SUM_II" , "N", 19, 7 }, ; { "SII_PERC" , "N", 19, 7 }, ; { "RANG" , "N", 15, 0 }, ; { "ABS" , "N", 15, 0 }, ; { "PERC_FIZ" , "N", 19, 7 }, ; { "Sum_ZnGr" , "N", 19, 7 }, ; { "N_GrOpSc" , "N", 15, 0 }, ; { "KodGr_min" , "N", 15, 0 }, ; // Минимальный код градаций описательной шкалы { "KodGr_max" , "N", 15, 0 }, ; // Максимальный код градаций описательной шкалы { "N_combinat", "N", 15, 0 }, ; // Число комбинаций различных сочетаний значений факторов { "Date" , "C", 10, 0 }, ; { "Time" , "C", 8, 0 } } IF mUpdate DC_DBFILE( DC_SETDCLIP(),cFileName, ,,,'DBFNTX',, aStructure) ELSE DbCreate( cFileName, aStructure ) ENDIF GenNtxOpSc() DC_DataRest( aSaveGenDbf ) RETURN NIL ******** Создание индексных массивов БД описательных шкал FUNCTION GenNtxOpSc() aSaveGN5 := DC_DataSave() IF .NOT. FILE("Opis_Sc.dbf") GenDbfOpSc(.F.) ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Opis_Sc EXCLUSIVE NEW INDEX ON STR(Kod_OpSc,19) TO Ops_kod INDEX ON Name_OpSc TO Ops_name INDEX ON STR(99999999.9999999-Int_Inf,19, 7) TO Ops_ini INDEX ON STR(Abs,19) TO Ops_abs CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DC_DataRest( aSaveGN5 ) RETURN NIL ******** Генерация БД классификационных шкал FUNCTION GenDbfClSc(mUpDate) aSaveGenDbf := DC_DataSave() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций cFileName := "Class_Sc.dbf" IF .NOT. FILE(cFileName) mUpDate = .F. ENDIF aStructure := { { "KOD_ClSc" , "N", 15, 0 }, ; { "NAME_ClSc" , "C",250, 0 }, ; { "INT_INF" , "N", 19, 7 }, ; { "SUM_II" , "N", 19, 7 }, ; { "SII_PERC" , "N", 19, 7 }, ; { "RANG" , "N", 15, 0 }, ; { "ABS" , "N", 15, 0 }, ; { "PERC_FIZ" , "N", 19, 7 }, ; { "Sum_ZnGr" , "N", 19, 7 }, ; { "N_GrClSc" , "N", 15, 0 }, ; { "KodGr_min" , "N", 15, 0 }, ; // Минимальный код градаций описательной шкалы { "KodGr_max" , "N", 15, 0 }, ; // Максимальный код градаций описательной шкалы { "Date" , "C", 10, 0 }, ; { "Time" , "C", 8, 0 } } IF mUpdate DC_DBFILE( DC_SETDCLIP(),cFileName, ,,,'DBFNTX',, aStructure) ELSE DbCreate( cFileName, aStructure ) ENDIF GenNtxClSc() * DC_DataRest( aSaveGenDbf ) RETURN NIL ******** Создание индексных массивов БД классификационных шкал FUNCTION GenNtxClSc() aSaveGN5 := DC_DataSave() IF .NOT. FILE("Class_Sc.dbf") GenDbfClSc(.F.) ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Class_Sc EXCLUSIVE NEW INDEX ON STR(Kod_ClSc,19) TO ClSc_kod INDEX ON Name_ClSc TO ClSc_name INDEX ON STR(99999999.9999999-Int_Inf,19, 7) TO Clsc_ini * 123456789012345678 * 12345678901.123456 * 10 19 INDEX ON STR(Abs,19) TO ClSc_abs CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DC_DataRest( aSaveGN5 ) RETURN NIL ******** Генерация БД градаций классификационных шкал FUNCTION GenDbfGrClSc(mUpDate) aSaveGenDbf := DC_DataSave() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций cFileName := "Gr_ClSc.dbf" IF .NOT. FILE(cFileName) mUpDate = .F. ENDIF aStructure := { { "KOD_ClSc" , "N", 15, 0 }, ; { "KOD_GrCS" , "N", 15, 0 }, ; { "NAME_GrCS" , "C",250, 0 }, ; { "Delete" , "C", 1, 0 }, ; { "INT_INF" , "N", 19, 7 }, ; { "SUM_II" , "N", 19, 7 }, ; { "SII_PERC" , "N", 19, 7 }, ; { "RANG" , "N", 21, 0 }, ; { "ABS" , "N", 21, 0 }, ; { "PERC_FIZ" , "N", 19, 7 }, ; { "Universal" , "N", 19, 7 }, ; { "KodGrCSOld", "N", 15, 0 }, ; { "Date" , "C", 10, 0 }, ; { "Time" , "C", 8, 0 } } IF mUpDate DC_DBFILE( DC_SETDCLIP(),cFileName, ,,,'DBFNTX',, aStructure) ELSE DbCreate( cFileName, aStructure ) ENDIF GenNtxGrClSc() DC_DataRest( aSaveGenDbf ) RETURN NIL ******** Создание индексных массивов БД градаций описательных шкал FUNCTION GenNtxGrClSc() IF .NOT. FILE("Gr_OpSc.dbf") GenDbfGrOpSc(.F.) ENDIF * MsgBox( Disk_dir ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Gr_ClSc EXCLUSIVE NEW INDEX ON STR(Kod_GrCS,19) TO Gcs_kod INDEX ON Name_GrCS TO Gcs_name *INDEX ON STR(99999999.9999999-Int_Inf, 19, 7) TO Gcs_ini * 123456789012345678 * 1234567890.1234567 * 10 19 INDEX ON STR(Abs,19) TO Gcs_abs CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций RETURN NIL ******** Генерация БД градаций описательных шкал FUNCTION GenDbfGrOpSc(mUpdate) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций cFileName := "Gr_OpSc.dbf" IF .NOT. FILE(cFileName) mUpDate = .F. ENDIF aStructure := { { "KOD_OpSc" , "N", 15, 0 }, ; { "KOD_GrOS" , "N", 15, 0 }, ; { "NAME_GrOS", "C",250, 0 }, ; { "INT_INF" , "N", 19, 7 }, ; { "SUM_II" , "N", 19, 7 }, ; { "SII_PERC" , "N", 19, 7 }, ; { "RANG" , "N", 15, 0 }, ; { "ABS" , "N", 15, 0 }, ; { "PERC_FIZ" , "N", 19, 7 }, ; { "Universal", "N", 19, 7 }, ; { "Date" , "C", 10, 0 }, ; { "Time" , "C", 8, 0 } } IF mUpDate DC_DBFILE( DC_SETDCLIP(),cFileName, ,,,'DBFNTX',, aStructure) ELSE DbCreate( cFileName, aStructure ) ENDIF GenNtxGrOpSc() RETURN NIL ******** Создание индексных массивов БД градаций описательных шкал FUNCTION GenNtxGrOpSc() IF .NOT. FILE("Gr_OpSc.dbf") GenDbfGrOpSc(.F.) ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Gr_OpSc EXCLUSIVE NEW INDEX ON STR(Kod_GrOS,19) TO Gos_kod INDEX ON Name_GrOS TO Gos_name INDEX ON STR(99999999.9999999-Int_Inf,19, 7) TO Gos_ini INDEX ON STR(Abs,19) TO Gos_abs CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций RETURN NIL *********************************************************************************************************** ********* 2.3.1. Ручной ввод-корректировка обучающей выборки *********************************************************************************************************** FUNCTION F2_3_1() LOCAL GetList := {}, GetOptions, oBrowUser, oBrowApp, bApp, bItems Running(.T.) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF ApplChange("2.3.1()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF IF FILE("_CurrInf.arx") // Файл с информацией о том, какая модель задана текущей M_CurrInf = DC_ARestore("_CurrInf.arx") ELSE DC_ASave(M_CurrInf, "_CurrInf.arx") ENDIF IF FILE("Obi_Zag.dbf") // БД заголовков обучающей выборки ** Переиндексировать БД Obi_Zag.dbf, ** если не хватает хотя бы одного какого-нибудь индексного массива IF .NOT. FILE("Oiz_kod.ntx" ) .OR.; .NOT. FILE("Oiz_name.ntx") .OR.; .NOT. FILE("Obi_Zag.ntx" ) GenNtxObiZag() ENDIF ELSE GenDbfObiZag() ENDIF IF FILE("Obi_Kcl.dbf") // БД классов обучающей выборки ** Переиндексировать БД Obi_Kcl.dbf, ** если не хватает хотя бы одного какого-нибудь индексного массива IF .NOT. FILE("Oic_kod.ntx") .OR.; .NOT. FILE("Obi_Kcl.ntx") GenNtxObiKcl() ENDIF ELSE GenDbfObiKcl() ENDIF IF FILE("Obi_Kpr.dbf") // БД признаков обучающей выборки ** Переиндексировать БД Obi_Kpr.dbf, ** если не хватает хотя бы одного какого-нибудь индексного массива IF .NOT. FILE("Oip_kod.ntx") .OR.; .NOT. FILE("Obi_Kpr.ntx") GenNtxObiKpr() ENDIF ELSE GenDbfObiKpr() 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 dbeSetDefault('DBFNTX') ***** Совпадают ли номера записей объектов обучающей выборки с их кодами? ***** Если нет, то перенумеровать их? CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Obi_Zag EXCLUSIVE NEW;N_Zag = RECCOUNT() USE Obi_Kcl EXCLUSIVE NEW;N_Kcl = RECCOUNT() USE Obi_Kpr EXCLUSIVE NEW;N_Kpr = RECCOUNT() SELECT Obi_Zag mFlagErr = .F. FOR j=RECCOUNT() TO 1 STEP -1 IF Kod_obj <> RECNO() mFlagErr = .T. EXIT ENDIF NEXT IF mFlagErr mRecode := 1 @ 1, 1 DCGROUP oGroup1 CAPTION L('Перекодировать объекты обучающей выборки?' ) SIZE 60, 10 @ 1, 1 DCSAY L('Коды объектов обучающей выборки должны совпадать с номерами записей,' ) PARENT oGroup1 @ 2, 1 DCSAY L('но они не совпадают. По-видимому, это связано с некорректым удалением') PARENT oGroup1 @ 3, 1 DCSAY L('некоторых объектов обучающей выборки. Есть два способа это исправить:') PARENT oGroup1 @ 4, 1 DCSAY L('1. Перекодировать обучающую выборку прямо сейчас.' ) PARENT oGroup1 @ 5, 1 DCSAY L('2. В режиме 5.10 выгрузить исходные данные в файл: "Inp_data.dbf",' ) PARENT oGroup1 @ 6, 1 DCSAY L(' а затем ввести их в систему в режиме 2.3.2.2.' ) PARENT oGroup1 @7.5, 1 DCRADIO mRecode VALUE 1 PROMPT L('Исправить нумерацию' ) PARENT oGroup1 @8.5, 1 DCRADIO mRecode VALUE 2 PROMPT L('Ничего не делать' ) PARENT oGroup1 DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; OPTIONS GetOptions ; ADDBUTTONS ; MODAL ; TITLE L('2.3.1. Ввод-корректировка обучающей выборки') IF mRecode = 1 nMax = N_Zag + N_Kcl + N_Kpr Mess = L('2.3.1. Исправление кодирования обучающей выборки.') @ 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) SELECT Obi_Zag DBGOBOTTOM() mKodMax = Kod_obj PRIVATE aKodOldNew[MAX(mKodMax, RECCOUNT())] SELECT Obi_Zag DBGOTOP() DO WHILE .NOT. EOF() mKodObj = Kod_obj aKodOldNew[mKodObj] = RECNO() REPLACE Kod_obj WITH aKodOldNew[mKodObj] DC_GetProgress(oProgress, ++nTime, nMax) DBSKIP(1) ENDDO SELECT Obi_Kcl DBGOTOP() DO WHILE .NOT. EOF() mKodObj = Kod_obj REPLACE Kod_obj WITH aKodOldNew[mKodObj] DC_GetProgress(oProgress, ++nTime, nMax) DBSKIP(1) ENDDO SELECT Obi_Kpr DBGOTOP() DO WHILE .NOT. EOF() mKodObj = Kod_obj REPLACE Kod_obj WITH aKodOldNew[mKodObj] DC_GetProgress(oProgress, ++nTime, nMax) DBSKIP(1) ENDDO * MsgBox('STOP') DC_GetProgress(oProgress,nMax,nMax) oDialog:Destroy() ENDIF ENDIF **************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Obi_Zag INDEX ON Kod_Obj TO Obi_Zag CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Obi_Kcl NEW INDEX ON Kod_Obj TO Obi_Kcl CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Obi_Kpr NEW INDEX ON Kod_Obj TO Obi_Kpr CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Obi_Zag INDEX Obi_Zag EXCLUSIVE USE Obi_Kcl INDEX Obi_Kcl EXCLUSIVE NEW USE Obi_Kpr INDEX Obi_Kpr EXCLUSIVE NEW USE Rso_Zag INDEX Rso_Zag EXCLUSIVE NEW USE Rso_Kcl INDEX Rso_Kcl EXCLUSIVE NEW USE Rso_Kpr INDEX Rso_Kpr EXCLUSIVE NEW /* ----- Create ToolBar ----- */ d = 8 @ 27.5, 0 DCTOOLBAR oToolBar SIZE 143, 1.5 DCADDBUTTON CAPTION L('Помощь') ; SIZE LEN(L("Помощь"))+2 ; ACTION {||Help231(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Помощь по режиму 2.3.1') @ DCGUI_ROW, DCGUI_COL + d DCPUSHBUTTON CAPTION L('Скопировать обуч.выб.в расп.'); SIZE LEN(L("Скопировать обуч.выб.в расп."))-5, 1.5 ; ACTION {||CopyOiRo(.T.,1,1,1,"",1,1), DC_GetRefresh(GetList)}; PARENT oToolBar ; TOOLTIP L('Скопировать обучающую выборку в распознаваемую') @ DCGUI_ROW, DCGUI_COL + d DCPUSHBUTTON CAPTION L('Добавить объект') ; SIZE LEN(L("Добавить объект"))+0, 1.5 ; ACTION {||Add_Obj2_3_1(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Добавить объект') @ DCGUI_ROW, DCGUI_COL + d DCPUSHBUTTON CAPTION L('Добавить классы') ; SIZE LEN(L("Добавить классы"))-0, 1.5 ; ACTION {||Add_Kcl2_3_1(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Добавить строку классов') @ DCGUI_ROW, DCGUI_COL + d DCPUSHBUTTON CAPTION L('Добавить признаки') ; SIZE LEN(L("Добавить признаки"))-1, 1.5 ; ACTION {||Add_Kpr2_3_1(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Добавить строку признаков') @ DCGUI_ROW, DCGUI_COL + d DCPUSHBUTTON CAPTION L('Удалить объект') ; SIZE LEN(L("Удалить объект"))-0, 1.5 ; ACTION {||Del_Obj2_3_1(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Удалить объект') @ DCGUI_ROW, DCGUI_COL + d DCPUSHBUTTON CAPTION L('Удалить классы') ; SIZE LEN(L("Удалить классы"))-0, 1.5 ; ACTION {||Del_Kcl2_3_1(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Удалить строку классов') @ DCGUI_ROW, DCGUI_COL + d DCPUSHBUTTON CAPTION L('Удалить признаки') ; SIZE LEN(L("Удалить признаки"))+0, 1.5 ; ACTION {||Del_Kpr2_3_1(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Удалить строку признаков') @ DCGUI_ROW, DCGUI_COL + d DCPUSHBUTTON CAPTION L('Очистить БД') ; SIZE LEN(L("Очистить БД"))+2, 1.5 ; ACTION {||Zap_db2_3_1(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Очистить базу данных') /* ----- Create browse-1: Главная БД Obi_Zag.dbf ----- */ bZag := {|| Obi_Kpr->(DC_SetScope(0,Obi_Zag->Kod_Obj)), ; Obi_Kpr->(DC_SetScope(1,Obi_Zag->Kod_Obj)), ; Obi_Kpr->(DC_DbGoTop()) , ; oBrowKpr:refreshAll() , ; Obi_Kcl->(DC_SetScope(0,Obi_Zag->Kod_Obj)), ; Obi_Kcl->(DC_SetScope(1,Obi_Zag->Kod_Obj)), ; Obi_Kcl->(DC_DbGoTop()) , ; oBrowKcl:refreshAll() } d = 10 @ 1, 0 DCBROWSE oBrowZag ALIAS 'Obi_Zag' SIZE 133+d,12.5 ; EDIT xbeBRW_ItemSelected MODE DCGUI_BROWSE_EDITDOWN ; // Редактирование БД Obi_Zag.dbf NOSOFTTRACK ; SCOPE ; ITEMMARKED {|| Eval(bZag), ; DC_GetRefresh(GetList,, ; DCGETREFRESH_TYPE_EXCLUDE,{GETLIST_BROWSE}) } DCSETPARENT oBrowZag DCBROWSECOL FIELD Obi_Zag->Kod_Obj HEADER L('Код объекта' ) WIDTH 1 PROTECT {|| .T. } DCBROWSECOL FIELD Obi_Zag->Name_obj HEADER L('Наименование объекта') WIDTH 54.5+d-4 DCBROWSECOL FIELD Obi_Zag->Date HEADER L('Дата' ) WIDTH 10.4 PROTECT {|| .T. } DCBROWSECOL FIELD Obi_Zag->Time HEADER L('Время' ) WIDTH 9.5 PROTECT {|| .T. } /* Create browse-2: БД Obi_Kcl.dbf, связанная отношением "Один ко многим" с БД Obi_Zag.dbf*/ DCSETPARENT TO @14, 0 DCBROWSE oBrowKcl ALIAS 'Obi_Kcl' SIZE 51,13 ; EDIT xbeBRW_ItemSelected MODE DCGUI_BROWSE_EDITDOWN ; NOSOFTTRACK ; SCOPE ; ITEMMARKED bItems DCSETPARENT oBrowKcl DCBROWSECOL FIELD Obi_Kcl->Kod_Obj HEADER L('Код объекта') WIDTH 1 PROTECT {|| .T. } DCBROWSECOL FIELD Obi_Kcl->Cls1 HEADER L('Класс 1' ) WIDTH 5 DCBROWSECOL FIELD Obi_Kcl->Cls2 HEADER L('Класс 2' ) WIDTH 5 DCBROWSECOL FIELD Obi_Kcl->Cls3 HEADER L('Класс 3' ) WIDTH 5 DCBROWSECOL FIELD Obi_Kcl->Cls4 HEADER L('Класс 4' ) WIDTH 5 /* Create browse-3: БД Obi_Kpr.dbf, связанная отношением "Один ко многим" с БД Obi_Zag.dbf*/ DCSETPARENT TO @14,54 DCBROWSE oBrowKpr ALIAS 'Obi_Kpr' SIZE 79+d,13 ; EDIT xbeBRW_ItemSelected MODE DCGUI_BROWSE_EDITDOWN ; NOSOFTTRACK ; SCOPE ; ITEMMARKED bItems DCSETPARENT oBrowKpr DCBROWSECOL FIELD Obi_Kpr->Kod_Obj HEADER L('Код объекта') WIDTH 1 PROTECT {|| .T. } DCBROWSECOL FIELD Obi_Kpr->Atr1 HEADER L('Признак 1' ) WIDTH 6 DCBROWSECOL FIELD Obi_Kpr->Atr2 HEADER L('Признак 2' ) WIDTH 6 DCBROWSECOL FIELD Obi_Kpr->Atr3 HEADER L('Признак 3' ) WIDTH 6 DCBROWSECOL FIELD Obi_Kpr->Atr4 HEADER L('Признак 4' ) WIDTH 6 DCBROWSECOL FIELD Obi_Kpr->Atr5 HEADER L('Признак 5' ) WIDTH 6 DCBROWSECOL FIELD Obi_Kpr->Atr6 HEADER L('Признак 6' ) WIDTH 6 DCBROWSECOL FIELD Obi_Kpr->Atr7 HEADER L('Признак 7' ) WIDTH 6 DCGETOPTIONS SAYFONT '10.Helv Bold' TABSTOP AUTORESIZE cTitle = L('2.3.1. Ручной ввод-корректировка обучающей выборки. Текущая модель: "')+UPPER(Ar_Model[M_CurrInf])+'"' DCREAD GUI ; FIT ; OPTIONS GetOptions ; MODAL ; TITLE cTitle ; EVAL {|o|SetAppFocus(oBrowZag:GetColumn(1))} ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ****** END OF EXAMPLE *********************** ************************************************************************************************** FUNCTION Help231() aHelp := {} AADD(aHelp, L('Режим: "2.3.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(' ')) 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.3.1.') RETURN NIL ************************************************************************************************** ******** Перекодирование и переиндексация распознаваемой выборки ************************************************************************************************** FUNCTION RecodingRsp() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rso_Zag EXCLUSIVE NEW USE Rso_Kcl EXCLUSIVE NEW USE Rso_Kpr EXCLUSIVE NEW * Формирование массивов старых и новых кодов **************************** * Перекодирование БД заголовков объектов распознаваемой выборки ********* M_MaxKodObj = 0 Ar_KodObjOld := {} // Коды объектов исходной выборки Ar_KodObjNew := {} // Коды объектов результирующей выборки SELECT Rso_zag DBGOTOP() DO WHILE .NOT. EOF() AADD(Ar_KodObjOld, Kod_obj) AADD(Ar_KodObjNew, ++M_MaxKodObj) REPLACE Kod_obj WITH M_MaxKodObj DBSKIP(1) ENDDO * Перекодирование БД кодов классов объектов распознаваемой выборки ****** SELECT Rso_Kcl DBGOTOP() DO WHILE .NOT. EOF() Pos = ASCAN(Ar_KodObjOld, Kod_obj) REPLACE Kod_obj WITH Ar_KodObjNew[Pos] DBSKIP(1) ENDDO * Перекодирование БД кодов признаков объектов распознаваемой выборки **** SELECT Rso_Kpr DBGOTOP() DO WHILE .NOT. EOF() Pos = ASCAN(Ar_KodObjOld, Kod_obj) REPLACE Kod_obj WITH Ar_KodObjNew[Pos] DBSKIP(1) ENDDO GenNtxRsoZag();GenNtxRsoKcl();GenNtxRsoKpr() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций RETURN NIL *************************************************************************************** ******** Скопировать обучающую выборку в распознаваемую ******** Для организации диалога использован пример XSample_184() из xdemo.exe *************************************************************************************** FUNCTION CopyOiRo(Dialog, nRadio1, nRadio2, nRadio3, Regim, mN1, mN2) LOCAL GetList[0], GetOptions, lCheck1, lCheck2, oGroup1, oGroup2, M_KodObj, lOk **SET TAG TO COMMAND aSaveCopOR := DC_DataSave() // Сохранение вычислительной среды (открытые и текущие БД и индексы) // Диалог задания параметров режима копирования обуч.выборки в распознаваемую IF Dialog CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Obi_Zag INDEX Obi_Zag EXCLUSIVE NEW nRadio1 := 1 nRadio2 := 1 nRadio3 := 1 N_CopyObj = 0 mN1 = 1 mN2 = RECCOUNT() @ 0, 0 DCGROUP oGroup1 CAPTION L('Какие объекты обуч.выборки копировать:' ) SIZE 45, 6.7 @ 7, 0 DCGROUP oGroup2 CAPTION L('Удалять ли из обуч.выборки скопированные объекты?') SIZE 45, 3.7 @11, 0 DCGROUP oGroup3 CAPTION L('Стирать или дополнять распознаваемую выборку:' ) SIZE 45, 4.0 @ 0,47 DCGROUP oGroup4 CAPTION L('Числовые параметры:' ) SIZE 28, 6.7 @ 7,47 DCGROUP oGroup5 CAPTION L('Пояснение:' ) SIZE 28, 8.0 @ 1, 1 DCRADIO nRadio1 VALUE 1 PROMPT L('Копировать всю обучающую выборку ') PARENT oGroup1 @ 2, 1 DCRADIO nRadio1 VALUE 2 PROMPT L('Копировать только текущий объект ') PARENT oGroup1 @ 3, 1 DCRADIO nRadio1 VALUE 3 PROMPT L('Копировать каждый N-й объект ') PARENT oGroup1 @ 4, 1 DCRADIO nRadio1 VALUE 4 PROMPT L('Копировать N случайных объектов ') PARENT oGroup1 @ 5, 1 DCRADIO nRadio1 VALUE 5 PROMPT L('Копировать объекты от N1 до N2 (fastest)') PARENT oGroup1 @ 1, 1 DCRADIO nRadio2 VALUE 1 PROMPT L('Не удалять в обучающей выборке ') PARENT oGroup2 @ 2, 1 DCRADIO nRadio2 VALUE 2 PROMPT L('Удалять в обучающей выборке ') PARENT oGroup2 @ 1, 1 DCRADIO nRadio3 VALUE 1 PROMPT L('Стирать расп.выборку перед копированием ') PARENT oGroup3 @ 2, 1 DCRADIO nRadio3 VALUE 2 PROMPT L('Дополнять распознаваемую выборку ') PARENT oGroup3 @ 3, 0.2 DCSAY L(" ") GET N_CopyObj PARENT oGroup4 PICTURE "#########" EDITPROTECT {|| .NOT.nRadio1=3 } HIDE {|| .NOT.nRadio1=3 } @ 4, 0.2 DCSAY L(" ") GET N_CopyObj PARENT oGroup4 PICTURE "#########" EDITPROTECT {|| .NOT.nRadio1=4 } HIDE {|| .NOT.nRadio1=4 } @ 5, 0.2 DCSAY L(" ") GET mN1 PARENT oGroup4 PICTURE "#########" EDITPROTECT {|| .NOT.nRadio1=5 } HIDE {|| .NOT.nRadio1=5 } @ 5,13.5 DCSAY L(" ") GET mN2 PARENT oGroup4 PICTURE "#########" EDITPROTECT {|| .NOT.nRadio1=5 } HIDE {|| .NOT.nRadio1=5 } @ 1, 1 DCSAY L("Данный режим основан на идеях ") PARENT oGroup5 @ 2, 1 DCSAY L("бутстрепной статистики и готовит") PARENT oGroup5 @ 3, 1 DCSAY L("данные для измерения внутренней ") PARENT oGroup5 @ 4, 1 DCSAY L("и внешней, интегральной и диффе-") PARENT oGroup5 @ 5, 1 DCSAY L("ренциальной достоверности стат. ") PARENT oGroup5 @ 6, 1 DCSAY L("моделей и моделей знаний" ) PARENT oGroup5 @ 6.7, 15.6 DCPUSHBUTTON ; PARENT oGroup5 ; CAPTION L('Подробнее') ; SIZE LEN(L('Подробнее'))+1, 0.9 ; ACTION {||Help_OiRo()} DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; OPTIONS GetOptions ; ADDBUTTONS ; MODAL ; TITLE L('2.3.1. Копирование обучающей выборки в распознаваемую') *************************************************** IF lExit ** Button Ok ELSE ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** DC_DataRest( aSaveCopOR ) // Восстановление вычислительной среды (открытые и текущие БД и индексы) Running(.F.) RETURN NIL ENDIF *************************************************** ENDIF ************************************************************************************* ** Скопировать просто как файлы и переименовать ************************************* ************************************************************************************* IF nRadio1=1 .AND. nRadio2=1 .AND. nRadio3=1 IF Dialog;oScr := DC_WaitOn(L('Идет процесс копирования обучающей выборки в распознаваемую. Немного подождите!'),,,,,,,,,,,.F.);ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций COPY FILE ("Obi_Zag.dbf") TO ("Rso_Zag.dbf") COPY FILE ("ObI_Kcl.dbf") TO ("Rso_Kcl.dbf") COPY FILE ("Obi_Kpr.dbf") TO ("Rso_Kpr.dbf") GenNtxRsoZag();GenNtxRsoKcl();GenNtxRsoKpr() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций IF Dialog;DC_Impl(oScr);ENDIF DC_DataRest( aSaveCopOR ) // Восстановление вычислительной среды (открытые и текущие БД и индексы) RETURN NIL ENDIF ******************************************************** ************************************************************************************* ** Скопировать просто как файлы, переименовать и удалить каждый N-й объект ************************************************************************************* IF nRadio1=3 .AND. nRadio2=1 .AND. nRadio3=1 // Копировать каждый N-й объект <<<===###################### IF Dialog;oScr := DC_WaitOn(L('Идет процесс копирования обучающей выборки в распознаваемую. Немного подождите!'),,,,,,,,,,,.F.);ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций COPY FILE ("Obi_Zag.dbf") TO ("Rso_Zag.dbf") COPY FILE ("ObI_Kcl.dbf") TO ("Rso_Kcl.dbf") COPY FILE ("Obi_Kpr.dbf") TO ("Rso_Kpr.dbf") USE Rso_Zag EXCLUSIVE NEW DELETE FOR Kod_obj <> N_CopyObj*INT(Kod_obj/N_CopyObj);PACK USE Rso_Kcl EXCLUSIVE NEW DELETE FOR Kod_obj <> N_CopyObj*INT(Kod_obj/N_CopyObj);PACK USE Rso_Kpr EXCLUSIVE NEW DELETE FOR Kod_obj <> N_CopyObj*INT(Kod_obj/N_CopyObj);PACK RecodingRsp() IF Dialog;DC_Impl(oScr);ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DC_DataRest( aSaveCopOR ) // Восстановление вычислительной среды (открытые и текущие БД и индексы) RETURN NIL ENDIF ************************************************************************************ ** Скопировать просто как файлы, переименовать и удалить все записи до N1 и после N2 ************************************************************************************ IF nRadio1=5 .AND. nRadio2=1 .AND. nRadio3=1 // Копировать все объекты от N1 до N2 IF Dialog;oScr := DC_WaitOn(L('Идет процесс копирования обучающей выборки в распознаваемую. Немного подождите!'),,,,,,,,,,,.F.);ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций COPY FILE ("Obi_Zag.dbf") TO ("Rso_Zag.dbf") COPY FILE ("ObI_Kcl.dbf") TO ("Rso_Kcl.dbf") COPY FILE ("Obi_Kpr.dbf") TO ("Rso_Kpr.dbf") USE Rso_Zag EXCLUSIVE NEW DELETE FOR Kod_obj < mN1 .OR. Kod_obj > mN2;PACK USE Rso_Kcl EXCLUSIVE NEW DELETE FOR Kod_obj < mN1 .OR. Kod_obj > mN2;PACK USE Rso_Kpr EXCLUSIVE NEW DELETE FOR Kod_obj < mN1 .OR. Kod_obj > mN2;PACK IF mN1 = 1 GenNtxRsoZag();GenNtxRsoKcl();GenNtxRsoKpr() ELSE RecodingRsp() ENDIF IF Dialog;DC_Impl(oScr);ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DC_DataRest( aSaveCopOR ) // Восстановление вычислительной среды (открытые и текущие БД и индексы) RETURN NIL ENDIF aFileName := {"Obi_Zag.dbf",; "ObI_Kcl.dbf",; "Obi_Kpr.dbf",; "Rso_Zag.dbf",; "Rso_Kcl.dbf",; "Rso_Kpr.dbf" } // Проверка наличия всех файлов обуч.выборки Flag = .F. FOR j=1 TO 6 IF .NOT. FILE(aFileName[j]) // Существует ли исходный файл Flag = .T. EXIT ENDIF NEXT // Если все исходные файлы существуют, то копирование их в расп.выборку IF Flag LB_Warning(L("Отсутсвуют БД обучающей и распознаваемой выборки!!!")) Running(.F.) RETURN NIL ENDIF IF nRadio1 = 2 // Копировать только текущий объект обуч.выборки SELECT Obi_zag M_KodObj = Kod_obj ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Obi_Zag INDEX Obi_Zag EXCLUSIVE NEW;N0_ObiZag = RECCOUNT() USE Obi_Kcl INDEX Obi_Kcl EXCLUSIVE NEW;N0_ObiKcl = RECCOUNT() USE Obi_Kpr INDEX Obi_Kpr EXCLUSIVE NEW;N0_ObiKpr = RECCOUNT() USE Rso_Zag INDEX Rso_Zag EXCLUSIVE NEW USE Rso_Kcl INDEX Rso_Kcl EXCLUSIVE NEW USE Rso_Kpr INDEX Rso_Kpr EXCLUSIVE NEW IF N0_ObiZag = 0 LB_Warning(L("База данных заголовков объектов обучающей выборки пуста !!!")) Flag = .T. ENDIF IF N0_ObiKcl = 0 LB_Warning(L("База данных кодов классов объектов обучающей выборки пуста !!!")) Flag = .T. ENDIF IF N0_ObiKpr = 0 LB_Warning(L("База данных кодов признаков объектов обучающей выборки пуста !!!")) Flag = .T. ENDIF IF Flag DC_DataRest( aSaveCopOR ) // Восстановление вычислительной среды (открытые и текущие БД и индексы) RETURN NIL ENDIF // Подготовка данных для отображения графического прогресс-бар // Определить значение Wsego Ar_RndObj := {} DO CASE CASE nRadio1 = 1 // Копировать всю обучающую выборку SELECT Obi_zag;N_ObiZag = RECCOUNT() SET FILTER TO DBGOTOP();DBGOBOTTOM();DBGOTOP() SELECT Obi_Kcl;N_ObiKcl = RECCOUNT() SET FILTER TO DBGOTOP();DBGOBOTTOM();DBGOTOP() SELECT Obi_Kpr;N_ObiKpr = RECCOUNT() SET FILTER TO DBGOTOP();DBGOBOTTOM();DBGOTOP() CASE nRadio1 = 2 // Копировать только текущий объект SELECT Obi_zag SET FILTER TO M_KodObj = Kod_obj DBGOTOP();DBGOBOTTOM();DBGOTOP() COUNT TO N_ObiZag SELECT Obi_Kcl SET FILTER TO M_KodObj = Kod_obj DBGOTOP();DBGOBOTTOM();DBGOTOP() COUNT TO N_ObiKcl SELECT Obi_Kpr SET FILTER TO M_KodObj = Kod_obj DBGOTOP();DBGOBOTTOM();DBGOTOP() COUNT TO N_ObiKpr CASE nRadio1 = 3 // Копировать каждый N-й объект IF 0 < N_CopyObj .AND. N_CopyObj <= N0_ObiZag SELECT Obi_zag // Если код объекта обуч.выборки нацело делится на N_CopyObj, то копировать этот объект SET FILTER TO Kod_obj = N_CopyObj*INT(Kod_obj/N_CopyObj) DBGOTOP();DBGOBOTTOM();DBGOTOP() COUNT TO N_ObiZag SELECT Obi_Kcl // Если код объекта обуч.выборки нацело делится на N_CopyObj, то копировать этот объект SET FILTER TO Kod_obj = N_CopyObj*INT(Kod_obj/N_CopyObj) DBGOTOP();DBGOBOTTOM();DBGOTOP() COUNT TO N_ObiKcl SELECT Obi_Kpr // Если код объекта обуч.выборки нацело делится на N_CopyObj, то копировать этот объект SET FILTER TO Kod_obj = N_CopyObj*INT(Kod_obj/N_CopyObj) DBGOTOP();DBGOBOTTOM();DBGOTOP() COUNT TO N_ObiKpr ELSE Mess = L("Каждый N-й объект обуч.выборки, где N = # !!!") Mess = STRTRAN(Mess,"#", ALLTRIM(STR(N_ObiZag,19))) LB_Warning(Mess) ENDIF CASE nRadio1 = 4 // Копировать N случайных объектов (по-другому отобр.прогн.времени исп.) // Сформировать массив кодов случайных объектов обучающей выборки без повторов из N элементов DO WHILE LEN(Ar_RndObj) < N_CopyObj // В массиве еще нет N_CopyObj элементов? // Случайный номер записи от 1 до N0_ObiZag (N0_ObiZag - кол-во объектов обуч.выборки) M_KodObj = 1+INT(RANDOM()%N0_ObiZag) IF ASCAN(Ar_RndObj, M_KodObj) = 0 // Номер этого объекта еще не разыгрывался? AADD (Ar_RndObj, M_KodObj) ENDIF ENDDO ASORT(Ar_RndObj) * DC_DebugQout( Ar_RndObj ) K_cls = N0_ObiKcl / N0_ObiZag // Сколько строк в БД кодов классов приходится в среднем на один объект обуч.выборки K_gos = N0_ObiKpr / N0_ObiZag // Сколько строк в БД кодов признаков приходится в среднем на один объект обуч.выборки N_ObiZag = N_CopyObj // Количество случайно выбранных объектов N_ObiKcl = K_cls * N_CopyObj // Оценка числа записей в БД кодов классов, приходящихся на случайно выбранные объекты N_ObiKpr = K_gos * N_CopyObj // Оценка числа записей в БД кодов признаков, приходящихся на случайно выбранные объекты CASE nRadio1 = 5 // Копировать все объекты, начиная с N-го SELECT Obi_zag DBGOTO(mN1);M_KodObj1 = Kod_obj DBGOTO(mN2);M_KodObj2 = Kod_obj SET FILTER TO M_KodObj1 <= Kod_Obj .AND. Kod_Obj <= M_KodObj2 DBGOTOP();DBGOBOTTOM();DBGOTOP() COUNT TO N_ObiZag SELECT Obi_Kcl SET FILTER TO M_KodObj1 <= Kod_Obj .AND. Kod_Obj <= M_KodObj2 DBGOTOP();DBGOBOTTOM();DBGOTOP() COUNT TO N_ObiKcl SELECT Obi_Kpr SET FILTER TO M_KodObj1 <= Kod_Obj .AND. Kod_Obj <= M_KodObj2 DBGOTOP();DBGOBOTTOM();DBGOTOP() COUNT TO N_ObiKpr ENDCASE DO CASE CASE nRadio3 = 1 // Стирать расп.выборку перед копированием SELECT Rso_Zag;ZAP SELECT Rso_Kcl;ZAP SELECT Rso_Kpr;ZAP M_MaxKodObj = 0 CASE nRadio3 = 2 // Дополнять расп.выборку SELECT Rso_zag DBGOBOTTOM() M_MaxKodObj = Kod_Obj ENDCASE Ar_KodObjOld := {} // Коды объектов исходной выборки Ar_KodObjNew := {} // Коды объектов результирующей выборки IF Dialog // Задание максимальной величины параметра Time DO CASE CASE nRadio2=1 // Не удалять из обуч.выборки скопированные объекты Wsego = N0_ObiZag + N0_ObiKcl + N0_ObiKpr + 3 // Отображение стадии исполнения. Будет написано прямо в окне 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" // Зарезервировано для названия операции, если диалог @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 2] FONT "10.Helv" // 1/4: Obi_Zag @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 3] FONT "10.Helv" // 2/4: Obi_Kcl @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 4] FONT "10.Helv" // 3/4: Obi_Kpr @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 5] FONT "10.Helv" // 4/4: Переиндексация CASE nRadio2=2 // Удалять из обуч.выборки скопированные объекты Wsego = N0_ObiZag + N0_ObiKcl + N0_ObiKpr + 3 + (N0_ObiZag - N_ObiZag) + (N0_ObiKcl - N_ObiKcl) + (N0_ObiKpr - N_ObiKpr) + 6 // Отображение стадии исполнения. Будет написано прямо в окне 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" // 1/9: Obi_Zag @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 3] FONT "10.Helv" // 2/9: Obi_Kcl @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 4] FONT "10.Helv" // 3/9: Obi_Kpr @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 5] FONT "10.Helv" // 4/9: Удаление скопированных объектов из обучающей выборки - 3 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 6] FONT "10.Helv" // 5/9: Перекодирование БД заголовков объектов обуч.выборки @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 7] FONT "10.Helv" // 6/9: Перекодирование БД кодов классов объектов обуч.выборки @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 8] FONT "10.Helv" // 7/9: Перекодирование БД кодов признаков объектов обуч.выборки @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 9] FONT "10.Helv" // 8/9: Переиндексация баз данных обучающей выборки - 3 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[10] FONT "10.Helv" // 9/9: Переиндексация ENDCASE 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 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('2.3.1. Копирование обучающей выборки в распознаваемую') ; PARENT @oDialog ; FIT ; EXIT ; MODAL oDialog:show() // Завершение подготовки данных для отображения графического прогресс-бар ENDIF // Копирование обуч.выборки в распознаваемую s = 1 IF Dialog aSay[ s++]:SetCaption(L('ОПЕРАЦИЯ: КОПИРОВАНИЕ ОБУЧАЮЩЕЙ ВЫБОРКИ В РАСПОЗНАВАЕМУЮ')) // Почему-то копирует не подмножество, а всю об.выборку целиком (когда GPU) <<<===################################### ENDIF aSay[s]:SetCaption(L("1/"+IF(nRadio2=1,'4','9')+": Копирование базы заголовков обучающей выборки")) SELECT Obi_zag // ***************************************************** DBGOTOP() DO WHILE .NOT. EOF() IF ( nRadio1 = 4 .AND. ASCAN(Ar_RndObj, Kod_obj) > 0 ) .OR. nRadio1 <> 4 AADD(Ar_KodObjOld, Kod_obj) AADD(Ar_KodObjNew, ++M_MaxKodObj) // Если дополнять БД, то 1-й код следующий за последним Ar := {};FOR j=1 TO FCOUNT();AADD(Ar, FIELDGET(j));NEXT SELECT Rso_zag APPEND BLANK FOR j=1 TO FCOUNT() FIELDPUT(j,Ar[j]) Pos = ASCAN(Ar_KodObjOld, Ar[1]) FIELDPUT(1, Ar_KodObjNew[Pos]) NEXT SELECT Obi_zag IF nRadio2=2;DELETE;ENDIF ENDIF IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF DBSKIP(1) ENDDO aSay[s]:SetCaption(aSay[s++]:caption+L(" - Готово ")) aSay[s]:SetCaption(L("2/"+IF(nRadio2=1,'4','9')+": Копирование базы кодов классов обучающей выборки")) SELECT Obi_Kcl // ******************************************************** DBGOTOP() DO WHILE .NOT. EOF() IF ( nRadio1 = 4 .AND. ASCAN(Ar_RndObj, Kod_obj) > 0 ) .OR. nRadio1 <> 4 Ar := {};FOR j=1 TO FCOUNT();AADD(Ar, FIELDGET(j));NEXT SELECT Rso_Kcl APPEND BLANK FOR j=1 TO FCOUNT() FIELDPUT(j,Ar[j]) Pos = ASCAN(Ar_KodObjOld, Ar[1]) FIELDPUT(1, Ar_KodObjNew[Pos]) NEXT SELECT Obi_Kcl IF nRadio2=2;DELETE;ENDIF ENDIF IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF DBSKIP(1) ENDDO aSay[s]:SetCaption(aSay[s++]:caption+L(" - Готово ")) aSay[s]:SetCaption(L("3/"+IF(nRadio2=1,'4','9')+": Копирование базы кодов признаков обучающей выборки")) SELECT Obi_Kpr // ********************************************************** DBGOTOP() DO WHILE .NOT. EOF() IF ( nRadio1 = 4 .AND. ASCAN(Ar_RndObj, Kod_obj) > 0 ) .OR. nRadio1 <> 4 Ar := {};FOR j=1 TO FCOUNT();AADD(Ar, FIELDGET(j));NEXT SELECT Rso_Kpr APPEND BLANK FOR j=1 TO FCOUNT() FIELDPUT(j,Ar[j]) Pos = ASCAN(Ar_KodObjOld, Ar[1]) FIELDPUT(1, Ar_KodObjNew[Pos]) NEXT SELECT Obi_Kpr IF nRadio2=2;DELETE;ENDIF ENDIF IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF DBSKIP(1) ENDDO aSay[s]:SetCaption(aSay[s++]:caption+L(" - Готово ")) IF nRadio2=2 // 4-8 делать и отображать только, если это задано ################################# aSay[s]:SetCaption(L("4/9: Удаление скопированных объектов из обучающей выборки")) IF nRadio2=2;SELECT Obi_zag;PACK;ENDIF IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF IF nRadio2=2;SELECT Obi_Kcl;PACK;ENDIF IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF IF nRadio2=2;SELECT Obi_Kpr;PACK;ENDIF IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF aSay[s]:SetCaption(aSay[s++]:caption+L(" - Готово ")) aSay[s]:SetCaption(L("5/9: Перекодирование БД заголовков объектов обуч.выборки")) M_MaxKodObj = 0 Ar_KodObjOld := {} // Коды объектов исходной выборки Ar_KodObjNew := {} // Коды объектов результирующей выборки SELECT Obi_zag // **************************************************** SET FILTER TO RECALL ALL DBGOTOP() DO WHILE .NOT. EOF() IF nRadio2=2 AADD(Ar_KodObjOld, Kod_obj) AADD(Ar_KodObjNew, ++M_MaxKodObj) // Если дополнять БД, то 1-й код следующий за последним REPLACE Kod_obj WITH M_MaxKodObj ENDIF IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF DBSKIP(1) ENDDO aSay[s]:SetCaption(aSay[s++]:caption+L(" - Готово ")) aSay[s]:SetCaption(L("6/9: Перекодирование БД кодов классов объектов обуч.выборки")) SELECT Obi_Kcl // **************************************************** SET FILTER TO RECALL ALL DBGOTOP() DO WHILE .NOT. EOF() IF nRadio2=2 Pos = ASCAN(Ar_KodObjOld, Kod_obj) REPLACE Kod_obj WITH Ar_KodObjNew[Pos] ENDIF IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF DBSKIP(1) ENDDO aSay[s]:SetCaption(aSay[s++]:caption+L(" - Готово ")) aSay[s]:SetCaption(L("7/9: Перекодирование БД кодов признаков объектов обуч.выборки")) SELECT Obi_Kpr // **************************************************** SET FILTER TO RECALL ALL DBGOTOP() DO WHILE .NOT. EOF() IF nRadio2=2 Pos = ASCAN(Ar_KodObjOld, Kod_obj) REPLACE Kod_obj WITH Ar_KodObjNew[Pos] ENDIF IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF DBSKIP(1) ENDDO aSay[s]:SetCaption(aSay[s++]:caption+L(" - Готово ")) aSay[s]:SetCaption(L("8/9: Переиндексация баз данных обучающей выборки")) IF nRadio2=2;GenNtxObiZag();ENDIF IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF IF nRadio2=2;GenNtxObiKcl();ENDIF IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF IF nRadio2=2;GenNtxObiKpr();ENDIF IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF aSay[s]:SetCaption(aSay[s++]:caption+L(" - Готово ")) ENDIF // 5-9 делать и отображать только, если это задано ####################################### aSay[s]:SetCaption(IF(nRadio2=1,'4','9')+"/"+IF(nRadio2=1,'4','9')+L(": Переиндексация баз данных распознаваемой выборки")) GenNtxRsoZag() IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF GenNtxRsoKcl() IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF GenNtxRsoKpr() IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF aSay[s]:SetCaption(aSay[s++]:caption+L(" - Готово ")) IF Dialog aSay[ 1]:SetCaption(aSay[ 1]:caption+L(" - Готово ")) // Заключительные операции и деструктурирование окна отображения графического Progress-bar Running(.T.) // Чтобы не могли запустить какой-нибудь режим пока висит окно окончания работы 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() ELSE FOR j=2 TO IF(nRadio2=1,5,10);aSay[j]:SetCaption(L(" "));NEXT ENDIF DC_DataRest( aSaveCopOR ) // Восстановление вычислительной среды (открытые и текущие БД и индексы) RETURN NIL ************************************************************************************************** FUNCTION Help_OiRo() 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('проверять гипотезу о репрезентативности обучающей выборки по отношению к некоторой ')) AADD(aHelp, L('генеральной совокупности, более широкой, чем она сама. Для расчета внешней достоверности ')) AADD(aHelp, L('модели необходимо скопировать объекты из обучающей выборки в распознаваемую с удалением ')) AADD(aHelp, L('скопированных объектов из обучающей выборки, а затем (в режиме 3.4) выполнить пересинтез ')) AADD(aHelp, L('модели и контрольное распознавание (в режиме 4.1.2), после чего получить отчет по его ')) AADD(aHelp, L('достоверности. Для комплексного исследования внутренней и внешней достоверности всех ')) AADD(aHelp, L('моделей предназначен режим 3.5. Отметим, что при увеличении объема обучающей выборки ')) 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-8, 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.1. Копирование обучающей выборки в распознаваемую') RETURN NIL ************************************************************************************************** ******** Добавить объект в конец БД Obi_Zag.dbf FUNCTION Add_Obj2_3_1() SELECT Obi_Zag DBGOBOTTOM() M_KodObj = Kod_Obj APPEND BLANK REPLACE Kod_Obj WITH M_KodObj+1 REPLACE Date WITH DTOC(DATE()) REPLACE Time WITH Time() Add_Kcl2_3_1() Add_Kpr2_3_1() SELECT Obi_Zag DBGOBOTTOM() DC_GetRefresh(GetList) RETURN NIL ******** Добавить строку классов в конец БД Obi_Kcl.dbf FUNCTION Add_Kcl2_3_1() SELECT Obi_Zag M_KodObj = Kod_Obj SELECT Obi_Kcl APPEND BLANK REPLACE Kod_Obj WITH M_KodObj DBGOTOP() DC_GetRefresh(GetList) RETURN NIL ******** Добавить строку признаков в конец БД Obi_Kpr.dbf FUNCTION Add_Kpr2_3_1() SELECT Obi_Zag M_KodObj = Kod_Obj SELECT Obi_Kpr APPEND BLANK REPLACE Kod_Obj WITH M_KodObj DBGOTOP() DC_GetRefresh(GetList) RETURN NIL ******** Удалить текущую запись в БД Obi_Zag.dbf ******** и связанные с ней записи БД Obi_Kcl.dbf и Obi_Kpr.dbf FUNCTION Del_Obj2_3_1() SELECT Obi_Zag M_Recno = RECNO() M_Kod_obj = Kod_Obj DELETE PACK // Удалить связанные БД SELECT Obi_Kcl DELETE FOR M_Kod_obj = Kod_Obj PACK SELECT Obi_Kpr DELETE FOR M_Kod_obj = Kod_Obj PACK SELECT Obi_Zag DBGOTO(M_Recno) RETURN NIL ******** Удалить текущую запись в БД Obi_Kcl.dbf FUNCTION Del_Kcl2_3_1() SELECT Obi_Kcl M_Recno = RECNO() DELETE PACK DBGOTO(M_Recno) RETURN NIL ******** Удалить текущую запись в БД Obi_Kpr.dbf FUNCTION Del_Kpr2_3_1() SELECT Obi_Kpr M_Recno = RECNO() DELETE PACK DBGOTO(M_Recno) RETURN NIL ******** Очистить БД FUNCTION Zap_db2_3_1() SELECT Obi_Zag;ZAP APPEND BLANK REPLACE Kod_Obj WITH 1 REPLACE Date WITH DTOC(DATE()) REPLACE Time WITH Time() SELECT Obi_Kcl;ZAP APPEND BLANK REPLACE Kod_Obj WITH 1 SELECT Obi_Kpr;ZAP APPEND BLANK REPLACE Kod_Obj WITH 1 RETURN NIL ******** Генерация БД заголовков обучающей выборки FUNCTION GenDbfObiZag() aSaveGenDbf := DC_DataSave() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций cFileName := "Obi_Zag.dbf" aStructure := { { "Kod_Obj" , "N", 15, 0 }, ; { "Name_Obj", "C",250, 0 }, ; { "Date" , "C", 10, 0 }, ; { "Time" , "C", 8 , 0 } } DbCreate( cFileName, aStructure ) GenNtxObiZag() * DC_DataRest( aSaveGenDbf ) RETURN NIL ******** Генерация БД кодов классов обучающей выборки FUNCTION GenDbfObiKcl() aSaveGenDbf := DC_DataSave() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций cFileName := "ObI_Kcl.dbf" aStructure := { { "Kod_Obj" , "N", 15, 0 }, ; { "Cls1" , "N", 15, 0 }, ; { "Cls2" , "N", 15, 0 }, ; { "Cls3" , "N", 15, 0 }, ; { "Cls4" , "N", 15, 0 } } DbCreate( cFileName, aStructure ) GenNtxObiKcl() * DC_DataRest( aSaveGenDbf ) RETURN NIL ******** Генерация БД кодов признаков обучающей выборки FUNCTION GenDbfObiKpr() aSaveGenDbf := DC_DataSave() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций cFileName := "Obi_Kpr.dbf" aStructure := { { "Kod_Obj", "N", 15, 0 }, ; { "Atr1" , "N", 15, 0 }, ; { "Atr2" , "N", 15, 0 }, ; { "Atr3" , "N", 15, 0 }, ; { "Atr4" , "N", 15, 0 }, ; { "Atr5" , "N", 15, 0 }, ; { "Atr6" , "N", 15, 0 }, ; { "Atr7" , "N", 15, 0 } } DbCreate( cFileName, aStructure ) GenNtxObiKpr() * DC_DataRest( aSaveGenDbf ) RETURN NIL ******** Создание индексных массивов БД заголовков объектов обучающей выборки FUNCTION GenNtxObiZag() aSaveGN7 := DC_DataSave() IF .NOT. FILE("Obi_Zag.dbf") GenDbfOpSc(.F.) ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Obi_Zag EXCLUSIVE NEW INDEX ON STR(Kod_Obj,15) TO Oiz_kod INDEX ON Name_Obj TO Oiz_name INDEX ON Kod_Obj TO Obi_Zag CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций *DC_DataRest( aSaveGN7 ) RETURN NIL ******** Создание индексных массивов БД кодов классов обучающей выборки FUNCTION GenNtxObiKcl() aSaveGN8 := DC_DataSave() IF .NOT. FILE("Obi_Kcl.dbf") GenDbfObiKcl() ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Obi_Kcl EXCLUSIVE NEW INDEX ON STR(Kod_Obj,19) TO Oic_kod INDEX ON Kod_Obj TO Obi_Kcl CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций *DC_DataRest( aSaveGN8 ) RETURN NIL ******** Создание индексных массивов БД кодов признаков обучающей выборки FUNCTION GenNtxObiKpr() aSaveGN9 := DC_DataSave() IF .NOT. FILE("Obi_Kpr.dbf") GenDbfObiKpr() ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Obi_Kpr EXCLUSIVE NEW INDEX ON STR(Kod_Obj,19) TO Oip_kod INDEX ON Kod_Obj TO Obi_Kpr CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций *DC_DataRest( aSaveGN9 ) // С включенным ADS DC_DataRest() не работает!!! RETURN NIL *********************************************************************************************************************************** ******** 5.1. Конвертер моделей Abs,Prc#,Inf# => CSV ******** Преобразование статистических Abs, Prc1, Prc2 и системно когнитивных моделей Inf1, Inf2, Inf3, Inf4, Inf5, Inf6, Inf7 ******** из стандарта TXT в стандарт CSV. Особенно это может пригодиться для кластеризации в системе IBM SPSS Statistics ******** 27.0.1 IF026. Преобразование происходит без ограничений на размерность модели (количество классов и количество признаков), ******** т.е. для Big Data *********************************************************************************************************************************** FUNCTION F5_1() LOCAL GetList := {}, GetOptions Running(.T.) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF ApplChange("5.1()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL 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.1. Конвертер моделей Abs,Prc#,Inf# => CSV')) 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 ********************************************************************************************************************** PRIVATE aModels[LEN(Ar_Model)] AFILL(aModels, .F.) aModels[6] = .T. // Диалог задания моделей расчета матриц сходства классов @ 0,0 DCGROUP oGroup1 CAPTION L('Задайте модели для конвертирования TXT => CSV:') SIZE 82,13.5 @ 1,1 DCSAY L('Статистические базы:') PARENT oGroup1 @ 2,3 DCCHECKBOX aModels[ 1] PROMPT L('1. ABS - частный критерий: количество встреч сочетаний: "класс-признак" у объектов обуч.выборки') PARENT oGroup1 @ 3,3 DCCHECKBOX aModels[ 2] PROMPT L('2. PRC1 - частный критерий: усл. вероятность i-го признака среди признаков объектов j-го класса ') PARENT oGroup1 @ 4,3 DCCHECKBOX aModels[ 3] PROMPT L('3. PRC2 - частный критерий: условная вероятность i-го признака у объектов j-го класса ') PARENT oGroup1 @ 5.2,1 DCSAY L('Системно-когнитивные модели (Базы знаний):') PARENT oGroup1 @ 6,3 DCCHECKBOX aModels[ 4] PROMPT L('4. INF1 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC1 ') PARENT oGroup1 @ 7,3 DCCHECKBOX aModels[ 5] PROMPT L('5. INF2 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC2 ') PARENT oGroup1 @ 8,3 DCCHECKBOX aModels[ 6] PROMPT L('6. INF3 - частный критерий: Xи-квадрат, разности между фактическими и ожидаемыми абс.частотами ') PARENT oGroup1 @ 9,3 DCCHECKBOX aModels[ 7] PROMPT L('7. INF4 - частный критерий: ROI (Return On Investment); вероятности из PRC1 ') PARENT oGroup1 @10,3 DCCHECKBOX aModels[ 8] PROMPT L('8. INF5 - частный критерий: ROI (Return On Investment); вероятности из PRC2 ') PARENT oGroup1 @11,3 DCCHECKBOX aModels[ 9] PROMPT L('9. INF6 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC1 ') PARENT oGroup1 @12,3 DCCHECKBOX aModels[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('5.1. Конвертер моделей Abs,Prc#,Inf# => CSV') 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 ********************************************************************************************************************** ***** Копировать txt=>dbf mLenNameMax = CreateStructAll() // Создание файлов структур баз данных всех моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() // Количество классов (градаций классификационных шкал) USE Attributes EXCLUSIVE NEW;N_Gos = RECCOUNT() // Количество признаков (градаций описательных шкал) 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") * ########################################################################### // Открытие текстовых баз данных ******************************************** *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() // Количество классов (градаций классификационных шкал) USE Attributes EXCLUSIVE NEW;N_Gos = RECCOUNT() // Количество признаков (градаций описательных шкал) ************************************************************************************** mNModels := 0 FOR j=1 TO LEN(Ar_Model) IF aModels[j] mNModels++ ENDIF NEXT IF mNModels = 0 LB_Warning(L('Задайте хоть одну модель для конвертирования!'), L('5.1. Конвертер моделей Abs,Prc#,Inf# => CSV')) ELSE nMax = N_Gos * mNModels Mess = L('Копирование основных баз данных моделей: Abs, Prc#, Inf#: TXT => CSV') @ 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 ************************************************************************************** ******** Копирование БД.TXT => БД.CSV ************** aClsName := {} SELECT Classes DBGOTOP() DO WHILE .NOT. EOF() mV = STRTRAN(ALLTRIM(NAME_CLS),',',';') mV = STRTRAN(mV,' ','_') AADD(aClsName, mV) // Локальная кодировка * AADD(aClsName, ConvToAnsiCP(mV)) * AADD(aClsName, ConvToOemCP (mV)) * AADD(aClsName, Str2Unicode (mV)) DBSKIP(1) ENDDO FOR z=1 TO LEN(Ar_Model) IF aModels[z] *** Открыть процесс печати выходной CSV-формы по заданной модели set device to printer;set printer on;set printer to (Ar_Model[z]+'.csv');set console off ***** Наименования колонок ************ ??'Kod_pr,Name' FOR j=1 TO LEN(aClsName) ??','+aClsName[j] NEXT FOR i=1 TO N_Gos ? ALLTRIM(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], i, 1 )) ??','+ALLTRIM(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], i, 2 )) FOR j=1 TO N_Cls ??','+ALLTRIM(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], i, 2+j )) NEXT DC_GetProgress(oProgr, ++nTime, nMax) NEXT ********** Закрыть процесс печати выходной CSV-формы по заданной модели Set device to screen;Set printer off;Set printer to;Set console on ENDIF NEXT DC_GetProgress(oProgr,nMax,nMax) oDial:Destroy() ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций FOR z=1 TO LEN(nHandle) FClose( nHandle[z] ) // Закрытие txt баз данных ###################################### NEXT IF mNModels > 0 aMess := {} AADD(aMess, L('Копирование основных баз данных моделей:')) AADD(aMess, L('Abs,Prc#,Inf#: TXT=>CSV завершено успешно!')) AADD(aMess, L('Результат находится в папке:')) AADD(aMess, M_PathAppl) LB_Warning(aMess, L('5.1. Конвертер моделей Abs,Prc#,Inf# => CSV')) ENDIF ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL *********************************************************************************************************** ********* 5.1. Конвертер приложения: Old => New ********* (отображение стадии процесса с очень точным адаптивным прогнозированием времени исполнения: ********* FUNCTION XSample_56() и XSample_14() xdemo.exe) ********* ВСЕ БД СОРТИРОВАТЬ ПО ВОЗРАСТАНИЮ КОДОВ !!! *********************************************************************************************************** FUNCTION F5_1old() LOCAL GetList := {}, oMainDlg LOCAL oProgress, oDialog, lOk := .t., oButton, nEvent, mp1, mp2, oXbp PUBLIC aSay[10], Mess98, Mess99 Running(.T.) ******** Добавить в БД Appls.dbf запись для нового приложения IF .NOT. FILE("Appls.dbf") LB_Warning(L("отсутствует БД приложений. Перейдите в диспетчер приложений (режим 1.3)!","5.1. Конвертер приложения: Old => New" )) Running(.F.) RETURN NIL ENDIF **SET TAG TO COMMAND aSave_adds := DC_DataSave() // Сохранение вычислительной среды (открытые и текущие БД и индексы) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Appls EXCLUSIVE NEW SELECT Appls DBGOTOP() DO WHILE .NOT. EOF() REPLACE By_default WITH "" DBSKIP(1) ENDDO M_NewAppl = ADD_ZAPPL('Новое приложение, конвертированное из БД системы "ЭЙДОС-12.5". Это название желательно скорректировать') DIRCHANGE(M_ApplsPath) // Перейти в папку с БД приложений IF FILEDATE("OldAppls",16) = CTOD("//") DIRMAKE("OldAppls") Mess = L('В папке с БД приложений "#" не было директории OldAppls для БД старой модели и она была создана!') Mess = STRTRAN(Mess, "#", UPPER(ALLTRIM(M_ApplsPath))) LB_Warning(Mess, L("5.1. Конвертер приложения: Old => New" )) ELSE DIRCHANGE(M_NewAppl) // Перейти в папку с БД новой модели и создать БД формализации предметной области: GenDbfClSc(.F.) // Классификационные шкалы ######### GenDbfGrClSc(.F.) // Градации классификационных шкал ######### GenDbfClass(.F.) // Классификационные шкалы и градации GenDbfOpSc(.F.) // Описательные шкалы GenDbfGrOpSc(.F.) // Градации описательных шкал GenDbfAttr(.F.) // Описательные шкалы и градации ######### GenDbfObiZag() // Заголовки объектов обучающей выборки GenDbfObiKcl() // Коды классов объектов обучающей выборки GenDbfObiKpr() // Коды признаков объектов обучающей выборки GenDbfRsoZag() // Заголовки объектов распознаваемой выборки GenDbfRsoKcl() // Коды классов объектов распознаваемой выборки GenDbfRsoKpr() // Коды признаков объектов распознаваемой выборки DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели и проверить ее наличие IF .NOT. FILE("OBJECT.DBF" ) .OR. ; .NOT. FILE("PRIZ_OB.DBF" ) .OR. ; .NOT. FILE("PRIZ_PER.DBF") .OR. ; .NOT. FILE("PRIZ_PER.DBT") .OR. ; .NOT. FILE("OBINFZAG.DBF") .OR. ; .NOT. FILE("OBINFKPR.DBF") .OR. ; .NOT. FILE("RSANKZAG.DBF") .OR. ; .NOT. FILE("RSANKKPR.DBF") Mess1 = 'В папке старой модели "#\OldAppls" должны быть файлы:' Mess1 = STRTRAN(Mess1, "#", UPPER(ALLTRIM(M_ApplsPath))) Mess2 = 'OBJECT.DBF, PRIZ_OB.DBF, PRIZ_PER.DBF,PRIZ_PER.DBT,' Mess3 = 'OBINFZAG.DBF, OBINFKPR.DBF, RSANKZAG.DBF, RSANKKPR.DBF' Mess4 = 'Скопируйте их из старого приложения и повторите данный режим' DCMSGBOX Mess1, ; Mess2, ; Mess3, ; Mess4 ; TITLE L("Сообщение об ошибке в режиме 5.1"); FONT "10.Arial" ; BUTTONS {'Выйти из режима'} CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы RETURN NIL ENDIF // Подготовка данных для отображения графического прогресс-бар // Определить значение Wsego DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Object EXCLUSIVE NEW;N_Obj = RECCOUNT() USE Priz_ob EXCLUSIVE NEW;N_Pro = RECCOUNT() USE Priz_per EXCLUSIVE NEW;N_Prp = RECCOUNT() USE ObInfZag EXCLUSIVE NEW;N_OiZag = RECCOUNT() // БД используется 2 раза USE ObInfKpr EXCLUSIVE NEW;N_OiKpr = RECCOUNT() USE RsAnkZag EXCLUSIVE NEW;N_RoZag = RECCOUNT() // БД используется 2 раза USE RsAnkKpr EXCLUSIVE NEW;N_RoKpr = RECCOUNT() // Задание максимальной величины параметра Time Wsego = N_Obj + N_Pro + N_Prp + 2*N_OiZag + N_OiKpr + 2*N_RoZag + N_RoKpr // Отображение стадии исполнения. Будет написано прямо в окне 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.5 ; 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 {||lOk:=.T.} OBJECT oButton ; SIZE 7,1.5 DCREAD GUI ; TITLE L('5.1. Конвертер приложения из стандарта БД системы "Эйдос-12.5" в стандарт "Эйдос-Х++"') ; 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("Шаг 1-й из 9. Конвертирование БД классификационных шкал и градаций")) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели USE Object EXCLUSIVE NEW INDEX ON STR(Kod,4) TO Obj_kod CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(M_NewAppl) // Перейти в папку с БД новой модели USE Classes EXCLUSIVE;ZAP DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели USE Object INDEX Obj_kod EXCLUSIVE NEW SELECT Object;SET ORDER TO 1 DBGOTOP() DO WHILE .NOT. EOF() M_Kod = Kod M_Name = Name DIRCHANGE(M_NewAppl) // Перейти в папку с БД новой модели SELECT Classes APPEND BLANK REPLACE Kod_cls WITH M_Kod REPLACE Name_cls WITH M_Name IF M_Kod <> RECNO() Mess = L("При конвертировании справочника классов не совпали коды и номера записей !!!") LB_Warning(Mess) ENDIF DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели SELECT Object DBSKIP(1) lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) ENDDO aSay[ 1]:SetCaption(aSay[ 1]:caption+L(" - Готово ")) // Конвертирование БД описательных шкал и градаций // Шкалы aSay[ 2]:SetCaption(L("Шаг 2-й из 9. Конвертирование БД описательных шкал")) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели USE Priz_ob EXCLUSIVE NEW INDEX ON STR(Kod,4) TO Prob_kod CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(M_NewAppl) // Перейти в папку с БД новой модели USE Opis_Sc EXCLUSIVE;ZAP DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели USE Priz_ob INDEX Prob_kod EXCLUSIVE NEW SELECT Priz_ob;SET ORDER TO 1 DBGOTOP() DO WHILE .NOT. EOF() M_Kod = Kod M_Name = Name DIRCHANGE(M_NewAppl) // Перейти в папку с БД новой модели SELECT Opis_Sc APPEND BLANK REPLACE Kod_OpSc WITH M_Kod REPLACE Name_OpSc WITH M_Name IF M_Kod <> RECNO() Mess = L("При конвертировании описательных шкал не совпали коды и номера записей !!!") LB_Warning(Mess) ENDIF DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели SELECT Priz_ob DBSKIP(1) lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) ENDDO aSay[ 2]:SetCaption(aSay[ 2]:caption+L(" - Готово ")) // Градации aSay[ 3]:SetCaption(L("Шаг 3-й из 9. Конвертирование БД градаций описательных шкал")) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели USE Priz_per EXCLUSIVE NEW INDEX ON STR(Kod_ob_pr,4)+STR(Kod,4) TO Prop_kod CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(M_NewAppl) // Перейти в папку с БД новой модели USE Gr_OpSc EXCLUSIVE;ZAP DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели USE Priz_per INDEX Prop_kod EXCLUSIVE NEW SELECT Priz_per;SET ORDER TO 1 DBGOTOP() DO WHILE .NOT. EOF() M_Kod = Kod M_Name = Name M_KodObPr = Kod_ob_pr DIRCHANGE(M_NewAppl) // Перейти в папку с БД новой модели SELECT Gr_OpSc APPEND BLANK REPLACE Kod_GrOS WITH M_Kod REPLACE Kod_OpSc WITH M_KodObPr REPLACE Name_GrOS WITH M_Name IF M_Kod <> RECNO() Mess = L("При конвертировании градаций описательных шкал не совпали коды и номера записей !!!") LB_Warning(Mess) ENDIF DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели SELECT Priz_per DBSKIP(1) lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) ENDDO aSay[ 3]:SetCaption(aSay[ 3]:caption+L(" - Готово ")) // Конвертирование БД обучающей выборки // Заголовки aSay[ 4]:SetCaption(L("Шаг 4-й из 9. Конвертирование БД заголовков объектов обучающей выборки")) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели USE ObInfZag EXCLUSIVE NEW INDEX ON STR(Kod_ist,19) TO Oiz_kist CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(M_NewAppl) // Перейти в папку с БД новой модели USE Obi_Zag EXCLUSIVE;ZAP DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели USE ObInfZag INDEX Oiz_kist EXCLUSIVE NEW SELECT ObInfZag;SET ORDER TO 1 DBGOTOP() DO WHILE .NOT. EOF() M_KodObj = Kod_ist M_NameObj = Name_ist DIRCHANGE(M_NewAppl) // Перейти в папку с БД новой модели SELECT Obi_Zag APPEND BLANK REPLACE Kod_Obj WITH M_KodObj REPLACE Name_Obj WITH M_NameObj REPLACE Date WITH DTOC(DATE()) REPLACE Time WITH TIME() DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели SELECT ObInfZag DBSKIP(1) lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) ENDDO aSay[ 4]:SetCaption(aSay[ 4]:caption+L(" - Готово ")) // Коды классов aSay[ 5]:SetCaption(L("Шаг 5-й из 9. Конвертирование БД кодов классов объектов обучающей выборки")) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(M_NewAppl) // Перейти в папку с БД новой модели USE Obi_Kcl EXCLUSIVE;ZAP DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели USE ObInfZag EXCLUSIVE NEW DBGOTOP() DO WHILE .NOT. EOF() M_KodObj = Kod_ist Ar_Kcl := {} FOR j=3 TO FCOUNT()-4 Mv = FIELDGET(j) IF Mv > 0 AADD(Ar_Kcl, Mv) ELSE EXIT ENDIF NEXT ****** Запись массива кодов классов из Ar_Kcl[] в БД Obi_Kcl DIRCHANGE(M_NewAppl) // Перейти в папку с БД новой модели SELECT Obi_Kcl APPEND BLANK REPLACE Kod_Obj WITH M_KodObj IF LEN(Ar_Kcl) > 0 k=1 FOR j=1 TO LEN(Ar_Kcl) IF k <= 4 FIELDPUT(1+k++,Ar_Kcl[j]) ELSE k=1 APPEND BLANK REPLACE Kod_Obj WITH M_KodObj FIELDPUT(1+k++,Ar_Kcl[j]) ENDIF NEXT ENDIF DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели SELECT ObInfZag DBSKIP(1) lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) ENDDO aSay[ 5]:SetCaption(aSay[ 5]:caption+L(" - Готово ")) // Коды признаков aSay[ 6]:SetCaption(L("Шаг 6-й из 9. Конвертирование БД кодов признаков объектов обучающей выборки")) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели USE ObInfKpr EXCLUSIVE NEW // Рассортировать старую БД кодов признаков ObInfKpr.dbf по коду источника INDEX ON STR(Kod_ist,19) TO Oik_Kist CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(M_NewAppl) // Перейти в папку с БД новой модели USE Obi_Kpr EXCLUSIVE;ZAP DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели USE ObInfKpr INDEX Oik_Kist EXCLUSIVE NEW SELECT ObInfKpr;SET ORDER TO 1 DBGOTOP() DO WHILE .NOT. EOF() Ar_Kpr := {} M_KodistOld = Kod_ist DO WHILE M_KodistOld = Kod_ist .AND. .NOT. EOF() // Цикл накопления кодов признаков одного объекта M_KodObj = Kod_ist FOR j=2 TO FCOUNT()-1 Mv = FIELDGET(j) IF Mv > 0 AADD(Ar_Kpr, Mv) ENDIF NEXT DBSKIP(1) lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) ENDDO ****** Запись массива кодов признаков из Ar_Kpr[] в БД Obi_Kpr DIRCHANGE(M_NewAppl) // Перейти в папку с БД новой модели SELECT Obi_Kpr APPEND BLANK REPLACE Kod_Obj WITH M_KodObj IF LEN(Ar_Kpr) > 0 k=1 FOR j=1 TO LEN(Ar_Kpr) IF k <= 7 FIELDPUT(1+k++,Ar_Kpr[j]) ELSE k=1 APPEND BLANK REPLACE Kod_Obj WITH M_KodObj FIELDPUT(1+k++,Ar_Kpr[j]) ENDIF NEXT ENDIF DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели SELECT ObInfKpr ENDDO aSay[ 6]:SetCaption(aSay[ 6]:caption+L(" - Готово ")) // Конвертирование БД распознаваемой выборки // Заголовки aSay[ 7]:SetCaption(L("Шаг 7-й из 9. Конвертирование БД заголовков объектов распознаваемой выборки")) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели USE RsAnkZag EXCLUSIVE NEW INDEX ON STR(Kod_ist,19) TO Roz_kist CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(M_NewAppl) // Перейти в папку с БД новой модели USE Rso_Zag EXCLUSIVE;ZAP DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели USE RsAnkZag INDEX Roz_kist EXCLUSIVE NEW SELECT RsAnkZag;SET ORDER TO 1 DBGOTOP() DO WHILE .NOT. EOF() M_KodObj = Kod_ist M_NameObj = Name_ist DIRCHANGE(M_NewAppl) // Перейти в папку с БД новой модели SELECT Rso_Zag APPEND BLANK REPLACE Kod_Obj WITH M_KodObj REPLACE Name_Obj WITH M_NameObj REPLACE Date WITH DTOC(DATE()) REPLACE Time WITH TIME() DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели SELECT RsAnkZag DBSKIP(1) lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) ENDDO aSay[ 7]:SetCaption(aSay[ 7]:caption+L(" - Готово ")) // Коды классов aSay[ 8]:SetCaption(L("Шаг 8-й из 9. Конвертирование БД кодов классов объектов распознаваемой выборки")) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(M_NewAppl) // Перейти в папку с БД новой модели USE Rso_Kcl EXCLUSIVE;ZAP DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели USE RsAnkZag EXCLUSIVE NEW DBGOTOP() DO WHILE .NOT. EOF() M_KodObj = Kod_ist Ar_Kcl := {} FOR j=3 TO FCOUNT()-4 Mv = FIELDGET(j) IF Mv > 0 AADD(Ar_Kcl, Mv) ELSE EXIT ENDIF NEXT ****** Запись массива кодов классов из Ar_Kcl[] в БД Obi_Kcl DIRCHANGE(M_NewAppl) // Перейти в папку с БД новой модели SELECT Rso_Kcl APPEND BLANK REPLACE Kod_Obj WITH M_KodObj IF LEN(Ar_Kcl) > 0 k=1 FOR j=1 TO LEN(Ar_Kcl) IF k <= 4 FIELDPUT(1+k++,Ar_Kcl[j]) ELSE k=1 APPEND BLANK REPLACE Kod_Obj WITH M_KodObj FIELDPUT(1+k++,Ar_Kcl[j]) ENDIF NEXT ENDIF DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели SELECT RsAnkZag DBSKIP(1) lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) ENDDO aSay[ 8]:SetCaption(aSay[ 8]:caption+L(" - Готово ")) // Коды признаков aSay[ 9]:SetCaption(L("Шаг 9-й из 9. Конвертирование БД кодов признаков объектов распознаваемой выборки")) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели USE RsAnkKpr EXCLUSIVE NEW // Рассортировать старую БД кодов признаков RsAnkKpr.dbf по коду источника INDEX ON STR(Kod_ist,19) TO Roz_Kist CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(M_NewAppl) // Перейти в папку с БД новой модели USE Rso_Kpr EXCLUSIVE;ZAP DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели USE RsAnkKpr INDEX Roz_Kist EXCLUSIVE NEW SELECT RsAnkKpr SET ORDER TO 1 DBGOTOP() DO WHILE .NOT. EOF() Ar_Kpr := {} M_KodistOld = Kod_ist DO WHILE M_KodistOld = Kod_ist .AND. .NOT. EOF() // Цикл накопления кодов признаков одного объекта M_KodObj = Kod_ist FOR j=2 TO FCOUNT()-1 Mv = FIELDGET(j) IF Mv > 0 AADD(Ar_Kpr, Mv) ENDIF NEXT DBSKIP(1) lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) ENDDO ****** Запись массива кодов признаков из Ar_Kpr[] в БД Obi_Kpr DIRCHANGE(M_NewAppl) // Перейти в папку с БД новой модели SELECT Rso_Kpr APPEND BLANK REPLACE Kod_Obj WITH M_KodObj IF LEN(Ar_Kpr) > 0 k=1 FOR j=1 TO LEN(Ar_Kpr) IF k <= 7 FIELDPUT(1+k++,Ar_Kpr[j]) ELSE k=1 APPEND BLANK REPLACE Kod_Obj WITH M_KodObj FIELDPUT(1+k++,Ar_Kpr[j]) ENDIF NEXT ENDIF DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели SELECT RsAnkKpr ENDDO aSay[ 9]:SetCaption(aSay[ 9]:caption+L(" - Готово ")) aSay[10]:SetCaption(L('Переиндексация всех БД созданного приложения')) DIRCHANGE(M_NewAppl) // Перейти в папку с БД новой модели и создать БД формализации предметной области: GenNtxClass() // Классификационные шкалы и градации GenNtxOpSc() // Описательные шкалы GenNtxGrOpSc() // Градации описательных шкал GenNtxObiZag() // Заголовки объектов обучающей выборки GenNtxObiKcl() // Коды классов объектов обучающей выборки GenNtxObiKpr() // Коды признаков объектов обучающей выборки GenNtxRsoZag() // Заголовки объектов распознаваемой выборки GenNtxRsoKcl() // Коды классов объектов распознаваемой выборки GenNtxRsoKpr() // Коды признаков объектов распознаваемой выборки aSay[10]:SetCaption(aSay[10]:caption+L(' - Готово ')) Running(.T.) // Чтобы не могли запустить какой-нибудь режим пока висит окно окончания работы 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 ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ******************************************************************************************************************************************** ******** 5.2. Создание классов на основе кластеров. Данный режим обеспечивает создание в файле "Inp_data.csv", аналогичном "Inp_data.xls(x)" ******** новых классификационных шкал, соответствующих уровням иерархии дерева агломеративной кластеризации классов (режим 2.3.2.1), и новых ******** классов, соответствующих кластерам. При вводе данных из файла "Inp_data.csv" в систему "Эйдос" в API-2.3.2.2 могут быть созданы ******** модели многослойных нейронных сетей. Преобразование "Inp_data.csv" => "Inp_data.xlsx(x)" лучше осуществить в онлайн конверторе. ******************************************************************************************************************************************** FUNCTION F5_2() LOCAL GetList := {}, GetOptions Running(.T.) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF ApplChange("5.2()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF dbeSetDefault('DBFNTX') Ar_Model := {"Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } mFlagErr = .F. IF .NOT. FILE('TreeCls.dbf') mFlagErr = .T. aMess := {} AADD(aMess, L('Отсутствуют результаты когнитивной агломеративной кластеризации классов !!!')) AADD(aMess, L('Необходимо провести когнитивную агломеративную кластеризацию классов в режиме 4.2.2.3 !!!')) LB_Warning(aMess, L('5.2. Создание классов на основе кластеров')) ENDIF IF .NOT. FILE('EventsKO.dbf') mFlagErr = .T. aMess := {} AADD(aMess, L('Исходные данные не были введены в систему с помощью API-2.3.2.2 !!!')) AADD(aMess, L('Данный режим предполагает, что был использован именно этот режим!!!')) LB_Warning(aMess, L('5.2. Создание классов на основе кластеров')) 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;N_Cls = RECCOUNT() // Количество классов (градаций классификационных шкал) USE TreeCls EXCLUSIVE NEW;N_TreeCls = RECCOUNT();DBGOBOTTOM();N_Layer = HIERARCHY // Количество уровней иерархии дерева кластеризации - слоев нейронной сети, если считать с нулевого: классы - признаки USE Inp_data EXCLUSIVE NEW USE Class_Sc EXCLUSIVE NEW;N_ClSh = RECCOUNT() USE Gr_ClSc EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Opis_Sc EXCLUSIVE NEW;N_OpSh = RECCOUNT() USE ObI_Kcl EXCLUSIVE NEW;N_ObiKcl = RECCOUNT() USE EventsKO EXCLUSIVE NEW;N_Obj = RECCOUNT() nMax = 2*N_TreeCls + N_ClSh + N_OpSh + N_Cls + 3*N_Obj 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 ************************************************************************************** ********** Сформировать массивы наименований классификационных и описательных шкал и посчитать количество уровней иерархии в дереве кластеризации mLayer *** aClSh_Name := {} // Массив имен классификационных шкал aClustName := {} // Массив имен кластеров и классов aLayer := {} // Номер слоя нейронной сети, если считать с нулевого: классы - признаки AADD(aClSh_Name, 'N1') // Наименования объектов обучающей выборки // Учитывать только те строки в TreeCls, в которых полные, НЕОБРЕЗАННЫЕ наименования кластеров /// <<<===################# mFlagErr = .F. SELECT TreeCls // Учитывать только те строки в TreeCls, в которых полные, необрезанные наименования кластеров DBGOBOTTOM() DO WHILE .NOT. BOF() IF HIERARCHY > 0 mClustName = ALLTRIM(NAMECLS_FU) mLayer = 0 // Посчитать сколько закрывающх скобок в конце наименования кластера - это и есть номер слоя нейронной сети или уровень иерархии дерева FOR s=LEN(mClustName) TO 1 STEP -1 IF SUBSTR(mClustName, s, 1) = ')' mLayer++ ELSE EXIT ENDIF NEXT // Количество закрывающих скобок должно быть равно уровню иерархии, иначе запись не обрабатывать (удалять) IF mLayer <> HIERARCHY mFlagErr = .T. DELETE ENDIF ENDIF DC_GetProgress(oProgr, ++nTime, nMax) // №1: N_TreeCls DBSKIP(-1) ENDDO IF mFlagErr PACK ENDIF DBGOBOTTOM() N_Layer = HIERARCHY * Чтобы коды классов в наименованиях кластеров соответствовали кодам классов в НОВОЙ модели нужно исходные классификационные шкалы * в "Inp_data.xls(x)" должны быть ПЕРЕД новыми шкалами с именами вида: "Layer_##", соответствующими слоям нейронной сети. **************************************************************************************************************************************************** *** Создать базу данных Inp_data_clust.dbf, в которой 1-я колонка содержит информацию об источнике данных (наименования объектов обучающей выборки), *** затем идут старые классификационные шкалы из Inp_data.dbf, после них N_Layer колонок Layer_## соответствуют слоям нейронной сети, *** а потом идут те же самые колонки описательных шкал, что в Inp_data.dbf *** и потом ее и печатать в CSV. В колонках Layer_## значения - наименования кластеров уровней иерархии ## **************************************************************************************************************************************************** SELECT Inp_data aStruInpdata := DbStruct() aStr := {} AADD(aStr, { aStruInpdata[1,1], aStruInpdata[1,2], aStruInpdata[1,3], aStruInpdata[1,4] }) // Наименования объектов обучающей выборки FOR j=1 TO N_ClSh AADD(aStr, { aStruInpdata[1+j,1], aStruInpdata[1+j,2], aStruInpdata[1+j,3], aStruInpdata[1+j,4] }) // Наименования старых классификационных шкал NEXT FOR j=N_Layer TO 1 STEP -1 FieldName = "Layer_"+ALLTRIM(STR(j,15)) AADD(aStr, { FieldName , "C", 250, 0 }) // Наименования новых классификационных шкал, соотвествующих слоям нейронной сети NEXT mOtst = 1+N_ClSh FOR j=1 TO N_OpSh AADD(aStr, { aStruInpdata[1+N_ClSh+j,1], aStruInpdata[1+N_ClSh+j,2], aStruInpdata[1+N_ClSh+j,3], aStruInpdata[1+N_ClSh+j,4] }) // Наименования описательных шкал NEXT DbCreate( 'Inp_data_clust.dbf', aStr ) USE Inp_data_clust EXCLUSIVE NEW ******************************************************************************************************************************* SELECT Class_Sc DBGOTOP() DO WHILE .NOT. EOF() AADD(aClSh_Name, ALLTRIM(NAME_CLSC)) // Наименования классификационных шкал для классов (0-й слой) DC_GetProgress(oProgr, ++nTime, nMax) // №2: N_ClSh DBSKIP(1) ENDDO SELECT TreeCls // Учитывать только те строки в TreeCls, в которых полные, необрезанные наименования кластеров DBGOBOTTOM() DO WHILE .NOT. BOF() IF HIERARCHY > 0 IF .NOT. Deleted() AADD(aClustName, ALLTRIM(NAMECLS_FU)) // Имя кластера - класса IF ASCAN(aClSh_Name, 'Layer_'+ALLTRIM(STR(HIERARCHY))) = 0 AADD (aClSh_Name, 'Layer_'+ALLTRIM(STR(HIERARCHY))) // Наименования классификационных шкал для кластеров AADD(aLayer, HIERARCHY) // Номер слоя нейронной сети, если считать с нулевого: классы - признаки ENDIF ENDIF ENDIF DC_GetProgress(oProgr, ++nTime, nMax) // №1: N_TreeCls DBSKIP(-1) ENDDO * DC_DebugQout( aClustName ) // Отладка <<<===############# aOpSh_Name := {} SELECT Opis_Sc DBGOTOP() DO WHILE .NOT. EOF() AADD(aOpSh_Name, ALLTRIM(NAME_OPSC)) // Наименования описательных шкал для признаков (0-й слой) DC_GetProgress(oProgr, ++nTime, nMax) // №3: N_OpSh DBSKIP(1) ENDDO aClsName := {} SELECT Gr_ClSc DBGOTOP() DO WHILE .NOT. EOF() AADD(aClsName, ALLTRIM(NAME_GRCS)) // Имя кластера - класса DC_GetProgress(oProgr, ++nTime, nMax) // №4: N_Cls DBSKIP(1) ENDDO * LB_Warning(aClsName, L('5.2. Создание классов на основе кластеров')) *** Открыть процесс печати выходной CSV-формы по заданной модели *** IF FILE ('Inp_data.csv') ERASE('Inp_data.csv') ENDIF set device to printer;set printer on;set printer to ('Inp_data.csv');set console off ***** Наименования колонок файла 'Inp_data.csv' ************ FOR j=1 TO LEN(aClSh_Name) ??IF(j>1,',','')+aClSh_Name[j] NEXT FOR j=1 TO LEN(aOpSh_Name) ??','+aOpSh_Name[j] NEXT ****** Вставить все данные из Inp_data.dbf в Inp_data_clust.dbf ************************************************** ****** Сначала колонку с информацией об объектах обучающей выборки, затем старые классификационные шкалы (N_ClSh), ****** а потом шкалы слоев сети, потом все описательные шкалы aVl := {} // Массив значений записи aFn := {} // Массив имен полей записи aClSh_Name[j] SELECT Inp_data DBGOTOP() DO WHILE .NOT. EOF() // Начало цикла по объектам обучающей выборки ***************************************** FOR j=1 TO FCOUNT() AADD(aVl, FIELDGET (j)) AADD(aFn, FIELDNAME(j)) NEXT SELECT Inp_data_clust // <<<===############ Почему-то данные записываются со смещением на 1 и с пропуском шкал слоев APPEND BLANK FOR j=1 TO LEN(aVl) mFn = aFn[j] REPLACE &mFn WITH aVl[j] NEXT DC_GetProgress(oProgr, ++nTime, nMax) // №4: N_Obj SELECT Inp_data DBSKIP(1) ENDDO SELECT EventsKO DBGOTOP() ***************************************************************************************************************************************** DO WHILE .NOT. EOF() // Начало цикла по объектам обучающей выборки ***************************************** mRecno = RECNO() // Коды объектов обучающей выборки aKodCls := {} // Коды классов объекта обучающей выборки FOR j=1 TO N_ClSh mVal = FIELDGET(1+j) IF mVal > 0 AADD(aKodCls, ALLTRIM(STR(mVal))) ENDIF NEXT * При поиске в наименовании кластера находится код класса 2 в наименовании кластера, в котром есть код 12. Это неверно. Это надо исправить <<<===############### * (((9,13),(2,(3,(4,14)))),((5,12),((8,10),(7,(1,(6,11)))))) ((5,12),((8,10),(7,(1,(6,11))))) ((9,13),(2,(3,(4,14)))) ((8,10),(7,(1,(6,11)))) (2,(3,(4,14))) (7,(1,(6,11))) (3,(4,14)) (1,(6,11)) (4,14) (6,11) (9,13) (8,10) (5,12) * DC_DebugQout( aKodCls ) // Отладка <<<===############# SELECT Inp_data_clust // <<<===########################################### FOR kcl = 1 TO LEN(aKodCls) ***** Вставить наименования кластеров в строку, соотвествующую объекту обучающей выборки в колонку, соответствующую слою нейросети ************* FOR ncl=1 TO LEN(aClustName) IF LEN(ALLTRIM(aClustName[ncl])) < 250 // При очень длинных наименованиях кластеров не будет закрывающих скобок и алгоритм не будет работать. Поэтому есть предельная длина наименования кластера * При поиске в наименовании кластера находится код класса 2 в наименовании кластера, в котром есть код 12. Это неверно. Это надо исправить <<<===############### * (((9,13),(2,(3,(4,14)))),((5,12),((8,10),(7,(1,(6,11)))))) ((5,12),((8,10),(7,(1,(6,11))))) ((9,13),(2,(3,(4,14)))) ((8,10),(7,(1,(6,11)))) (2,(3,(4,14))) (7,(1,(6,11))) (3,(4,14)) (1,(6,11)) (4,14) (6,11) (9,13) (8,10) (5,12) mPos1 = AT(','+aKodCls[kcl]+')', aClustName[ncl]) mPos2 = AT('('+aKodCls[kcl]+',', aClustName[ncl]) mPos = mPos1 + mPos2 * MsgBox(STR(mPos)) IF mPos > 0 mLayer = 0 // Посчитать сколько закрывающх скобок в конце наименования кластера - это и есть номер слоя нейронной сети или уровень иерархии дерева FOR s=LEN(aClustName[ncl]) TO 1 STEP -1 IF SUBSTR(aClustName[ncl], s, 1) = ')' mLayer++ ELSE EXIT ENDIF NEXT * MsgBox(aClustName[ncl]+' '+STR(mLayer)) // Если это не первый код класса, то в поле уже может быть наименование кластера, тогда к нему надо ДОБАВИТЬ новое или тоже самое наименование кластера нового класса // В API-2.3.2.2 для классов надо будет делать спец.интерпретацию текстовых полей и вводить по словам (слово - наименование кластера, разделитель - пробел) IF mLayer > 0 mNameLayer = 'Layer_'+ALLTRIM(STR(mLayer)) SELECT Inp_data_clust // <<<===########################################### DBGOTO(mRecno) // Строка mPos = ASCAN(aClSh_Name, mNameLayer) // Колонка IF mPos > 0 mVcn = ALLTRIM(FIELDGET(mPos)) IF LEN(mVcn + ' ' + aClustName[ncl]) < 250 IF mVcn <> aClustName[ncl] // Убрать повторы наименований кластеров FIELDPUT(mPos, mVcn + ' ' + aClustName[ncl]) ENDIF ENDIF ENDIF ENDIF ENDIF ENDIF NEXT NEXT DC_GetProgress(oProgr, ++nTime, nMax) // №5: N_Obj SELECT EventsKO DBGOTO(mRecno) // Строка DBSKIP(1) ENDDO SELECT Inp_data_clust DBGOTOP() DO WHILE .NOT. EOF() ? FOR j=1 TO FCOUNT() mVal = FIELDGET(j) IF VALTYPE(mVal) = 'N' mVal = STR(mVal, FIELDSIZE(j), FIELDDECI(j)) ENDIF ??IF(j>1,',','')+STRTRAN(ALLTRIM(mVal),',','.') NEXT DC_GetProgress(oProgr, ++nTime, nMax) // №6: N_Obj DBSKIP(1) ENDDO ********** Закрыть процесс печати выходной CSV-формы по заданной модели Set device to screen;Set printer off;Set printer to;Set console on * MsgBox('STOP') DC_GetProgress(oProgr,nMax,nMax) oDial:Destroy() ***************************************************************************************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций Name_SS = M_PathAppl+"\Inp_data.csv" Name_DD = Disk_dir+"\AID_DATA\Inp_data\Inp_data.csv" * MsgBox(Name_SS+' '+Name_DD) COPY FILE (Name_SS) TO (Name_DD) * Информация о результатах завершения перекодирования в файле: 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 = *.csv"+CrLf+; "enc_from = cp866"+CrLf+; "enc_to = UTF-8"+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') aHelp := {} AADD(aHelp, L('СОЗДАНИЕ КЛАССОВ НА ОСНОВЕ КЛАСТЕРОВ УСПЕШНО ЗАВЕРШЕНО !!! ')) AADD(aHelp, L(' ')) IF mFlagErr AADD(aHelp, L('ОДНАКО, встретились слишком длинные наименования кластеров, которые не обработаны (слишком много уровней иерархии). ')) AADD(aHelp, L(' ')) ENDIF AADD(aHelp, L('Данный режим позволяет, как ДОПОЛНИТЬ автоматизированное обучение с учителем автоматическим обучением без учителя, ')) AADD(aHelp, L('так и реализовать обучение без учителя в чистом виде. Кроме того в данном режиме создаются исходные данные для моделей')) AADD(aHelp, L('МНОГОСЛОЙНЫХ НЕЙРОННЫХ СЕТЕЙ. В результате работы режима создан файл "Inp_data.csv", аналогичный исходному ')) AADD(aHelp, L('"Inp_data.xls(x)", но с ДОПОЛНИТЕЛЬНЫМИ классификационными шкалами для каждого уровня иерархии дерева агломеративной')) AADD(aHelp, L('кластеризации классов (режим 4.2.2.3), и новыми классами, соответствующими кластерам. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Результирующий файл находится по пути:')+' '+Name_DD+'.') AADD(aHelp, L(' ')) AADD(aHelp, L('Преобразование "Inp_data.csv" => "Inp_data.xls(x)" можно осуществить в MS Excel или в онлайн CSV-XLS конверторе. Но перед')) AADD(aHelp, L('этим необходимо перекодировать этот файл из кодировки OEM866 (DOS) в WIN 65001 (Unicode UTF-8). Это проще всего ')) AADD(aHelp, L('сделать в блокноте или во внешнем конверторе, который можно вызвать, кликнув по кнопке внизу этого окна. При этом ')) AADD(aHelp, L('правильные параметры перекодировщика уже установлены программно. Остается лишь кликнуть "Найти" и "Перекодировать". ')) AADD(aHelp, L('При вводе данных из "Inp_data.csv" в MS Excel НЕОБХОДИМО в числовых колонках поменять десятичные точки на запятые ')) AADD(aHelp, L('(онлайн конверторы обычно это делают сами). ')) AADD(aHelp, L(' ')) AADD(aHelp, L('При вводе данных из файла "Inp_data.xls(x)" в систему "Эйдос" в API-2.3.2.2 могут быть созданы модели МНОГОСЛОЙНЫХ ')) AADD(aHelp, L('НЕЙРОННЫХ СЕТЕЙ. Для этого в API-2.3.2.2 надо создавать модели для каждого слоя, задавая классы предыдущего слоя ')) AADD(aHelp, L('как признаки последующего слоя. Чтобы коды классов в наименованиях кластеров соответствовали кодам классов в НОВОЙ ')) AADD(aHelp, L('модели исходные классификационные шкалы в "Inp_data.xls(x)" поставлены ПЕРЕД новыми шкалами с именами вида: "Layer_##",')) AADD(aHelp, L('соответствующими слоям нейронной сети. После этого можно ввести исходные данные из Inp_data.xls(x) в систему "Эйдос"')) AADD(aHelp, L('в API-2.3.2.2, а затем выполнить синтез и верификацию моделей в режиме 3.5 и далее решать в них различные задачи как')) AADD(aHelp, L('обычно (см. режим 6.4 и хелп режима 1.3). ')) AADD(aHelp, L(' ')) AADD(aHelp, L('ОБУЧЕНИЕ БЕЗ УЧИТЕЛЯ: ')) AADD(aHelp, L('1. Создать модель, в которой каждому объекту обучающей выборки соответствует один класс. ')) AADD(aHelp, L('2. Провести кластерный анализ классов, т.е. выполнить режимы 4.2.2.1 и 4.2.2.3. ')) AADD(aHelp, L('3. Выполнить данный режим. ')) AADD(aHelp, L('4. В файле: "Inp_data.xls(x)" присвоить классам, созданным на основе кластеров, имена, соответствующие их смыслу. ')) AADD(aHelp, L('5. Создать статистические и системно-когнитивные модели и решать в них задачи, как обычно (см. режим 6.4. ')) 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;s=s+d @s,2 DCPUSHBUTTON CAPTION L('Перекодировщик TXT- и CSV-файлов') SIZE LEN(L('Перекодировщик TXT- и CSV-файлов')), 1.5 ACTION {||LC_RunShell("recoder-v3-1-0.exe",1332681493)} DCREAD GUI TO lExit FIT MODAL TITLE L('5.2. Создание классов на основе кластеров') ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL *********************************************************************************************************** ********* 5.2. Конвертер приложения: New => Old ********* Основные базы данных текущего приложения перобразуется к старому стандарту в папку OldAppls *********************************************************************************************************** FUNCTION F5_2old() LOCAL GetList := {}, oMainDlg LOCAL oProgress, oDialog, lOk := .t., oButton, nEvent, mp1, mp2, oXbp PUBLIC aSay[10], Mess98, Mess99 Running(.T.) **SET TAG TO COMMAND aSave_adds := DC_DataSave() // Сохранение вычислительной среды (открытые и текущие БД и индексы) DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения // Удалить и создать папку для старого приложения (это проще, чем стирать файлы внутри нее) DIRCHANGE(M_ApplsPath) // Перейти в папку с БД приложений ZapDir("OldAppls",.T.) DIRMAKE("OldAppls") // Перейти в папку с БД старой модели и создать там файлы баз данных старого стандарта DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") GenDBFobj_old() GenDBFprp_old() GenDBFpro_old() * GenDBFAbs_old() * GenDBFInf_old() GenObiZag_old() // Создание БД обучающей и распознаваемой выборки GenObiKpr_old() // Подготовка данных для отображения графического прогресс-бар // Определить значение Wsego * Classes.dbf => OBJECT.DBF * Opis_Sc.dbf => PRIZ_OB.DBF * Gr_OpSc.dbf => PRIZ_PER.DBF * Obi_Zag.dbf, ObI_Kcl.dbf => OBINFZAG.DBF * Obi_Kpr.dbf => OBINFKPR.DBF * Rso_Zag.dbf, Rso_Kcl.dbf => RSANKZAG.DBF * Rso_Kpr.dbf => RSANKKPR.DBF * Abs.dbf => Abs.dbf // Для запуска модуля визуализации когнитивных функций * Inf.dbf => Inf.dbf DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Opis_Sc EXCLUSIVE NEW;N_OpSc = RECCOUNT() USE Gr_OpSc EXCLUSIVE NEW;N_GrOS = RECCOUNT() USE Obi_Zag EXCLUSIVE NEW;N_OiZag = RECCOUNT() USE ObI_Kcl EXCLUSIVE NEW;N_OiCls = RECCOUNT() USE Obi_Kpr EXCLUSIVE NEW;N_OiKpr = RECCOUNT() USE Rso_Zag EXCLUSIVE NEW;N_RoZag = RECCOUNT() USE Rso_Kcl EXCLUSIVE NEW;N_RoCls = RECCOUNT() USE Rso_Kpr EXCLUSIVE NEW;N_RoKpr = RECCOUNT() USE Abs EXCLUSIVE NEW;N_Abs = RECCOUNT() USE Inf EXCLUSIVE NEW;N_Inf = RECCOUNT() // Задание максимальной величины параметра Time Wsego = N_Cls+N_OpSc+N_GrOS+2*N_OiZag+2*N_RoZag+N_Abs+N_Inf // Отображение стадии исполнения. Будет написано прямо в окне Progress-bar @ 0,0 DCGROUP oGroup1 CAPTION L('Стадии исполнения процесса') FONT "6.Helv" SIZE 105,10.5 ; PARENT oTabPage1 @12,0 DCGROUP oGroup2 CAPTION L('Прогноз времени исполнения') FONT "6.Helv" SIZE 105,5.5 ; PARENT oTabPage2 s = 1 PRIVATE aSay[11] @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++ @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('5.2. Конвертер приложения из стандарта БД системы "Эйдос-Х++" в стандарт "Эйдос-12.5"') ; 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("Шаг 1-й из 9. Конвертирование БД классификационных шкал и градаций")) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели USE Object EXCLUSIVE NEW;ZAP DIRCHANGE(M_PathAppl) // Перейти в папку текущей модели USE Classes EXCLUSIVE NEW SELECT Classes DBGOTOP() DO WHILE .NOT. EOF() M_Kod = FIELDGET(1) M_Name = FIELDGET(2) DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели SELECT Object APPEND BLANK FIELDPUT(1, M_Kod ) FIELDPUT(2, M_Name) DIRCHANGE(M_PathAppl) // Перейти в папку текущей модели SELECT Classes DBSKIP(1) lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) ENDDO aSay[ 1]:SetCaption(aSay[ 1]:caption+L(" - Готово ")) // Конвертирование БД описательных шкал и градаций // Шкалы aSay[ 2]:SetCaption(L("Шаг 2-й из 9. Конвертирование БД описательных шкал")) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели USE Priz_ob EXCLUSIVE NEW;ZAP DIRCHANGE(M_PathAppl) // Перейти в папку текущей модели USE Opis_Sc EXCLUSIVE NEW USE Gr_OpSc EXCLUSIVE NEW SELECT Opis_Sc DBGOTOP() DO WHILE .NOT. EOF() M_Kod = FIELDGET(1) M_Name = FIELDGET(2) SELECT Gr_OpSc SET FILTER TO Kod_OpSc = M_Kod Ar_GrOS := {} DBGOTOP() DO WHILE .NOT. EOF() AADD(Ar_GrOS, Kod_GrOS) DBSKIP(1) ENDDO DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели SELECT Priz_ob APPEND BLANK FIELDPUT(1, M_Kod ) FIELDPUT(2, M_Name) FOR j=1 TO LEN(Ar_GrOS) FIELDPUT(2+j, Ar_GrOS[j]) NEXT DIRCHANGE(M_PathAppl) // Перейти в папку текущей модели SELECT Opis_Sc DBSKIP(1) lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) ENDDO aSay[ 2]:SetCaption(aSay[ 2]:caption+L(" - Готово ")) // Градации aSay[ 3]:SetCaption(L("Шаг 3-й из 9. Конвертирование БД градаций описательных шкал")) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели USE Priz_per EXCLUSIVE NEW;ZAP DIRCHANGE(M_PathAppl) // Перейти в папку текущей модели USE Gr_OpSc EXCLUSIVE NEW SELECT Gr_OpSc DBGOTOP() DO WHILE .NOT. EOF() M_KodOpSc = FIELDGET(1) M_KodGrOS = FIELDGET(2) M_NameGrOS = FIELDGET(3) DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели SELECT Priz_per APPEND BLANK FIELDPUT(1, M_KodGrOS ) FIELDPUT(2, M_NameGrOS) FIELDPUT(3, M_KodOpSc ) DIRCHANGE(M_PathAppl) // Перейти в папку текущей модели SELECT Gr_OpSc DBSKIP(1) lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) ENDDO aSay[ 3]:SetCaption(aSay[ 3]:caption+L(" - Готово ")) // Конвертирование БД обучающей выборки // Заголовки aSay[ 4]:SetCaption(L("Шаг 4-й из 9. Конвертирование БД заголовков и кодов классов объектов обучающей выборки")) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели USE OBINFZAG EXCLUSIVE NEW;ZAP DIRCHANGE(M_PathAppl) // Перейти в папку текущей модели USE Obi_zag EXCLUSIVE NEW USE Obi_kcl EXCLUSIVE NEW SELECT Obi_zag DBGOTOP() DO WHILE .NOT. EOF() M_Kod = FIELDGET(1) M_Name = FIELDGET(2) SELECT Obi_kcl SET FILTER TO Kod_obj = M_Kod Ar_kcl := {} DBGOTOP() DO WHILE .NOT. EOF() FOR j=2 TO 5 Fv = FIELDGET(j) IF Fv > 0 AADD(Ar_kcl, Fv) ENDIF NEXT DBSKIP(1) ENDDO DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели SELECT OBINFZAG APPEND BLANK FIELDPUT(1, M_Kod ) FIELDPUT(2, M_Name) FOR j=1 TO LEN(Ar_kcl) FIELDPUT(2+j, Ar_kcl[j]) NEXT DIRCHANGE(M_PathAppl) // Перейти в папку текущей модели SELECT Obi_zag DBSKIP(1) lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) ENDDO aSay[ 4]:SetCaption(aSay[ 4]:caption+L(" - Готово ")) // Коды признаков aSay[ 5]:SetCaption(L("Шаг 5-й из 9. Конвертирование БД кодов признаков объектов обучающей выборки")) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели USE OBINFKPR EXCLUSIVE NEW;ZAP DIRCHANGE(M_PathAppl) // Перейти в папку текущей модели USE Obi_zag EXCLUSIVE NEW USE Obi_kpr EXCLUSIVE NEW SELECT Obi_zag DBGOTOP() DO WHILE .NOT. EOF() M_Kod = FIELDGET(1) SELECT Obi_kpr SET FILTER TO Kod_obj = M_Kod Ar_kpr := {} DBGOTOP() DO WHILE .NOT. EOF() FOR j=2 TO 8 Fv = FIELDGET(j) IF Fv > 0 AADD(Ar_kpr, Fv) ENDIF NEXT DBSKIP(1) ENDDO * DC_DebugQout( Ar_kpr ) *** Занести массив кодов признаков в БД ObI_Kpr IF LEN(Ar_Kpr) > 0 DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели SELECT OBINFKPR APPEND BLANK FIELDPUT(1, M_Kod ) k=1 FOR j=1 TO LEN(Ar_Kpr) IF k <= 11 FIELDPUT(1+k++,Ar_Kpr[j]) ELSE k=1 APPEND BLANK FIELDPUT(1, M_Kod ) FIELDPUT(1+k++,Ar_Kpr[j]) ENDIF NEXT ENDIF DIRCHANGE(M_PathAppl) // Перейти в папку текущей модели SELECT Obi_zag DBSKIP(1) lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) ENDDO aSay[ 5]:SetCaption(aSay[ 5]:caption+L(" - Готово ")) // Конвертирование БД распознаваемой выборки // Заголовки aSay[ 6]:SetCaption(L("Шаг 6-й из 9. Конвертирование БД заголовков и кодов классов объектов распознаваемой выборки")) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели USE RsAnkZAG EXCLUSIVE NEW;ZAP DIRCHANGE(M_PathAppl) // Перейти в папку текущей модели USE Rso_zag EXCLUSIVE NEW USE Rso_kcl EXCLUSIVE NEW SELECT Rso_zag DBGOTOP() DO WHILE .NOT. EOF() M_Kod = FIELDGET(1) M_Name = FIELDGET(2) SELECT Rso_kcl SET FILTER TO Kod_obj = M_Kod Ar_kcl := {} DBGOTOP() DO WHILE .NOT. EOF() FOR j=2 TO 5 Fv = FIELDGET(j) IF Fv > 0 AADD(Ar_kcl, Fv) ENDIF NEXT DBSKIP(1) ENDDO DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели SELECT RsAnkZAG APPEND BLANK FIELDPUT(1, M_Kod ) FIELDPUT(2, M_Name) FOR j=1 TO LEN(Ar_kcl) FIELDPUT(2+j, Ar_kcl[j]) NEXT DIRCHANGE(M_PathAppl) // Перейти в папку текущей модели SELECT Rso_zag DBSKIP(1) lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) ENDDO aSay[ 6]:SetCaption(aSay[ 6]:caption+L(" - Готово ")) // Коды признаков aSay[ 7]:SetCaption(L("Шаг 7-й из 9. Конвертирование БД кодов признаков объектов распознаваемой выборки")) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели USE RsAnkKPR EXCLUSIVE NEW;ZAP DIRCHANGE(M_PathAppl) // Перейти в папку текущей модели USE Rso_zag EXCLUSIVE NEW USE Rso_kpr EXCLUSIVE NEW SELECT Rso_zag DBGOTOP() DO WHILE .NOT. EOF() M_Kod = FIELDGET(1) SELECT Rso_kpr SET FILTER TO Kod_obj = M_Kod Ar_kpr := {} DBGOTOP() DO WHILE .NOT. EOF() FOR j=2 TO 8 Fv = FIELDGET(j) IF Fv > 0 AADD(Ar_kpr, Fv) ENDIF NEXT DBSKIP(1) ENDDO * DC_DebugQout( Ar_kpr ) *** Занести массив кодов признаков в БД ObI_Kpr IF LEN(Ar_Kpr) > 0 DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели SELECT RsAnkKPR APPEND BLANK FIELDPUT(1, M_Kod ) k=1 FOR j=1 TO LEN(Ar_Kpr) IF k <= 11 FIELDPUT(1+k++,Ar_Kpr[j]) ELSE k=1 APPEND BLANK FIELDPUT(1, M_Kod ) FIELDPUT(1+k++,Ar_Kpr[j]) ENDIF NEXT ENDIF DIRCHANGE(M_PathAppl) // Перейти в папку текущей модели SELECT Rso_zag DBSKIP(1) lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) ENDDO aSay[ 7]:SetCaption(aSay[ 7]:caption+L(" - Готово ")) aSay[ 8]:SetCaption(L("Шаг 8-й из 9. Конвертирование БД абсолютных частот Abs.dbf")) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели GenDBFAbs_old() USE Abs_old EXCLUSIVE NEW;ZAP DIRCHANGE(M_PathAppl) // Перейти в папку текущей модели USE Abs EXCLUSIVE NEW SELECT Abs DBGOTOP() DO WHILE .NOT. EOF() Ar := {} FOR j=1 TO FCOUNT() AADD(Ar, FIELDGET(j)) NEXT DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели SELECT Abs_old APPEND BLANK FIELDPUT(1, Ar[1]) FOR j=3 TO LEN(Ar) FIELDPUT(j-1, Ar[j]) NEXT DIRCHANGE(M_PathAppl) // Перейти в папку текущей модели SELECT Abs DBSKIP(1) lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) ENDDO aSay[ 8]:SetCaption(aSay[ 8]:caption+L(" - Готово ")) aSay[ 9]:SetCaption(L("Шаг 9-й из 9. Конвертирование БД абсолютных частот Inf.dbf")) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели GenDBFInf_old() USE Inf_old EXCLUSIVE NEW;ZAP DIRCHANGE(M_PathAppl) // Перейти в папку текущей модели USE Inf EXCLUSIVE NEW SELECT Inf DBGOTOP() DO WHILE .NOT. EOF() Ar := {} FOR j=1 TO FCOUNT() AADD(Ar, FIELDGET(j)) NEXT DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели SELECT Inf_old APPEND BLANK FIELDPUT(1, Ar[1]) FOR j=3 TO LEN(Ar) FIELDPUT(j-1, Ar[j]) NEXT DIRCHANGE(M_PathAppl) // Перейти в папку текущей модели SELECT Inf DBSKIP(1) lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) ENDDO aSay[ 9]:SetCaption(aSay[ 9]:caption+L(" - Готово ")) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(UPPER(ALLTRIM(M_ApplsPath))+"\OldAppls") // Перейти в папку с БД старой модели RenameFile( "Abs_old.dbf", "Abs.dbf" ) RenameFile( "Inf_old.dbf", "Inf.dbf" ) DIRCHANGE(M_PathAppl) // Перейти в папку текущей модели Running(.T.) // Чтобы не могли запустить какой-нибудь режим пока висит окно окончания работы 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() ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL *********************************************************************************************************** ****** Графический прогресс-бар (на основе примера XSample_14() xdemo.exe) *********************************************************************************************************** FUNCTION Time_Progress(Time_Progress, Wsego, oProgress, lOk ) LOCAL nMaxCount := Wsego xtime = Time_Progress ** Отображение занимает очень много времени, поэтому показывать прогресс не чаще чем через 0.1 секунды (как в PercTimeVisio()) * T2tp = (DOY(DATE())-1)*86400+SECONDS() // Текущее время * IF T2tp - T1tp > 0.1 .OR. xtime = Wsego // Время в секундах или 100% * aSay[mPTVnumb]:SetCaption(mPTVmess+' '+ALLTRIM(STR(mNumPP/Wsego*100,15,7))+'%') *** Индикация времени исполнения ***** Процесс может идти больше суток, поэтому для определения ***** во всех случаях вычисляется время, прошедшее с начала года * T_Mess1 = "Начало:"+" "+TIME() // Начало ***** Прошло секунд с начала процесса PUBLIC T_Mess2 := "ch:mi:se" 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 // Секунды T_Mess2 = "Прошло:"+" "+ALLTRIM(STRTRAN(T_Mess2,"ch",STR(ch2,19))) T_Mess2 = STRTRAN(T_Mess2,"mi",STRTRAN(STR(mm2,2)," ","0")) T_Mess2 = STRTRAN(T_Mess2,"se",STRTRAN(STR(cc2,2)," ","0")) *@19,2 SAY T_Mess2+" всего: "+ALLTRIM(STR(Sec_2,17))+" сек." PUBLIC T_Mess3 := "ch:mi:se" // Осталось Sec_3 = Sec_2*Wsego/xtime // Прогн.длит.исп. в секундах ch3 = INT(Sec_3/3600) // Часы mm3 = INT(Sec_3/60)-ch3*60 // Минуты cc3 = Sec_3-ch3*3600-mm3*60 // Секунды T_Mess3 = ALLTRIM(STRTRAN(T_Mess3,"ch",STR(ch3,19))) T_Mess3 = STRTRAN(T_Mess3,"mi",STRTRAN(STR(mm3,2)," ","0")) T_Mess3 = STRTRAN(T_Mess3,"se",STRTRAN(STR(cc3,2)," ","0")) *@20,2 SAY T_Mess3+" всего: "+ALLTRIM(STR(Sec_3,17))+" сек." PUBLIC T_Mess4 := "ch:mi:se" // Окончание Sec_4 = Sec_1 + Sec_3 - (DOY(DATE())-1)*86400 ch4 = INT(Sec_4/3600) // Часы mm4 = INT(Sec_4/60)-ch4*60 // Минуты cc4 = Sec_4-ch4*3600-mm4*60 // Секунды T_Mess4 = "Окончание:"+" "+ALLTRIM(STRTRAN(T_Mess4,"ch",STR(ch4,19))) T_Mess4 = STRTRAN(T_Mess4,"mi",STRTRAN(STR(mm4,2)," ","0")) T_Mess4 = STRTRAN(T_Mess4,"se",STRTRAN(STR(cc4,2)," ","0")) *@21,2 SAY T_Mess4+" всего: "+ALLTRIM(STR(Sec_4,17L())+" сек.с нач.суток") PUBLIC T_Mess5 := "Средн.время обработки 1-го объекта: ch:mi:se" Sec_5 = Sec_2/xtime ch5 = INT(Sec_5/3600) // Часы mm5 = INT(Sec_5/60)-ch5*60 // Минуты cc5 = Sec_5-ch5*3600-mm5*60 // Секунды T_Mess5 = ALLTRIM(STRTRAN(T_Mess5,"ch",STR(ch5,19))) T_Mess5 = STRTRAN(T_Mess5,"mi",STRTRAN(STR(mm5,2)," ","0")) T_Mess5 = STRTRAN(T_Mess5,"se",STRTRAN(STR(cc5,2)," ","0")) *@22,2 SAY T_Mess5+" всего: "+ALLTRIM(STR(Sec_5,17))+" сек." PUBLIC T_Mess6 := "ch:mi:se" // Осталось Sec_6 = Sec_3 - Sec_2 ch6 = INT(Sec_6/3600) // Часы mm6 = INT(Sec_6/60)-ch6*60 // Минуты cc6 = Sec_6-ch6*3600-mm6*60 // Секунды T_Mess6 = "Осталось:"+" "+ALLTRIM(STRTRAN(T_Mess6,"ch",STR(ch6,19))) T_Mess6 = STRTRAN(T_Mess6,"mi",STRTRAN(STR(mm6,2)," ","0")) T_Mess6 = STRTRAN(T_Mess6,"se",STRTRAN(STR(cc6,2)," ","0")) *@23,2 SAY T_Mess6+" всего: "+ALLTRIM(STR(Sec_6,17))+" сек." Mess98 = T_Mess1+SPACE(142-LEN(T_Mess1)-LEN(T_Mess4))+T_Mess4 // Начало, окончание (прогноз) 145 oSay98:SetCaption(Mess98);oSay98:SetCaption(oSay98:caption) // <<<===##################### ERROR после F2_3_2_2() Mess99 = T_Mess2+SPACE(144-LEN(T_Mess2)-LEN(T_Mess6))+T_Mess6 // Прошло, осталось (прогноз) 146 oSay99:SetCaption(Mess99);oSay99:SetCaption(oSay99:caption) // <<<===##################### ERROR после F2_3_2_2() DC_GetProgress( oProgress, Time_Progress, Wsego ) // Отображение графического Progress-bar * Sec_1 // Начало * Sec_4 // Окончание * Sec_2 // Прошло секунд с начала процесса * Sec_6 // Осталось секунд до окончания * mTimeProgress=ROUND(Sec_2/(Sec_2+Sec_6)*100,0) * DC_GetProgress( oProgress, mTimeProgress, 100 ) // Отображение графического Progress-bar * DC_GetProgress( oProgress, ROUND(Sec_2,0), ROUND(Sec_2+Sec_6,0) ) // Отображение графического Progress-bar * MsgBox(STR(ROUND(Sec_2,0))+STR(ROUND(Sec_2+Sec_6,0))) * MsgBox(STR(mTimeProgress)) * MILLISEC(1000) * K=100/Wsego;mTimeProgress=ROUND(K*Time_Progress,0) * DC_GetProgress( oProgress, mTimeProgress, 100 ) // Отображение графического Progress-bar DC_AppEvent( @lOk, 0, .01 ) * T1tp = T2tp * ENDIF RETURN lOk ****************************************************************************************************************************************** FUNCTION DC_GetProgress( oProgress, nCurrCount, nMaxCount, nEvery, lBar ) LOCAL nX, aSize, aAttr[ GRA_AA_COUNT], lClear, lVertical, aPoints, ; aAttrS[ GRA_AS_COUNT ], aPos, aPos2[2], nPercent, cPercent, ; nWidth, nHeight, nOldPercent IF Valtype(oProgress) # 'O' RETURN nil ELSE DEFAULT nCurrCount := 0 DEFAULT nMaxCount := oProgress:maxCount DEFAULT nEvery := oProgress:every DEFAULT lVertical := oProgress:vertical IF nEvery > 0 .AND. nCurrCount % Int(nEvery) # 0 .AND. ; Valtype(nMaxCount) = 'N' .AND. nCurrCount < nMaxCount RETURN nil ENDIF ENDIF DEFAULT lBar := .t. IF nMaxCount = 0 nPercent := 0 ELSE nPercent := nCurrCount/nMaxCount ENDIF IF nMaxCount == 0 nOldPercent := 0 ELSE nOldPercent := oProgress:currCount/nMaxCount ENDIF lClear := nCurrCount <= oProgress:currCount IF Valtype(nMaxCount) = 'N' oProgress:maxCount := nMaxCount ELSE nMaxCount := oProgress:maxCount ENDIF IF lBar IF lVertical aSize := { oProgress:currentSize()[2], oProgress:currentSize()[1] } ELSE aSize := oProgress:currentSize() ENDIF aSize[1] -= 2 aSize[2] -= 2 IF nMaxCount > 0 nX := aSize[1] * ( nCurrCount / nMaxCount ) ELSE nX := 0 ENDIF nX := Min( nX, aSize[1] ) // Calculate width for rectangle IF nX <= 0 nX := 1 ENDIF IF Valtype(oProgress:presSpace) # 'O' oProgress:presSpace := oProgress:lockPS() ENDIF IF lClear .OR. ( oProgress:percent .AND. !oProgress:dynamic ) .OR. nPercent < .1 aAttr[ GRA_AA_COLOR ] := oProgress:backColor GraSetAttrArea( oProgress:presSpace, aAttr ) GraBox( oProgress:presSpace, {1,1}, ; IIF( lVertical, {aSize[2], aSize[1]},{aSize[1], aSize[2]}), GRA_FILL ) lClear := .T. ENDIF aAttr[ GRA_AA_COLOR ] := oProgress:barColor GraSetAttrArea( oProgress:presSpace, aAttr ) IF Int(nOldPercent*100) # Int(nPercent*100) .OR. lClear GraBox( oProgress:presSpace, {1,1}, ; IIF( lVertical, {aSize[1],nX},{nX, aSize[2]} ), ; IIF( oProgress:outline,GRA_OUTLINEFILL,GRA_FILL ), ; oProgress:radius, oProgress:radius ) ENDIF ENDIF IF oProgress:percent IF lVertical aSize := { oProgress:currentSize()[2], oProgress:currentSize()[1] } ELSE aSize := oProgress:currentSize() ENDIF IF Int(nOldPercent*100) # Int(nPercent*100) .OR. lClear .OR. nCurrCount >= nMaxCount cPercent := Str(100*nPercent,10,5)+"%" aPoints := GraQueryTextBox( oProgress:presSpace, cPercent ) nWidth := aPoints[3,1] - aPoints[1,1] nHeight := aPoints[1,2] - aPoints[2,2] IF oProgress:dynamic aPos2[1] := (nX-nWidth) / 2 IF aPos2[1] < 2 aPos2[1] := 2 ENDIF ELSE aPos2[1] := ( aSize[1] - nWidth ) / 2 ENDIF aPos2[2] := (( aSize[2] - nHeight ) / 2) + 2 IF Valtype( oProgress:percentColor ) == 'N' aAttrs[ GRA_AS_COLOR ] := oProgress:percentColor ENDIF GraSetAttrString( oProgress:presSpace, aAttrS ) GraStringAt( oProgress:presSpace, aPos2, cPercent ) ENDIF ENDIF oProgress:currCount := nCurrCount RETURN .t. ****************************************************************************************************************************************** ******** Ускоренный синтез всех статистических и системно-когнитивных моделей: {Abs, Prc1, Prc2, Inf1, Inf2, Inf3, Inf4, Inf5, Inf6, Inf7} ****************************************************************************************************************************************** FUNCTION F3_1() Running(.T.) F3_5('GPU','Sint','3.1','ALL') ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN lOk ****************************************************************************************************************************************** ******** Верификация всех статистических и системно-когнитивных моделей: {Abs, Prc1, Prc2, Inf1, Inf2, Inf3, Inf4, Inf5, Inf6, Inf7} ******** на графическом процессоре (GPU) с использованием параллельных вычислений ****************************************************************************************************************************************** FUNCTION F3_2() Running(.T.) F3_5('GPU','Rec','3.2','ALL') ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN lOk ******************************************************************************************************************************************************** ******** Ускоренный синтез и верификация всех статистических и системно-когнитивных моделей: {Abs, Prc1, Prc2, Inf1, Inf2, Inf3, Inf4, Inf5, Inf6, Inf7} ******** на графическом процессоре (GPU) с использованием параллельных вычислений ******************************************************************************************************************************************************** FUNCTION F3_3() Running(.T.) F3_5('GPU','SintRec','3.3','ALL') ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN lOk *********************************************************************************************************** FUNCTION F3_4() F4_1_3_6('3.4.') RETURN lOk *********************************************************************************************************** ******** 3.1. Накопление абсолютных частот ############################################################### *********************************************************************************************************** FUNCTION F3_1CPU(Dialog, TP, Ws, oP, lO, Regim ) LOCAL GetList := {}, oMainDlg, lCancelled := .F. LOCAL oProgress, oDialog, lOk := .t., oButton, nEvent, mp1, mp2, oXbp Running(.T.) Time_Progress = TP Wsego = Ws oProgress = oP lOk = lO IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF Dialog IF ApplChange("3.1()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF ELSE IF ApplChange("") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ENDIF IF FILE("Classes.dbf") // БД градаций класс.шкал: Classes.dbf ** Переиндексировать БД Calsses.dbf, если не хватает какого-нибудь индексного массива IF FILE("Cls_kod.ntx" ).AND.; FILE("Cls_name.ntx").AND.; FILE("Cls_ini.ntx" ).AND.; FILE("Cls_abs.ntx" ) ELSE GenNtxClass() ENDIF ****** Если БД Classes.dbf есть, то загрузить ее структуру в массив ELSE GenDbfClass(.F.) ENDIF IF .NOT. FILE("Gr_ClSc.dbf") // БД градаций класс.шкал GenNtxGrClSc() ENDIF IF .NOT. FILE("Attributes.dbf") // БД наименований и градаций описательных шкал GenDbfAttr(.F.) ENDIF IF FILE("Gr_OpSc.dbf") // БД градаций описательных шкал ** Переиндексировать БД Gr_OpSc.dbf, ** если не хватает хотя бы одного какого-нибудь индексного массива IF .NOT. FILE("Gos_kod.ntx" ).OR.; .NOT. FILE("Gos_name.ntx").OR.; .NOT. FILE("Gos_ini.ntx" ).OR.; .NOT. FILE("Gos_abs.ntx") GenNtxGrOpSc() ENDIF ELSE GenDbfGrOpSc(.F.) ENDIF IF FILE("Obi_Zag.dbf") // БД заголовков обучающей выборки ** Переиндексировать БД Obi_Zag.dbf, ** если не хватает хотя бы одного какого-нибудь индексного массива IF .NOT. FILE("Oiz_kod.ntx" ) .OR.; .NOT. FILE("Oiz_name.ntx") .OR.; .NOT. FILE("Obi_Zag.ntx" ) GenNtxObiZag() ENDIF ELSE GenDbfObiZag() ENDIF IF FILE("Obi_Kcl.dbf") // БД классов обучающей выборки ** Переиндексировать БД Obi_Kcl.dbf, ** если не хватает хотя бы одного какого-нибудь индексного массива IF .NOT. FILE("Oic_kod.ntx") .OR.; .NOT. FILE("Obi_Kcl.ntx") GenNtxObiKcl() ENDIF ELSE GenDbfObiKcl() ENDIF IF FILE("Obi_Kpr.dbf") // БД признаков обучающей выборки ** Переиндексировать БД Obi_Kpr.dbf, ** если не хватает хотя бы одного какого-нибудь индексного массива IF .NOT. FILE("Oip_kod.ntx") .OR.; .NOT. FILE("Obi_Kpr.ntx") GenNtxObiKpr() ENDIF ELSE GenDbfObiKpr() ENDIF dbeSetDefault('DBFNTX') CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Gr_OpSc EXCLUSIVE NEW;N_Gos = RECCOUNT() USE Obi_Zag EXCLUSIVE NEW;N_Obj = RECCOUNT() mFlagErr = .F. DO CASE CASE N_Cls = 0 LB_Warning(L("База абсолютных частот не может быть создана, т.к. справочник классов пуст !!!")) mFlagErr = .T. CASE N_Gos = 0 LB_Warning(L("База абсолютных частот не может быть создана, т.к. справочник признаков пуст !!!")) mFlagErr = .T. CASE N_Obj = 0 LB_Warning(L("База абсолютных частот не может быть создана, т.к. обучающая выборка пуста !!!")) mFlagErr = .T. ENDCASE 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 // Подготовка данных для отображения графического прогресс-бар // Определить значение Wsego Wsego = N_Obj + ; // 5/8: Расчет базы абсолютных частот - ABS - Обработка #/$ объекта обучающей выборки N_Cls + ; // 6/8: Занесение информации в БД Abs.dbf по итоговым строкам и столбцам 2*N_Cls + ; // 7/8: Перенос информации из БД Abs.dbf в БД классов Classes и Gr_ClSc 2*N_Gos // 8/8: Перенос информации из БД Abs.dbf в БД признаков Attributes и Gr_OpSc // Отображение стадии исполнения. Будет написано прямо в окне Progress-bar @ 0,0 DCGROUP oGroup1 CAPTION L('Стадии исполнения процесса') FONT "6.Helv" SIZE 105,10.5 ; PARENT oTabPage1 @12,0 DCGROUP oGroup2 CAPTION L('Прогноз времени исполнения') FONT "6.Helv" SIZE 105,5.5 ; PARENT oTabPage2 s = 1 @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('3.1. Формирование базы абсолютных частот'); PARENT @oDialog ; FIT ; EXIT ; MODAL oDialog:show() ENDIF ********************************************************************************* // Стадия исполнения отображается всегда, даже когда задан режим "без диалога" (Dialog=.F.) // Под диалогом понимается диалог задания моделей для синтеза и выбор текущей IF Dialog aSay[ 2]:SetCaption(L('ОПЕРАЦИЯ: СИНТЕЗ СТАТ.МОДЕЛИ "ABS" (РАСЧЕТ МАТРИЦЫ АБСОЛЮТНЫХ ЧАСТОТ):')) ENDIF aSay[ 3]:SetCaption(L("1/8: Создание базы абсолютных частот - ABS")) GenDBFAbs() aSay[ 3]:SetCaption(aSay[ 3]:caption+L(" - Готово ")) aSay[ 4]:SetCaption(L("2/8: Переиндексация базы заголовков объектов обучающей выборки: Obi_Zag.dbf")) GenNtxObiZag() aSay[ 4]:SetCaption(aSay[ 4]:caption+L(" - Готово ")) aSay[ 5]:SetCaption(L("3/8: Переиндексация базы кодов классов объектов обучающей выборки: ObI_Kcl.dbf")) GenNtxObiKcl() aSay[ 5]:SetCaption(aSay[ 5]:caption+L(" - Готово ")) aSay[ 6]:SetCaption(L("4/8: Переиндексация базы кодов признаков объектов обучающей выборки: Obi_Kpr.dbf")) GenNtxObiKpr() aSay[ 6]:SetCaption(aSay[ 6]:caption+L(" - Готово ")) ******************** ПРОЦЕСС ФОРМИРОВАНИЯ БД ABS.DBF mLenNameMax = CreateStructAll() // Создание файлов структур баз данных всех моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Gr_ClSc EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW;N_Gos = RECCOUNT() USE Opis_Sc EXCLUSIVE NEW USE Gr_OpSc EXCLUSIVE NEW USE Obi_Zag INDEX Oiz_kod EXCLUSIVE NEW;N_Obj = RECCOUNT() USE Obi_Kcl INDEX Oic_kod EXCLUSIVE NEW USE Obi_Kpr INDEX Oip_kod EXCLUSIVE NEW * ########################################################################### // Открытие текстовых баз данных ******************************************** *DC_ASave(aStructure, "_AbsStruct.arx") // Когда БД создается - записывать структуру, когда открывается - считывать aInfStruct = DC_ARestore("_AbsStruct.arx") ***** Массивы для учета заполненных строк и столбцов для ускорения просчета ***** "Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" ***** Возможно, если их использовать, изменятся результаты рассчетов (надо проверить) PRIVATE aStrEmpty[N_Gos] // .T., если строка не пустая и .F. - если пустая PRIVATE aColEmpty[N_Cls] // .T., если колонка не пустая и .F. - если пустая AFILL(aStrEmpty,.F.) AFILL(aColEmpty,.F.) 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 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 1 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 * ########################################################################### // Итоговые строки и столбцы PRIVATE Ar_SummaObj[3+N_Cls] // Строка "Сумма числа объектов по классам" AFILL(Ar_SummaObj,0) Summa_Obj = 0 // Сумма Obj по всей БД Abs.txt Summa_Nij = 0 // Сумма Nij по всей БД Abs.txt PRIVATE Ar_Summ_i[N_Gos], Ar_Summ_j[N_Cls+6] // N_Cls + 1-коды, 2-наименования, 3-Summ, 4-Sred, 5-Disp, 6-средн.модулей отклонения от средн. PRIVATE Ar_Sred_i[N_Gos], Ar_Sred_j[N_Cls+6] PRIVATE Ar_Disp_i[N_Gos], Ar_Disp_j[N_Cls+6] PRIVATE Ar_ADMA_i[N_Gos] AFILL(Ar_Summ_i, 0) AFILL(Ar_Summ_j, 0) AFILL(Ar_Sred_i, 0) AFILL(Ar_Sred_j, 0) AFILL(Ar_Disp_i, 0) AFILL(Ar_Disp_j, 0) AFILL(Ar_ADMA_i, 0) IF Dialog // Начало отсчета времени для прогнозирования длительности исполнения 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 ENDIF 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 SET ORDER TO 1 DBGOTOP() Mess = L(' ') ******* Запись фона в ABS ************************** mFonAbs = 0 IF FILE('_FonAbs.txt') * StrFile(ALLTRIM(STR(mFonAbs,19,7)),'_FonAbs.txt') mFonAbs = VAL(FileStr('_FonAbs.txt')) ENDIF IF mFonAbs <> 0 FOR i=1 TO N_Gos For j=1 TO N_Cls String = STR(mFonAbs, 19, 7 ) // Ячейка [i,j]++ Flag_err = LC_FieldPut( Ar_Model[1]+".txt", nHandle[1], i, 2+j, String ) // Запись поля в БД (корректная) ############ Ar_Summ_j[j] = Ar_Summ_j[j] + mFonAbs // Строка "Сумма абс.частот" по столбцам Ar_Summ_i[i] = Ar_Summ_i[i] + mFonAbs // Столбец "Сумма абс.частот" по строкам Summa_Nij = Summa_Nij + mFonAbs // Сумма Nij по всей БД Abs.txt aColEmpty[j] = .T. // .T., если колонка не пустая и .F. - если пустая aStrEmpty[i] = .T. // .T., если строка не пустая и .F. - если пустая NEXT NEXT ENDIF **************************************************** DO WHILE .NOT. EOF() // Начало цикла по объектам обучающей выборки // Стадия исполнения отображается всегда, даже когда задан режим "без диалога" (Dialog=.F.) // Под диалогом понимается диалог задания моделей для синтеза и выбор текущей * aSay[ 7]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(7, mMess, N_ALL) * DC_CompleteEvents() // Обработка события Cancel M_KodObj = Kod_Obj // Код объекта обучающей выборки // Формирование массива кодов признаков текущего объекта обучающей выборки SELECT Obi_Kpr;SET ORDER TO 1;T=DBSEEK(STR(M_KodObj,19)) IF T Ar_Kpr := {} DO WHILE M_KodObj = Kod_Obj .AND. .NOT. EOF() // Начало цикла по записям БД кодов классов текущего объекта FOR j=2 TO 8 M_Kpr = FIELDGET(j) IF VALTYPE(M_Kpr) = "N" IF 0 < M_Kpr .AND. M_Kpr <= N_Gos AADD(Ar_Kpr, M_Kpr) ENDIF ENDIF NEXT DBSKIP(1) ENDDO ENDIF // Формирование массива кодов классов текущего объекта обучающей выборки SELECT Obi_Kcl;SET ORDER TO 1;T=DBSEEK(STR(M_KodObj,19)) IF T Ar_Kcl := {} DO WHILE M_KodObj = Kod_Obj .AND. .NOT. EOF() // Начало цикла по записям БД кодов классов текущего объекта FOR j=2 TO 5 M_Kcl = FIELDGET(j) IF VALTYPE(M_Kcl) = "N" IF 0 < M_Kcl .AND. M_Kcl <= N_Cls AADD(Ar_Kcl, M_Kcl) ENDIF ENDIF NEXT DBSKIP(1) ENDDO ENDIF // Суммирование 1 в ячейки БД Abs.dbf, соответствующие строкам и столбцам, // а также в строку и столбец "Сумма" и строку: Кол-во объектов по классам" IF LEN(Ar_Kcl) > 0 .AND. LEN(Ar_Kpr) > 0 FOR i=1 TO LEN(Ar_Kpr) For j=1 TO LEN(Ar_Kcl) String = LC_FieldGet( Ar_Model[1]+".txt", nHandle[1], Ar_Kpr[i], 2+Ar_Kcl[j] ) // Считывание поля из БД (корректная) ####### String = STR(VAL(String)+1, aInfStruct[2+Ar_Kcl[j],3],aInfStruct[2+Ar_Kcl[j],4] ) // Ячейка [i,j]++ Flag_err = LC_FieldPut( Ar_Model[1]+".txt", nHandle[1], Ar_Kpr[i], 2+Ar_Kcl[j], String ) // Запись поля в БД (корректная) ############ Ar_Summ_j[Ar_Kcl[j]] = Ar_Summ_j[Ar_Kcl[j]] + 1 // Строка "Сумма абс.частот" по столбцам Ar_Summ_i[Ar_Kpr[i]] = Ar_Summ_i[Ar_Kpr[i]] + 1 // Столбец "Сумма абс.частот" по строкам Summa_Nij++ // Сумма Nij по всей БД Abs.txt aColEmpty[Ar_Kcl[j]] = .T. // .T., если колонка не пустая и .F. - если пустая aStrEmpty[Ar_Kpr[i]] = .T. // .T., если строка не пустая и .F. - если пустая NEXT NEXT For j=1 TO LEN(Ar_Kcl) Ar_SummaObj[Ar_Kcl[j]] = Ar_SummaObj[Ar_Kcl[j]] + 1 // Строка "Сумма числа объектов по классам" <<<===############################# Summa_Obj++ // Сумма Obj по всей БД Abs.dbf NEXT ENDIF // Стадия исполнения отображается всегда, даже когда задан режим "без диалога" (Dialog=.F.) // Под диалогом понимается диалог задания моделей для синтеза и выбор текущей IF Regim<>"3_5";lOk = Time_Progress (++Time_progress, Wsego, oProgress, lOk );ENDIF SELECT Obi_zag DBSKIP(1) ENDDO aSay[ 7]:SetCaption(aSay[ 7]:caption+L(" - Готово ")) ************** Прерывание процесса по нажатию 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() * FClose( nHandle[1] ) // Закрытие текстовой базы данных ############################## * ************************************************************** * ***** БД, открытые перед запуском главного меню * ***** Восстанавливать их после выхода из функций главного меню * ************************************************************** * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы * USE PathGrAp EXCLUSIVE NEW * USE Appls EXCLUSIVE NEW * USE Users EXCLUSIVE NEW * ************************************************************** * Running(.F.) * RETURN( Time_Progress ) *ENDIF // Стадия исполнения отображается всегда, даже когда задан режим "без диалога" (Dialog=.F.) // Под диалогом понимается диалог задания моделей для синтеза и выбор текущей aSay[ 8]:SetCaption(L("6/8: Занесение информации в БД Abs.dbf по итоговым строкам и столбцам")) mMess = L("6/8: Занесение информации в БД Abs.dbf по итоговым строкам и столбцам:") mNumPP = 0 N_ALL = N_Cls * №1 DC_ASave(aStrEmpty, "_aStrEmpty.arx") // Записывать только здесь, а при расчете остальных БД только считывать DC_ASave(aColEmpty, "_aColEmpty.arx") *aStrEmpty = DC_ARestore("_aStrEmpty.arx") *aColEmpty = DC_ARestore("_aColEmpty.arx") PostCalcINF(1) // Дорасчет и занесение сумм, средних и ср.кв.откл. // Суммарное кол-во объектов j-го класса. ТОЧНО ТАКЖЕ занести эту информацию в последнюю строку всех моделей Prc#, Inf# FOR j=1 TO N_Cls // №1, N_Cls ################################ * aSay[ 8]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(8, mMess, N_ALL) String = STR(Ar_SummaObj[j], aInfStruct[2+j,3], aInfStruct[2+j,4]) LC_FieldPut( Ar_Model[1]+".txt", nHandle[1], 4+N_Gos, 2+j, String ) // Запись поля в БД (корректная) ############ IF Regim<>"3_5";lOk = Time_Progress (++Time_progress, Wsego, oProgress, lOk );ENDIF NEXT // Сумма числа Obj по всей БД Abs.dbf String = STR(Summa_Obj, aInfStruct[3+N_Cls,3], aInfStruct[3+N_Cls,4]) LC_FieldPut( Ar_Model[1]+".txt", nHandle[1], 4+N_Gos,3+N_Cls, String ) // Запись поля в БД (корректная) ############ aSay[ 8]:SetCaption(aSay[ 8]:caption+L(" - Готово ")) // ########################################################################################################################## aSay[ 9]:SetCaption(L("7/8: Перенос информации из БД Abs.dbf в БД классов Classes и Gr_ClSc")) mMess = L("7/8: Перенос информации из БД Abs.dbf в БД классов Classes и Gr_ClSc:") mNumPP = 0 N_ALL = N_Cls + N_Cls * №1 №2 SELECT Classes FOR j = 1 TO N_Cls // №1, N_Cls ################################ * aSay[ 9]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(9, mMess, N_ALL) DBGOTO(j) REPLACE Abs WITH Ar_SummaObj[j] // Кол-во объектов обучающей выборки, относящихся к j-му классу (абс.) REPLACE Perc_fiz WITH Ar_SummaObj[j]/N_Obj*100 // Кол-во объектов обучающей выборки, относящихся к j-му классу (%) IF Regim<>"3_5";lOk = Time_Progress (++Time_progress, Wsego, oProgress, lOk );ENDIF NEXT SELECT Gr_ClSc FOR j = 1 TO N_Cls // №2, N_Cls ################################ * aSay[ 9]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(9, mMess, N_ALL) DBGOTO(j) REPLACE Abs WITH Ar_SummaObj[j] // Кол-во объектов обучающей выборки, относящихся к j-му классу (абс.) REPLACE Perc_fiz WITH Ar_SummaObj[j]/N_Obj*100 // Кол-во объектов обучающей выборки, относящихся к j-му классу (%) IF Regim<>"3_5";lOk = Time_Progress (++Time_progress, Wsego, oProgress, lOk );ENDIF NEXT aSay[ 9]:SetCaption(aSay[ 9]:caption+L(" - Готово ")) aSay[10]:SetCaption(L("8/8: Перенос информации из БД Abs.dbf в БД признаков Attributes и Gr_OpSc")) mMess = L("8/8: Перенос информации из БД Abs.dbf в БД признаков Attributes и Gr_OpSc:") mNumPP = 0 N_ALL = N_Gos + N_Gos * №1 №2 SELECT Attributes FOR i = 1 TO N_Gos // №1, N_Gos ################################ * aSay[10]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(10, mMess, N_ALL) DBGOTO(i) REPLACE Abs WITH Ar_Summ_i[i] // Кол-во объектов обучающей выборки, имеющих i-й признак (абс.) REPLACE Perc_fiz WITH Ar_Summ_i[i]/N_Obj*100 // Кол-во объектов обучающей выборки, имеющих i-й признак (%) IF Regim<>"3_5";lOk = Time_Progress (++Time_progress, Wsego, oProgress, lOk );ENDIF NEXT SELECT Gr_OpSc FOR i = 1 TO N_Gos // №2, N_Gos ################################ * aSay[10]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(10, mMess, N_ALL) DBGOTO(i) REPLACE Abs WITH Ar_Summ_i[i] // Кол-во объектов обучающей выборки, имеющих i-й признак (абс.) REPLACE Perc_fiz WITH Ar_Summ_i[i]/N_Obj*100 // Кол-во объектов обучающей выборки, имеющих i-й признак (%) IF Regim<>"3_5";lOk = Time_Progress (++Time_progress, Wsego, oProgress, lOk );ENDIF NEXT aSay[10]:SetCaption(aSay[10]:caption+L(" - Готово ")) // ########################################################################################################################## aCalcInf[1] = .T. DC_ASave(aCalcInf, "_CalcInf.arx") // Запись информации о расчете Abs.txt *MsgBox(STR(nRadioModel)) IF nRadioModel = 2 Calc_model_2nd_level(1, 2, nRadModelCr) ENDIF FClose( nHandle[1] ) // Закрытие текстовой базы данных ###################################### IF Dialog aSay[ 2]:SetCaption(aSay[ 2]:caption+L(" - Готово ")) Running(.T.) // Чтобы не могли запустить какой-нибудь режим пока висит окно окончания работы oSay97:SetCaption(L("БАЗА АСБОЛЮТНЫХ ЧАСТОТ ABS.TXT СФОРМИРОВАНА !")) oSay97:SetCaption(oSay97:caption) oButton:SetCaption(L('&Ok')) // Деструктурирование окна отображения графического Progress-bar oButton:activate := {||PostAppEvent(xbeP_Close,,,oDialog)} //<<<<<< Add This DC_AppEvent( @lOk ) oDialog:Destroy() ENDIF ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN( Time_Progress ) ******************************************************** ******** Создание БД абсолютных частот Abs.dbf ******************************************************** FUNCTION GenDBFAbsOld(mLenName) aSaveGenDbf := DC_DataSave() IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF ApplChange("") // Перейти в папку выбранного приложения или выйти из системы LB_Warning(L("Необходимо задать (выбрать) хотя бы одно текущее приложение !!!")) Running(.F.) RETURN NIL ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций IF FILE("Classes.dbf") // БД градаций класс.шкал: Classes.dbf ** Переиндексировать БД Calsses.dbf, если не хватает какого-нибудь индексного массива IF FILE("Cls_kod.ntx" ).AND.; FILE("Cls_name.ntx").AND.; FILE("Cls_ini.ntx" ).AND.; FILE("Cls_abs.ntx" ) ELSE GenNtxClass() ENDIF ****** Если БД Classes.dbf есть, то загрузить ее структуру в массив ELSE GenDbfClass(.F.) ENDIF IF FILE("Opis_Sc.dbf") // БД описательных шкал ** Переиндексировать БД Opis_Sc.dbf, ** если не хватает хотя бы одного какого-нибудь индексного массива IF .NOT. FILE("Ops_kod.ntx" ).OR.; .NOT. FILE("Ops_name.ntx").OR.; .NOT. FILE("Ops_ini.ntx" ).OR.; .NOT. FILE("Ops_abs.ntx" ) GenNtxOpSc() ENDIF ELSE GenDbfOpSc(.F.) ENDIF IF FILE("Gr_OpSc.dbf") // БД градаций описательных шкал ** Переиндексировать БД Gr_OpSc.dbf, ** если не хватает хотя бы одного какого-нибудь индексного массива IF .NOT. FILE("Gos_kod.ntx" ).OR.; .NOT. FILE("Gos_name.ntx").OR.; .NOT. FILE("Gos_ini.ntx" ).OR.; .NOT. FILE("Gos_abs.ntx" ) GenNtxGrOpSc() ENDIF ELSE GenDbfGrOpSc(.F.) ENDIF dbeSetDefault('DBFNTX') IF ApplChange("") // Перейти в папку выбранного приложения или выйти из системы LB_Warning(L("Необходимо задать (выбрать) хотя бы одно текущее приложение !!!")) Running(.F.) RETURN NIL ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Gr_OpSc EXCLUSIVE NEW;N_Gos = RECCOUNT() IF N_Cls * N_Gos = 0 LB_Warning(L("БД абсолютных частот не может быть создана, т.к. БД классов и признаков пусты !!!")) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN(.F.) ENDIF IF N_Cls > 2035 Mess = L('БД абсолютных частот не может быть создана, т.к. в модели # классов, что более 2035 !') Mess = STRTRAN(Mess, "#", ALLTRIM(STR(N_Cls))) LB_Warning(Mess, L('Создание БД абсолютных частот Abs.dbf')) ENDIF *StrFile(ALLTRIM(STR(nRadioModel)), '_Calc_model_2nd_level.txt') mModel_2nd_level = VAL(FileStr('_Calc_model_2nd_level.txt')) // = 1 - создавать только базовые модели, иначе - создавать модели 2-го или 3-го уровней CREATE Struc APPEND BLANK REPLACE Field_name WITH "Kod_Pr",; Field_type WITH "N",; Field_len WITH 15,; Field_dec WITH 0 APPEND BLANK REPLACE Field_name WITH "Name",; Field_type WITH "C",; Field_len WITH mLenName; Field_dec WITH 0 IF mModel_2nd_level = 1 FOR j = 1 TO N_Cls APPEND BLANK REPLACE Field_name WITH "CLS"+ALLTRIM(STR(j,19)),; Field_type WITH "N",; Field_len WITH 19,; Field_dec WITH 7 NEXT ELSE FOR j = 1 TO N_Cls APPEND BLANK REPLACE Field_name WITH "CLS"+ALLTRIM(STR(j,19)),; Field_type WITH "N",; Field_len WITH 19,; Field_dec WITH 7 NEXT ENDIF APPEND BLANK REPLACE Field_name WITH "SUMMA",; Field_type WITH "N",; Field_len WITH 19,; Field_dec WITH 7 APPEND BLANK REPLACE Field_name WITH "SREDN",; Field_type WITH "N",; Field_len WITH 19,; Field_dec WITH 7 APPEND BLANK REPLACE Field_name WITH "DISP",; Field_type WITH "N",; Field_len WITH 19,; Field_dec WITH 7 APPEND BLANK REPLACE Field_name WITH "ADMA",; Field_type WITH "N",; Field_len WITH 19,; Field_dec WITH 7 ****** Создаем базу абсолютных частот CREATE Abs FROM Struc CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций ERASE Struc.dbf ***** Заполнение БД Abs.dbf пустыми записями CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Opis_sc EXCLUSIVE NEW INDEX ON STR(Kod_opsc,19) TO Kod_OpSc CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Gr_OpSc EXCLUSIVE NEW INDEX ON STR(Kod_opsc,19)+STR(Kod_gros,19) TO Kod_GrOs // Вставить наименования: ОПИСАТЕЛЬНАЯ ШКАЛА-градация, шкалы и градации сортировать по их кодам CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Opis_sc INDEX Kod_OpSc EXCLUSIVE NEW USE Gr_OpSc INDEX Kod_GrOs EXCLUSIVE NEW USE Abs EXCLUSIVE NEW FOR i=1 TO N_Gos SELECT Abs APPEND BLANK REPLACE Kod_pr WITH RECNO() M_KodGrOs = Kod_pr SELECT Gr_OpSc;DBGOTO(i) M_NameGrOS = ALLTRIM(Name_GrOS) M_KodOpSc = Kod_OpSc SELECT Opis_Sc;DBGOTO(M_KodOpSc) M_NameOS = UPPER(ALLTRIM(Name_OpSc)) // Если в названии градации уже включено наим.шкалы, то повторно не включать его IF AT(M_NameOS, UPPER(M_NameGrOS)) = 0 M_Name = M_NameOS+"-"+M_NameGrOS ELSE M_Name = M_NameGrOS ENDIF SELECT Abs REPLACE Name WITH M_Name NEXT APPEND BLANK // Запись N_Gos+1 - строка: "Сумма", REPLACE Name WITH "Сумма числа признаков" *FOR j=3 TO FCOUNT();FIELDPUT(j,0);NEXT APPEND BLANK // Запись N_Gos+2 - "Среднее" REPLACE Name WITH "Среднее" *FOR j=3 TO FCOUNT();FIELDPUT(j,0);NEXT APPEND BLANK // Запись N_Gos+3 - "Среднеквадратичное отклонение", "Редукция класса" REPLACE Name WITH "Среднеквадратичное отклонение" *FOR j=3 TO FCOUNT();FIELDPUT(j,0);NEXT APPEND BLANK // Запись N_Gos+4 - Количество объектов обучающей выборки,относящихся к данному классу REPLACE Name WITH "Сумма числа объектов обуч.выборки" *FOR j=3 TO FCOUNT();FIELDPUT(j,0);NEXT DC_DataRest( aSaveGenDbf ) Running(.F.) RETURN(.T.) ******************************************************** ******** Создание БД абсолютных частот Abs.txt ######### ******************************************************** FUNCTION GenDBFAbs() aSaveGenDbf := DC_DataSave() IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF ApplChange("") // Перейти в папку выбранного приложения или выйти из системы LB_Warning(L("Необходимо задать (выбрать) хотя бы одно текущее приложение !!!")) Running(.F.) RETURN NIL ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций IF FILE("Classes.dbf") // БД градаций класс.шкал: Classes.dbf ** Переиндексировать БД Calsses.dbf, если не хватает какого-нибудь индексного массива IF FILE("Cls_kod.ntx" ).AND.; FILE("Cls_name.ntx").AND.; FILE("Cls_ini.ntx" ).AND.; FILE("Cls_abs.ntx" ) ELSE GenNtxClass() ENDIF ****** Если БД Classes.dbf есть, то загрузить ее структуру в массив ELSE GenDbfClass(.F.) ENDIF IF FILE("Opis_Sc.dbf") // БД описательных шкал ** Переиндексировать БД Opis_Sc.dbf, ** если не хватает хотя бы одного какого-нибудь индексного массива IF .NOT. FILE("Ops_kod.ntx" ).OR.; .NOT. FILE("Ops_name.ntx").OR.; .NOT. FILE("Ops_ini.ntx" ).OR.; .NOT. FILE("Ops_abs.ntx" ) GenNtxOpSc() ENDIF ELSE GenDbfOpSc(.F.) ENDIF IF FILE("Gr_OpSc.dbf") // БД градаций описательных шкал ** Переиндексировать БД Gr_OpSc.dbf, ** если не хватает хотя бы одного какого-нибудь индексного массива IF .NOT. FILE("Gos_kod.ntx" ).OR.; .NOT. FILE("Gos_name.ntx").OR.; .NOT. FILE("Gos_ini.ntx" ).OR.; .NOT. FILE("Gos_abs.ntx" ) GenNtxGrOpSc() ENDIF ELSE GenDbfGrOpSc(.F.) ENDIF dbeSetDefault('DBFNTX') mLenNameMax = CreateStructAll() // Создание файлов структур баз данных всех моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Attributes EXCLUSIVE NEW;N_Atr = RECCOUNT() USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Gr_OpSc EXCLUSIVE NEW;N_Gos = RECCOUNT() USE Opis_sc EXCLUSIVE NEW IF N_Cls * N_Gos = 0 LB_Warning(L("БД абсолютных частот не может быть создана, т.к. БД классов и признаков пусты !!!")) * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы Running(.F.) RETURN(.F.) ENDIF * ########################################################################### *DC_ASave(aInfStruct, "_AbsStruct.arx") // Когда БД создается - записывать структуру, когда открывается - считывать aInfStruct = DC_ARestore("_AbsStruct.arx") ************************************************* DB_name = "Abs.txt" nHandle := FCreate( DB_name, FC_NORMAL ) // Создание БД (если она была, то все равно создается пустая) IF nHandle = -1 MsgBox(L("Файл: "+DB_name+" не может быть создан. Ошибка: ")+FERROR()) RETURN NIL ENDIF ***** Формирование пустой записи 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) LC_DbCreate( DB_name, nHandle, Lc_buf, N_Gos+4 ) // Создание БД.txt, содержащей N_Rec пустых записей ################ для ABS с фоновым значением *nHandle := FOpen( DB_name, 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 * ########################################################################### // Вставить наименования: ОПИСАТЕЛЬНАЯ ШКАЛА-градация, шкалы и градации сортировать по их кодам CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Opis_sc EXCLUSIVE NEW USE Gr_OpSc EXCLUSIVE NEW FOR i=1 TO N_Gos String = STR(i, aInfStruct[1,3],0) LC_FieldPut( DB_name, nHandle, i, 1, String ) // Запись поля в БД (корректная) ##################### SELECT Gr_OpSc;DBGOTO(i) M_NameGrOS = ALLTRIM(Name_GrOS) M_KodOpSc = Kod_OpSc SELECT Opis_Sc;DBGOTO(M_KodOpSc) M_NameOS = UPPER(ALLTRIM(Name_OpSc)) // Если в названии градации уже включено наим.шкалы, то повторно не включать его IF AT(M_NameOS, UPPER(M_NameGrOS)) = 0 M_Name = M_NameOS+"-"+M_NameGrOS ELSE M_Name = M_NameGrOS ENDIF String = SUBSTR(M_Name,1,aInfStruct[2,3]) LC_FieldPut( DB_name, nHandle, i, 2, String ) // Запись поля в БД (корректная) ##################### NEXT LC_FieldPut( DB_name, nHandle, N_Gos+1, 2, "Сумма числа признаков" ) LC_FieldPut( DB_name, nHandle, N_Gos+2, 2, "Среднее" ) LC_FieldPut( DB_name, nHandle, N_Gos+3, 2, "Среднеквадратичное отклонение" ) LC_FieldPut( DB_name, nHandle, N_Gos+4, 2, "Сумма числа объектов обуч.выборки" ) FClose( nHandle ) // Закрытие текстовой базы данных ###################################### DC_DataRest( aSaveGenDbf ) RETURN(.T.) *********************************************************************************************************** ******** 3.2. Расчет условных и безусловных процентных распределений Prc1.txt, Prc2.txt ################## *********************************************************************************************************** FUNCTION F3_2CPU(Dialog, TP, Ws, oP, lO, Regim ) LOCAL GetList := {}, oMainDlg, lCancelled := .F. LOCAL oProgress, oDialog, lOk := .t., oButton, nEvent, mp1, mp2, oXbp Running(.T.) Time_Progress = TP Wsego = Ws oProgress = oP lOk = lO IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF Dialog IF ApplChange("3.2()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF ELSE IF ApplChange("") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения PUBLIC aSaveMainM := DC_ARestore("_SaveMainM.arx") // Восстановление вычислительной среды (открытые и текущие БД и индексы) с диска DC_DataRest( aSaveMainM ) // Восстановление вычислительной среды (открытые и текущие БД и индексы) Running(.F.) RETURN NIL ENDIF ENDIF IF .NOT. FILE("Abs.txt") // БД абс.частот IF .NOT. GenDbfAbs() Running(.F.) RETURN NIL ENDIF ENDIF ****** Задание на расчет моделей знаний IF FILE("_CalcInf.arx") // Файл с информацией о том, какие модели были рассчитаны ранее aCalcInf = DC_ARestore("_CalcInf.arx") IF aCalcInf[1] = .F. LB_Warning(L('Режим 3.2 "Расчет условных и безусловных процентных распределений" не может быть выполнен, т.к. для этого сначала необходимо сформировать базу абсолютных частот в режиме 3.1 !!!')) Running(.F.) RETURN NIL ENDIF ELSE LB_Warning(L('Режим 3.2 "Расчет условных и безусловных процентных распределений" не может быть выполнен, т.к. для этого сначала необходимо сформировать базу абсолютных частот в режиме 3.1 !!!')) Running(.F.) RETURN NIL ENDIF dbeSetDefault('DBFNTX') CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Gr_OpSc EXCLUSIVE NEW;N_Gos = RECCOUNT() USE Opis_Sc EXCLUSIVE NEW *********************************************************************** IF Dialog // Подготовка данных для отображения графического прогресс-бар // Определить значение Wsego Wsego = N_Gos // Задание максимальной величины параметра Time // Отображение стадии исполнения. Будет написано прямо в окне 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.5 ; PARENT oTabPage2 s = 1 @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++ @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('3.1.1.2. Расчет условных и безусловных процентных распределений'); PARENT @oDialog ; FIT ; EXIT ; MODAL oDialog:show() ENDIF *********************************************************************** IF Dialog aSay[ 3]:SetCaption(L('ОПЕРАЦИЯ: СОЗДАНИЕ БАЗ УСЛОВНЫХ И БЕЗУСЛОВНЫХ ПРОЦЕНТНЫХ РАСПРЕДЕЛЕНИЙ - PRC1, PRC2:')) ENDIF aSay[ 4]:SetCaption(L("1/2: Создание баз данных: PRC1 и PRC2.")) GenDBFPrc() aSay[ 4]:SetCaption(aSay[ 4]:caption+L(" - Готово ")) ******** ПРОЦЕСС ФОРМИРОВАНИЯ БД PRC1.DBF и PRC2.DBF mLenNameMax = CreateStructAll() // Создание файлов структур баз данных всех моделей 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 * ########################################################################### // Открытие текстовых баз данных ******************************************** *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 * ########################################################################### // Итоговые строки и столбцы PRIVATE Nij[N_Cls+6] // i-я строка базы абс.частот PRIVATE Nj[N_Cls+6] // Строка "Сумма числа признаков по классам" базы абс.частот PRIVATE NObj[N_Cls+6] // Строка "Сумма числа объектов по классам" базы абс.частот AFILL(Nij,0) AFILL(Nj,0) AFILL(NObj,0) PRIVATE Ar_Sum1_i[N_Gos], Ar_Sum1_j[N_Cls] // N_Cls + 1-коды, 2-наименования, 3-Summ, 4-Sred, 5-Disp PRIVATE Ar_Sum2_i[N_Gos], Ar_Sum2_j[N_Cls] // N_Cls + 1-коды, 2-наименования, 3-Summ, 4-Sred, 5-Disp PRIVATE Ar_Summ_i[N_Gos], Ar_Summ_j[N_Cls] // N_Cls + 1-коды, 2-наименования, 3-Summ, 4-Sred, 5-Disp PRIVATE Ar_Sred_i[N_Gos], Ar_Sred_j[N_Cls] PRIVATE Ar_Disp_i[N_Gos], Ar_Disp_j[N_Cls] PRIVATE Ar_ADMA_i[N_Gos] AFILL(Ar_Sum1_i, 0) AFILL(Ar_Sum1_j, 0) AFILL(Ar_Sum2_i, 0) AFILL(Ar_Sum2_j, 0) AFILL(Ar_Summ_i, 0) AFILL(Ar_Summ_j, 0) AFILL(Ar_Sred_i, 0) AFILL(Ar_Sred_j, 0) AFILL(Ar_Disp_i, 0) AFILL(Ar_Disp_j, 0) AFILL(Ar_ADMA_i, 0) *DC_ASave(aStrEmpty, "_aStrEmpty.arx") // Записывать только после расчета Abs.txt, а при расчете остальных БД только считывать *DC_ASave(aColEmpty, "_aColEmpty.arx") aStrEmpty = DC_ARestore("_aStrEmpty.arx") aColEmpty = DC_ARestore("_aColEmpty.arx") ****** Занести строки БД ABS.TXT в массивы mNumPP = 0 N_ALL = N_Cls + N_Gos + N_Cls + N_Gos + N_Cls + N_Gos + N_Gos + N_Cls + N_Gos + N_Cls * №1 №2 №3 №4 №5 №6 №7 №8 №9 №10 mMess = L('2/2: Расчет усл.и безусл.процентных распределений PRC1 и PRC2:') 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 N_Cls // №1, N_Cls ################################ * aSay[ 5]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(5, mMess, N_ALL) * IF aColEmpty[j] Nj[j] = VAL(LC_FieldGet( Ar_Model[1]+".txt", nHandle[1], N_Gos+1, 2+j )) NObj[j] = VAL(LC_FieldGet( Ar_Model[1]+".txt", nHandle[1], N_Gos+4, 2+j )) * ENDIF NEXT IF Dialog // Начало отсчета времени для прогнозирования длительности исполнения 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 ENDIF // Цикл по строкам Abs.txt ******* FOR i=1 TO N_Gos // №2, N_Gos ################################ // Стадия исполнения отображается всегда, даже когда задан режим "без диалога" (Dialog=.F.) // Под диалогом понимается диалог задания моделей для синтеза и выбор текущей * aSay[ 5]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(5, mMess, N_ALL) * 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() * FOR z=1 TO 3 * 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( Time_Progress ) * ENDIF * ************* Прерывание процесса по нажатию Cancel ############################################## * // Продолжение процесса * IF aStrEmpty[i] // Формирование массива распределения абс.частот встреч признака по классам из БД ABS.TXT FOR j=1 TO N_Cls * IF aColEmpty[j] Nij[j] = VAL(LC_FieldGet( Ar_Model[1]+".txt", nHandle[1], i, 2+j )) * ENDIF NEXT For j=1 TO N_Cls IF Nj[j] <> 0 .AND. Nij[j] <> 0 Iij = Nij[j]/Nj[j]*100 String = STR(Iij, aInfStruct[j+2,3], aInfStruct[2+j,4] ) LC_FieldPut( Ar_Model[2]+".txt", nHandle[2], i, 2+j, String ) Ar_Sum1_j[j] = Ar_Sum1_j[j] + Iij // Расчет строки "Сумма" Ar_Sum1_i[i] = Ar_Sum1_i[i] + Iij // Расчет столбца "Сумма" ENDIF NEXT For j=1 TO N_Cls IF NObj[j] <> 0 .AND. Nij[j] <> 0 Iij = Nij[j]/NObj[j]*100 String = STR(Iij, aInfStruct[2+j,3], aInfStruct[2+j,4] ) LC_FieldPut( Ar_Model[3]+".txt", nHandle[3], i, 2+j, String ) Ar_Sum2_j[j] = Ar_Sum2_j[j] + Iij // Расчет строки "Сумма" Ar_Sum2_i[i] = Ar_Sum2_i[i] + Iij // Расчет столбца "Сумма" ENDIF NEXT * ENDIF IF Regim<>"3_5";lOk = Time_Progress (++Time_progress, Wsego, oProgress, lOk );ENDIF NEXT *** Расчет и занесение итоговых строк FOR j=1 TO LEN(Ar_Sum1_j) // №3, N_Cls ################################ * aSay[ 5]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(5, mMess, N_ALL) Ar_Summ_j[j] = Ar_Sum1_j[j] NEXT FOR i=1 TO LEN(Ar_Sum1_i) // №4, N_Gos ################################ * aSay[ 5]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(5, mMess, N_ALL) Ar_Summ_i[i] = Ar_Sum1_i[i] NEXT PostCalcINF(2) FOR j=1 TO LEN(Ar_Sum2_j) // №5, N_Cls ################################ * aSay[ 5]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(5, mMess, N_ALL) Ar_Summ_j[j] = Ar_Sum2_j[j] NEXT FOR i=1 TO LEN(Ar_Sum2_i) // №6, N_Gos ################################ * aSay[ 5]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(5, mMess, N_ALL) Ar_Summ_i[i] = Ar_Sum2_i[i] NEXT PostCalcINF(3) *** ####################################################################################################### *** Посчитать и занести в файлы Prc1.txt Prc2.txt наим.и знач.строк (вместо этого внести 4-ю строку из Abs) и столбцов безусловных вероятностей (вместо сумм), *** а в PostCalcINF() не записывать этих столбцов (использовать их только в массивах), если z=2 или z=3. 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 ******************************************* *** Prc1.txt ****************************** ******************************************* IF N > 0 *** Запись столбца "Безусловная вероятность" For i=1 TO N_Gos // №7, N_Gos ################################ * aSay[ 5]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(5, mMess, N_ALL) Ni = VAL(LC_FieldGet( Ar_Model[1]+".txt", nHandle[1], i, N_Cls+3 )) // Сумма Ni из Abs.txt IF Ni <> 0 String = STR(Ni/N*100, aInfStruct[N_Cls+3,3], aInfStruct[N_Cls+3,4] ) LC_FieldPut( Ar_Model[2]+".txt", nHandle[2], i, N_Cls+3, String ) ENDIF NEXT ***** Запись строки "Безусловная вероятность" (вместо этого внести 4-ю строку из Abs) For j=1 TO N_Cls // №8, N_Cls ################################ * aSay[ 5]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(5, mMess, N_ALL) * Nj = VAL(LC_FieldGet( Ar_Model[1]+".txt", nHandle[1], N_Gos+1, 2+j )) // Сумма Nj из Abs.txt NObj_j = VAL(LC_FieldGet( Ar_Model[1]+".txt", nHandle[1], N_Gos+4, 2+j )) // Сумма NObj_j из Abs.txt * IF Nj <> 0 IF NObj_j <> 0 * String = STR(Nj/N*100, aInfStruct[2+j,3], aInfStruct[2+j,4] ) String = STR(NObj_j , aInfStruct[2+j,3], aInfStruct[2+j,4] ) LC_FieldPut( Ar_Model[2]+".txt", nHandle[2], N_Gos+4, 2+j, String ) ENDIF NEXT // Сумма числа Obj по всей БД Abs.dbf String = STR(NObj, aInfStruct[3+N_Cls,3], aInfStruct[3+N_Cls,4]) LC_FieldPut( Ar_Model[2]+".txt", nHandle[2], 4+N_Gos,3+N_Cls, String ) // Запись поля в БД (корректная) <<<===############ ENDIF ******************************************* *** Prc2.txt ****************************** ******************************************* IF NObj > 0 *** Запись столбца "Безусловная вероятность" FOR i=1 TO N_Gos // №9, N_Gos ################################ * aSay[ 5]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(5, mMess, N_ALL) 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 ***** Запись строки "Безусловная вероятность" (вместо этого внести 4-ю строку из Abs) FOR j=1 TO N_Cls // №10, N_Cls ############################### * aSay[ 5]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(5, mMess, N_ALL) * Nj = VAL(LC_FieldGet( Ar_Model[1]+".txt", nHandle[1], N_Gos+4, 2+j )) // Сумма NObj_j из Abs.txt NObj_j = VAL(LC_FieldGet( Ar_Model[1]+".txt", nHandle[1], N_Gos+4, 2+j )) // Сумма NObj_j из Abs.txt * IF Nj <> 0 IF NObj_j <> 0 * String = STR(Nj/NObj*100, aInfStruct[2+j,3], aInfStruct[2+j,4] ) String = STR(NObj_j , aInfStruct[2+j,3], aInfStruct[2+j,4] ) LC_FieldPut( Ar_Model[3]+".txt", nHandle[3], N_Gos+4, 2+j, String ) ENDIF NEXT // Сумма числа Obj по всей БД Abs.dbf String = STR(NObj, aInfStruct[3+N_Cls,3], aInfStruct[3+N_Cls,4]) LC_FieldPut( Ar_Model[3]+".txt", nHandle[3], 4+N_Gos,3+N_Cls, String ) // Запись поля в БД (корректная) <<<===############ ENDIF aSay[ 5]:SetCaption(aSay[ 5]:caption+L(" - Готово ")) aCalcInf[2] = .T. aCalcInf[3] = .T. DC_ASave(aCalcInf, "_CalcInf.arx") // Запись информации о расчете Prc1 и Prc2 FOR z=1 TO 3 FClose( nHandle[z] ) // Закрытие dbf и txt баз данных ###################################### NEXT IF Dialog Running(.T.) // Чтобы не могли запустить какой-нибудь режим пока висит окно окончания работы oSay97:SetCaption(L("Расчет баз условных и безусловных процентных распределений Prc1.txt и Prc2.txt завершен !")) oSay97:SetCaption(oSay97:caption) oButton:SetCaption(L('&Ok')) // Деструктурирование окна отображения графического Progress-bar oButton:activate := {||PostAppEvent(xbeP_Close,,,oDialog)} //<<<<<< Add This DC_AppEvent( @lOk ) oDialog:Destroy() ENDIF ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN( Time_Progress ) ******************************************************************** ******** Создание БД условных и безусловных процентных распределений ******************************************************************** FUNCTION GenDBFPrcOld(mLenName) aSaveGenDbf := DC_DataSave() IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF ApplChange("") // Перейти в папку выбранного приложения или выйти из системы LB_Warning(L("Необходимо задать (выбрать) хотя бы одно текущее приложение !!!")) Running(.F.) RETURN NIL ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций IF FILE("Classes.dbf") // БД градаций класс.шкал: Classes.dbf ** Переиндексировать БД Calsses.dbf, если не хватает какого-нибудь индексного массива IF FILE("Cls_kod.ntx" ).AND.; FILE("Cls_name.ntx").AND.; FILE("Cls_ini.ntx" ).AND.; FILE("Cls_abs.ntx" ) ELSE GenNtxClass() ENDIF ****** Если БД Classes.dbf есть, то загрузить ее структуру в массив ELSE GenDbfClass(.F.) ENDIF IF FILE("Opis_Sc.dbf") // БД описательных шкал ** Переиндексировать БД Opis_Sc.dbf, ** если не хватает хотя бы одного какого-нибудь индексного массива IF .NOT. FILE("Ops_kod.ntx" ).OR.; .NOT. FILE("Ops_name.ntx").OR.; .NOT. FILE("Ops_ini.ntx" ).OR.; .NOT. FILE("Ops_abs.ntx" ) GenNtxOpSc() ENDIF ELSE GenDbfOpSc(.F.) ENDIF IF FILE("Gr_OpSc.dbf") // БД градаций описательных шкал ** Переиндексировать БД Gr_OpSc.dbf, ** если не хватает хотя бы одного какого-нибудь индексного массива IF .NOT. FILE("Gos_kod.ntx" ).OR.; .NOT. FILE("Gos_name.ntx").OR.; .NOT. FILE("Gos_ini.ntx" ).OR.; .NOT. FILE("Gos_abs.ntx" ) GenNtxGrOpSc() ENDIF ELSE GenDbfGrOpSc(.F.) ENDIF dbeSetDefault('DBFNTX') CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Gr_OpSc EXCLUSIVE NEW;N_Gos = RECCOUNT() IF N_Cls * N_Gos = 0 LB_Warning(L("Базы процентных распределений не могут быть созданы, т.к. БД классов и признаков пусты !!!")) * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы RETURN NIL ENDIF IF N_Cls > 2035 Mess = L('Базы процентных распределений, т.к. в модели # классов, что более 2035 !') Mess = STRTRAN(Mess, "#", ALLTRIM(STR(N_Cls))) LB_Warning(Mess, L('Создание БД абсолютных частот Abs.dbf')) ENDIF * 12345678901234567890123 * 123.1234567890123456789 CREATE Struc APPEND BLANK REPLACE Field_name WITH "Kod_Pr",; Field_type WITH "N",; Field_len WITH 15,; Field_dec WITH 0 APPEND BLANK REPLACE Field_name WITH "Name",; Field_type WITH "C",; Field_len WITH mLenName; Field_dec WITH 0 FOR j = 1 TO N_Cls APPEND BLANK REPLACE Field_name WITH "CLS"+ALLTRIM(STR(j,19)),; Field_type WITH "N",; Field_len WITH 19,; Field_dec WITH 7 NEXT APPEND BLANK REPLACE Field_name WITH "SUMMA",; Field_type WITH "N",; Field_len WITH 19,; Field_dec WITH 7 APPEND BLANK REPLACE Field_name WITH "SREDN",; Field_type WITH "N",; Field_len WITH 19,; Field_dec WITH 7 APPEND BLANK REPLACE Field_name WITH "DISP",; Field_type WITH "N",; Field_len WITH 19,; Field_dec WITH 7 APPEND BLANK REPLACE Field_name WITH "ADMA",; Field_type WITH "N",; Field_len WITH 19,; Field_dec WITH 7 ****** Создаем базу абсолютных частот CREATE Prc1 FROM Struc CREATE Prc2 FROM Struc CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций ERASE Struc.dbf ***** Заполнение БД Abs.dbf пустыми записями CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Opis_sc EXCLUSIVE NEW INDEX ON STR(Kod_opsc,19) TO Kod_OpSc // Вставить в БД Prc1.dbf и Prc2.dbf коды признаков и наименования: ОПИСАТЕЛЬНАЯ ШКАЛА-градация CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Opis_sc INDEX Kod_OpSc EXCLUSIVE NEW USE Gr_OpSc EXCLUSIVE NEW USE Abs EXCLUSIVE NEW USE Prc1 EXCLUSIVE NEW USE Prc2 EXCLUSIVE NEW FOR i=1 TO N_Gos SELECT Gr_OpSc;DBGOTO(i) M_KodGrOs = Kod_GrOs M_NameGrOS = ALLTRIM(Name_GrOs) M_KodOpSc = Kod_OpSc SELECT Opis_Sc;DBGOTO(M_KodOpSc) M_NameOS = UPPER(ALLTRIM(Name_OpSc)) // Если в названии градации уже включено наим.шкалы, то повторно не включать его IF AT(M_NameOS, UPPER(M_NameGrOS)) = 0 M_Name = M_NameOS+"-"+M_NameGrOS ELSE M_Name = M_NameGrOS ENDIF SELECT Prc1 APPEND BLANK REPLACE Kod_pr WITH M_KodGrOs REPLACE Name WITH M_Name * FOR j=3 TO FCOUNT();FIELDPUT(j,0);NEXT SELECT Prc2 APPEND BLANK REPLACE Kod_pr WITH M_KodGrOs REPLACE Name WITH M_Name * FOR j=3 TO FCOUNT();FIELDPUT(j,0);NEXT NEXT SELECT Prc1 APPEND BLANK // Запись N_Gos+1 - строка: "Сумма", REPLACE Name WITH "Сумма" *FOR j=3 TO FCOUNT();FIELDPUT(j,0);NEXT APPEND BLANK // Запись N_Gos+2 - "Среднее" REPLACE Name WITH "Среднее" *FOR j=3 TO FCOUNT();FIELDPUT(j,0);NEXT APPEND BLANK // Запись N_Gos+3 - "Среднеквадратичное отклонение", "Редукция класса" REPLACE Name WITH "Среднеквадратичное отклонение" *FOR j=3 TO FCOUNT();FIELDPUT(j,0);NEXT APPEND BLANK // Запись N_Gos+4 - Количество объектов обучающей выборки,относящихся к данному классу REPLACE Name WITH "Сумма числа объектов обуч.выборки" *FOR j=3 TO FCOUNT();FIELDPUT(j,0);NEXT SELECT Prc2 APPEND BLANK // Запись N_Gos+1 - строка: "Сумма", REPLACE Name WITH "Сумма" *FOR j=3 TO FCOUNT();FIELDPUT(j,0);NEXT APPEND BLANK // Запись N_Gos+2 - "Среднее" REPLACE Name WITH "Среднее" *FOR j=3 TO FCOUNT();FIELDPUT(j,0);NEXT APPEND BLANK // Запись N_Gos+3 - "Среднеквадратичное отклонение", "Редукция класса" REPLACE Name WITH "Среднеквадратичное отклонение" *FOR j=3 TO FCOUNT();FIELDPUT(j,0);NEXT APPEND BLANK // Запись N_Gos+4 - Количество объектов обучающей выборки,относящихся к данному классу REPLACE Name WITH "Сумма числа объектов обуч.выборки" *FOR j=3 TO FCOUNT();FIELDPUT(j,0);NEXT CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DC_DataRest( aSaveGenDbf ) RETURN NIL ******************************************************************************** ******** Создание БД условных и безусловных процентных распределений ########### ******************************************************************************** FUNCTION GenDBFPrc() aSaveGenDbf := DC_DataSave() IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF ApplChange("") // Перейти в папку выбранного приложения или выйти из системы LB_Warning(L("Необходимо задать (выбрать) хотя бы одно текущее приложение !!!")) Running(.F.) RETURN NIL ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций IF FILE("Classes.dbf") // БД градаций класс.шкал: Classes.dbf ** Переиндексировать БД Calsses.dbf, если не хватает какого-нибудь индексного массива IF FILE("Cls_kod.ntx" ).AND.; FILE("Cls_name.ntx").AND.; FILE("Cls_ini.ntx" ).AND.; FILE("Cls_abs.ntx" ) ELSE GenNtxClass() ENDIF ****** Если БД Classes.dbf есть, то загрузить ее структуру в массив ELSE GenDbfClass(.F.) ENDIF IF FILE("Opis_Sc.dbf") // БД описательных шкал ** Переиндексировать БД Opis_Sc.dbf, ** если не хватает хотя бы одного какого-нибудь индексного массива IF .NOT. FILE("Ops_kod.ntx" ).OR.; .NOT. FILE("Ops_name.ntx").OR.; .NOT. FILE("Ops_ini.ntx" ).OR.; .NOT. FILE("Ops_abs.ntx" ) GenNtxOpSc() ENDIF ELSE GenDbfOpSc(.F.) ENDIF IF FILE("Gr_OpSc.dbf") // БД градаций описательных шкал ** Переиндексировать БД Gr_OpSc.dbf, ** если не хватает хотя бы одного какого-нибудь индексного массива IF .NOT. FILE("Gos_kod.ntx" ).OR.; .NOT. FILE("Gos_name.ntx").OR.; .NOT. FILE("Gos_ini.ntx" ).OR.; .NOT. FILE("Gos_abs.ntx" ) GenNtxGrOpSc() ENDIF ELSE GenDbfGrOpSc(.F.) ENDIF dbeSetDefault('DBFNTX') 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 IF N_Cls * N_Gos = 0 LB_Warning(L("Базы процентных распределений не могут быть созданы, т.к. БД классов и признаков пусты !!!")) * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы RETURN NIL ENDIF * ########################################################################### *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) ******** Создать БД ********************* DB_name1 = "Prc1.txt" nHandle1 := FCreate( DB_name1, FC_NORMAL ) // Создание БД (если она была, то все равно создается пустая) IF nHandle1 = -1 MsgBox(L("Файл: "+DB_name1+" не может быть создан. Ошибка:")+FERROR()) RETURN NIL ENDIF LC_DbCreate( DB_name1, nHandle1, Lc_buf, N_Gos+4 ) // Создание БД.txt, содержащей N_Rec пустых записей ############ DB_name2 = "Prc2.txt" nHandle2 := FCreate( DB_name2, FC_NORMAL ) // Создание БД (если она была, то все равно создается пустая) IF nHandle2 = -1 MsgBox("Файл: "+DB_name2+" не может быть создан. Ошибка:"+FERROR()) RETURN NIL ENDIF LC_DbCreate( DB_name2, nHandle2, Lc_buf, N_Gos+4 ) // Создание БД.txt, содержащей N_Rec пустых записей ############ *nHandle := FOpen( DB_name, 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 * ########################################################################### // Вставить в БД Prc1.txt и Prc2.txt коды признаков и наименования: ОПИСАТЕЛЬНАЯ ШКАЛА-градация CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Opis_sc EXCLUSIVE NEW USE Gr_OpSc EXCLUSIVE NEW FOR i=1 TO N_Gos String = STR(i, aInfStruct[1,3],0) LC_FieldPut( DB_name1, nHandle1, i, 1, String ) // Запись поля в БД (корректная) ##################### LC_FieldPut( DB_name2, nHandle2, i, 1, String ) // Запись поля в БД (корректная) ##################### SELECT Gr_OpSc;DBGOTO(i) M_NameGrOS = ALLTRIM(Name_GrOS) M_KodOpSc = Kod_OpSc SELECT Opis_Sc;DBGOTO(M_KodOpSc) M_NameOS = UPPER(ALLTRIM(Name_OpSc)) // Если в названии градации уже включено наим.шкалы, то повторно не включать его IF AT(M_NameOS, UPPER(M_NameGrOS)) = 0 M_Name = M_NameOS+"-"+M_NameGrOS ELSE M_Name = M_NameGrOS ENDIF String = SUBSTR(M_Name,1,aInfStruct[2,3]) LC_FieldPut( DB_name1, nHandle1, i, 2, String ) // Запись поля в БД (корректная) ##################### LC_FieldPut( DB_name2, nHandle2, i, 2, String ) // Запись поля в БД (корректная) ##################### NEXT LC_FieldPut( DB_name1, nHandle1, N_Gos+1, 2, "Сумма" ) LC_FieldPut( DB_name1, nHandle1, N_Gos+2, 2, "Среднее" ) LC_FieldPut( DB_name1, nHandle1, N_Gos+3, 2, "Среднеквадратичное отклонение" ) LC_FieldPut( DB_name1, nHandle1, N_Gos+4, 2, "Сумма числа объектов обуч.выборки" ) // Для того, чтобы можно было копировать модели в Abs как файлы *LC_FieldPut( DB_name1, nHandle1, N_Gos+4, 2, "Безусловная вероятность" ) LC_FieldPut( DB_name2, nHandle2, N_Gos+1, 2, "Сумма" ) LC_FieldPut( DB_name2, nHandle2, N_Gos+2, 2, "Среднее" ) LC_FieldPut( DB_name2, nHandle2, N_Gos+3, 2, "Среднеквадратичное отклонение" ) LC_FieldPut( DB_name2, nHandle2, N_Gos+4, 2, "Сумма числа объектов обуч.выборки" ) // Для того, чтобы можно было копировать модели в Abs как файлы *LC_FieldPut( DB_name2, nHandle2, N_Gos+4, 2, "Безусловная вероятность" ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций FClose( nHandle1 ) // Закрытие текстовой базы данных ###################################### FClose( nHandle2 ) // Закрытие текстовой базы данных ###################################### DC_DataRest( aSaveGenDbf ) RETURN NIL ******************************************************************** ******** Создание баз знаний с различными частными критериями знаний ******************************************************************** FUNCTION GenDBFInfOld(mLenName) aSaveGenDbf := DC_DataSave() IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) RETURN NIL ENDIF IF ApplChange("") // Перейти в папку выбранного приложения или выйти из системы LB_Warning(L("Необходимо задать (выбрать) хотя бы одно текущее приложение !!!")) Running(.F.) RETURN NIL ENDIF IF FILE("Classes.dbf") // БД градаций класс.шкал: Classes.dbf ** Переиндексировать БД Calsses.dbf, если не хватает какого-нибудь индексного массива IF FILE("Cls_kod.ntx" ).AND.; FILE("Cls_name.ntx").AND.; FILE("Cls_ini.ntx" ).AND.; FILE("Cls_abs.ntx" ) ELSE GenNtxClass() ENDIF ****** Если БД Classes.dbf есть, то загрузить ее структуру в массив ELSE GenDbfClass(.F.) ENDIF IF FILE("Opis_Sc.dbf") // БД описательных шкал ** Переиндексировать БД Opis_Sc.dbf, ** если не хватает хотя бы одного какого-нибудь индексного массива IF .NOT. FILE("Ops_kod.ntx" ).OR.; .NOT. FILE("Ops_name.ntx").OR.; .NOT. FILE("Ops_ini.ntx" ).OR.; .NOT. FILE("Ops_abs.ntx" ) GenNtxOpSc() ENDIF ELSE GenDbfOpSc(.F.) ENDIF IF FILE("Gr_OpSc.dbf") // БД градаций описательных шкал ** Переиндексировать БД Gr_OpSc.dbf, ** если не хватает хотя бы одного какого-нибудь индексного массива IF .NOT. FILE("Gos_kod.ntx" ).OR.; .NOT. FILE("Gos_name.ntx").OR.; .NOT. FILE("Gos_ini.ntx" ).OR.; .NOT. FILE("Gos_abs.ntx" ) GenNtxGrOpSc() ENDIF ELSE GenDbfGrOpSc(.F.) ENDIF dbeSetDefault('DBFNTX') CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Gr_OpSc EXCLUSIVE NEW;N_Gos = RECCOUNT() IF N_Cls * N_Gos = 0 LB_Warning(L("базы знаний не могут быть созданы, т.к. БД классов и признаков пусты !!!")) * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы RETURN NIL ENDIF IF N_Cls > 2035 Mess = L('Базы знаний не могут быть созданы, т.к. в модели # классов, что более 2035 !') Mess = STRTRAN(Mess, "#", ALLTRIM(STR(N_Cls))) LB_Warning(Mess, L('Создание БД абсолютных частот Abs.dbf')) ENDIF * 12345678901234567890123 * 1234567.123456789012345 CREATE Struc APPEND BLANK REPLACE Field_name WITH "Kod_Pr",; Field_type WITH "N",; Field_len WITH 15,; Field_dec WITH 0 APPEND BLANK REPLACE Field_name WITH "Name",; Field_type WITH "C",; Field_len WITH mLenName; Field_dec WITH 0 FOR j = 1 TO N_Cls APPEND BLANK REPLACE Field_name WITH "CLS"+ALLTRIM(STR(j,19)),; Field_type WITH "N",; Field_len WITH 19,; Field_dec WITH 7 NEXT APPEND BLANK REPLACE Field_name WITH "SUMMA",; Field_type WITH "N",; Field_len WITH 19,; Field_dec WITH 7 APPEND BLANK REPLACE Field_name WITH "SREDN",; Field_type WITH "N",; Field_len WITH 19,; Field_dec WITH 7 APPEND BLANK REPLACE Field_name WITH "DISP",; Field_type WITH "N",; Field_len WITH 19,; Field_dec WITH 7 APPEND BLANK REPLACE Field_name WITH "ADMA",; Field_type WITH "N",; Field_len WITH 19,; Field_dec WITH 7 ****** Создаем стат.базы и базы знаний (7 по частным критериям знаний) Ar_Model := {"Abs","Prc1","Prc2","Inf","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } FOR z=4 TO LEN(Ar_Model) M_Inf = Ar_Model[z] CREATE (M_Inf) FROM Struc NEXT CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций ERASE Struc.dbf ***** Заполнение БД Abs.dbf пустыми записями CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Opis_sc EXCLUSIVE NEW INDEX ON STR(Kod_opsc,19) TO Kod_OpSc // Вставить в БД Inf#.dbf коды признаков и наименования: ОПИСАТЕЛЬНАЯ ШКАЛА-градация, // а также итоговые строки в одну БД, а остальные скопировать как файлы CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Opis_sc INDEX Kod_OpSc EXCLUSIVE NEW USE Gr_OpSc EXCLUSIVE NEW USE Abs EXCLUSIVE NEW USE Inf EXCLUSIVE NEW FOR i=1 TO N_Gos SELECT Gr_OpSc;DBGOTO(i) M_KodGrOs = Kod_GrOS M_NameGrOS = ALLTRIM(Name_GrOS) M_KodOpSc = Kod_OpSc SELECT Opis_Sc;DBGOTO(M_KodOpSc) M_NameOS = UPPER(ALLTRIM(Name_OpSc)) // Если в названии градации уже включено наим.шкалы, то повторно не включать его IF AT(M_NameOS, UPPER(M_NameGrOS)) = 0 M_Name = M_NameOS+"-"+M_NameGrOS ELSE M_Name = M_NameGrOS ENDIF SELECT Inf // Имя БЗ брать из переменной APPEND BLANK REPLACE Kod_pr WITH M_KodGrOs REPLACE Name WITH M_Name * FOR j=3 TO FCOUNT();FIELDPUT(j,0);NEXT NEXT APPEND BLANK // Запись N_Gos+1 - строка: "Сумма", REPLACE Name WITH "Сумма" *FOR j=3 TO FCOUNT();FIELDPUT(j,0);NEXT APPEND BLANK // Запись N_Gos+2 - "Среднее" REPLACE Name WITH "Среднее" *FOR j=3 TO FCOUNT();FIELDPUT(j,0);NEXT APPEND BLANK // Запись N_Gos+3 - "Среднеквадратичное отклонение", "Редукция класса" REPLACE Name WITH "Среднеквадратичное отклонение" *FOR j=3 TO FCOUNT();FIELDPUT(j,0);NEXT APPEND BLANK // Запись N_Gos+4 - Количество объектов обучающей выборки,относящихся к данному классу REPLACE Name WITH "Сумма числа объектов обуч.выборки" *FOR j=3 TO FCOUNT();FIELDPUT(j,0);NEXT // Сделать в цикле, формируя имя базы знаний CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций FOR z=5 TO LEN(Ar_Model) M_Inf = Ar_Model[z]+".dbf" COPY FILE ("Inf.dbf") TO (M_Inf) NEXT CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DC_DataRest( aSaveGenDbf ) RETURN NIL ********************************************************* ******** Создание файлов структур баз данных всех моделей ********************************************************* FUNCTION CreateStructAll() // Создание файлов структур баз данных всех моделей IF .NOT. FILE("Classes.dbf") // БД градаций класс.шкал: Classes.dbf LB_Warning(L("Необходимо создать, задать или выбрать хотя бы одно текущее приложение !!!")) RETURN (-1) ENDIF IF .NOT. FILE("Attributes.dbf") // БД градаций опис.шкал: Attributes.dbf LB_Warning(L("Необходимо создать, задать или выбрать хотя бы одно текущее приложение !!!")) RETURN (-1) ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Attributes EXCLUSIVE NEW USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() // Определить максимальную длину наименования: ОПИСАТЕЛЬНАЯ ШКАЛА-градация mLenNameMax = 33 // Меньше 33 наименование делать не нужно, т.к. в итоговых строках есть наименование длиной 33 символа: "Сумма числа объектов обуч.выборки" SELECT Attributes DBGOTOP() DO WHILE .NOT. EOF() mLenNameMax = MAX(mLenNameMax, LEN(ALLTRIM(Name_atr))) DBSKIP(1) ENDDO ********** Структура создаваемой базы Abs.dbf ********************** aInfStruct := { { "Kod_pr", "N", 15, 0},; // 1 { "Name" , "C",mLenNameMax, 0} } // 2 FOR j=1 TO N_Cls FieldName = "N"+ALLTRIM(STR(j,15)) AADD(aInfStruct, { FieldName, "N", 19, 1 }) NEXT AADD(aInfStruct, { "Summa", "N", 19, 1 }) AADD(aInfStruct, { "Sredn", "N", 19, 7 }) AADD(aInfStruct, { "Disp" , "N", 19, 7 }) AADD(aInfStruct, { "ADMA" , "N", 19, 7 }) DC_ASave(aInfStruct, "_AbsStruct.arx") // Когда БД создается - записывать структуру, когда открывается - считывать *aInfStruct = DC_ARestore("_AbsStruct.arx") ********** Структура создаваемой базы Prc#.dbf, Inf#.dbf *********** aInfStruct := { { "Kod_pr", "N", 15, 0},; // 1 { "Name" , "C",mLenNameMax, 0} } // 2 FOR j=1 TO N_Cls FieldName = "N"+ALLTRIM(STR(j,15)) AADD(aInfStruct, { FieldName, "N", 19, 7 }) NEXT AADD(aInfStruct, { "Summa", "N", 19, 7 }) AADD(aInfStruct, { "Sredn", "N", 19, 7 }) AADD(aInfStruct, { "Disp" , "N", 19, 7 }) AADD(aInfStruct, { "ADMA" , "N", 19, 7 }) DC_ASave(aInfStruct, "_PrcStruct.arx") // Когда БД создается - записывать структуру, когда открывается - считывать *aInfStruct = DC_ARestore("_PrcStruct.arx") DC_ASave(aInfStruct, "_InfStruct.arx") // Когда БД создается - записывать структуру, когда открывается - считывать *aInfStruct = DC_ARestore("_InfStruct.arx") RETURN (mLenNameMax) ******************************************************************************* ******** Создание баз знаний с различными частными критериями знаний ########## ******************************************************************************* FUNCTION GenDBFInf() aSaveGenDbf := DC_DataSave() IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) RETURN NIL ENDIF IF ApplChange("") // Перейти в папку выбранного приложения или выйти из системы LB_Warning(L("Необходимо задать (выбрать) хотя бы одно текущее приложение !!!")) Running(.F.) RETURN NIL ENDIF IF FILE("Classes.dbf") // БД градаций класс.шкал: Classes.dbf ** Переиндексировать БД Calsses.dbf, если не хватает какого-нибудь индексного массива IF FILE("Cls_kod.ntx" ).AND.; FILE("Cls_name.ntx").AND.; FILE("Cls_ini.ntx" ).AND.; FILE("Cls_abs.ntx" ) ELSE GenNtxClass() ENDIF ****** Если БД Classes.dbf есть, то загрузить ее структуру в массив ELSE GenDbfClass(.F.) ENDIF IF FILE("Opis_Sc.dbf") // БД описательных шкал ** Переиндексировать БД Opis_Sc.dbf, ** если не хватает хотя бы одного какого-нибудь индексного массива IF .NOT. FILE("Ops_kod.ntx" ).OR.; .NOT. FILE("Ops_name.ntx").OR.; .NOT. FILE("Ops_ini.ntx" ).OR.; .NOT. FILE("Ops_abs.ntx" ) GenNtxOpSc() ENDIF ELSE GenDbfOpSc(.F.) ENDIF IF FILE("Gr_OpSc.dbf") // БД градаций описательных шкал ** Переиндексировать БД Gr_OpSc.dbf, ** если не хватает хотя бы одного какого-нибудь индексного массива IF .NOT. FILE("Gos_kod.ntx" ).OR.; .NOT. FILE("Gos_name.ntx").OR.; .NOT. FILE("Gos_ini.ntx" ).OR.; .NOT. FILE("Gos_abs.ntx" ) GenNtxGrOpSc() ENDIF ELSE GenDbfGrOpSc(.F.) ENDIF dbeSetDefault('DBFNTX') 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 IF N_Cls * N_Gos = 0 LB_Warning(L("базы знаний не могут быть созданы, т.к. БД классов и признаков пусты !!!")) * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы RETURN NIL ENDIF * ########################################################################### *DC_ASave(aInfStruct, "_InfStruct.arx") // Когда БД создается - записывать структуру, когда открывается - считывать aInfStruct = DC_ARestore("_InfStruct.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=4 TO LEN(Ar_Model) IF aCalcInf[z] // Создавать только заданные БД, т.к. они могут быть очень большого размера DB_name = Ar_Model[z]+".txt" nHandle[z] := FCreate( DB_name, FC_NORMAL ) // Создание БД (если она была, то все равно создается пустая) IF nHandle[z] = -1 MsgBox("Файл: "+DB_name+" не может быть создан. Ошибка:"+FERROR()) RETURN NIL ENDIF LC_DbCreate( DB_name, nHandle[z], Lc_buf, N_Gos+4 ) // Создание БД.txt, содержащей N_Rec пустых записей ############ ENDIF NEXT *nHandle := FOpen( DB_name, 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 * ########################################################################### // Вставить в БД Inf#.txt коды признаков и наименования: ОПИСАТЕЛЬНАЯ ШКАЛА-градация CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Opis_sc EXCLUSIVE NEW USE Gr_OpSc EXCLUSIVE NEW FOR i=1 TO N_Gos String = STR(i, aInfStruct[1,3],0) FOR z=4 TO LEN(Ar_Model) IF aCalcInf[z] // Создавать только заданные БД, т.к. они могут быть очень большого размера DB_name = Ar_Model[z]+".txt" LC_FieldPut( DB_name, nHandle[z], i, 1, String ) // Запись поля в БД (корректная) ##################### ENDIF NEXT SELECT Gr_OpSc;DBGOTO(i) M_NameGrOS = ALLTRIM(Name_GrOS) M_KodOpSc = Kod_OpSc SELECT Opis_Sc;DBGOTO(M_KodOpSc) M_NameOS = UPPER(ALLTRIM(Name_OpSc)) // Если в названии градации уже включено наим.шкалы, то повторно не включать его IF AT(M_NameOS, UPPER(M_NameGrOS)) = 0 M_Name = M_NameOS+"-"+M_NameGrOS ELSE M_Name = M_NameGrOS ENDIF String = SUBSTR(M_Name,1,aInfStruct[2,3]) FOR z=4 TO LEN(Ar_Model) IF aCalcInf[z] // Создавать только заданные БД, т.к. они могут быть очень большого размера DB_name = Ar_Model[z]+".txt" LC_FieldPut( DB_name, nHandle[z], i, 2, M_Name ) // Запись поля в БД (корректная) ##################### ENDIF NEXT NEXT FOR z=4 TO LEN(Ar_Model) IF aCalcInf[z] // Создавать только заданные БД, т.к. они могут быть очень большого размера DB_name = Ar_Model[z]+".txt" LC_FieldPut( DB_name, nHandle[z], N_Gos+1, 2, "Сумма" ) LC_FieldPut( DB_name, nHandle[z], N_Gos+2, 2, "Среднее" ) LC_FieldPut( DB_name, nHandle[z], N_Gos+3, 2, "Среднеквадратичное отклонение" ) LC_FieldPut( DB_name, nHandle[z], N_Gos+4, 2, "Сумма числа объектов обуч.выборки" ) // Для того, чтобы можно было копировать модели в Abs как файлы ENDIF NEXT CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций FOR z=4 TO LEN(Ar_Model) IF aCalcInf[z] // Создавать только заданные БД, т.к. они могут быть очень большого размера FClose( nHandle[z] ) // Закрытие текстовой базы данных ###################################### ENDIF NEXT DC_DataRest( aSaveGenDbf ) RETURN NIL *************************************************************************** // Дорасчет строки и столбца "Сумма", "Среднее", "Средн.квадр.отклонение" // для открытой стат.модели или модели знаний (заданной SELECT) // и перенос Int_Inf (Disp) в Attributes и Gr_ClSc ######### F5_6() ####### *************************************************************************** FUNCTION PostCalcINFold() *** Запись столбца "Сумма" For i=1 TO N_Gos DBGOTO(i) FIELDPUT(3+N_Cls, Ar_Summ_i[i]) // Запись столбца "Сумма" NEXT ***** Запись строки "Сумма" Summa_all = 0 DBGOTO(N_Gos+1) For j=1 TO N_Cls FIELDPUT(2+j, Ar_Summ_j[j]) // Запись строки "Сумма" Summa_all = Summa_all + Ar_Summ_j[j] NEXT FIELDPUT(3+N_Cls, Summa_all) // Запись углового элемента "Сумма" Sredn_all = Summa_all/(N_Cls*N_Gos) DBGOTO(N_Gos+2) FIELDPUT(4+N_Cls, Sredn_all) // Запись углового элемента "Среднее" *** Расчет средних по строкам FOR i = 1 TO N_Gos DBGOTO(i) Ar_Sred_i[i] = Ar_Summ_i[i]/N_Cls FIELDPUT(4+N_Cls,Ar_Sred_i[i]) // "Среднее" по строке NEXT ****** Расчет средних по столбцам DBGOTO(N_Gos+2) // "Среднее" строка FOR j = 1 TO N_Cls Ar_Sred_j[j] = Ar_Summ_j[j]/N_Gos FIELDPUT(2+j,Ar_Sred_j[j]) // "Среднее" строка NEXT *** Расчет и запись столбца значимости признаков (градаций описательных шкал) FOR i = 1 TO N_Gos DBGOTO(i) FOR j = 1 TO N_Cls Iij=FIELDGET(2+j) // Информативность-элемент (i,j) Ar_Disp_i[i] = Ar_Disp_i[i] + (Ar_Sred_i[i]-Iij)^2 NEXT Ar_Disp_i[i] = SQRT(Ar_Disp_i[i]/(N_Cls-1)) // Средн.квадр.отклонение Iij по признаку FIELDPUT(5+N_Cls,Ar_Disp_i[i]) NEXT **** Расчет степени редукции классов Disp_all = 0 // угловой элемент "Дисперсия" FOR j = 1 TO N_Cls FOR i = 1 TO N_Gos DBGOTO(i) Iij=FIELDGET(2+j) // Информативность-элемент (i,j) Ar_Disp_j[j] = Ar_Disp_j[j]+(Ar_Sred_j[j]-Iij)^2 Disp_all = Disp_all + (Sredn_all - Iij) ^ 2 NEXT DBGOTO(N_Gos+3) // "Дисперсия" строка Ar_Disp_j[j] = SQRT(Ar_Disp_j[j]/(N_Gos-1)) // Средн.квадр.отклонение Iij по классу FIELDPUT(2+j,Ar_Disp_j[j]) NEXT DBGOTO(N_Gos+3) // "Дисперсия" строка FIELDPUT(5+N_Cls,SQRT(Disp_all/(N_Cls*N_Gos-1))) // "Дисперсия" - угловой элемент RETURN NIL ********************************************************************************************************* ******** 3.3. Расчет заданных из 7 моделей знаний: ########### ******** Inf1~Prc1, Inf2~Prc2, Inf3-хи-квадрат, Inf4-roi~Prc1, Inf5-roi~Prc2, Inf6-Dp~Prc1, Inf7-Dp~Prc2 ******** для задания БЗ использован пример XSample_184() из xdemo.exe ########### ********************************************************************************************************* FUNCTION F3_3CPU(Dialog, TP, Ws, oP, lO, Regim ) LOCAL GetList[0], GetOptions, oGroup1, oGroup2, oGroup3, oMainDlg, oLastFocus LOCAL oProgress, oDialog, lOk := .t., oButton, nEvent, mp1, mp2, oXbp, lCancelled := .F. Running(.T.) Time_Progress = TP Wsego = Ws oProgress = oP lOk = lO IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF Dialog IF ApplChange("3.3()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ELSE IF ApplChange("") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ENDIF IF .NOT. FILE("Abs.txt") // БД абс.частот F3_1(.F.) ENDIF *IF .NOT. FILE("Prc1.txt") .OR.; // БД процентных распределений * .NOT. FILE("Prc2.txt") * F3_2(.F.) *ENDIF dbeSetDefault('DBFNTX') IF ApplChange("") // Перейти в папку выбранного приложения или выйти из системы LB_Warning(L("Необходимо задать (выбрать) хотя бы одно текущее приложение !!!")) Running(.F.) RETURN NIL ENDIF ****** Задание на расчет баз знаний IF .NOT. FILE("_CalcInf.arx") // Файл с информацией о том, какие модели были рассчитаны ранее aMess := {} AADD(aMess, L("Расчет заданных из 7 моделей знаний не может быть выполнен,") ) AADD(aMess, L("т.к. для этого необходимо сначала сформировать базы абсолютных частот в режиме 3.1")) AADD(aMess, L("и, для расчета моделей INF#, кроме INF3, усл.и безусл.проц.распр. в режиме 3.2 !!!")) LB_Warning(aMess, L("3.3. Расчет заданных из 7 моделей знаний")) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF IF aCalcInf[1] = .F. aMess := {} AADD(aMess, L("Расчет заданных из 7 моделей знаний не может быть выполнен, т.к. для этого") ) AADD(aMess, L("необходимо сначала сформировать базу абсолютных частот ABS.DBF в режиме 3.1")) LB_Warning(aMess, L("3.3. Расчет заданных из 7 моделей знаний")) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** 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("_CurrInf.arx") // Файл с информацией о том, какая модель задана текущей M_CurrInf = DC_ARestore("_CurrInf.arx") ELSE M_CurrInf = 0 DC_ASave(M_CurrInf, "_CurrInf.arx") ENDIF * LB_Warning(STR(M_CurrInf,19)) ****** Задание моделей знаний для расчета и задание текущей модели @ 0, 0 DCGROUP oGroup1 CAPTION L('Задайте, какие базы знаний рассчитывать') SIZE 68 ,8.5 @ 0,70 DCGROUP oGroup2 CAPTION L('Задайте текущую базу знаний' ) SIZE 28 ,8.5 @10, 0 DCGROUP oGroup3 CAPTION L('Как задавать параметры синтеза моделей' ) SIZE 98.5,6 @ 1, 3 DCCHECKBOX aCalcInf[ 4] PROMPT L('INF1 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC1') PARENT oGroup1 @ 2, 3 DCCHECKBOX aCalcInf[ 5] PROMPT L('INF2 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC2') PARENT oGroup1 @ 3, 3 DCCHECKBOX aCalcInf[ 6] PROMPT L('INF3 - частный критерий: Xи-квадрат, разности между факт.и ожид.абс.частотами ') PARENT oGroup1 @ 4, 3 DCCHECKBOX aCalcInf[ 7] PROMPT L('INF4 - частный критерий: ROI (Return On Investment); вероятности из PRC1 ') PARENT oGroup1 @ 5, 3 DCCHECKBOX aCalcInf[ 8] PROMPT L('INF5 - частный критерий: ROI (Return On Investment); вероятности из PRC2 ') PARENT oGroup1 @ 6, 3 DCCHECKBOX aCalcInf[ 9] PROMPT L('INF6 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC1 ') PARENT oGroup1 @ 7, 3 DCCHECKBOX aCalcInf[10] PROMPT L('INF7 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC2 ') PARENT oGroup1 @ 1, 3 DCRADIO M_CurrInf VALUE 4 PROMPT L('INF1') PARENT oGroup2 EDITPROTECT {|| .NOT. aCalcInf[ 4] } HIDE {|| .NOT. aCalcInf[ 4] } @ 2, 3 DCRADIO M_CurrInf VALUE 5 PROMPT L('INF2') PARENT oGroup2 EDITPROTECT {|| .NOT. aCalcInf[ 5] } HIDE {|| .NOT. aCalcInf[ 5] } @ 3, 3 DCRADIO M_CurrInf VALUE 6 PROMPT L('INF3') PARENT oGroup2 EDITPROTECT {|| .NOT. aCalcInf[ 6] } HIDE {|| .NOT. aCalcInf[ 6] } @ 4, 3 DCRADIO M_CurrInf VALUE 7 PROMPT L('INF4') PARENT oGroup2 EDITPROTECT {|| .NOT. aCalcInf[ 7] } HIDE {|| .NOT. aCalcInf[ 7] } @ 5, 3 DCRADIO M_CurrInf VALUE 8 PROMPT L('INF5') PARENT oGroup2 EDITPROTECT {|| .NOT. aCalcInf[ 8] } HIDE {|| .NOT. aCalcInf[ 8] } @ 6, 3 DCRADIO M_CurrInf VALUE 9 PROMPT L('INF6') PARENT oGroup2 EDITPROTECT {|| .NOT. aCalcInf[ 9] } HIDE {|| .NOT. aCalcInf[ 9] } @ 7, 3 DCRADIO M_CurrInf VALUE 10 PROMPT L('INF7') PARENT oGroup2 EDITPROTECT {|| .NOT. aCalcInf[10] } HIDE {|| .NOT. aCalcInf[10] } @ 8.7, 0 DCPUSHBUTTON ; CAPTION L('Вид частных критериев 7 моделей знаний') ; SIZE LEN(L('Вид частных критериев 7 моделей знаний')), 1 ; ACTION {||Help33()} @ 1, 3 DCSAY L('Задайте, какие базы знаний рассчитывать. Рекомендуется задать все, если это приемлемо по длительности расчетов. Затем') PARENT oGroup3 @ 2, 3 DCSAY L('задайте одну из моделей знаний, которая будет текущей после завершения синтеза моделей. В качестве текущей можно вы-') PARENT oGroup3 @ 3, 3 DCSAY L('брать только одну из баз знаний, которые заданы для расчета. До исследования достоверности моделей в режиме 3.5 реко-') PARENT oGroup3 @ 4, 3 DCSAY L('мендуется задавать для расчета и делать текущей базу знаний INF1. Подробнее смысл моделей знаний, применяемых в сис-') PARENT oGroup3 @ 5, 3 DCSAY L('теме "Эйдос-Х++", раскрыт в режиме 6.4. и публикациях, размещенных по адресу: http://www.twirpx.com/file/793311/ ') PARENT oGroup3 DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; ADDBUTTONS; OPTIONS GetOptions ; MODAL ; TITLE L('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(aCalcInf , "_CalcInf.arx") // Файл с информацией о том, создание каких моделей было задано DC_ASave(M_CurrInf, "_CurrInf.arx") // Файл с информацией о том, какая модель задана текущей IF ASCAN(aCalcInf, .T.) = 0 LB_Warning(L("Необходимо задать хотя бы одну модель знаний для расчета !")) Running(.F.) RETURN NIL ENDIF IF M_CurrInf = 0 LB_Warning(L("Необходимо задать хотя бы одну модель знаний в качестве текущей !")) Running(.F.) RETURN NIL ELSE IF aCalcInf[M_CurrInf] = .F. LB_Warning(L("Модель знаний, заданная в качестве текущей, должна быть задана и для расчета !")) Running(.F.) RETURN NIL ENDIF ENDIF ELSE ENDIF // Диалог ***** Для расчета любой из моделей INF#, кроме модели INF3, необходим предварительный расчет PRC1 и PRC2 * Ar_Model := {"Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } * 1 2 3 4 5 6 7 8 9 10 IF aCalcInf[4] .OR. aCalcInf[5] .OR. aCalcInf[7] .OR. aCalcInf[8] .OR. aCalcInf[9] .OR. aCalcInf[10] IF aCalcInf[2] = .F. .OR. aCalcInf[3] = .F. aMess := {} AADD(aMess, L("Расчет заданных из 7 моделей знаний не может быть выполнен, т.к. для этого")) AADD(aMess, L(" необходимо сначала сформировать базы и условных и безусловных процентных") ) AADD(aMess, L(" распределений PRC1.DBF и PRC2.DBF в режиме 3.2 !!!") ) LB_Warning(aMess, L("3.3. Расчет заданных из 7 моделей знаний")) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ENDIF ***************************************************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Gr_ClSc EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW USE Gr_OpSc EXCLUSIVE NEW;N_Gos = RECCOUNT() ***************************************************************************************************** IF Dialog // Подготовка данных для отображения графического прогресс-бар // Определить значение Wsego // Задание максимальной величины параметра Time Wsego = IF(aCalcInf[ 4],N_Gos,0)+; // Расчет и дорасчет модели IF(aCalcInf[ 5],N_Gos,0)+; IF(aCalcInf[ 6],N_Gos,0)+; IF(aCalcInf[ 7],N_Gos,0)+; IF(aCalcInf[ 8],N_Gos,0)+; IF(aCalcInf[ 9],N_Gos,0)+; IF(aCalcInf[10],N_Gos,0) // Отображение стадии исполнения. Будет написано прямо в окне 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[ 2] FONT "10.Helv" // Abs @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 3] FONT "10.Helv" // Prc1, Prc2 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 4] FONT "10.Helv" // @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 5] FONT "10.Helv" // 1 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 6] FONT "10.Helv" // 2 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 7] FONT "10.Helv" // 3 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 8] FONT "10.Helv" // 4 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 9] FONT "10.Helv" // 5 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[10] FONT "10.Helv" // 6 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[11] FONT "10.Helv" // 7 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[12] FONT "10.Helv" // 8 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[13] FONT "10.Helv" // 9 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('3.3. Расчет заданных из 7 моделей знаний') ; PARENT @oDialog ; FIT ; EXIT ; MODAL oDialog:show() ENDIF ***************************************************************************************************** IF Dialog aSay[ 4]:SetCaption(L('ОПЕРАЦИЯ: СОЗДАНИЕ БАЗ ЗНАНИЙ: "INF1 - INF7"')) ENDIF aSay[ 5]:SetCaption(L("1/9: Генерация баз знаний: INF1 - INF7. Немного подождите !!!")) GenDBFInf() aSay[ 5]:SetCaption(L('1/9: Генерация баз знаний: "INF1 - INF7"')) aSay[ 5]:SetCaption(aSay[ 5]:caption+L(" - Готово ")) mLenNameMax = CreateStructAll() // Создание файлов структур баз данных всех моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() // Количество классов (градаций классификационных шкал) USE Gr_ClSc EXCLUSIVE NEW USE Class_Sc EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW USE Gr_OpSc EXCLUSIVE NEW;N_Gos = RECCOUNT() // Количество признаков (градаций описательных шкал) USE Opis_Sc EXCLUSIVE NEW **** Текстовые базы данных ********************* *USE Abs EXCLUSIVE NEW // БД - матрица абсолютных частот (матрица сопряженности) *USE Prc1 EXCLUSIVE NEW // ИБ - матрица условных и безусловных процентных распределений признаков по классам *USE Prc2 EXCLUSIVE NEW // ИБ - матрица условных и безусловных процентных распределений признаков по объектам, относящися к классам *USE Inf EXCLUSIVE NEW // Текущая модель *USE Inf1 EXCLUSIVE NEW // БЗ-1 - Inf1~Prc1 *USE Inf2 EXCLUSIVE NEW // БЗ-2 - Inf2~Prc2 *USE Inf3 EXCLUSIVE NEW // БЗ-3 - Inf3-хи-квадрат *USE Inf4 EXCLUSIVE NEW // БЗ-4 - Inf4-roi~Prc1 *USE Inf5 EXCLUSIVE NEW // БЗ-5 - Inf5-roi~Prc2 *USE Inf6 EXCLUSIVE NEW // БЗ-6 - Inf6-Dp~Prc1 *USE Inf7 EXCLUSIVE NEW // БЗ-7 - Inf7-Dp~Prc2 * ########################################################################### // Открытие текстовых баз данных ******************************************** *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 // Число полей 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 по частным критериям знаний) PUBLIC 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 ******* Рассчет массива начальных позиций полей в строке PRIVATE aPos[N_Col] aPos[1] = 1 FOR j=2 TO N_Col aPos[j] = aPos[j-1] + aInfStruct[j-1,3] NEXT * ########################################################################### // Добавить формирование класс.шкал и градаций <<<===################################################################# // Добавить формирование опис.шкал и БД Attributes aSave3_3 := DC_DataSave() ***************************************************************************************************** ******* Общая часть для всех INF# DB_Name = Ar_Model[1]+".txt" // Суммарное количество фактов, учтенных в модели N1 = VAL(LC_FieldGet( DB_Name, nHandle[1], N_Gos+1, N_Cls+3 )) // факт - это встреча в обучающей выборке сочетания: класс х признак K1 = LOG(N_Cls)/LOG(N1)/LOG(2) // Нормировочный коэффициент для INF1 N2 = VAL(LC_FieldGet( DB_Name, nHandle[1], N_Gos+4, N_Cls+3 )) // Суммарное количество объектов обучающей выборки, учтенных в модели K2 = LOG(N_Cls)/LOG(N2)/LOG(2) // Нормировочный коэффициент для INF2 // Итоговые строки и столбцы ******* Для рассчета хи-квадрат PRIVATE Nij[N_Cls] // i-я строка базы абс.частот PRIVATE Ni[N_Gos] // Столбец "Сумма числа признаков" базы абс.частот PRIVATE Nj[N_Cls] // Строка "Сумма числа признаков" базы абс.частот PRIVATE Ar_Pij[N_Cls+6] PRIVATE Ar_Summ_i[N_Gos+3], Ar_Summ_j[N_Cls+6] // N_Cls + 1-коды, 2-наименования, 3-Summ, 4-Sred, 5-Disp PRIVATE Ar_Sred_i[N_Gos+3], Ar_Sred_j[N_Cls+6] PRIVATE Ar_Disp_i[N_Gos+3], Ar_Disp_j[N_Cls+6] PRIVATE Ar_ADMA_i[N_Gos+3] ***************************************************************************************** **** Проверка диалога *FOR j=1 TO LEN(aCalcInf) * IF aCalcInf[j] * LB_Warning(L("Задан Расчет модели знаний: "+ALLTRIM(STR(j,19))) * ELSE * LB_Warning(L("Расчет модели знаний: "+ALLTRIM(STR(j,19))+" не задан") * ENDIF *NEXT *LB_Warning(L("Текущей задана модель: "+STR(M_CurrInf,19)) ** ################################################################################# ** В БУДУЩЕМ РАСЧЕТ ВСЕХ INF# СДЕЛАТЬ НЕПОСРЕДСТВЕННО НА ОСНОВЕ ABS.DBF ############ ** ################################################################################# IF aCalcInf[1+3] IF Dialog // Начало отсчета времени для прогнозирования длительности исполнения 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 ENDIF AFILL(Ar_Summ_i, 0) AFILL(Ar_Summ_j, 0) AFILL(Ar_Sred_i, 0) AFILL(Ar_Sred_j, 0) AFILL(Ar_Disp_i, 0) AFILL(Ar_Disp_j, 0) AFILL(Ar_ADMA_i, 0) mMess = L("2/9: Расчет модели знаний INF1 с частным критерием А.Харкевича PRC1:") mNumPP = 0 N_ALL = N_Gos * №1 FOR i=1 TO N_Gos // №1, N_Gos ################################ // Стадия исполнения отображается всегда, даже когда задан режим "без диалога" (Dialog=.F.) // Под диалогом понимается диалог задания моделей для синтеза и выбор текущей * aSay[ 6]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(6, mMess, N_ALL) * IF aStrEmpty[i] Pi = VAL(LC_FieldGet( Ar_Model[2]+".txt", nHandle[2], i, N_Cls+3 )) // Безусловная вероятность встречи i-го признака IF Pi > 0 AFILL(Ar_Pij, 0) FOR j=1 TO N_Cls * IF aColEmpty[j] Ar_Pij[j] = VAL(LC_FieldGet( Ar_Model[2]+".txt", nHandle[2], i, 2+j )) // Условные вероятности встречи i-го признака у объектов j-го класса * ENDIF NEXT For j=1 TO N_Cls * IF aColEmpty[j] IF Pi <> 0 IF Ar_Pij[j]/Pi > 0 ************************* Iij = K1*LOG(Ar_Pij[j]/Pi) // Расчет и запись Iij // ВСЕ СЧИТАТЬ НЕПОСРЕДСТВЕННО НА ОСНОВЕ БД ABS.DBF ################# ************************* IF Iij <> 0 String = STR(Iij, aInfStruct[2+j,3], aInfStruct[2+j,4] ) // ##################### LC_FieldPut( Ar_Model[4]+".txt", nHandle[4], i, 2+j, String ) Ar_Summ_j[j] = Ar_Summ_j[j] + Iij // Расчет строки и углового элемента "Сумма" Ar_Summ_i[i] = Ar_Summ_i[i] + Iij // Расчет i-го элемента столбца "Сумма" ENDIF ENDIF ENDIF * ENDIF NEXT ENDIF * ENDIF IF Regim<>"3_5";lOk = Time_Progress (++Time_progress, Wsego, oProgress, lOk );ENDIF NEXT aSay[ 6]:SetCaption(aSay[ 6]:caption+L(" - Дорасчет")) aCalcInf[4] = .T.;PostCalcINF(4) // Дорасчет сумм, средних и ср.кв.откл., а также среднего модулей отклонения о среднего IF M_CurrInf=1+3 // Сделать данную модель баз знаний текущей (без диалога) F5_6(M_CurrInf,.F.,"3_3");DC_DataRest( aSave3_3 ) aSay[ 6]:SetCaption(aSay[ 6]:caption+L(" - Текущая")) ENDIF IF nRadioModel = 3 Calc_model_2nd_level(4, nRadioModel, nRadModelCr) ENDIF aSay[ 6]:SetCaption(aSay[ 6]:caption+L(" - Готово ")) ENDIF ***************************************************************************************** ***************************************************************************************** IF aCalcInf[2+3] AFILL(Ar_Summ_i, 0) AFILL(Ar_Summ_j, 0) AFILL(Ar_Sred_i, 0) AFILL(Ar_Sred_j, 0) AFILL(Ar_Disp_i, 0) AFILL(Ar_Disp_j, 0) AFILL(Ar_ADMA_i, 0) mMess = L("3/9: Расчет модели знаний INF2 с частным критерием А.Харкевича PRC2:") mNumPP = 0 N_ALL = N_Gos * №1 FOR i=1 TO N_Gos // №1, N_Gos ################################ // Стадия исполнения отображается всегда, даже когда задан режим "без диалога" (Dialog=.F.) // Под диалогом понимается диалог задания моделей для синтеза и выбор текущей * aSay[ 7]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(7, mMess, N_ALL) * IF aStrEmpty[i] Pi = VAL(LC_FieldGet( Ar_Model[3]+".txt", nHandle[3], i, N_Cls+3 )) // Безусловная вероятность встречи i-го признака IF Pi > 0 AFILL(Ar_Pij, 0) FOR j=1 TO N_Cls * IF aColEmpty[j] Ar_Pij[j] = VAL(LC_FieldGet( Ar_Model[3]+".txt", nHandle[3], i, 2+j )) // Условные вероятности встречи i-го признака у объектов j-го класса * ENDIF NEXT For j=1 TO N_Cls * IF aColEmpty[j] IF Pi <> 0 IF Ar_Pij[j]/Pi > 0 ************************* Iij = K2*LOG(Ar_Pij[j]/Pi) // Расчет и запись Iij ************************* IF Iij <> 0 String = STR(Iij, aInfStruct[2+j,3], aInfStruct[2+j,4] ) // ##################### LC_FieldPut( Ar_Model[5]+".txt", nHandle[5], i, 2+j, String ) Ar_Summ_j[j] = Ar_Summ_j[j] + Iij // Расчет строки и углового элемента "Сумма" Ar_Summ_i[i] = Ar_Summ_i[i] + Iij // Расчет i-го элемента столбца "Сумма" ENDIF ENDIF ENDIF * ENDIF NEXT ENDIF * ENDIF IF Regim<>"3_5";lOk = Time_Progress (++Time_progress, Wsego, oProgress, lOk );ENDIF NEXT aSay[ 7]:SetCaption(aSay[ 7]:caption+L(" - Дорасчет")) aCalcInf[5] = .T.;PostCalcINF(5) // Дорасчет сумм, средних и ср.кв.откл. IF M_CurrInf=2+3 // Сделать данную модель баз знаний текущей (без диалога) F5_6(M_CurrInf,.F.,"3_3");DC_DataRest( aSave3_3 ) aSay[ 7]:SetCaption(aSay[ 7]:caption+L(" - Текущая")) ENDIF IF nRadioModel = 3 Calc_model_2nd_level(5, nRadioModel, nRadModelCr) ENDIF aSay[ 7]:SetCaption(aSay[ 7]:caption+L(" - Готово ")) ENDIF ***************************************************************************************** ***************************************************************************************** IF aCalcInf[3+3] AFILL(Ar_Summ_i, 0) AFILL(Ar_Summ_j, 0) AFILL(Ar_Sred_i, 0) AFILL(Ar_Sred_j, 0) AFILL(Ar_Disp_i, 0) AFILL(Ar_Disp_j, 0) AFILL(Ar_ADMA_i, 0) ***** Строка Nj: "Сумма числа признаков всего по классу" AFILL(Nj,0) FOR j=1 TO N_Cls * IF aColEmpty[j] Nj[j] = VAL(LC_FieldGet( Ar_Model[1]+".txt", nHandle[1], N_Gos+1, 2+j )) * ENDIF NEXT ***** Строка Ni "Сумма числа признаков по признаку" AFILL(Ni,0) FOR i=1 TO N_Gos * IF aStrEmpty[i] Ni[i] = VAL(LC_FieldGet( Ar_Model[1]+".txt", nHandle[1], i, N_Cls+3 )) * ENDIF NEXT N = VAL(LC_FieldGet( Ar_Model[1]+".txt", nHandle[1], N_Gos+1, N_Cls+3 )) mMess = L("4/9: Расчет модели знаний INF3 - Xи-квадрат:") mNumPP = 0 N_ALL = N_Gos * №1 FOR i=1 TO N_Gos // №1, N_Gos ################################ // Стадия исполнения отображается всегда, даже когда задан режим "без диалога" (Dialog=.F.) // Под диалогом понимается диалог задания моделей для синтеза и выбор текущей * aSay[ 8]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(8, mMess, N_ALL) * IF aStrEmpty[i] AFILL(Nij,0) FOR j=1 TO N_Cls * IF aColEmpty[j] Nij[j] = VAL(LC_FieldGet( Ar_Model[1]+".txt", nHandle[1], i, 2+j )) * ENDIF NEXT For j=1 TO N_Cls * IF aColEmpty[j] IF N <> 0 Iij = Nij[j]-(Ni[i]*Nj[j])/N IF Iij <> 0 String = STR(Iij, aInfStruct[2+j,3], aInfStruct[2+j,4] ) // ##################### LC_FieldPut( Ar_Model[6]+".txt", nHandle[6], i, 2+j, String ) Ar_Summ_j[j] = Ar_Summ_j[j] + Iij // Расчет строки и углового элемента "Сумма" Ar_Summ_i[i] = Ar_Summ_i[i] + Iij // Расчет i-го элемента столбца "Сумма" ENDIF ENDIF * ENDIF NEXT * ENDIF IF Regim<>"3_5";lOk = Time_Progress (++Time_progress, Wsego, oProgress, lOk );ENDIF NEXT aSay[ 8]:SetCaption(aSay[ 8]:caption+L(" - Дорасчет")) aCalcInf[6] = .T.;PostCalcINF(6) // Дорасчет сумм, средних и ср.кв.откл. IF M_CurrInf=3+3 // Сделать данную модель баз знаний текущей (без диалога) F5_6(M_CurrInf,.F.,"3_3");DC_DataRest( aSave3_3 ) aSay[ 8]:SetCaption(aSay[ 8]:caption+L(" - Текущая")) ENDIF IF nRadioModel = 3 Calc_model_2nd_level(6, nRadioModel, nRadModelCr) ENDIF aSay[ 8]:SetCaption(aSay[ 8]:caption+L(" - Готово ")) ENDIF ***************************************************************************************** ***************************************************************************************** IF aCalcInf[4+3] AFILL(Ar_Summ_i, 0) AFILL(Ar_Summ_j, 0) AFILL(Ar_Sred_i, 0) AFILL(Ar_Sred_j, 0) AFILL(Ar_Disp_i, 0) AFILL(Ar_Disp_j, 0) AFILL(Ar_ADMA_i, 0) mMess = L("5/9: Расчет модели знаний INF4 - ROI (Return On Investment) - PRC1:") mNumPP = 0 N_ALL = N_Gos * №1 FOR i=1 TO N_Gos // №1, N_Gos ################################ // Стадия исполнения отображается всегда, даже когда задан режим "без диалога" (Dialog=.F.) // Под диалогом понимается диалог задания моделей для синтеза и выбор текущей * aSay[ 9]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(9, mMess, N_ALL) * IF aStrEmpty[i] Pi = VAL(LC_FieldGet( Ar_Model[2]+".txt", nHandle[2], i, N_Cls+3 )) // Безусловная вероятность встречи i-го признака IF Pi > 0 AFILL(Ar_Pij, 0) FOR j=1 TO N_Cls * IF aColEmpty[j] Ar_Pij[j] = VAL(LC_FieldGet( Ar_Model[2]+".txt", nHandle[2], i, 2+j )) // Условные вероятности встречи i-го признака у объектов j-го класса * ENDIF NEXT For j=1 TO N_Cls * IF aColEmpty[j] IF Pi <> 0 IF Ar_Pij[j]/Pi > 0 ************************* Iij = Ar_Pij[j]/Pi - 1 // Расчет и запись Iij ************************* IF Iij <> 0 String = STR(Iij, aInfStruct[2+j,3], aInfStruct[2+j,4] ) // ##################### LC_FieldPut( Ar_Model[7]+".txt", nHandle[7], i, 2+j, String ) Ar_Summ_j[j] = Ar_Summ_j[j] + Iij // Расчет строки и углового элемента "Сумма" Ar_Summ_i[i] = Ar_Summ_i[i] + Iij // Расчет i-го элемента столбца "Сумма" ENDIF ENDIF ENDIF * ENDIF NEXT ENDIF * ENDIF IF Regim<>"3_5";lOk = Time_Progress (++Time_progress, Wsego, oProgress, lOk );ENDIF NEXT aSay[ 9]:SetCaption(aSay[ 9]:caption+L(" - Дорасчет")) aCalcInf[7] = .T.;PostCalcINF(7) // Дорасчет сумм, средних и ср.кв.откл. IF M_CurrInf=4+3 // Сделать данную модель баз знаний текущей (без диалога) F5_6(M_CurrInf,.F.,"3_3");DC_DataRest( aSave3_3 ) aSay[ 9]:SetCaption(aSay[ 9]:caption+L(" - Текущая")) ENDIF IF nRadioModel = 3 Calc_model_2nd_level(7, nRadioModel, nRadModelCr) ENDIF aSay[ 9]:SetCaption(aSay[ 9]:caption+L(" - Готово ")) ENDIF ***************************************************************************************** ***************************************************************************************** IF aCalcInf[5+3] AFILL(Ar_Summ_i, 0) AFILL(Ar_Summ_j, 0) AFILL(Ar_Sred_i, 0) AFILL(Ar_Sred_j, 0) AFILL(Ar_Disp_i, 0) AFILL(Ar_Disp_j, 0) AFILL(Ar_ADMA_i, 0) mMess = L("6/9: Расчет модели знаний INF5 - ROI (Return On Investment) - PRC2:") mNumPP = 0 N_ALL = N_Gos * №1 FOR i=1 TO N_Gos // №1, N_Gos ################################ // Стадия исполнения отображается всегда, даже когда задан режим "без диалога" (Dialog=.F.) // Под диалогом понимается диалог задания моделей для синтеза и выбор текущей * aSay[10]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(10, mMess, N_ALL) * IF aStrEmpty[i] Pi = VAL(LC_FieldGet( Ar_Model[3]+".txt", nHandle[3], i, N_Cls+3 )) // Безусловная вероятность встречи i-го признака IF Pi > 0 AFILL(Ar_Pij, 0) FOR j=1 TO N_Cls * IF aColEmpty[j] Ar_Pij[j] = VAL(LC_FieldGet( Ar_Model[3]+".txt", nHandle[3], i, 2+j )) // Условные вероятности встречи i-го признака у объектов j-го класса * ENDIF NEXT For j=1 TO N_Cls * IF aColEmpty[j] IF Pi <> 0 IF Ar_Pij[j]/Pi > 0 ************************* Iij = Ar_Pij[j]/Pi - 1 // Расчет и запись Iij ************************* IF Iij <> 0 String = STR(Iij, aInfStruct[2+j,3], aInfStruct[2+j,4] ) // ##################### LC_FieldPut( Ar_Model[8]+".txt", nHandle[8], i, 2+j, String ) Ar_Summ_j[j] = Ar_Summ_j[j] + Iij // Расчет строки и углового элемента "Сумма" Ar_Summ_i[i] = Ar_Summ_i[i] + Iij // Расчет i-го элемента столбца "Сумма" ENDIF ENDIF ENDIF * ENDIF NEXT ENDIF * ENDIF IF Regim<>"3_5";lOk = Time_Progress (++Time_progress, Wsego, oProgress, lOk );ENDIF NEXT aSay[10]:SetCaption(aSay[10]:caption+L(" - Дорасчет")) aCalcInf[8] = .T.;PostCalcINF(8) // Дорасчет сумм, средних и ср.кв.откл. IF M_CurrInf=5+3 // Сделать данную модель баз знаний текущей (без диалога) F5_6(M_CurrInf,.F.,"3_3");DC_DataRest( aSave3_3 ) aSay[10]:SetCaption(aSay[10]:caption+L(" - Текущая")) ENDIF IF nRadioModel = 3 Calc_model_2nd_level(8, nRadioModel, nRadModelCr) ENDIF aSay[10]:SetCaption(aSay[10]:caption+L(" - Готово ")) ENDIF ***************************************************************************************** ***************************************************************************************** IF aCalcInf[6+3] AFILL(Ar_Summ_i, 0) AFILL(Ar_Summ_j, 0) AFILL(Ar_Sred_i, 0) AFILL(Ar_Sred_j, 0) AFILL(Ar_Disp_i, 0) AFILL(Ar_Disp_j, 0) AFILL(Ar_ADMA_i, 0) mMess = L("7/9: Расчет модели знаний INF6 - Разность усл.и безусл.вероятн. - PRC1:") mNumPP = 0 N_ALL = N_Gos * №1 FOR i=1 TO N_Gos // №1, N_Gos ################################ // Стадия исполнения отображается всегда, даже когда задан режим "без диалога" (Dialog=.F.) // Под диалогом понимается диалог задания моделей для синтеза и выбор текущей * aSay[11]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(11, mMess, N_ALL) * IF aStrEmpty[i] Pi = VAL(LC_FieldGet( Ar_Model[2]+".txt", nHandle[2], i, N_Cls+3 )) // Безусловная вероятность встречи i-го признака IF Pi > 0 AFILL(Ar_Pij, 0) FOR j=1 TO N_Cls * IF aColEmpty[j] Ar_Pij[j] = VAL(LC_FieldGet( Ar_Model[2]+".txt", nHandle[2], i, 2+j )) // Условные вероятности встречи i-го признака у объектов j-го класса * ENDIF NEXT For j=1 TO N_Cls * IF aColEmpty[j] IF Pi <> 0 IF Ar_Pij[j]/Pi > 0 ************************* Iij = Ar_Pij[j] - Pi // Расчет и запись Iij ************************* IF Iij <> 0 String = STR(Iij, aInfStruct[2+j,3], aInfStruct[2+j,4] ) // ##################### LC_FieldPut( Ar_Model[9]+".txt", nHandle[9], i, 2+j, String ) Ar_Summ_j[j] = Ar_Summ_j[j] + Iij // Расчет строки и углового элемента "Сумма" Ar_Summ_i[i] = Ar_Summ_i[i] + Iij // Расчет i-го элемента столбца "Сумма" ENDIF ENDIF ENDIF * ENDIF NEXT ENDIF * ENDIF IF Regim<>"3_5";lOk = Time_Progress (++Time_progress, Wsego, oProgress, lOk );ENDIF NEXT aSay[11]:SetCaption(aSay[11]:caption+L(" - Дорасчет")) aCalcInf[9] = .T.;PostCalcINF(9) // Дорасчет сумм, средних и ср.кв.откл. IF M_CurrInf=6+3 // Сделать данную модель баз знаний текущей (без диалога) F5_6(M_CurrInf,.F.,"3_3");DC_DataRest( aSave3_3 ) aSay[11]:SetCaption(aSay[11]:caption+L(" - Текущая")) ENDIF IF nRadioModel = 3 Calc_model_2nd_level(9, nRadioModel, nRadModelCr) ENDIF aSay[11]:SetCaption(aSay[11]:caption+L(" - Готово ")) ENDIF ***************************************************************************************** ***************************************************************************************** IF aCalcInf[7+3] AFILL(Ar_Summ_i, 0) AFILL(Ar_Summ_j, 0) AFILL(Ar_Sred_i, 0) AFILL(Ar_Sred_j, 0) AFILL(Ar_Disp_i, 0) AFILL(Ar_Disp_j, 0) AFILL(Ar_ADMA_i, 0) mMess = L("8/9: Расчет модели знаний INF7 - Разность усл.и безусл.вероятн. - PRC2:") mNumPP = 0 N_ALL = N_Gos * №1 FOR i=1 TO N_Gos // №1, N_Gos ################################ // Стадия исполнения отображается всегда, даже когда задан режим "без диалога" (Dialog=.F.) // Под диалогом понимается диалог задания моделей для синтеза и выбор текущей * aSay[12]:SetCaption(mMess+' '+ALLTRIM(STR(++mNumPP/N_ALL*100,15,7))+'%') PercTimeVisio(12, mMess, N_ALL) * IF aStrEmpty[i] Pi = VAL(LC_FieldGet( Ar_Model[3]+".txt", nHandle[3], i, N_Cls+3 )) // Безусловная вероятность встречи i-го признака IF Pi > 0 AFILL(Ar_Pij, 0) FOR j=1 TO N_Cls Ar_Pij[j] = VAL(LC_FieldGet( Ar_Model[3]+".txt", nHandle[3], i, 2+j )) // Условные вероятности встречи i-го признака у объектов j-го класса NEXT For j=1 TO N_Cls * IF aColEmpty[j] IF Pi <> 0 IF Ar_Pij[j]/Pi > 0 ************************* Iij = Ar_Pij[j] - Pi // Расчет и запись Iij ************************* IF Iij <> 0 String = STR(Iij, aInfStruct[2+j,3], aInfStruct[2+j,4] ) // ##################### LC_FieldPut( Ar_Model[10]+".txt", nHandle[10], i, 2+j, String ) Ar_Summ_j[j] = Ar_Summ_j[j] + Iij // Расчет строки и углового элемента "Сумма" Ar_Summ_i[i] = Ar_Summ_i[i] + Iij // Расчет i-го элемента столбца "Сумма" ENDIF ENDIF ENDIF * ENDIF NEXT ENDIF * ENDIF IF Regim<>"3_5";lOk = Time_Progress (++Time_progress, Wsego, oProgress, lOk );ENDIF NEXT * MsgBox( "0 "+CURDIR() ) aSay[12]:SetCaption(aSay[12]:caption+L(" - Дорасчет")) aCalcInf[10] = .T.;PostCalcINF(10) // Дорасчет сумм, средних и ср.кв.откл. IF M_CurrInf=7+3 // Сделать данную модель баз знаний текущей (без диалога) F5_6(M_CurrInf,.F.,"3_3");DC_DataRest( aSave3_3 ) aSay[12]:SetCaption(aSay[12]:caption+L(" - Текущая")) ENDIF IF nRadioModel = 3 Calc_model_2nd_level(10, nRadioModel, nRadModelCr) Calc_model_2nd_level( 1, nRadioModel, nRadModelCr) Calc_model_2nd_level( 2, nRadioModel, nRadModelCr) Calc_model_2nd_level( 3, nRadioModel, nRadModelCr) ENDIF aSay[12]:SetCaption(aSay[12]:caption+L(" - Готово ")) ENDIF ***************************************************************************************** ****** Переиндексация БД классов и признаков (закрывает все БД, поэтому в самом конце, ****** хотя можно сохранять и восстанавливать вычислительную среду) aSay[13]:SetCaption(L("9/9: Переиндексация БД классификационных и описательных шкал и градаций")) *MsgBox( "1 "+CURDIR() ) *GenNtxClass() *MsgBox( "2 "+CURDIR() ) *GenNtxGrClSc() // ################################################################### *MsgBox( "3 "+CURDIR() ) *GenNtxOpSc() *MsgBox( "4 "+CURDIR() ) *GenNtxGrOpSc() aSay[13]:SetCaption(aSay[13]:caption+L(" - Готово ")) FOR z=1 TO LEN(Ar_Model) FClose( nHandle[z] ) // Закрытие dbf и txt баз данных ###################################### NEXT ***************************************************************************************** DC_ASave(aCalcInf, "_CalcInf.arx") // Запись информации о расчете моделей IF Dialog Running(.T.) // Чтобы не могли запустить какой-нибудь режим пока висит окно окончания работы oSay97:SetCaption(L("РАСЧЕТ ВСЕХ ЗАДАННЫХ БАЗ ЗНАНИЙ СИCТЕМЫ ЭЙДОС-X++ ЗАВЕРШЕН !")) oSay97:SetCaption(oSay97:caption) oButton:SetCaption(L('&Ok')) // Деструктурирование окна отображения графического Progress-bar oButton:activate := {||PostAppEvent(xbeP_Close,,,oDialog)} //<<<<<< Add This DC_AppEvent( @lOk ) oDialog:Destroy() ENDIF ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN( Time_Progress ) *********************************************************************************************************************** // Дорасчет строки и столбца "Сумма", "Среднее", "Средн.квадр.отклонение", средний модуль отклнения от среднего ####### // для текущей стат.модели или модели знаний (заданной F5_6()) ####### // и перенос Int_Inf (Disp) в Attributes, Opis_Sc, Gr_OpSc и Classes, Class_Sc, Gr_ClSc ####### *********************************************************************************************************************** FUNCTION PostCalcINF(z) LOCAL oPr, oDial Ar_Model := {"Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } *oScr := DC_WaitOn(L('Дорасчет строки и столбца "Сумма", "Среднее", "Средн.квадр.отклонение", "средн.модуль откл.от средн.". Немного подождите!!!'),,,,,,,,,,,.F.) *DC_ASave(aStrEmpty, "_aStrEmpty.arx") // Записывать только после расчета Abs.txt, а при расчете остальных БД только считывать *DC_ASave(aColEmpty, "_aColEmpty.arx") aStrEmpty = DC_ARestore("_aStrEmpty.arx") aColEmpty = DC_ARestore("_aColEmpty.arx") nMax = N_Gos + N_Cls + N_Cls + N_Gos + N_Cls + N_Gos + N_Cls - IF(z=2 .OR. z=3, N_Gos, 0) * 1 2 3 4 5 6 7 nMess = L('Дорасчет итоговых строк и столбцов в модели: "')+UPPER(Ar_Model[z])+'"' @ 5,4 DCPROGRESS oPr SIZE 80,1.0 MAXCOUNT nMax COLOR BD_TLCGOLD PERCENT EVERY 100 DCREAD GUI TITLE nMess PARENT @oDial FIT EXIT oDial:show() nTime = 0 DC_GetProgress(oPr,0,nMax) IF z = 2 .OR. z = 3 ELSE *** Запись столбца "Сумма" For i=1 TO N_Gos // №1, N_Gos, #################################################### * IF Ar_Summ_i[i] <> 0 String = STR(Ar_Summ_i[i], aInfStruct[N_Cls+3,3], aInfStruct[N_Cls+3,4] ) // Запись столбца "Сумма" LC_FieldPut( Ar_Model[z]+".txt", nHandle[z], i, N_Cls+3, String ) * ENDIF DC_GetProgress(oPr, ++nTime, nMax) NEXT ENDIF ***** Запись строки "Сумма" For j=1 TO N_Cls // №2, N_Cls, #################################################### * IF Ar_Summ_j[j] <> 0 String = STR(Ar_Summ_j[j], aInfStruct[2+j,3], aInfStruct[2+j,4] ) // Запись строки "Сумма" LC_FieldPut( Ar_Model[z]+".txt", nHandle[z], N_Gos+1, 2+j, String ) * ENDIF DC_GetProgress(oPr, ++nTime, nMax) NEXT ***** Рассчет углового элемента "Сумма" Summa_all = 0 For j=1 TO N_Cls // №3, N_Cls, #################################################### Summa_all = Summa_all + Ar_Summ_j[j] NEXT Sredn_all = Summa_all/(N_Cls*N_Gos) *IF Summa_all <> 0 String = STR(Summa_all, aInfStruct[N_Cls+3,3], aInfStruct[N_Cls+3,4] ) // Запись углового элемента "Сумма" LC_FieldPut( Ar_Model[z]+".txt", nHandle[z], N_Gos+1, N_Cls+3, String ) String = STR(Sredn_all, aInfStruct[N_Cls+4,3], aInfStruct[N_Cls+4,4] ) // Запись углового элемента "Среднее" LC_FieldPut( Ar_Model[z]+".txt", nHandle[z], N_Gos+2, N_Cls+4, String ) *ENDIF *** Расчет средних по строкам *** FOR i = 1 TO N_Gos // №4, N_Gos, #################################################### Ar_Sred_i[i] = Ar_Summ_i[i]/N_Cls * IF Ar_Sred_i[i] <> 0 String = STR(Ar_Sred_i[i], aInfStruct[N_Cls+4,3], aInfStruct[N_Cls+4,4] ) // Запись столбца "Среднее" LC_FieldPut( Ar_Model[z]+".txt", nHandle[z], i, N_Cls+4, String ) * ENDIF DC_GetProgress(oPr, ++nTime, nMax) NEXT ****** Расчет средних по столбцам *** FOR j = 1 TO N_Cls // №5, N_Cls, #################################################### Ar_Sred_j[j] = Ar_Summ_j[j]/N_Gos * IF Ar_Sred_j[j] <> 0 String = STR(Ar_Sred_j[j], aInfStruct[N_Cls+4,3], aInfStruct[N_Cls+4,4] ) // Запись строки "Среднее" LC_FieldPut( Ar_Model[z]+".txt", nHandle[z], N_Gos+2, 2+j, String ) * ENDIF DC_GetProgress(oPr, ++nTime, nMax) NEXT *** Расчет и запись столбца значимости признаков (градаций описательных шкал) - ср.кв.откл. и ср.отл.мод.от ср. *** * the average deviation of the modules from the average FOR i = 1 TO N_Gos // №6, N_Gos, ############################################## FOR j = 1 TO N_Cls Iij = 0 * DC_DebugQout( aStrEmpty[i] ) * DC_DebugQout( aColEmpty[j] ) * IF aStrEmpty[i] .AND. aColEmpty[j] Iij = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], i, 2+j )) // Информативность-элемент (i,j) * ENDIF Ar_Disp_i[i] = Ar_Disp_i[i] + (Ar_Sred_i[i]-Iij)^2 Ar_ADMA_i[i] = Ar_ADMA_i[i] + ABS(Ar_Sred_i[i]-Iij) NEXT Ar_Disp_i[i] = SQRT(Ar_Disp_i[i]/(N_Cls-1)) // Средн.квадр.отклонение Iij по i-му признаку Ar_ADMA_i[i] = Ar_ADMA_i[i]/N_Cls // средн.мод.отл.от средн. Iij по i-му признаку * IF Ar_Disp_i[i] <> 0 String = STR(Ar_Disp_i[i], aInfStruct[N_Cls+5,3], aInfStruct[N_Cls+5,4] ) // Запись столбца "Ср.кв.откл." LC_FieldPut( Ar_Model[z]+".txt", nHandle[z], i, N_Cls+5, String ) * ENDIF * IF Ar_ADMA_i[i] <> 0 String = STR(Ar_ADMA_i[i], aInfStruct[N_Cls+6,3], aInfStruct[N_Cls+6,4] ) // Запись столбца "ср.отл.мод.от ср." LC_FieldPut( Ar_Model[z]+".txt", nHandle[z], i, N_Cls+6, String ) * ENDIF DC_GetProgress(oPr, ++nTime, nMax) NEXT **** Расчет степени редукции классов *** Disp_all = 0 // угловой элемент "Дисперсия" FOR j = 1 TO N_Cls // №7, N_Cls, ############################################## FOR i = 1 TO N_Gos Iij = 0 * IF aStrEmpty[i] .AND. aColEmpty[j] Iij = VAL(LC_FieldGet( Ar_Model[z]+".txt", nHandle[z], i, 2+j )) // Информативность-элемент (i,j) * ENDIF Ar_Disp_j[j] = Ar_Disp_j[j]+(Ar_Sred_j[j]-Iij)^2 Disp_all = Disp_all + (Sredn_all - Iij) ^ 2 NEXT Ar_Disp_j[j] = SQRT(Ar_Disp_j[j]/(N_Gos-1)) // Средн.квадр.отклонение Iij по классу * IF Ar_Disp_j[j] <> 0 String = STR(Ar_Disp_j[j], aInfStruct[N_Cls+5,3], aInfStruct[N_Cls+5,4] ) // Запись строки "Ср.кв.откл." LC_FieldPut( Ar_Model[z]+".txt", nHandle[z], N_Gos+3, 2+j, String ) * ENDIF DC_GetProgress(oPr, ++nTime, nMax) NEXT *IF Disp_all <> 0 String = STR(SQRT(Disp_all/(N_Cls*N_Gos-1)), aInfStruct[N_Cls+5,3], aInfStruct[N_Cls+5,4] ) // "Дисперсия" - угловой элемент LC_FieldPut( Ar_Model[z]+".txt", nHandle[z], N_Gos+3, N_Cls+5, String ) *ENDIF **** Переписать последнюю строку из ABS в модель INF(z) *** FOR j=1 TO N_Cls // №8, N_Cls ################################ SummaObj = VAL(LC_FieldGet( Ar_Model[1]+".txt", nHandle[1], 4+N_Gos, 2+j )) // Скачивание поля из БД (корректная) ############ String = STR(SummaObj, aInfStruct[2+j,3], aInfStruct[2+j,4]) LC_FieldPut( Ar_Model[z]+".txt", nHandle[z], 4+N_Gos, 2+j, String ) // Запись поля в БД (корректная) ############ NEXT // Сумма числа Obj по всей БД Abs.dbf SummaObj = VAL(LC_FieldGet( Ar_Model[1]+".txt", nHandle[1], 4+N_Gos, 3+N_Cls )) // Скачивание поля из БД (корректная) ############ String = STR(SummaObj, aInfStruct[3+N_Cls,3], aInfStruct[3+N_Cls,4]) LC_FieldPut( Ar_Model[z]+".txt", nHandle[z], 4+N_Gos,3+N_Cls, String ) // Запись поля в БД (корректная) ############ DC_GetProgress(oPr,nMax,nMax) oDial:Destroy() *DC_Impl(oScr) *MsgBox(Ar_Model[z]) RETURN NIL ********************************************************************************************************** ******** Помощь по режиму 3_3: Смысл частных критериев знаний, применяемых в системе "Эйдос-Х++" ********************************************************************************************************** FUNCTION Help33() aSaveH3_3 := DC_DataSave() // Сохранение вычислительной среды (открытые и текущие БД и индексы) DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы cFile = "_Priv_Criteria.pdf" IF .NOT. FILE(cFile) Mess = L('В папке с исполнимым модулем системы нет файла: "#"') Mess = STRTRAN(Mess, "#", cFile) LB_Warning(Mess) ENDIF // Проверить контрольную сумму файла и если она не совпадает // выдать сообщение о том, что файл поврежден (чтобы было невозможно заменить графический файл). IF FILECHECK(cFile) = 93032445 // <<<===############### * DC_PrintPreviewAcrobat( cFile, 'Help3.3: Смысл частных критериев знаний системы "Эйдос-Х++"' ) * MsgBox(Disk_dir+'\'+cFile) * LC_RunUrl(Disk_dir+'\'+cFile) RunShell(cFile,"SumatraPDF-3.4.5-32.exe",.T.) ELSE Mess = L('Файл: "#" поврежден (CRC=$) и не может быть отображен!') Mess = STRTRAN(Mess, "#", cFile) Mess = STRTRAN(Mess, "$", ALLTRIM(STR(FILECHECK(cFile),19))) // Отображение контрольной суммы файла LB_Warning(Mess) ENDIF DIRCHANGE(Disk_dir) DC_DataRest( aSaveH3_3 ) // Восстановление вычислительной среды (открытые и текущие БД и индексы) RETURN NIL *********************************************************************************************************** ********* 4.1.1. Ручной ввод-корректировка распознаваемой выборки ********* режим сисадмина точно такой-же, как режим "2.3.1. Ввод-корректровка обучающей выборки", ********* а для администратора приложений и пользователей надо убрать возможность просмотра ********* и корректировки кодов классов и, соответственно, по-другому расположить окна *********************************************************************************************************** FUNCTION F4_1_1() LOCAL GetList := {}, GetOptions, oBrowUser, oBrowApp, bApp, bItems Running(.T.) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF ApplChange("4.1.1()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF IF FILE("Obi_Zag.dbf") // БД заголовков обучающей выборки ** Переиндексировать БД Obi_Zag.dbf, ** если не хватает хотя бы одного какого-нибудь индексного массива IF .NOT. FILE("Oiz_kod.ntx" ) .OR.; .NOT. FILE("Oiz_name.ntx") .OR.; .NOT. FILE("Obi_Zag.ntx" ) GenNtxObiZag() ENDIF ELSE GenDbfObiZag() ENDIF IF FILE("Obi_Kcl.dbf") // БД классов обучающей выборки ** Переиндексировать БД Obi_Kcl.dbf, ** если не хватает хотя бы одного какого-нибудь индексного массива IF .NOT. FILE("Oic_kod.ntx") .OR.; .NOT. FILE("Obi_Kcl.ntx") GenNtxObiKcl() ENDIF ELSE GenDbfObiKcl() ENDIF IF FILE("Obi_Kpr.dbf") // БД признаков обучающей выборки ** Переиндексировать БД Obi_Kpr.dbf, ** если не хватает хотя бы одного какого-нибудь индексного массива IF .NOT. FILE("Oip_kod.ntx") .OR.; .NOT. FILE("Obi_Kpr.ntx") GenNtxObiKpr() ENDIF ELSE GenDbfObiKpr() 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 dbeSetDefault('DBFNTX') IF ApplChange("") // Перейти в папку выбранного приложения или выйти из системы LB_Warning(L("Необходимо задать (выбрать) хотя бы одно текущее приложение !!!")) Running(.F.) RETURN NIL ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rso_Zag INDEX ON Kod_Obj TO Rso_Zag CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rso_Kcl NEW INDEX ON Kod_Obj TO Rso_Kcl CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rso_Kpr NEW INDEX ON Kod_Obj TO Rso_Kpr CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Obi_Zag INDEX Obi_Zag EXCLUSIVE USE Obi_Kcl INDEX Obi_Kcl EXCLUSIVE NEW USE Obi_Kpr INDEX Obi_Kpr EXCLUSIVE NEW USE Rso_Zag INDEX Rso_Zag EXCLUSIVE NEW USE Rso_Kcl INDEX Rso_Kcl EXCLUSIVE NEW USE Rso_Kpr INDEX Rso_Kpr EXCLUSIVE NEW /* ----- Create ToolBar ----- */ d = 12 @ 27.5, 0 DCTOOLBAR oToolBar SIZE 143, 1.5 DCADDBUTTON CAPTION L('Помощь') ; SIZE LEN(L("Помощь"))+4 ; ACTION {||Help411(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Помощь по режиму 4.1.1') @ DCGUI_ROW, DCGUI_COL + d DCPUSHBUTTON CAPTION L('Скопировать расп.выб.в обуч.') ; SIZE LEN(L("Скопировать обуч.выб.в расп."))-3, 1.5 ; ACTION {||CopyRoOi4_1_1(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Скопировать распознаваемую выборку в обучающую') @ DCGUI_ROW, DCGUI_COL + d DCPUSHBUTTON CAPTION L('Добавить объект') ; SIZE LEN(L("Добавить объект"))+1, 1.5 ; ACTION {||Add_Obj4_1_1(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Добавить объект') @ DCGUI_ROW, DCGUI_COL + d DCPUSHBUTTON CAPTION L('Добавить признаки') ; SIZE LEN(L("Добавить признаки"))+1, 1.5 ; ACTION {||Add_Kpr4_1_1(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Добавить строку признаков') @ DCGUI_ROW, DCGUI_COL + d DCPUSHBUTTON CAPTION L('Удалить объект') ; SIZE LEN(L("Удалить объект"))+2, 1.5 ; ACTION {||Del_Obj4_1_1(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Удалить объект') @ DCGUI_ROW, DCGUI_COL + d DCPUSHBUTTON CAPTION L('Удалить классы') ; SIZE LEN(L("Удалить классы"))+2, 1.5 ; ACTION {||Del_Kcl4_1_1(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Удалить строку классов') @ DCGUI_ROW, DCGUI_COL + d DCPUSHBUTTON CAPTION L('Удалить признаки') ; SIZE LEN(L("Удалить признаки"))+1, 1.5 ; ACTION {||Del_Kpr4_1_1(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Удалить строку признаков') @ DCGUI_ROW, DCGUI_COL + d DCPUSHBUTTON CAPTION L('Очистить БД') ; SIZE LEN(L("Очистить БД"))+2, 1.5 ; ACTION {||Zap_db4_1_1(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Очистить базу данных') /* ----- Create browse-1: Главная БД Rso_Zag.dbf ----- */ bZag := {|| Rso_Kpr->(DC_SetScope(0,Rso_Zag->Kod_Obj)), ; Rso_Kpr->(DC_SetScope(1,Rso_Zag->Kod_Obj)), ; Rso_Kpr->(DC_DbGoTop()) , ; oBrowKpr:refreshAll() , ; Rso_Kcl->(DC_SetScope(0,Rso_Zag->Kod_Obj)), ; Rso_Kcl->(DC_SetScope(1,Rso_Zag->Kod_Obj)), ; Rso_Kcl->(DC_DbGoTop()) , ; oBrowKcl:refreshAll() } d = 10 @ 1, 0 DCBROWSE oBrowZag ALIAS 'Rso_Zag' SIZE 133+d,12.5 ; EDIT xbeBRW_ItemSelected MODE DCGUI_BROWSE_EDITDOWN ; // Редактирование БД Rso_Zag.dbf NOSOFTTRACK ; SCOPE ; ITEMMARKED {|| Eval(bZag), ; DC_GetRefresh(GetList,, ; DCGETREFRESH_TYPE_EXCLUDE,{GETLIST_BROWSE}) } DCSETPARENT oBrowZag DCBROWSECOL FIELD Rso_Zag->Kod_Obj HEADER L('Код объекта' ) WIDTH 1 PROTECT {|| .T. } DCBROWSECOL FIELD Rso_Zag->Name_obj HEADER L('Наименование объекта') WIDTH 54.5+d-4 DCBROWSECOL FIELD Rso_Zag->Date HEADER L('Дата' ) WIDTH 10.4 PROTECT {|| .T. } DCBROWSECOL FIELD Rso_Zag->Time HEADER L('Время' ) WIDTH 9.5 PROTECT {|| .T. } /* Create browse-2: БД Rso_Kcl.dbf, связанная отношением "Один ко многим" с БД Rso_Zag.dbf*/ DCSETPARENT TO @14, 0 DCBROWSE oBrowKcl ALIAS 'Rso_Kcl' SIZE 51,13 ; EDIT xbeBRW_ItemSelected MODE DCGUI_BROWSE_EDITDOWN ; NOSOFTTRACK ; SCOPE ; ITEMMARKED bItems DCSETPARENT oBrowKcl DCBROWSECOL FIELD Rso_Kcl->Kod_Obj HEADER L('Код объекта') WIDTH 1 PROTECT {|| .T. } DCBROWSECOL FIELD Rso_Kcl->Cls1 HEADER L('Класс 1' ) WIDTH 5 DCBROWSECOL FIELD Rso_Kcl->Cls2 HEADER L('Класс 2' ) WIDTH 5 DCBROWSECOL FIELD Rso_Kcl->Cls3 HEADER L('Класс 3' ) WIDTH 5 DCBROWSECOL FIELD Rso_Kcl->Cls4 HEADER L('Класс 4' ) WIDTH 5 /* Create browse-3: БД Rso_Kpr.dbf, связанная отношением "Один ко многим" с БД Rso_Zag.dbf*/ DCSETPARENT TO @14,54 DCBROWSE oBrowKpr ALIAS 'Rso_Kpr' SIZE 79+d,13 ; EDIT xbeBRW_ItemSelected MODE DCGUI_BROWSE_EDITDOWN ; NOSOFTTRACK ; SCOPE ; ITEMMARKED bItems DCSETPARENT oBrowKpr DCBROWSECOL FIELD Rso_Kpr->Kod_Obj HEADER L('Код объекта') WIDTH 1 PROTECT {|| .T. } DCBROWSECOL FIELD Rso_Kpr->Atr1 HEADER L('Признак 1' ) WIDTH 6 DCBROWSECOL FIELD Rso_Kpr->Atr2 HEADER L('Признак 2' ) WIDTH 6 DCBROWSECOL FIELD Rso_Kpr->Atr3 HEADER L('Признак 3' ) WIDTH 6 DCBROWSECOL FIELD Rso_Kpr->Atr4 HEADER L('Признак 4' ) WIDTH 6 DCBROWSECOL FIELD Rso_Kpr->Atr5 HEADER L('Признак 5' ) WIDTH 6 DCBROWSECOL FIELD Rso_Kpr->Atr6 HEADER L('Признак 6' ) WIDTH 6 DCBROWSECOL FIELD Rso_Kpr->Atr7 HEADER L('Признак 7' ) WIDTH 6 DCGETOPTIONS SAYFONT '10.Helv Bold' TABSTOP AUTORESIZE IF Flag_SysAdmin cTitle = L('4.1.1. Ручной ввод-корректировка распознаваемой выборки (режим сисадмина). Текущая модель: "')+UPPER(Ar_Model[M_CurrInf])+'"' ELSE cTitle = L('4.1.1. Ручной ввод-корректировка распознаваемой выборки. Текущая модель: "')+UPPER(Ar_Model[M_CurrInf])+'"' ENDIF DCREAD GUI ; FIT ; OPTIONS GetOptions ; MODAL ; TITLE cTitle ; EVAL {|o|SetAppFocus(oBrowZag:GetColumn(1))} ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ****** END OF EXAMPLE *********************** ************************************************************************************************** FUNCTION Help411() aHelp := {} AADD(aHelp, L('Режим: "4.1.1. РУЧНОЙ ВВОД-КОРРЕКТИРОВКА РАСПОЗНАВАЕМОЙ ВЫБОРКИ",')) AADD(aHelp, L('предназначен для указания признаков конкретных объектов. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Коды признаков указываются в соответствии с описательными шкалами')) AADD(aHelp, L('и градациями. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Формирование распознаваемой выборки является последним этапом ')) AADD(aHelp, L('перед распознаванием объектов (режим 4.1.2), в котором описания ')) 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('Помощь по режиму: 4.1.1. (C) Система "ЭЙДОС-X++"') RETURN NIL ************************************************************************************************** ******** Скопировать распознаваемую выборку в обучающую ******** Для организации диалога использован пример XSample_184() из xdemo.exe FUNCTION CopyRoOi4_1_1() LOCAL GetList[0], GetOptions, lCheck1, lCheck2, nRadio1, nRadio2, ; oGroup1, oGroup2, M_KodObj, lOk nRadio1 := 2 nRadio2 := 2 @ 0, 0 DCGROUP oGroup1 CAPTION L('Что копировать') SIZE 40,4 @ 0,42 DCGROUP oGroup2 CAPTION L('Стирать или дополнять') SIZE 40,4 @ 1,2 DCRADIO nRadio1 VALUE 1 PROMPT L('Копировать всю базу данных' ) PARENT oGroup1 // nRadio1 := 1 @ 2,2 DCRADIO nRadio1 VALUE 2 PROMPT L('Копировать только текущий объект') PARENT oGroup1 // nRadio1 := 2 @ 1,2 DCRADIO nRadio2 VALUE 1 PROMPT L('Стирать обучающую выборку' ) PARENT oGroup2 // nRadio2 := 1 @ 2,2 DCRADIO nRadio2 VALUE 2 PROMPT L('Дополнять обучающую выборку' ) PARENT oGroup2 // nRadio2 := 2 DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; OPTIONS GetOptions ; ADDBUTTONS ; MODAL ; TITLE L('4.1.1. Параметры копирования распознаваемой выборки в обучающую') ******************************************************************** * DCREAD GUI ; * TO lExit ; IF lExit ** Button Ok ELSE RETURN NIL ENDIF ******************************************************************** *LB_Warning(L("Радио1:"+STR(nRadio1,3)+" Радио2:"+STR(nRadio2,3)) SELECT Rso_zag IF nRadio1 = 2 M_KodObj = Kod_obj ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Obi_Zag INDEX Obi_Zag EXCLUSIVE USE Obi_Kcl INDEX Obi_Kcl EXCLUSIVE NEW USE Obi_Kpr INDEX Obi_Kpr EXCLUSIVE NEW USE Rso_Zag INDEX Rso_Zag EXCLUSIVE NEW USE Rso_Kcl INDEX Rso_Kcl EXCLUSIVE NEW USE Rso_Kpr INDEX Rso_Kpr EXCLUSIVE NEW // Подготовка данных для отображения графического прогресс-бар // Определить значение Wsego DO CASE CASE nRadio1 = 1 SELECT Rso_zag;N_RsoZag = RECCOUNT() SELECT Rso_Kcl;N_RsoKcl = RECCOUNT() SELECT Rso_Kpr;N_RsoKpr = RECCOUNT() CASE nRadio1 = 2 SELECT Rso_zag SET FILTER TO M_KodObj = Kod_obj DBGOTOP();DBGOBOTTOM();DBGOTOP() COUNT TO N_RsoZag SELECT Rso_Kcl SET FILTER TO M_KodObj = Kod_obj DBGOTOP();DBGOBOTTOM();DBGOTOP() COUNT TO N_RsoKcl SELECT Rso_Kpr SET FILTER TO M_KodObj = Kod_obj DBGOTOP();DBGOBOTTOM();DBGOTOP() COUNT TO N_RsoKpr ENDCASE Wsego = N_RsoZag + N_RsoKcl + N_RsoKpr // Задание максимальной величины параметра Time 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 s = 1 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 1] FONT "10.Helv" // Obi_Zag @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 2] FONT "10.Helv" // Obi_Kcl @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 3] FONT "10.Helv" // Obi_Kpr @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 4] FONT "10.Helv" // Переиндексация s++ @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 8] 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('4.1.1. Копирование распознаваемой выборки в обучающую') ; PARENT @oDialog ; FIT ; EXIT ; MODAL oDialog:show() // Завершение подготовки данных для отображения графического прогресс-бар DO CASE CASE nRadio2 = 1 SELECT Obi_zag;ZAP SELECT Obi_Kcl;ZAP SELECT Obi_Kpr;ZAP CASE nRadio2 = 2 SELECT Obi_zag DBGOBOTTOM() M_MaxKodObj = Kod_Obj+1 Ar_KodObjOld := {} // Коды объектов исходной выборки Ar_KodObjNew := {} // Коды объектов результирующей выборки ENDCASE aSay[ 1]:SetCaption(L("Шаг 1-й из 4. Копирование базы заголовков распознаваемой выборки")) SELECT Rso_zag SET ORDER TO DBGOTOP() DO WHILE .NOT. EOF() IF nRadio2 = 2 AADD(Ar_KodObjOld, Kod_obj) AADD(Ar_KodObjNew, M_MaxKodObj++) // Если дополнять БД, то 1-й код следующий за последним ENDIF Ar := {} FOR j=1 TO FCOUNT() AADD(Ar, FIELDGET(j)) NEXT SELECT Obi_zag APPEND BLANK FOR j=1 TO FCOUNT() FIELDPUT(j,Ar[j]) IF nRadio2 = 2 Pos = ASCAN(Ar_KodObjOld, Ar[1]) FIELDPUT(1, Ar_KodObjNew[Pos]) ENDIF NEXT lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) SELECT Rso_zag DBSKIP(1) ENDDO aSay[ 1]:SetCaption(aSay[ 1]:caption+L(" - Готово ")) aSay[ 2]:SetCaption(L("Шаг 2-й из 4. Копирование базы кодов классов распознаваемой выборки")) SELECT Rso_Kcl DBGOTOP() DO WHILE .NOT. EOF() Ar := {} FOR j=1 TO FCOUNT() AADD(Ar, FIELDGET(j)) NEXT SELECT Obi_Kcl APPEND BLANK FOR j=1 TO FCOUNT() FIELDPUT(j,Ar[j]) IF nRadio2 = 2 Pos = ASCAN(Ar_KodObjOld, Ar[1]) FIELDPUT(1, Ar_KodObjNew[Pos]) ENDIF NEXT lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) SELECT Rso_Kcl DBSKIP(1) ENDDO aSay[ 2]:SetCaption(aSay[ 2]:caption+L(" - Готово ")) aSay[ 3]:SetCaption(L("Шаг 3-й из 4. Копирование базы кодов признаков распознаваемой выборки")) SELECT Rso_Kpr DBGOTOP() DO WHILE .NOT. EOF() Ar := {} FOR j=1 TO FCOUNT() AADD(Ar, FIELDGET(j)) NEXT SELECT Obi_Kpr APPEND BLANK FOR j=1 TO FCOUNT() FIELDPUT(j,Ar[j]) IF nRadio2 = 2 Pos = ASCAN(Ar_KodObjOld, Ar[1]) FIELDPUT(1, Ar_KodObjNew[Pos]) ENDIF NEXT lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) SELECT Rso_Kpr DBSKIP(1) ENDDO aSay[ 3]:SetCaption(aSay[ 3]:caption+L(" - Готово ")) aSay[ 4]:SetCaption(L("Шаг 4-й из 4. Переиндексация обучающей выборки")) SELECT Obi_zag INDEX ON STR(Kod_Obj,19) TO Oiz_kod INDEX ON Name_Obj TO Oiz_name INDEX ON Kod_Obj TO Obi_zag SELECT Obi_Kcl INDEX ON STR(Kod_Obj,19) TO Oic_kod INDEX ON Kod_Obj TO Obi_Kcl SELECT Obi_Kpr INDEX ON STR(Kod_Obj,19) TO Oip_kod INDEX ON Kod_Obj TO Obi_Kpr aSay[ 4]:SetCaption(aSay[ 4]:caption+L(" - Готово ")) // Заключительные операции и деструктурирование окна отображения графического Progress-bar aSay[ 8]:SetCaption(L("КОПИРОВАНИЕ РАСПОЗНАВАЕМОЙ ВЫБОРКИ В ОБУЧАЮЩУЮ ЗАВЕРШЕНО УСПЕШНО!!!")) aSay[ 8]:SetCaption(aSay[ 8]:caption) oButton:SetCaption(L('&Ok')) // Деструктурирование окна отображения графического Progress-bar oButton:activate := {||PostAppEvent(xbeP_Close,,,oDialog)} //<<<<<< Add This DC_AppEvent( @lOk ) oDialog:Destroy() RETURN NIL ******** Добавить объект в конец БД Rso_Zag.dbf FUNCTION Add_Obj4_1_1() SELECT Rso_Zag DBGOBOTTOM() M_KodObj = Kod_Obj APPEND BLANK REPLACE Kod_Obj WITH M_KodObj+1 REPLACE Date WITH DTOC(DATE()) REPLACE Time WITH Time() Add_Kcl4_1_1() Add_Kpr4_1_1() SELECT Rso_Zag DBGOBOTTOM() DC_GetRefresh(GetList) RETURN NIL ******** Добавить строку классов в конец БД Rso_Kcl.dbf FUNCTION Add_Kcl4_1_1() SELECT Rso_Zag M_KodObj = Kod_Obj SELECT Rso_Kcl APPEND BLANK REPLACE Kod_Obj WITH M_KodObj RETURN NIL ******** Добавить строку признаков в конец БД Rso_Kpr.dbf FUNCTION Add_Kpr4_1_1() SELECT Rso_Zag M_KodObj = Kod_Obj SELECT Rso_Kpr APPEND BLANK REPLACE Kod_Obj WITH M_KodObj RETURN NIL ******** Удалить текущую запись в БД Rso_Zag.dbf ******** и связанные с ней записи БД Rso_Kcl.dbf и Rso_Kpr.dbf FUNCTION Del_Obj4_1_1() SELECT Rso_Zag M_Recno = RECNO() M_Kod_obj = Kod_Obj DELETE PACK // Удалить связанные БД SELECT Rso_Kcl DELETE FOR M_Kod_obj = Kod_Obj PACK SELECT Rso_Kpr DELETE FOR M_Kod_obj = Kod_Obj PACK SELECT Rso_Zag DBGOTO(M_Recno) RETURN NIL ******** Удалить текущую запись в БД Rso_Kcl.dbf FUNCTION Del_Kcl4_1_1() SELECT Rso_Kcl M_Recno = RECNO() DELETE PACK DBGOTO(M_Recno) RETURN NIL ******** Удалить текущую запись в БД Rso_Kpr.dbf FUNCTION Del_Kpr4_1_1() SELECT Rso_Kpr M_Recno = RECNO() DELETE PACK DBGOTO(M_Recno) RETURN NIL ******** Очистить БД FUNCTION Zap_db4_1_1() SELECT Rso_Zag;ZAP APPEND BLANK REPLACE Kod_Obj WITH 1 REPLACE Date WITH DTOC(DATE()) REPLACE Time WITH Time() SELECT Rso_Kcl;ZAP APPEND BLANK REPLACE Kod_Obj WITH 1 SELECT Rso_Kpr;ZAP APPEND BLANK REPLACE Kod_Obj WITH 1 RETURN NIL ******** Генерация БД заголовков обучающей выборки FUNCTION GenDbfRsoZag() aSaveGenDbf := DC_DataSave() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций cFileName := "Rso_Zag.dbf" aStructure := { { "Kod_Obj" , "N", 15, 0 }, ; { "Name_Obj", "C", 65, 0 }, ; { "Date" , "C", 10, 0 }, ; { "Time" , "C", 8 , 0 } } DbCreate( cFileName, aStructure ) GenNtxRsoZag() DC_DataRest( aSaveGenDbf ) RETURN NIL ******** Генерация БД кодов классов обучающей выборки FUNCTION GenDbfRsoKcl() aSaveGenDbf := DC_DataSave() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций cFileName := "Rso_Kcl.dbf" aStructure := { { "Kod_Obj", "N", 15, 0 }, ; { "Cls1" , "N", 15, 0 }, ; { "Cls2" , "N", 15, 0 }, ; { "Cls3" , "N", 15, 0 }, ; { "Cls4" , "N", 15, 0 } } DbCreate( cFileName, aStructure ) GenNtxRsoKcl() DC_DataRest( aSaveGenDbf ) RETURN NIL ******** Генерация БД кодов признаков обучающей выборки FUNCTION GenDbfRsoKpr() aSaveGenDbf := DC_DataSave() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций cFileName := "Rso_Kpr.dbf" aStructure := { { "Kod_Obj", "N", 15, 0 }, ; { "Atr1" , "N", 15, 0 }, ; { "Atr2" , "N", 15, 0 }, ; { "Atr3" , "N", 15, 0 }, ; { "Atr4" , "N", 15, 0 }, ; { "Atr5" , "N", 15, 0 }, ; { "Atr6" , "N", 15, 0 }, ; { "Atr7" , "N", 15, 0 } } DbCreate( cFileName, aStructure ) GenNtxRsoKpr() DC_DataRest( aSaveGenDbf ) RETURN NIL ******** Создание индексных массивов БД заголовков объектов обучающей выборки FUNCTION GenNtxRsoZag() *aSaveGN10 := DC_DataSave() IF .NOT. FILE("Rso_Zag.dbf") GenDbfOpSc(.F.) ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rso_Zag EXCLUSIVE NEW INDEX ON STR(Kod_Obj,19) TO Roz_kod INDEX ON Name_Obj TO Roz_name INDEX ON Kod_Obj TO Rso_zag CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций *DC_DataRest( aSaveGN10 ) RETURN NIL ******** Создание индексных массивов БД кодов классов обучающей выборки FUNCTION GenNtxRsoKcl() *aSaveGN11 := DC_DataSave() IF .NOT. FILE("Rso_Kcl.dbf") GenDbfRsoKcl() ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rso_Kcl EXCLUSIVE NEW INDEX ON STR(Kod_Obj,19) TO Roc_kod INDEX ON Kod_Obj TO Rso_Kcl CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций *DC_DataRest( aSaveGN11 ) RETURN NIL ******** Создание индексных массивов БД кодов признаков обучающей выборки FUNCTION GenNtxRsoKpr() *aSaveGN12 := DC_DataSave() IF .NOT. FILE("Rso_Kpr.dbf") GenDbfRsoKpr() ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rso_Kpr EXCLUSIVE NEW INDEX ON STR(Kod_Obj,19) TO Rop_kod INDEX ON Kod_Obj TO Rso_Kpr CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций *DC_DataRest( aSaveGN12 ) RETURN NIL ******************************************************************************************** ******** 5.6. Выбрать модель и сделать ее текущей ########## ******************************************************************************************** ****** Этот перенос и дорасчет делать только для ТЕКУЩЕЙ модели (по умолчанию: INF1) ****** в режиме задания текущей модели (а отсюда его убрать): ****** 0. Задать текущую стат.модель или модель знаний ****** 2. Выполнить перенос информации из текущей модели в Attributes, Opis_Sc, Gr_OpSc и Classes, Class_Sc, Gr_ClSc ####### ****** - добавить формирование класс.шкал и градаций (если они уже созданы в 2.1) ****** - добавить формирование и перенос Int_Inf (Disp) в Attributes и Gr_ClSc ########## ****** 3. Сделать расчет значимости описательных шкал на основе INF. ****** 4. Сделать расчет значимости классификационных шкал на основе INF. ****** 5. Привести в соответствие файл о текущей модели: DC_ASave(M_CurrInf, "_CurrInf.arx") ******************************************************************************************** FUNCTION F5_6(M_CurrInf, Dialog, Regim) LOCAL GetList[0], lOk Running(.T.) *IF M_CurrInf = 1 ** IF Dialog * LB_Warning(L('База абсолютных частот "ABS" не может быть задана в качестве текущей!')) ** ENDIF * Running(.F.) * RETURN NIL *ENDIF IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF Dialog IF ApplChange("5.6()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF ELSE IF ApplChange("") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения PUBLIC aSaveMainM := DC_ARestore("_SaveMainM.arx") // Восстановление вычислительной среды (открытые и текущие БД и индексы) с диска DC_DataRest( aSaveMainM ) // Восстановление вычислительной среды (открытые и текущие БД и индексы) Running(.F.) RETURN NIL ENDIF ENDIF IF .NOT. FILE("Abs.txt") // БД абс.частот LB_Warning(L("Проведите рассчет матрицы абсолютных частот Abs в режиме 3.1!")) Running(.F.) RETURN NIL ENDIF IF .NOT. FILE("Prc1.txt") .OR.; // БД процентных распределений .NOT. FILE("Prc2.txt") LB_Warning(L("Проведите рассчет матриц условных и безусловных процентных распределений Prc1 и Prc2 в режиме 3.2 !")) Running(.F.) RETURN NIL ENDIF IF .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("Если нужно проведите рассчет баз знаний Inf1-Inf7 в режиме 3.3!")) Running(.F.) RETURN NIL ENDIF dbeSetDefault('DBFNTX') ****** Задание на расчет баз знаний IF FILE("_CalcInf.arx") // Файл с информацией о том, какие модели были рассчитаны ранее aCalcInf = DC_ARestore("_CalcInf.arx") ELSE LB_Warning(L("Необходимо выполнить расчет баз знаний в режиме 3.3.!")) Running(.F.) RETURN NIL ENDIF IF Dialog IF FILE("_CurrInf.arx") // Файл с информацией о том, какая модель задана текущей M_CurrInf = DC_ARestore("_CurrInf.arx") ELSE DC_ASave(M_CurrInf, "_CurrInf.arx") ENDIF ENDIF IF Dialog ******************************************************************************************* ****** 0. Задать текущую стат.модель или модель знаний ******************************************************************************************* ****** Задание текущей модели @ 0,0 DCGROUP oGroup1 CAPTION L('Задайте текущую стат.модель или модель знаний') SIZE 90,13.5 @14,0 DCGROUP oGroup2 CAPTION L('Как задавать параметры синтеза моделей' ) SIZE 90, 5.0 @ 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 DCSAY L('В качестве текущей можно задать любую из ранее расчитанных в режимах 3.1, 3.2, 3.3 или 3.4 стат. моделей') PARENT oGroup2 @2,3 DCSAY L('и моделей знаний, но до исследования достоверности моделей в режиме 3.5 рекомендуется выбрать в качестве') PARENT oGroup2 @3,3 DCSAY L('текущей базу знаний INF1. Смысл моделей знаний, применяемых в системе "Эйдос-Х++" раскрыт в публикациях,') PARENT oGroup2 @4,3 DCSAY L('размещенных по адресам: http://lc.kubagro.ru/aidos/index.htm, http://www.twirpx.com/file/793311/ ') PARENT oGroup2 DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; OPTIONS GetOptions ; ADDBUTTONS; MODAL ; TITLE L('5.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 ******************************************************************** Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } M_Inf = UPPER(Ar_Model[M_CurrInf]) mFlagErr = .F. * IF M_CurrInf = 1 * LB_Warning(L('База абсолютных частот "ABS" не может быть задана в качестве текущей! ')) * mFlagErr = .T. * ENDIF IF 1 <= M_CurrInf .AND. M_CurrInf <= 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 *************************************** DC_ASave(aCalcInf , "_CalcInf.arx") // Файл с информацией о том, создание каких моделей было задано DC_ASave(M_CurrInf, "_CurrInf.arx") // Файл с информацией о том, какая модель задана текущей StrFile(STR(M_CurrInf,3), "_CurrInf.txt") // Файл с информацией о том, какая модель задана текущей ******************************************************************************************** // Подготовка данных для отображения графического прогресс-бар // Определить значение Wsego CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Gr_ClSc EXCLUSIVE NEW;N_Gcs = RECCOUNT() USE Class_Sc EXCLUSIVE NEW;N_Csc = RECCOUNT() USE Attributes EXCLUSIVE NEW;N_Atr = RECCOUNT() USE Gr_OpSc EXCLUSIVE NEW;N_Gos = RECCOUNT() USE Opis_Sc EXCLUSIVE NEW;N_Osc = RECCOUNT() // Задание максимальной величины параметра Time Wsego = N_Gos+N_Cls+; // 1/7: Копирование в массивы итоговых строк и столбцов текущей модели N_Cls+; // 2/7: Перенос информации из текущей модели в базы классов: Classes и Gr_ClSc N_Gos+; // 3/7: Перенос информации из текущей модели в базы признаков: Attributes и Gr_OpSc N_Osc+N_Csc+; // 4/7: Расчет значимости класс.и опис.шкал - Сброс сумматоров N_Gos+N_Osc+; // 5/7: Расчет значимости класс.и опис.шкал - Накопление данных N_Cls+N_Csc+; N_Osc+N_Csc // 6/7: Расчет значимости класс.и опис.шкал - Дорасчет // Отображение стадии исполнения. Будет написано прямо в окне Progress-bar @ 0,0 DCGROUP oGroup1 CAPTION L('Стадии исполнения процесса') FONT "6.Helv" SIZE 105,9.5 ; PARENT oTabPage1 @11,0 DCGROUP oGroup2 CAPTION L('Прогноз времени исполнения') FONT "6.Helv" SIZE 105,5.0 ; PARENT oTabPage2 s = 1 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 6] FONT "10.Helv" // Зарезервировано под название операции @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 7] FONT "10.Helv" // 1 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 8] FONT "10.Helv" // 2 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 9] FONT "10.Helv" // 3 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[10] FONT "10.Helv" // 4 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[11] FONT "10.Helv" // 5 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[12] FONT "10.Helv" // 6 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[13] FONT "10.Helv" // 7 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('5.6. Выбрать модель и сделать ее текущей') ; PARENT @oDialog ; FIT ; EXIT ; MODAL oDialog:show() ENDIF ***************************************************************************************************** mLenNameMax = CreateStructAll() // Создание файлов структур баз данных всех моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Gr_ClSc EXCLUSIVE NEW;N_Gcs = RECCOUNT() USE Class_Sc EXCLUSIVE NEW;N_Csc = RECCOUNT() USE Attributes EXCLUSIVE NEW;N_Atr = RECCOUNT() USE Gr_OpSc EXCLUSIVE NEW;N_Gos = RECCOUNT() USE Opis_Sc EXCLUSIVE NEW;N_Osc = RECCOUNT() *USE Abs EXCLUSIVE NEW // БД - матрица абсолютных частот (матрица сопряженности) *USE Prc1 EXCLUSIVE NEW // ИБ - матрица условных и безусловных процентных распределений *USE Prc2 EXCLUSIVE NEW // ИБ - матрица условных и безусловных процентных распределений *USE Inf EXCLUSIVE NEW // Текущая модель *USE Inf1 EXCLUSIVE NEW // БЗ-1 - Inf1~Prc1 *USE Inf2 EXCLUSIVE NEW // БЗ-2 - Inf2~Prc2 *USE Inf3 EXCLUSIVE NEW // БЗ-3 - Inf3-хи-квадрат *USE Inf4 EXCLUSIVE NEW // БЗ-4 - Inf4-roi~Prc1 *USE Inf5 EXCLUSIVE NEW // БЗ-5 - Inf5-roi~Prc2 *USE Inf6 EXCLUSIVE NEW // БЗ-6 - Inf6-Dp~Prc1 *USE Inf7 EXCLUSIVE NEW // БЗ-7 - Inf7-Dp~Prc2 * ########################################################################### // Открытие текстовых баз данных ******************************************** *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 Len_LcBuf = LEN(Lc_buf) IF Regim = "MainMenu" .OR. Regim = "3_5" ****** Создаем стат.базы и базы знаний (7 по частным критериям знаний) PUBLIC Ar_Model := {"Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } M_Inf = UPPER(Ar_Model[M_CurrInf]) PUBLIC nHandle[LEN(Ar_Model)] nHandle[ 1] := FOpen( Ar_Model[ 1]+".txt", FO_READWRITE ) // Открыть БД Abs.txt IF M_CurrInf > 1 nHandle[M_CurrInf] := FOpen( Ar_Model[M_CurrInf]+".txt", FO_READWRITE ) // Открыть БД, выбранную в качестве текущей ###### ENDIF ENDIF **** Рассчет массива начальных позиций полей в строке PRIVATE aPos[N_Col] aPos[1] = 1 FOR j=2 TO N_Col aPos[j] = aPos[j-1] + aInfStruct[j-1,3] NEXT * ########################################################################### IF Dialog // Начало отсчета времени для прогнозирования длительности исполнения 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 ENDIF IF Dialog Mess = L('ОПЕРАЦИЯ: ПРИСВОЕНИЕ МОДЕЛИ "#" СТАТУСА ТЕКУЩЕЙ МОДЕЛИ:') Mess = STRTRAN(Mess, "#", M_Inf ) aSay[ 6]:SetCaption(Mess) ENDIF ******************************************************************************************* ****** 1. Скопировать Abs, Prc# или INF#. ******************************************************************************************* IF Regim = "3_3" .OR. Regim = "3_5" ELSE aSay[ 7]:SetCaption(L('1/7: Копирование в массивы итоговых строк и столбцов текущей модели')) ENDIF // Итоговые строки и столбцы PRIVATE Ar_Summ_i[N_Gos], Ar_Summ_j[N_Cls+6] // N_Cls + 1-коды, 2-наименования, 3-Summ, 4-Sred, 5-Disp, 6-средн.модулей отклонения от средн. PRIVATE Ar_Sred_i[N_Gos], Ar_Sred_j[N_Cls+6] PRIVATE Ar_Disp_i[N_Gos], Ar_Disp_j[N_Cls+6] PRIVATE Ar_ADMA_i[N_Gos] AFILL(Ar_Summ_i, 0) AFILL(Ar_Summ_j, 0) AFILL(Ar_Sred_i, 0) AFILL(Ar_Sred_j, 0) AFILL(Ar_Disp_i, 0) AFILL(Ar_Disp_j, 0) AFILL(Ar_ADMA_i, 0) FOR i=1 TO N_Gos Ar_Summ_i[i] = VAL(LC_FieldGet( Ar_Model[ 1]+".txt", nHandle[ 1], i, 3+N_Cls )) * Ar_Sred_i[i] = VAL(LC_FieldGet( Ar_Model[M_CurrInf]+".txt", nHandle[M_CurrInf], i, 4+N_Cls )) Ar_Disp_i[i] = VAL(LC_FieldGet( Ar_Model[M_CurrInf]+".txt", nHandle[M_CurrInf], i, 5+N_Cls )) Ar_ADMA_i[i] = VAL(LC_FieldGet( Ar_Model[M_CurrInf]+".txt", nHandle[M_CurrInf], i, 6+N_Cls )) IF Regim<>"3_3";IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF;ENDIF NEXT FOR j=1 TO N_Cls Ar_Summ_j[j] = VAL(LC_FieldGet( Ar_Model[ 1]+".txt", nHandle[ 1], 1+N_Gos, 2+j )) * Ar_Sred_j[j] = VAL(LC_FieldGet( Ar_Model[M_CurrInf]+".txt", nHandle[M_CurrInf], 2+N_Gos, 2+j )) Ar_Disp_j[j] = VAL(LC_FieldGet( Ar_Model[M_CurrInf]+".txt", nHandle[M_CurrInf], 3+N_Gos, 2+j )) * MsgBox(STR(j)+STR(Ar_Summ_j[j])+STR(Ar_Sred_j[j])+STR(Ar_Disp_j[j])) IF Regim<>"3_3";IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF;ENDIF NEXT IF Regim = "3_3" .OR. Regim = "3_5" ELSE aSay[ 7]:SetCaption(aSay[ 7]:caption+L(" - Готово")) ENDIF ******************************************************************************************** ****** 2. Выполнить перенос информации из INF# в Classes, Gr_OpSc. ******************************************************************************************** IF Regim = "3_3" .OR. Regim = "3_5" ELSE aSay[ 8]:SetCaption(L("2/7: Перенос информации из текущей модели в базы классов: Classes и Gr_ClSc")) ENDIF ****** Перенос в БД классов FOR j = 1 TO N_Cls SELECT Classes;DBGOTO(j) REPLACE Int_inf WITH Ar_Disp_j[j] // Степень редукции j-го класса REPLACE Abs WITH Ar_Summ_j[j] // Кол-во признаков j-го класса SELECT Gr_ClSc;DBGOTO(j) REPLACE Int_inf WITH Ar_Disp_j[j] // Степень редукции j-го класса REPLACE Abs WITH Ar_Summ_j[j] // Кол-во признаков j-го класса IF Regim<>"3_3";IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF;ENDIF NEXT IF Regim = "3_3" .OR. Regim = "3_5" ELSE aSay[ 8]:SetCaption(aSay[ 8]:caption+L(" - Готово")) ENDIF ***** Перенос Инт.инф. в БД признаков (градаций описательных шкал) IF Regim = "3_3" .OR. Regim = "3_5" ELSE aSay[ 9]:SetCaption(L("3/7: Перенос информации из текущей модели в базы признаков: Attributes и Gr_OpSc")) ENDIF FOR i = 1 TO N_Gos SELECT Attributes;DBGOTO(i) REPLACE Int_inf WITH Ar_Disp_i[i] // Значимость признака (градации описательной шкалы) ######################################### REPLACE Abs WITH Ar_Summ_i[i] // Кол-во i-х признаков в выборке SELECT Gr_OpSc;DBGOTO(i) REPLACE Int_inf WITH Ar_Disp_i[i] // Значимость признака (градации описательной шкалы) REPLACE Abs WITH Ar_Summ_i[i] // Кол-во i-х признаков в выборке IF Regim<>"3_3";IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF;ENDIF NEXT IF Regim = "3_3" .OR. Regim = "3_5" ELSE aSay[ 9]:SetCaption(aSay[ 9]:caption+L(" - Готово")) ENDIF ******************************************************************************************* ****** 3. Сделать расчет значимости классификационных и описательных шкал на основе INF# ******************************************************************************************** ****** Расчет значимости описательных шкал: ****** 1. Значимость шкалы равна СРЕДНЕЙ значимости ее градаций (признаков) ****** 2. Значимость шкалы равна СУММАРНОЙ значимости ее градаций (признаков) ****** Подготовка данных для расчета значимости классификационных и описательных шкал ****** Сброс сумматоров IF Regim = "3_3" .OR. Regim = "3_5" ELSE aSay[10]:SetCaption(L("4/7: Расчет значимости описательных шкал - Сброс сумматоров")) ENDIF SELECT Opis_Sc DBGOTOP() DO WHILE .NOT.EOF() REPLACE Sum_ZnGr WITH 0 REPLACE N_GrOpSc WITH 0 IF Regim<>"3_3";IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF;ENDIF DBSKIP(1) ENDDO ****** Сброс сумматоров IF Regim = "3_3" .OR. Regim = "3_5" ELSE aSay[10]:SetCaption(L("4/7: Расчет значимости классификационных шкал - Сброс сумматоров")) ENDIF SELECT Class_Sc DBGOTOP() DO WHILE .NOT.EOF() REPLACE Sum_ZnGr WITH 0 REPLACE N_GrClSc WITH 0 IF Regim<>"3_3";IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF;ENDIF DBSKIP(1) ENDDO IF Regim = "3_3" .OR. Regim = "3_5" ELSE aSay[10]:SetCaption(L("4/7: Расчет значимости класс.и опис.шкал-Сброс сумматоров - Готово")) ENDIF ****** Накопление исходных данных для расчета значимости описательных шкал IF Regim = "3_3" .OR. Regim = "3_5" ELSE aSay[11]:SetCaption(L("5/7: Расчет значимости описательных шкал - Накопление данных")) ENDIF SELECT Gr_OpSc DBGOTOP() DO WHILE .NOT.EOF() M_Recno = RECNO() M_KodOpSc = Kod_OpSc M_ZnGrOpS = Int_inf SELECT Opis_Sc DBGOTO(M_KodOpSc) M_SumZnGr = Sum_ZnGr M_NGrOpSc = N_GrOpSc REPLACE Sum_ZnGr WITH M_SumZnGr + M_ZnGrOpS REPLACE N_GrOpSc WITH M_NGrOpSc + 1 SELECT Gr_OpSc DBGOTO(M_Recno) IF Regim<>"3_3";IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF;ENDIF DBSKIP(1) ENDDO SELECT Opis_Sc mKodGrOS = 1 DBGOTOP() DO WHILE .NOT.EOF() REPLACE KodGr_Min WITH mKodGrOS mKodGrOS = mKodGrOS + N_GrOpSc - 1 REPLACE KodGr_Max WITH mKodGrOS++ IF Regim<>"3_3";IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF;ENDIF DBSKIP(1) ENDDO ****** Накопление исходных данных для расчета значимости классификационных шкал IF Regim = "3_3" .OR. Regim = "3_5" ELSE aSay[11]:SetCaption(L("5/7: Расчет значимости классификационных шкал - Накопление данных")) ENDIF SELECT Gr_ClSc DBGOTOP() DO WHILE .NOT.EOF() M_Recno = RECNO() M_KodClSc = Kod_ClSc M_ZnGrClS = Int_inf SELECT Class_Sc DBGOTO(M_KodClSc) M_SumZnGr = Sum_ZnGr M_NGrClSc = N_GrClSc REPLACE Sum_ZnGr WITH M_SumZnGr + M_ZnGrClS REPLACE N_GrClSc WITH M_NGrClSc + 1 SELECT Gr_ClSc DBGOTO(M_Recno) IF Regim<>"3_3";IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF;ENDIF DBSKIP(1) ENDDO SELECT Class_Sc mKodGrCS = 1 DBGOTOP() DO WHILE .NOT.EOF() REPLACE KodGr_Min WITH mKodGrCS mKodGrCS = mKodGrCS + N_GrClSc - 1 REPLACE KodGr_Max WITH mKodGrCS++ IF Regim<>"3_3";IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF;ENDIF DBSKIP(1) ENDDO IF Regim = "3_3" .OR. Regim = "3_5" ELSE aSay[11]:SetCaption(L("5/7: Расчет значимости класс.и опис.шкал-Накопление данных - Готово")) ENDIF ****** Расчет значимости описательных шкал IF Regim = "3_3" .OR. Regim = "3_5" ELSE aSay[12]:SetCaption(L("6/7: Расчет значимости описательных шкал - Дорасчет")) ENDIF SELECT Opis_Sc DBGOTOP() DO WHILE .NOT.EOF() REPLACE Int_inf WITH Sum_ZnGr / N_GrOpSc IF Regim<>"3_3";IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF;ENDIF DBSKIP(1) ENDDO ****** Расчет значимости классификационных шкал IF Regim = "3_3" .OR. Regim = "3_5" ELSE aSay[12]:SetCaption(L("6/7: Расчет значимости классификационных шкал - Дорасчет")) ENDIF SELECT Class_Sc DBGOTOP() DO WHILE .NOT.EOF() REPLACE Int_inf WITH Sum_ZnGr / N_GrClSc IF Regim<>"3_3";IF Regim<>"3_5";lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk );ENDIF;ENDIF DBSKIP(1) ENDDO IF Regim = "3_3" .OR. Regim = "3_5" ELSE aSay[12]:SetCaption(L("6/7: Расчет значимости класс.и опис.шкал-Дорасчет - Готово")) ENDIF ******************************************************************************************* ****** 4. Привести в соответствие файл о текущей модели: DC_ASave(M_CurrInf, "_CurrInf.arx") ******************************************************************************************** IF Regim = "3_3" .OR. Regim = "3_5" ELSE aSay[13]:SetCaption(L("7/7: Запись информации о текущей модели")) ENDIF DC_ASave(M_CurrInf, "_CurrInf.arx") IF Regim = "3_3" .OR. Regim = "3_5" ELSE aSay[13]:SetCaption(aSay[13]:caption+L(" - Готово")) ENDIF IF 1 <= M_CurrInf .AND. M_CurrInf <= 10 ELSE LB_Warning(L("Необходимо задать одну из моделей в качестве текущей !!! ")) Running(.F.) RETURN NIL ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций IF Regim = "MainMenu" .OR. Regim = "3_5" FClose( nHandle[ 1] ) // Закрытие текущей базы данных ############################## FClose( nHandle[M_CurrInf] ) // Закрытие текущей базы данных ############################## ENDIF IF Dialog IF M_CurrInf <= 3 Mess = L('Выбор стат.модели "#" в качестве текущей прошел успешно!!!') ELSE Mess = L('Выбор модели знаний "#" в качестве текущей прошел успешно!!!') ENDIF Running(.T.) // Чтобы не могли запустить какой-нибудь режим пока висит окно окончания работы Mess = STRTRAN(Mess,"#", UPPER(M_Inf)) 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() ENDIF ********* Прописывает для числовых шкал в БД Classes и Attributes минимальное, максимальное и среднее значение всех градаций MinMaxAvr() IF Regim = "MainMenu" ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** ENDIF Running(.F.) RETURN NIL **************************************************************************************************************** ******** 4.5.old Визуализация когнитивных функций (вариант с вызовом функции, сделанной Димой Бандык на Дельфи) **************************************************************************************************************** FUNCTION F4_5old() LOCAL GetList[0], lOk Running(.T.) IF ApplChange("4.5()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF ConvTXTtoDBF() // Преобразование Abs, Prc#, Inf# из TXT в DBF IF FILEDATE("Cogn_fun",16) = CTOD("//") DIRMAKE("Cogn_fun") aMess := {} AADD(aMess, L('В папке текущего приложения: "')+ALLTRIM(M_PathAppl)+'"') AADD(aMess, L('не было директории "Cogn_fun" для когнитивных функций и она была создана!')) LB_Warning(aMess, L('4.5. Визуализация когнитивных функций системы "Эйдос-Х++"' )) ENDIF DIRCHANGE(Disk_dir) // Перейти в папку системы CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций @ 0.0,0 DCGROUP oGroup1 CAPTION L('Что такое когнитивная функция:') SIZE 94,22.0 @ 22.5,0 DCGROUP oGroup2 CAPTION L('Задайте нужный режим:' ) SIZE 94, 4.2 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,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;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;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('КубГАУ, 2011. - №03(67). С. 240 - 282. - Шифр Информрегистра: 0421100012\0077. , 2,688 у.п.л. - Режим доступа: ') PARENT oGroup1;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.)} // .T. - внешняя программа запускается, а главная исполняется дальше, .F. - главная ждет окончания внешней программы @1.0, 1 DCPUSHBUTTON CAPTION L('Визуализации когнитивных функций' ) SIZE 43, 1.1 PARENT oGroup2 ACTION {||LC_RunShell("_4_5.exe",104905919)} FONT "10.HelvBold" * @1.0, 1 DCPUSHBUTTON CAPTION L('Визуализации когнитивных функций' ) SIZE 43, 1.1 PARENT oGroup2 ACTION {||LC_RunShell("__AIDOS-PY.exe", 717400306, '_4_5py')} FONT "10.HelvBold" // Мой вариант на Питоне в системе __AIDOS-PY.exe @2.5, 1 DCPUSHBUTTON CAPTION L('Литератур.ссылки на работы по когнитивным функциям' ) SIZE 43, 1.1 PARENT oGroup2 ACTION {||Publ_CognFun()} @1.0, 48 DCPUSHBUTTON CAPTION L('Литератур.ссылки на работы по когнитивным функциям' ) SIZE 44, 1.1 PARENT oGroup2 ACTION {||LC_RunUrl("http://lc.kubagro.ru/aidos/Works_on_cognitive_functions.htm")} @2.5, 48 DCPUSHBUTTON CAPTION L('Литератур.ссылки на работы по управлению знаниями' ) SIZE 44, 1.1 PARENT oGroup2 ACTION {||LC_RunUrl("http://lc.kubagro.ru/aidos/Works_on_identification_presentation_and_use_of_knowledge.htm")} DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; FIT ; OPTIONS GetOptions ; MODAL ; TITLE L('4.5. Визуализация когнитивных функций') ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL *********************************************************************************************************************************************************** FUNCTION Publ_CognFun() LOCAL GetList := {}, aPres, oBrowse, oToolBar, aColors, bColor, GetOptions * DCSETFONT TO '10.Arial' s=0;d=0.8 @s,1 DCSAY L('Луценко Е.В. АСК-анализ как метод выявления когнитивных функциональных зависимостей в многомерных зашумленных фрагментированных данных ') SAYSIZE 0;s=s+d @s,1 DCSAY L('/ Е.В. Луценко // Политематический сетевой электронный научный журнал Кубанского государственного аграрного университета (Научный журнал ') SAYSIZE 0;s=s+d @s,1 DCSAY L('КубГАУ) [Электронный ресурс]. - Краснодар: КубГАУ, 2005. - №03(11). С. 181 - 199. 1,188 у.п.л. - Режим доступа: ') SAYSIZE 0;s=s+d @s,1 DCSAY L('http://ej.kubagro.ru/2005/03/pdf/19.pdf') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://ej.kubagro.ru/2005/03/pdf/19.pdf', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} SAYSIZE 0;s=s+d ++s @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('ресурс]. - Краснодар: КубГАУ, 2009. - №07(51). С. 130 - 154. - Шифр Информрегистра: 0420900012\0066. 1,562 у.п.л. - Режим доступа: ') SAYSIZE 0;s=s+d @s,1 DCSAY L('http://ej.kubagro.ru/2009/07/pdf/06.pdf') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://ej.kubagro.ru/2009/07/pdf/06.pdf', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} SAYSIZE 0;s=s+d ++s @s,1 DCSAY L('Луценко Е.В. Управление агропромышленным холдингом на основе когнитивных функций связи результатов работы холдинга и характеристик его пред- ') SAYSIZE 0;s=s+d @s,1 DCSAY L('приятий / Е.В. Луценко, В.И. Лойко, О.А. Макаревич // Политематический сетевой электронный научный журнал Кубанского государственного аграр-') SAYSIZE 0;s=s+d @s,1 DCSAY L('ного университета (Научный журнал КубГАУ) [Электронный ресурс]. - Краснодар: КубГАУ, 2009. - №10(54). С.248 - 260. - Шифр Информрегистра: ') SAYSIZE 0;s=s+d @s,1 DCSAY L('0420900012\0111. 0,812 у.п.л. - Режим доступа: ') SAYSIZE 0;s=s+d @s,1 DCSAY L('http://ej.kubagro.ru/2009/10/pdf/15.pdf') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://ej.kubagro.ru/2009/10/pdf/15.pdf', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} SAYSIZE 0;s=s+d ++s @s,1 DCSAY L('Луценко Е.В. Когнитивные функции как адекватный инструмент для формального представления причинно-следственных зависимостей / Е.В. Луценко ') SAYSIZE 0;s=s+d @s,1 DCSAY L('// Политематический сетевой электронный научный журнал Кубанского государственного аграрного университета (Научный журнал КубГАУ) [Электрон- ') SAYSIZE 0;s=s+d @s,1 DCSAY L('ный ресурс]. - Краснодар: КубГАУ, 2010. - №09(63). С.1 - 23. - Шифр Информрегистра: 0421000012\0233. 1,438 у.п.л. - Режим доступа: ') SAYSIZE 0;s=s+d @s,1 DCSAY L('http://ej.kubagro.ru/2010/09/pdf/01.pdf') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://ej.kubagro.ru/2010/09/pdf/01.pdf', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} SAYSIZE 0;s=s+d ++s @s,1 DCSAY L('Трунев А.П. Автоматизированный системно-когнитивный анализ влияния тел Солнечной системы на движение полюса Земли и визуализация причинно- ') SAYSIZE 0;s=s+d @s,1 DCSAY L('следственных зависимостей в виде когнитивных функций / А.П. Трунев, Е.В. Луценко, Д.К. Бандык // Политематический сетевой электронный ') SAYSIZE 0;s=s+d @s,1 DCSAY L('научный журнал Кубанского государственного аграрного университета (Научный журнал КубГАУ) [Электронный ресурс]. - Краснодар: КубГАУ, 2011. ') SAYSIZE 0;s=s+d @s,1 DCSAY L('- №01(65). С. 232 - 258. - Шифр Информрегистра: 0421100012\0002. 1,688 у.п.л. - Режим доступа: ') SAYSIZE 0;s=s+d @s,1 DCSAY L('http://ej.kubagro.ru/2011/01/pdf/20.pdf') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://ej.kubagro.ru/2011/01/pdf/20.pdf', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} SAYSIZE 0;s=s+d ++s @s,1 DCSAY L('Луценко Е.В. Метод визуализации когнитивных функций - новый инструмент исследования эмпирических данных большой размерности / Е.В. Луценко, ') SAYSIZE 0;s=s+d @s,1 DCSAY L('А.П. Трунев, Д.К. Бандык // Политематический сетевой электронный научный журнал Кубанского государственного аграрного университета (Научный ') SAYSIZE 0;s=s+d @s,1 DCSAY L('журнал КубГАУ) [Электронный ресурс]. - Краснодар: КубГАУ, 2011. - №03(67). С.240 - 282. - Шифр Информрегистра: 0421100012\0077. 2,688 у.п.л. ') SAYSIZE 0;s=s+d @s,1 DCSAY L('- Режим доступа: ') SAYSIZE 0;s=s+d @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.)} SAYSIZE 0;s=s+d ++s @s,1 DCSAY L('Луценко Е.В. Развитие интеллектуальной системы "Эйдос-астра", снимающее ограничения на размерность баз знаний и разрешение когнитивных функций ') SAYSIZE 0;s=s+d @s,1 DCSAY L('/ Е.В. Луценко, А.П. Трунев, Е.А. Трунев // Политематический сетевой электронный научный журнал Кубанского государственного аграрного универси-') SAYSIZE 0;s=s+d @s,1 DCSAY L('тета (Научный журнал КубГАУ) [Электронный ресурс]. - Краснодар: КубГАУ, 2011. - №05(69). С. 353 - 377. - Шифр Информрегистра: 0421100012\0159. ') SAYSIZE 0;s=s+d @s,1 DCSAY L('1,562 у.п.л. - Режим доступа: ') SAYSIZE 0 @s,1 DCSAY L('http://ej.kubagro.ru/2011/05/pdf/31.pdf') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://ej.kubagro.ru/2011/05/pdf/31.pdf', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} SAYSIZE 0;s=s+d ++s @s,1 DCSAY L('Луценко Е.В. Применение СК-анализа и системы "Эйдос" для синтеза когнитивной матричной передаточной функции сложного объекта управления на основе') SAYSIZE 0;s=s+d @s,1 DCSAY L('эмпирических данных / Е.В. Луценко, В.Е. Коржаков // Политематический сетевой электронный научный журнал Кубанского государственного аграрного ') SAYSIZE 0;s=s+d @s,1 DCSAY L('университета (Научный журнал КубГАУ) [Электронный ресурс]. - Краснодар: КубГАУ, 2012. - №01(75). С. 681 - 714. 2,125 у.п.л. - Режим доступа: ') SAYSIZE 0;s=s+d @s,1 DCSAY L('http://ej.kubagro.ru/2012/01/pdf/53.pdf') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://ej.kubagro.ru/2012/01/pdf/53.pdf', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} SAYSIZE 0;s=s+d ++s @s,1 DCSAY L('Луценко Е.В. Когнитивные функции как обобщение классического понятия функциональной зависимости на основе теории информации в системной нечеткой ') SAYSIZE 0;s=s+d @s,1 DCSAY L('интервальной математике / Е.В. Луценко, А.И. Орлов // Политематический сетевой элек-тронный научный журнал Кубанского государственного аграрного') SAYSIZE 0;s=s+d @s,1 DCSAY L('университета (Научный журнал КубГАУ) [Электронный ресурс].-Краснодар:КубГАУ,2014.-№01(095).С.122-183.-IDA[article ID]:0951401007. -Режим доступа:') SAYSIZE 0;s=s+d @s,1 DCSAY L('http://ej.kubagro.ru/2014/01/pdf/07.pdf') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://ej.kubagro.ru/2014/01/pdf/07.pdf', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} SAYSIZE 0;s=s+d ++s @s,1 DCSAY L('Орлов А.И., Луценко Е.В. Системная нечеткая интервальная математика. Монография (научное издание). - Краснодар, КубГАУ. 2014. - 600 с. ') SAYSIZE 0;s=s+d @s,1 DCSAY L('ISBN 978-5-94672-757-0. - Режим доступа: ') SAYSIZE 0;s=s+d @s,1 DCSAY L('http://lc.kubagro.ru/aidos/aidos14_OL/index.htm') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://lc.kubagro.ru/aidos/aidos14_OL/index.htm', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} SAYSIZE 0;s=s+d DCREAD GUI FIT MODAL TITLE L('Подборка публикаций по когнитивным функциям') RETURN NIL *********************************************************************************************************************************************************** *********************************************************************************************************** ******** 4.5.Визуализация когнитивных функций (вариант с вызовом функции, сделанной мной на Питоне) *********************************************************************************************************** FUNCTION F4_5() LOCAL GetList[0], lOk Running(.T.) * Наименование приложения ******************* 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 IF ApplChange("4.5()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения IF FILEDATE("CognitiveFunctions",16) = CTOD("//") DIRMAKE("CognitiveFunctions") aMess := {} AADD(aMess, L('В папке текущего приложения: "')+ALLTRIM(M_PathAppl)+'"') AADD(aMess, L('не было директории "CognitiveFunctions" для когнитивных функций и она была создана!')) LB_Warning(aMess, L('4.5. Генерация, визуализация и запись когнитивных функций системы "Эйдос"' )) ENDIF * АЛГОРИТМ *********************************************************************************************************************************************************************************************************** * Весь диалог и выборку подматрицы в CSV СДЕЛАТЬ НА Аляске. На Питоне только само рисование одного вида когнитивной функции по ОДНОЙ подматрице. * Задать в диалоге текущую модель, вид когнитивной функции и количество градаций уровня функции. * Все базы данных, используемые программой, находятся по пути, который находится в поле PATH_APPL первой записи базы данных Appls.dbf, в которой поле: BY_DEFAULT не пустое. В этой же базе и наименование приложения. * * Начало цикла-1 по описательным шкалам, т.е. записям базы данных Opis_Sc.dbf. * KODGROS_MIN - переменная памяти, код начальной градации текущей описательной шкалы, значение взять из поля: KODGR_MIN базы данных Opis_Sc.dbf; * KODGROS_MAX - переменная памяти, код конечной градации текущей описательной шкалы, значение взять из поля: KODGR_MAX базы данных Opis_Sc.dbf; * Начало цикла-2 по классификационным шкалам, т.е. записям базы данных Class_Sc.dbf. * KODGRCS_MIN - переменная памяти, код начальной градации текущей описательной шкалы, значение взять из поля: KODGR_MIN базы данных Class _Sc.dbf; * KODGRCS_MAX - переменная памяти, код конечной градации текущей описательной шкалы, значение взять из поля: KODGR_MAX базы данных Class _Sc.dbf; * Начало цикла по заданнным моделям * Создать двумерный числовой CSV-массив SubMatrix из числа строк: KODGROS_MAX - KODGROS_MIN+1 и числа столбцов KODGRCS_MAX - KODGRCS_MIN+1. * Начало цикла-3 по записям Row базы данных выбранной модели от записи № KODGROS_MIN до записи № KODGROS_MAX * Начало цикла-4 по столбцам Col базы данных выбранной модели от столбца № KODGRСS_MIN +2до столбца № KODGRCS_MAX+2 * Извлечь значение элемента [Row,Col] из txt-базы данных текущей модели и, если оно не равно нулю, присвоить это значение элементу массива submatrix[Row,Col-2]. * Если же оно равно нулю, то присвоить элементу массива SubMatrix[Row,Col] псевдослучайное число отличающееся от нуля в четырех последних разрядах из семи знаков после запятой. * Конец цикла-4 * Конец цикла-3 * Начало цикла по видам когнитивных функций Эири цикл реализован в программе на Питоне * Создать CSV-файл со всеми параметрами, задаваемыми в диалоге: текущая модель, виды когнитивных функций, заданных для визуализации, а также наименование приложения, наименования классификационной и описательной шкал и градаций и т.д. * После формирования подматрицы SubMatrix[Row,Col] запустить внешнюю программу на Питоне для визуализации и записи когнитивных функций. * Конец цикла по видам когнитивных функций * Конец цикла по заданным моделям * Конец цикла-2 * Конец цикла-1 ********************************************************************************************************************************************************************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения IF .NOT. FILE( "Opis_Sc.dbf" ) .OR. ; .NOT. FILE( "Gr_OpSc.dbf" ) .OR. ; .NOT. FILE( "Class_Sc.dbf") .OR. ; .NOT. FILE( "Gr_ClSc.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) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) 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.5.")) LB_Warning(aMess, L('4.5. Генерация, визуализация и запись когнитивных функций системы "Эйдос"' )) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF * АЛГОРИТМ *********************************************************************************************************************************************************************************************************** * Весь диалог и выборку подматрицы в CSV СДЕЛАТЬ НА Аляске. На Питоне только само рисование одного вида когнитивной функции по ОДНОЙ подматрице. * Задать в диалоге текущую модель, вид когнитивной функции и количество градаций уровня функции. * Все базы данных, используемые программой, находятся по пути, который находится в поле PATH_APPL первой записи базы данных Appls.dbf, в которой поле: BY_DEFAULT не пустое. В этой же базе и наименование приложения. ******************************************************************************************* ****** 0. Задать текущую стат.модель или модель знаний ******************************************************************************************* * Задание и сохранение всех заданных параметров в файлах ******************** IF .NOT. FILE("_4_5new_CurrInf.arx") PRIVATE aCurrInf[10] AFILL(aCurrInf, .F.) aCurrInf[6] = .T. ELSE * DC_ASave(aCurrInf, "_4_5new_CurrInf.arx") aCurrInf := DC_ARestore("_4_5new_CurrInf.arx") ENDIF IF .NOT. FILE("_4_5new_CognFun.arx") PRIVATE aCognFun[5] AFILL(aCognFun, .F.) aCognFun[5] = .T. ELSE * DC_ASave(aCognFun, "_4_5new_CognFun.arx") aCognFun := DC_ARestore("_4_5new_CognFun.arx") ENDIF IF .NOT. FILE("_4_5py_Param.arx") aParameters := {} AADD(aParameters, .T.) // Соединять ли точки с максимальным количеством информации линией БЕЛОГО цвета? AADD(aParameters, .T.) // Соединять ли точки с максимальным количеством информации линией ЧЕРНОГО цвета? AADD(aParameters, 32 ) // Количество градаций уровня (цвета и изолиний) когнитивных функций AADD(aParameters,100 ) // Количество пикселей на дюйм в изображениях когнитивных функций AADD(aParameters,0.5 ) // Пауза в секундах между визуализациями когнитивных функций AADD(aParameters, 8 ) // Размер шрифта для наименований градаций классификационной и описательной шкал ELSE * DC_ASave(aParameters, "_4_5py_Param.arx") aParameters := DC_ARestore("_4_5py_Param.arx") ENDIF ****** Задание текущей модели @ 0,0 DCGROUP oGroup1 CAPTION L('Задайте статистические и/или системно-когнитивные модели для генерации когнитивных функций: ') SIZE 90,13.5 @ 1,1 DCSAY L('Статистические базы:' ) PARENT oGroup1 @ 2,3 DCCHECKBOX aCurrInf[ 1] PROMPT L('1. ABS - частный критерий: количество встреч сочетаний: "класс-признак" у объектов обуч.выборки') PARENT oGroup1 @ 3,3 DCCHECKBOX aCurrInf[ 2] PROMPT L('2. PRC1 - частный критерий: усл. вероятность i-го признака среди признаков объектов j-го класса ') PARENT oGroup1 @ 4,3 DCCHECKBOX aCurrInf[ 3] PROMPT L('3. PRC2 - частный критерий: условная вероятность i-го признака у объектов j-го класса ') PARENT oGroup1 @ 5.2,1 DCSAY L('Системно-когнитивные модели (Базы знаний):' ) PARENT oGroup1 @ 6,3 DCCHECKBOX aCurrInf[ 4] PROMPT L('4. INF1 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC1 ') PARENT oGroup1 @ 7,3 DCCHECKBOX aCurrInf[ 5] PROMPT L('5. INF2 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC2 ') PARENT oGroup1 @ 8,3 DCCHECKBOX aCurrInf[ 6] PROMPT L('6. INF3 - частный критерий: Xи-квадрат, разности между фактическими и ожидаемыми абс.частотами ') PARENT oGroup1 @ 9,3 DCCHECKBOX aCurrInf[ 7] PROMPT L('7. INF4 - частный критерий: ROI (Return On Investment); вероятности из PRC1 ') PARENT oGroup1 @10,3 DCCHECKBOX aCurrInf[ 8] PROMPT L('8. INF5 - частный критерий: ROI (Return On Investment); вероятности из PRC2 ') PARENT oGroup1 @11,3 DCCHECKBOX aCurrInf[ 9] PROMPT L('9. INF6 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC1 ') PARENT oGroup1 @12,3 DCCHECKBOX aCurrInf[10] PROMPT L('10.INF7 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC2 ') PARENT oGroup1 @14,0 DCGROUP oGroup2 CAPTION L('Задайте виды когнитивных функций для генерации, визуализации и записи: ') SIZE 90, 6.5 @ 1,3 DCCHECKBOX aCognFun[1] PROMPT L('1. Сетка триангуляции Делоне без цветовой заливки. ') PARENT oGroup2 @ 2,3 DCCHECKBOX aCognFun[2] PROMPT L('2. Сглаженные изолинии триангуляции Делоне без цветовой заливки. ') PARENT oGroup2 @ 3,3 DCCHECKBOX aCognFun[3] PROMPT L('3. Сетка триангуляции Делоне с цветовой заливкой. ') PARENT oGroup2 @ 4,3 DCCHECKBOX aCognFun[4] PROMPT L('4. Сглаженные изолинии триангуляции Делоне с цветовой заливкой. ') PARENT oGroup2 @ 5,3 DCCHECKBOX aCognFun[5] PROMPT L('5. Сглаженная цветовая заливка изолиний с заданным количеством градаций цвета. ') PARENT oGroup2 @21,0 DCGROUP oGroup3 CAPTION L('Задайте дополнительные параметры визуализации когнитивных функций: ') SIZE 90, 8.7 @ 1,3 DCCHECKBOX aParameters[1] PROMPT L('Соединять ли точки с максимальным количеством информации линией КРАСНОГО цвета? ') PARENT oGroup3 @ 2,3 DCCHECKBOX aParameters[2] PROMPT L('Соединять ли точки с минимальным количеством информации линией СИНЕГО цвета? ') PARENT oGroup3 @3.5,3 DCSAY L('Задайте количество градаций уровня (цвета и изолиний) когнитивных функций: ') PARENT oGroup3 @3.5,64 DCGET aParameters[3] PICTURE "#####" PARENT oGroup3 @4.7,3 DCSAY L('Задайте количество пикселей на дюйм в изображениях когнитивных функций: ') PARENT oGroup3 @4.7,64 DCGET aParameters[4] PICTURE "#####" PARENT oGroup3 @5.9,3 DCSAY L('Задайте паузу в секундах между визуализациями когнитивных функций: ') PARENT oGroup3 @5.9,64 DCGET aParameters[5] PICTURE "##.##" PARENT oGroup3 @7.1,3 DCSAY L('Задайте размер шрифта для наименований градаций шкал X и Y: ') PARENT oGroup3 @7.1,64 DCGET aParameters[6] PICTURE "#####" PARENT oGroup3 * Задайте размер окна визуализации когн.функций ####, ####, размер шрифта надписей по осям: ### <<<===#################### Это делать АВТОМАТИЧЕСКИ на Питоне @30.5, 1 DCPUSHBUTTON CAPTION L('Визуализация когнитивных функций new' ) SIZE 43, 1.1 ACTION {||DC_ReadGuiEvent(DCGUI_EXIT_OK,GetList)} FONT "10.HelvBold" // Просто выход из диалога с заданными папаметрами @30.5, 46 DCPUSHBUTTON CAPTION L('Визуализация когнитивных функций old' ) SIZE 43, 1.1 ACTION {||F4_5old()} FONT "10.Helv" @32.0, 1 DCPUSHBUTTON CAPTION L('Работы по когнитивным функциям-1 ' ) SIZE 43, 1.1 ACTION {||Publ_CognFun()} @32.0, 46 DCPUSHBUTTON CAPTION L('Работы по когнитивным функциям-2 ' ) SIZE 43, 1.1 ACTION {||LC_RunUrl("http://lc.kubagro.ru/aidos/Works_on_cognitive_functions.htm")} DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; OPTIONS GetOptions ; MODAL ; TITLE L('4.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 *********************************************************************** * Прверка корректности заданных параметров ************************ mFlagError = .F. aMess := {} IF aParameters[3] < 2 mFlagError = .T. AADD(aMess, L('Не задано ни одной градации уровня когнитивной функции')) ENDIF IF aParameters[4] < 70 mFlagError = .T. AADD(aMess, L('Задано слишком низкое качество визуализации когнитивной функции')) ENDIF IF aParameters[5] < 0 mFlagError = .T. AADD(aMess, L('Задана слишком маленькая пауза в секундах между визуализациями когнитивных функций')) ENDIF IF aParameters[6] < 5 mFlagError = .T. AADD(aMess, L('Задан слишком мелкий шрифта для наименований градаций классификационной и описательной шкал')) ENDIF s = 0 FOR j=1 TO LEN(aCurrInf) IF aCurrInf[j] s++ ENDIF NEXT IF s = 0 mFlagError = .T. AADD(aMess, L('Не задано ни одной модели для визуализации когнитивной функции')) AFILL(aCognFun, .F.) aCognFun[5] = .T. ENDIF s = 0 FOR j=1 TO LEN(aCognFun) IF aCognFun[j] s++ ENDIF NEXT IF s = 0 mFlagError = .T. AADD(aMess, L('Не задано не одного вида когнитивной функции для генерации!')) AFILL(aCurrInf, .F.) aCurrInf[6] = .T. ENDIF IF mFlagError aParameters := {} AADD(aParameters, .T.) // 1. Соединять ли точки с максимальным количеством информации линией БЕЛОГО цвета? AADD(aParameters, .T.) // 2. Соединять ли точки с максимальным количеством информации линией ЧЕРНОГО цвета? AADD(aParameters, 32 ) // 3. Количество градаций уровня (цвета и изолиний) когнитивных функций AADD(aParameters,100 ) // 4. Количество пикселей на дюйм в изображениях когнитивных функций AADD(aParameters,0.5 ) // 5. Пауза в секундах между визуализациями когнитивных функций AADD(aParameters, 8 ) // 6. Размер шрифта для наименований градаций классификационной и описательной шкал * Сохранение всех заданных параметров в файлах ******************** DC_ASave(aCurrInf, "_4_5new_CurrInf.arx") * aCurrInf := DC_ARestore("_4_5new_CurrInf.arx"") DC_ASave(aCognFun, "_4_5new_CognFun.arx") * aCognFun := DC_ARestore("_4_5new_CognFun.arx"") DC_ASave(aParameters, "_4_5py_Param.arx") * aParameters := DC_ARestore("_4_5py_Param.arx") LB_Warning(aMess, L('4.5. Генерация, визуализация и запись когнитивных функций системы "Эйдос"' )) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ******************************************************************** * Сохранение всех заданных параметров в файлах ******************** DC_ASave(aCurrInf, "_4_5new_CurrInf.arx") * aCurrInf := DC_ARestore("_4_5new_CurrInf.arx"") DC_ASave(aCognFun, "_4_5new_CognFun.arx") * aCognFun := DC_ARestore("_4_5new_CognFun.arx"") DC_ASave(aParameters, "_4_5py_Param.arx") * aParameters := DC_ARestore("_4_5py_Param.arx") * ########################################################################### * Открытие текстовых баз данных моделей ************************************* CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения USE Attributes EXCLUSIVE NEW USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() // Количество классов (градаций классификационных шкал) USE Gr_ClSc EXCLUSIVE NEW;N_Gcs = RECCOUNT() USE Class_Sc EXCLUSIVE NEW;N_Csc = RECCOUNT() USE Gr_OpSc EXCLUSIVE NEW;N_Gos = RECCOUNT() // Количество признаков (градаций описательных шкал) USE Opis_Sc EXCLUSIVE NEW;N_Osc = RECCOUNT() * DC_ASave(aInfStruct, "_InfStruct.arx") // Когда БД создается - записывать структуру, когда открывается - считывать aInfStruct = DC_ARestore("_InfStruct.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) // Открыть все текстовые базы данных моделей 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 * *************************************************************************** * ########################################################################### PRIVATE aModName[10] aModName := {L('1. ABS - частный критерий: количество встреч сочетаний: "класс-признак" у объектов обуч.выборки '),; L('2. PRC1 - частный критерий: условная вероятность i-го признака среди признаков объектов j-го класса'),; L('3. PRC2 - частный критерий: условная вероятность i-го признака у объектов j-го класса '),; L('4. INF1 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC-1 '),; L('5. INF2 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC-2 '),; L('6. INF3 - частный критерий: Xи-квадрат, разности между фактическими и ожидаемыми абс.частотами '),; L('7. INF4 - частный критерий: ROI (Return On Investment); вероятности из PRC-1 '),; L('8. INF5 - частный критерий: ROI (Return On Investment); вероятности из PRC-2 '),; L('9. INF6 - частный критерий: разность условной и безусловной вероятностей; вероятности из PRC-1 '),; L('10.INF7 - частный критерий: разность условной и безусловной вероятностей; вероятности из PRC-2 ') } PRIVATE aCognFunName[5] aCFunName = {L('1. Сетка триангуляции Делоне без цветовой заливки '),; L('2. Сглаженные изолинии триангуляции Делоне без цветовой заливки '),; L('3. Сетка триангуляции Делоне с цветовой заливкой '),; L('4. Сглаженные изолинии триангуляции Делоне с цветовой заливкой '),; L('5. Сглаженная цветовая заливка изолиний с заданным количеством градаций цвета') } *************************************************************************************************** * Определение количества формируемых графических файлов ******************************************* *************************************************************************************************** Wsego = 0 CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Class_Sc EXCLUSIVE NEW USE Opis_Sc EXCLUSIVE NEW SELECT Opis_Sc DBGOTOP() DO WHILE .NOT. EOF() // Начало цикла-1 по описательным шкалам, т.е. записям базы данных Opis_Sc.dbf SELECT Class_Sc DBGOTOP() DO WHILE .NOT. EOF() // Начало цикла-2 по классификационным шкалам, т.е. записям базы данных Class_Sc.dbf FOR mModel=1 TO LEN(aCurrInf) // Начало цикла по моделям IF aCurrInf[mModel] FOR mCognFun=1 TO LEN(aCognFun) // Начало цикла по видам когнитивных функций. Это нужно потому, что в откомпилированной программе на Питоне рисуется только 1 вид когнитивной функции, хотя ы PyCharm сколько угодно IF aCognFun[mCognFun] * LC_RunShell("_4_5py.exe",1586783151) // Мой вариант на Питоне/C++ * LC_RunShellAidosPy(717400306, "_4_5py") * LC_RunShell("__AIDOS-PY.exe", 717400306, "_4_5py") // Мой вариант на Питоне в системе __AIDOS-PY.exe Wsego++ ENDIF NEXT // Конец цикла по когнитивным функциям ENDIF NEXT // Конец цикла по моделям SELECT Class_Sc DBSKIP(1) ENDDO // Конец цикла-2 SELECT Opis_Sc DBSKIP(1) ENDDO // Конец цикла-1 mTitleName = L('4.5. Генерация, визуализация и запись когнитивных функций системы "Эйдос"' ) // Отображение стадии исполнения. Будет написано прямо в окне 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 ************************************************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Gr_ClSc EXCLUSIVE NEW USE Class_Sc EXCLUSIVE NEW;N_ClSc = LEN(ALLTRIM(STR(RECCOUNT()))) USE Gr_OpSc EXCLUSIVE NEW USE Opis_Sc EXCLUSIVE NEW;N_OpSc = LEN(ALLTRIM(STR(RECCOUNT()))) SELECT Opis_Sc DBGOTOP() DO WHILE .NOT. EOF() // Начало цикла-1 по описательным шкалам, т.е. записям базы данных Opis_Sc.dbf mKodOpSc = ALLTRIM(STR(KOD_OPSC)) mNameOpSc = ALLTRIM(NAME_OPSC) mKODGROS_MIN = KODGR_MIN // переменная памяти, код начальной градации текущей описательной шкалы, значение взять из поля: KODGR_MIN базы данных Opis_Sc.dbf mKODGROS_MAX = KODGR_MAX // переменная памяти, код конечной градации текущей описательной шкалы, значение взять из поля: KODGR_MAX базы данных Opis_Sc.dbf SELECT Gr_OpSc aNameGrOpSc := {} AADD(aNameGrOpSc,'') FOR j=mKODGROS_MIN TO mKODGROS_MAX DBGOTO(j) AADD(aNameGrOpSc,'['+ALLTRIM(STR(j))+']-'+ALLTRIM(NAME_GROS)) NEXT * DC_DebugQout( aNameGrOpSc ) // <<<===############### SELECT Opis_Sc SELECT Class_Sc DBGOTOP() DO WHILE .NOT. EOF() // Начало цикла-2 по классификационным шкалам, т.е. записям базы данных Class_Sc.dbf mKodClSc = ALLTRIM(STR(KOD_CLSC)) mNameClSc = ALLTRIM(NAME_CLSC) mKODGRCS_MIN = KODGR_MIN // переменная памяти, код начальной градации текущей описательной шкалы, значение взять из поля: KODGR_MIN базы данных Class _Sc.dbf mKODGRCS_MAX = KODGR_MAX // переменная памяти, код конечной градации текущей описательной шкалы, значение взять из поля: KODGR_MAX базы данных Class _Sc.dbf SELECT Gr_ClSc aNameGrClSc := {} AADD(aNameGrClSc,'') FOR j=mKODGRCS_MIN TO mKODGRCS_MAX DBGOTO(j) AADD(aNameGrClSc,'['+ALLTRIM(STR(j))+']-'+ALLTRIM(NAME_GRCS)) NEXT SELECT Class_Sc mRecno_ClSc = RECNO() N_Gos = mKODGROS_MAX - mKODGROS_MIN + 1 N_Gcs = mKODGRCS_MAX - mKODGRCS_MIN + 1 * N_Gos = LEN(aNameGrOpSc)-1 * N_Gcs = LEN(aNameGrClSc)-1 FOR mModel=1 TO LEN(aCurrInf) // Начало цикла по моделям IF aCurrInf[mModel] mSubMatrix = '' PRIVATE aSubMatrix[N_Gos, N_Gcs] // Массив для траспонированной субматрицы * AFILL(aSubMatrix, 0) FOR mLine = mKODGROS_MIN TO mKODGROS_MAX // Начало цикла-3 по записям mLine базы данных выбранной модели от записи № KODGROS_MIN до записи № KODGROS_MAX mString = '' FOR mCol = mKODGRCS_MIN TO mKODGRCS_MAX // Начало цикла-4 по столбцам mCol базы данных выбранной модели от столбца № KODGRСS_MIN+2 до столбца № KODGRCS_MAX+2 * Извлечь значение элемента [mLine,mCol] из txt-базы данных текущей модели и, если оно не равно нулю, присвоить это значение элементу массива SubMatrix[mLine,mCol-mKODGRCS_MIN+1]. Fv = LC_FieldGet( Ar_Model[mModel]+".txt", nHandle[mModel], mLine, mCol+2 ) Fv = IF(LEN(ALLTRIM(Fv))=0,'0',Fv) aSubMatrix[mLine-mKODGROS_MIN+1, mCol-mKODGRCS_MIN+1] = VAL(Fv) // <<<===########################### * Если значение в подматрице SubMatrix.CSV равно нулю, то вместо него использовать псевдослучайное число отличающееся от нуля в четырех последних разрядах из семи знаков после запятой. Это сделать в Питоне <<<===#################### * Может быть потребуется заменить десятичную точку на десятичную запятую mString = mString + ALLTRIM(Fv) + IF(MCol 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 aMess := {} AADD(aMess, L("Вывод результатов распознавания невозможен, т.к. оно не проводилось !!!")) AADD(aMess, L("Необходимо выполнить распознавание обучающей выборки в режиме 3.5")) AADD(aMess, L("или распознаваемой выборки в режиме 4.1.2 !!!")) LB_Warning(aMess, L("Информационное сообщение")) RETURN NIL ENDIF // Проверка на наличие отображаемых баз данных результатов распознавания IF .NOT. FILE("Rso_Zag.dbf") LB_Warning(L("Нет распознаваемой выборки! Небходимо выполнить режим: 4.1.1 или создать ее другим способом!")) Running(.F.) RETURN NIL ENDIF IF .NOT. FILE("Rsp1k.dbf") LB_Warning(L("Нет баз данных визуализация результатов распознавания! Небходимо выполнить режим: 4.1.2!")) Running(.F.) RETURN NIL ENDIF IF .NOT. FILE("Rsp1i.dbf") LB_Warning(L("Нет баз данных визуализация результатов распознавания! Небходимо выполнить режим: 4.1.2!")) Running(.F.) RETURN NIL ENDIF dbeSetDefault('DBFNTX') CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rso_Zag INDEX ON Kod_Obj TO Rso_Zag CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rsp1k NEW INDEX ON Kod_Obj TO Rsp1k CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rsp1i NEW INDEX ON Kod_Obj TO Rsp1i CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rso_Zag INDEX Rso_Zag EXCLUSIVE USE Rsp1k INDEX Rsp1k EXCLUSIVE NEW USE Rsp1i INDEX Rsp1i EXCLUSIVE NEW /* ----- Create ToolBar ----- */ ***** Кнопки визу ********************************************************************** @ 27.5, 0 DCPUSHBUTTON CAPTION L('Помощь' ) SIZE 9,1.3 ACTION {||Help4131a() , DC_GetRefresh(GetList)} TOOLTIP L('Помощь по режиму' ) @ DCGUI_ROW, DCGUI_COL + 8 DCPUSHBUTTON CAPTION L('9 классов' ) SIZE 10,1.3 ACTION {||Fltr9On4131() , DC_GetRefresh(GetList)} TOOLTIP L('Показать 9 классов с максимальным модулем сходства' ) @ DCGUI_ROW, DCGUI_COL + 1 DCPUSHBUTTON CAPTION L('Классы с MaxMin УрСх' ) SIZE 19,1.3 ACTION {||FltrMOn4131(Rsp1k->Kod_Cls) , DC_GetRefresh(GetList)} TOOLTIP L('Показать по каждой классиф.шкале только по 2 класса с макс.и миним.уровнями сходства' ) @ DCGUI_ROW, DCGUI_COL + 1 DCPUSHBUTTON CAPTION L('9 классов с MaxMin УрСх' ) SIZE 21,1.3 ACTION {||Fltr9MOn4131(Rsp1k->Kod_Cls) , DC_GetRefresh(GetList)} TOOLTIP L('Показать по каждой классиф.шкале только по 2 класса с макс.и миним.уровнями сходства' ) @ DCGUI_ROW, DCGUI_COL + 1 DCPUSHBUTTON CAPTION L('ВСЕ классы' ) SIZE 11,1.3 ACTION {||Fltr9Off4131() , DC_GetRefresh(GetList)} TOOLTIP L('Показать все записи независимо от модуля сходства' ) @ DCGUI_ROW, DCGUI_COL + 8 DCPUSHBUTTON CAPTION L('ВКЛ. фильтр по класс.шкале') SIZE 24,1.3 ACTION {||FltrOnCls4131(Rsp1k->Kod_Cls) , DC_GetRefresh(GetList)} TOOLTIP L('Показать все классы только одной классиф.шкалы, на которой стоит курсор в верхнем правом окне') @ DCGUI_ROW, DCGUI_COL + 1 DCPUSHBUTTON CAPTION L('ВЫКЛ.фильтр по класс.шкале') SIZE 25,1.3 ACTION {||FltrOffCls4131() , DC_GetRefresh(GetList)} TOOLTIP L('Показать сходство и различия с классами всех классификационных шкал' ) @ DCGUI_ROW, DCGUI_COL + 8 DCPUSHBUTTON CAPTION L('Граф.диаграммы' ) SIZE 15,1.3 ACTION {||ChartOn4131(Rso_Zag->Kod_Obj, Rsp1k->Kod_Cls, Ar_Model[M_CurrInf]) , DC_GetRefresh(GetList)} TOOLTIP L('Вывод графической диаграммы прогнозируемых сценариев' ) **************************************************************** @1.0, 0 DCPUSHBUTTON ; CAPTION L('Распознаваемые объекты') ; SIZE 34.8, 1 ; ACTION {||Help4131b()} @1.0,38 DCPUSHBUTTON ; CAPTION L('Интегральный критерий сходства: "Семантический резонанс знаний"'); SIZE 99.7, 1 ; ACTION {||Help4131c()} @14.2,38 DCPUSHBUTTON ; CAPTION L('Интегральный критерий сходства: "Сумма знаний"'); SIZE 99.7, 1 ; ACTION {||Help4_1_3_1d()} **************************************************************** PRIVATE bColorBlockKor:={|| iif(Rsp1k->Korr>0 ,{GRA_CLR_RED,nil},iif(Rsp1k->Korr=0 ,{GRA_CLR_WHITE,nil},{GRA_CLR_BLUE,nil})) } // Клиффорд PRIVATE bColorBlockInf:={|| iif(Rsp1i->Sum_inf>0,{GRA_CLR_RED,nil},iif(Rsp1i->Sum_inf=0,{GRA_CLR_WHITE,nil},{GRA_CLR_BLUE,nil})) } // Клиффорд /* ----- Create browse-1: Главная БД Rso_Zag.dbf ----- */ *bZag := {|| Rsp1i->(DC_SetScope(0,Rso_Zag->Kod_Obj)), ; * Rsp1i->(DC_SetScope(1,Rso_Zag->Kod_Obj)), ; * Rsp1i->(DC_DbGoTop()) , ; * oBrowInf:refreshAll() , ; * Rsp1k->(DC_SetScope(0,Rso_Zag->Kod_Obj)), ; * Rsp1k->(DC_SetScope(1,Rso_Zag->Kod_Obj)), ; * Rsp1k->(DC_DbGoTop()) , ; * oBrowKor:refreshAll() } bZag := {|| Rsp1i->(DC_SetScope(0,Rso_Zag->Kod_Obj)), ; Rsp1i->(DC_SetScope(1,Rso_Zag->Kod_Obj)), ; Rsp1i->(DC_DbGoTop()) , ; oBrowInf:refreshAll() , ; Rsp1k->(DC_SetScope(0,Rso_Zag->Kod_Obj)), ; Rsp1k->(DC_SetScope(1,Rso_Zag->Kod_Obj)), ; Rsp1k->(DC_DbGoTop()) , ; oBrowKor:refreshAll() } @ 2, 0 DCBROWSE oBrowZag ALIAS 'Rso_Zag' SIZE 34.8,25.2 ; PRESENTATION LC_BrowPres() ; // Только просмотр БД NOSOFTTRACK ; SCOPE ; ITEMMARKED {|| Eval(bZag), ; DC_GetRefresh(GetList,, ; DCGETREFRESH_TYPE_EXCLUDE,{GETLIST_BROWSE}) } DCSETPARENT oBrowZag DCBROWSECOL FIELD Rso_Zag->Kod_Obj HEADER L('Код' ) WIDTH 5 DCBROWSECOL FIELD Rso_Zag->Name_obj HEADER L('Наим.объекта') WIDTH 14.5 DCBROWSECOL FIELD Rso_Zag->Date HEADER L('Дата' ) WIDTH 10 DCBROWSECOL FIELD Rso_Zag->Time HEADER L('Время' ) WIDTH 9 /* Create browse-2: БД Rsp1k.dbf, связанная отношением "Один ко многим" с БД Rso_Zag.dbf*/ DCSETPARENT TO @2, 38 DCBROWSE oBrowKor ALIAS 'Rsp1k' SIZE 99.7,12.0 ; PRESENTATION LC_BrowPres() ; // Только просмотр БД NOSOFTTRACK ; SCOPE ; ITEMMARKED bItems DCSETPARENT oBrowKor DCBROWSECOL FIELD Rsp1k->Kod_Cls HEADER L('Код' ) WIDTH 5 DCBROWSECOL FIELD Rsp1k->Name_cls HEADER L('Наименование класса') WIDTH 30 DCBROWSECOL FIELD Rsp1k->Korr HEADER L('Сходство' ) WIDTH 6 DCBROWSECOL FIELD Rsp1k->Fakt HEADER L('Факт' ) WIDTH 1 DCBROWSECOL FIELD Rsp1k->Histogram HEADER L('Сходство' ) WIDTH 19 COLOR bColorBlockKor DCBROWSECOL FIELD Rsp1k->Date HEADER L('Дата' ) WIDTH 10 DCBROWSECOL FIELD Rsp1k->Time HEADER L('Время' ) WIDTH 9 /* Create browse-3: БД Rsp1i.dbf, связанная отношением "Один ко многим" с БД Rso_Zag.dbf*/ DCSETPARENT TO @15.2,38 DCBROWSE oBrowInf ALIAS 'Rsp1i' SIZE 99.7,12.0; PRESENTATION LC_BrowPres() ; // Только просмотр БД NOSOFTTRACK ; SCOPE ; ITEMMARKED bItems DCSETPARENT oBrowInf DCBROWSECOL FIELD Rsp1i->Kod_Cls HEADER L('Код' ) WIDTH 5 DCBROWSECOL FIELD Rsp1i->Name_cls HEADER L('Наименование класса') WIDTH 30 DCBROWSECOL FIELD Rsp1i->Sum_inf HEADER L('Сходство' ) WIDTH 6 DCBROWSECOL FIELD Rsp1i->Fakt HEADER L('Факт' ) WIDTH 1 DCBROWSECOL FIELD Rsp1i->Histogram HEADER L('Сходство' ) WIDTH 19 COLOR bColorBlockInf DCBROWSECOL FIELD Rsp1i->Date HEADER L('Дата' ) WIDTH 10 DCBROWSECOL FIELD Rsp1i->Time HEADER L('Время' ) WIDTH 9 SELECT Rso_Zag DCGETOPTIONS SAYFONT '10.Helv Bold' TABSTOP AUTORESIZE cTitle = L('4.1.3.1. Визуализация результатов распознавания в отношении: "Объект-классы". Текущая модель: "')+UPPER(Ar_Model[M_CurrInf])+'"' DCREAD GUI ; FIT ; OPTIONS GetOptions ; MODAL ; TITLE cTitle ; EVAL {|o|SetAppFocus(oBrowZag:GetColumn(1))} ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ********** END OF EXAMPLE *********************** ************************************************************************************************** FUNCTION Help4131a() aHelp := {} AADD(aHelp, L('Режим: 4.1.3.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('- [9 классов]: Показать 9 классов с максимальным модулем сходства ')) AADD(aHelp, L('- [Классы с MaxMin УрСх]: Показать по каждой классификационной ')) AADD(aHelp, L(' шкале только по 2 класса с максимальным и минимальным уровнями сходства ')) AADD(aHelp, L('- [ВСЕ классы]: Показать все записи независимо от модуля сходства ')) 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-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('Помощь по режиму: 4.1.3.1. (C) Система "ЭЙДОС-X++"') RETURN NIL ************************************************************************************************** ************************************************************************************************** FUNCTION Help4131b() aHelp := {} AADD(aHelp, L('ПОЯСНЕНИЕ ПО СМЫСЛУ ТЕРМИНА: "РАСПОЗНАВАЕМАЯ ВЫБОРКА". ')) AADD(aHelp, L('Распознаваемая выборка представляет собой описания конкретных объектов, предъявляемых системе')) AADD(aHelp, L('"Эйдос-Х++" для распознавания, идентификации и прогнозирования. Эти описания вводятся в режиме')) AADD(aHelp, L('4.1.1 или формируются другим способом, и состоят из перечисления кодов признаков(градаций ')) AADD(aHelp, L('описательных шкал) каждого объекта в соответствии с справочниками описательных шкал и градаций')) AADD(aHelp, L('(режим 2.2). При этом коды могут быть приведены в любом порядке. Коды несуществующих ')) AADD(aHelp, L('признаков, в т.ч. 0, игнорируются. Используя модель знаний, созданную в 3-й подсистеме, ')) 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('4.1.3.1. Смысл термина: "Распознаваемая выборка" (C) Система "ЭЙДОС-X++"') RETURN NIL ************************************************************************************************** ***************************************************************************************** ******** Помощь по режиму 4.1.3.1: смысл интегрального критерия "Семантический ******** резонанс знаний" сходства распознаваемых объектов с классами системы "Эйдос-Х++" ***************************************************************************************** FUNCTION Help4131c() aSaveH4131 := DC_DataSave() // Сохранение вычислительной среды (открытые и текущие БД и индексы) DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы cFile = "_Int_Criteria2.pdf" IF .NOT. FILE(cFile) Mess = L('В папке с исполнимым модулем системы нет файла: "#"') Mess = STRTRAN(Mess, "#", cFile) LB_Warning(Mess) ENDIF // Проверить контрольную сумму файла и если она не совпадает // выдать сообщение о том, что файл поврежден (чтобы было невозможно заменить графический файл). IF FILECHECK(cFile) = 59487304 // <<<===############### * DC_PrintPreviewAcrobat( cFile, 'Сценарный метод АСК-анализа' ) RunShell(cFile,"SumatraPDF-3.4.5-32.exe",.T.) ELSE Mess = L('Файл: "#" поврежден (CRC=$) и не может быть отображен!') Mess = STRTRAN(Mess, "#", cFile) Mess = STRTRAN(Mess, "$", ALLTRIM(STR(FILECHECK(cFile),19))) // Отображение контрольной суммы файла LB_Warning(Mess) ENDIF IF ApplChange("") // Перейти в папку выбранного приложения или выйти из системы LB_Warning(L("Необходимо задать (выбрать) хотя бы одно текущее приложение !!!")) Running(.F.) RETURN NIL ENDIF DC_DataRest( aSaveH4131 ) // Восстановление вычислительной среды (открытые и текущие БД и индексы) RETURN NIL ****************************************************************************** ******** Помощь по режиму 4.1.3.1: Смысл интегрального критерия "Сумма знаний" ******** сходства распознаваемых объектов с классами системы "Эйдос-Х++" ****************************************************************************** FUNCTION Help4_1_3_1d() * SET TAG TO COMMAND aSaveH4131 := DC_DataSave() // Сохранение вычислительной среды (открытые и текущие БД и индексы) DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы cFile = "_Int_Criteria1.pdf" IF .NOT. FILE(cFile) Mess = L('В папке с исполнимым модулем системы нет файла: "#"') Mess = STRTRAN(Mess, "#", cFile) LB_Warning(Mess) ENDIF // Проверить контрольную сумму файла и если она не совпадает // выдать сообщение о том, что файл поврежден (чтобы было невозможно заменить графический файл). IF FILECHECK(cFile) = 59487304 // <<<===############### * DC_PrintPreviewAcrobat( cFile, 'Сценарный метод АСК-анализа' ) RunShell(cFile,"SumatraPDF-3.4.5-32.exe",.T.) ELSE Mess = L('Файл: "#" поврежден (CRC=$) и не может быть отображен!') Mess = STRTRAN(Mess, "#", cFile) Mess = STRTRAN(Mess, "$", ALLTRIM(STR(FILECHECK(cFile),19))) // Отображение контрольной суммы файла LB_Warning(Mess) ENDIF IF ApplChange("") // Перейти в папку выбранного приложения или выйти из системы LB_Warning(L("Необходимо задать (выбрать) хотя бы одно текущее приложение !!!")) Running(.F.) RETURN NIL ENDIF DC_DataRest( aSaveH4131 ) // Восстановление вычислительной среды (открытые и текущие БД и индексы) RETURN NIL ***************************************************************************************************************** ******** Помощь по режиму 4.1.3.1: Смысл интегральных критериев: "Сумма знаний" и "Семантический резонанс знаний" ******** сходства распознаваемых объектов с классами системы "Эйдос-Х++" ***************************************************************************************************************** FUNCTION Help4131() DIRCHANGE(Disk_dir) cFile = "_Int_Criteria1.pdf" IF .NOT. FILE(cFile) Mess = L('В папке с исполнимым модулем системы нет файла: "#"') Mess = STRTRAN(Mess, "#", cFile) LB_Warning(Mess) ENDIF // Проверить контрольную сумму файла и если она не совпадает // выдать сообщение о том, что файл поврежден (чтобы было невозможно заменить графический файл). IF FILECHECK(cFile) = 59487304 // <<<===############### * DC_PrintPreviewAcrobat( cFile, 'Сценарный метод АСК-анализа' ) RunShell(cFile,"SumatraPDF-3.4.5-32.exe",.T.) ELSE Mess = L('Файл: "#" поврежден (CRC=$) и не может быть отображен!') Mess = STRTRAN(Mess, "#", cFile) Mess = STRTRAN(Mess, "$", ALLTRIM(STR(FILECHECK(cFile),19))) // Отображение контрольной суммы файла LB_Warning(Mess) ENDIF cFile = "_Int_Criteria2.pdf" IF .NOT. FILE(cFile) Mess = L('В папке с исполнимым модулем системы нет файла: "#"') Mess = STRTRAN(Mess, "#", cFile) LB_Warning(Mess) ENDIF // Проверить контрольную сумму файла и если она не совпадает // выдать сообщение о том, что файл поврежден (чтобы было невозможно заменить графический файл). IF FILECHECK(cFile) = 59487304 // <<<===############### * DC_PrintPreviewAcrobat( cFile, 'Сценарный метод АСК-анализа' ) RunShell(cFile,"SumatraPDF-3.4.5-32.exe",.T.) ELSE Mess = L('Файл: "#" поврежден (CRC=$) и не может быть отображен!') Mess = STRTRAN(Mess, "#", cFile) Mess = STRTRAN(Mess, "$", ALLTRIM(STR(FILECHECK(cFile),19))) // Отображение контрольной суммы файла LB_Warning(Mess) ENDIF IF ApplChange("") // Перейти в папку выбранного приложения или выйти из системы LB_Warning(L("Необходимо задать (выбрать) хотя бы одно текущее приложение !!!")) Running(.F.) RETURN NIL ENDIF RETURN NIL ****************************************************************************** FUNCTION Search4_1_3_1() Razrab() RETURN NIL ******** Выбрать классификационную шкалу и сделать по ней фильтр ******************************* FUNCTION FltrOnCls4131(mKodClSc) // Код класс.шкалы брать прямо из базы Rsp1k.dbf из текущей записи SELECT Rsp1k // В этих базах для визуализации добавить поле с кодом класс.шкалы, чтобы можно было по нему делать фильтр mKodClSc = Kod_ClSc SET FILTER TO mKodClSc = Kod_ClSc DBGOTOP();DBGOBOTTOM();DBGOTOP() DC_GetRefresh(GetList) SELECT Rsp1i // В этих базах для визуализации добавить поле с кодом класс.шкалы, чтобы можно было по нему делать фильтр SET FILTER TO mKodClSc = Kod_ClSc DBGOTOP();DBGOBOTTOM();DBGOTOP() DC_GetRefresh(GetList) RETURN NIL ******** Отменить фильтр по классификационной шкале ******************************************** FUNCTION FltrOffCls4131() SELECT Rsp1k;SET FILTER TO;DBGOTOP();DBGOBOTTOM();DBGOTOP();DC_GetRefresh(GetList) SELECT Rsp1i;SET FILTER TO;DBGOTOP();DBGOBOTTOM();DBGOTOP();DC_GetRefresh(GetList) RETURN NIL ******** Отображать не более 9 записей на объект с максимальным модулем интегрального критерия FUNCTION Fltr9On4131() Fltr9Off4131() SELECT Rsp1k;SET FILTER TO Filter9 = '#';DBGOTOP();DBGOBOTTOM();DBGOTOP();DC_GetRefresh(GetList) SELECT Rsp1i;SET FILTER TO Filter9 = '#';DBGOTOP();DBGOBOTTOM();DBGOTOP();DC_GetRefresh(GetList) RETURN NIL ******** Отображать по каждой класс.шкале только по 2 класса: с Max.и Min.Ур.Сх. FUNCTION FltrMOn4131() Fltr9Off4131() SELECT Rsp1k;SET FILTER TO FilterM = '#';DBGOTOP();DBGOBOTTOM();DBGOTOP();DC_GetRefresh(GetList) SELECT Rsp1i;SET FILTER TO FilterM = '#';DBGOTOP();DBGOBOTTOM();DBGOTOP();DC_GetRefresh(GetList) RETURN NIL ******** Отображать не более 9 записей на объект с максимальным модулем интегрального критерия ******** по каждой класс.шкале только по 2 класса: с Max.и Min.Ур.Сх. FUNCTION Fltr9MOn4131() Fltr9Off4131() SELECT Rsp1k;SET FILTER TO Filter9 = '#' .AND. FilterM = '#';DBGOTOP();DBGOBOTTOM();DBGOTOP();DC_GetRefresh(GetList) SELECT Rsp1i;SET FILTER TO Filter9 = '#' .AND. FilterM = '#';DBGOTOP();DBGOBOTTOM();DBGOTOP();DC_GetRefresh(GetList) RETURN NIL ******** Выключить фильтр, т.е. показать все классы FUNCTION Fltr9Off4131() SELECT Rsp1k;SET FILTER TO;DBGOTOP();DBGOBOTTOM();DBGOTOP();DC_GetRefresh(GetList) SELECT Rsp1i;SET FILTER TO;DBGOTOP();DBGOBOTTOM();DBGOTOP();DC_GetRefresh(GetList) RETURN NIL FUNCTION PrintXLS4131() Razrab() RETURN NIL ****************************************************************************** ******************************************************************************************* ******** 4.1.3.2. Визуализация результатов распознавания в подробной наглядной форме в ******** отношении: "Один класс - много объектов" с двумя интегральными критериями ******** сходства между конкретным образом распознаваемого объекта и обобщенными ******** образами классов: "Семантический резонанс знаний" и "Сумма знаний" ******************************************************************************************* FUNCTION F4_1_3_2() LOCAL GetList := {}, GetOptions, oBrowUser, oBrowApp, bApp, bItems Running(.T.) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF ApplChange("4.1.3.2()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW Running(.F.) RETURN NIL ENDIF IF FILE("_CalcInf.arx") // Файл с информацией о том, какие модели были рассчитаны ранее aCalcInf = DC_ARestore("_CalcInf.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 IF FILE("_CurrInf.arx") // Файл с информацией о том, какая модель задана текущей M_CurrInf = DC_ARestore("_CurrInf.arx") ELSE LB_Warning(L("Вывод результатов распознавания невозможен, т.к. нет информации о том, какая модель текущая !!! ")) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW Running(.F.) RETURN NIL 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("Информационное сообщение")) ELSE * Mess = L("Результаты распознавания соответствуют текущей модели #") * Mess = STRTRAN(Mess, "#", Ar_Model[M_RaspInf]) * LB_Warning(Mess, L("Информационное сообщение")) ENDIF ELSE LB_Warning(L("Вывод результатов распознавания невозможен, т.к. оно не проводилось !!!"), L("Информационное сообщение")) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW Running(.F.) RETURN NIL ENDIF // Проверка на наличие отображаемых баз данных результатов распознавания IF .NOT. FILE("Classes.dbf") LB_Warning(L("Нет справочника классов! Небходимо выполнить режим: 2.1 или создать его другим способом!")) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW Running(.F.) RETURN NIL ENDIF IF .NOT. FILE("Rsp2k.dbf") LB_Warning(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 IF .NOT. FILE("Rsp2i.dbf") LB_Warning(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 dbeSetDefault('DBFNTX') CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes INDEX ON Kod_cls TO Classes CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rsp2k NEW INDEX ON Kod_cls TO Rsp2k CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rsp2i NEW INDEX ON Kod_cls TO Rsp2i CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes INDEX Classes EXCLUSIVE *SET FILTER TO Int_inf+Abs > 0 DBGOTOP();DBGOBOTTOM();DBGOTOP() USE Rsp2k INDEX Rsp2k EXCLUSIVE NEW USE Rsp2i INDEX Rsp2i EXCLUSIVE NEW /* ----- Create ToolBar ----- */ @ 27.7, 0 DCTOOLBAR oToolBar SIZE 131, 1.5 DCADDBUTTON CAPTION L('Помощь') ; SIZE LEN(L("Помощь"))+2 ; ACTION {||Help4132a(), DC_GetRefresh(GetList)} ; PARENT oToolBar DCADDBUTTON CAPTION L('Поиск объекта') ; SIZE LEN(L("Поиск объекта"))+2 ; ACTION {||Search4_1_3_2(), DC_GetRefresh(GetList)} ; PARENT oToolBar DCADDBUTTON CAPTION L('В начало БД') ; SIZE LEN(L("В начало БД"))+2 ; ACTION {||dbGoTop(), DC_GetRefresh(GetList)} ; WHEN {||!DC_TestBof()} ; PARENT oToolBar DCADDBUTTON CAPTION L('В конец БД') ; SIZE LEN(L("В конец БД"))+2 ; ACTION {||dbGoBottom(), DC_GetRefresh(GetList)} ; WHEN {||!DC_TestEof()} ; PARENT oToolBar DCADDBUTTON CAPTION L('Предыдущая') ; SIZE LEN(L("Предыдущая"))+2 ; ACTION {||dbSkip(-1), DC_GetRefresh(GetList)} ; WHEN {||!DC_TestBof()} ; PARENT oToolBar DCADDBUTTON CAPTION L('Следующая') ; SIZE LEN(L("Следующая"))+2 ; ACTION {||dbSkip(1), DC_GetRefresh(GetList)} ; WHEN {||!DC_TestEof()} ; PARENT oToolBar DCADDBUTTON CAPTION L('9 записей') ; SIZE LEN(L("9 записей"))+2 ; ACTION {||FltrOn4_1_3_2(), DC_GetRefresh(GetList)} ; PARENT oToolBar DCADDBUTTON CAPTION L('Все записи') ; SIZE LEN(L("Все записи"))+2 ; ACTION {||FltrOff4_1_3_2(), DC_GetRefresh(GetList)} ; PARENT oToolBar DCADDBUTTON CAPTION L('Печать XLS') ; SIZE LEN(L("Печать XLS"))+2 ; ACTION {||PrintXLS4_1_3_2(), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION L('Печать TXT') ; SIZE LEN(L("Печать TXT"))+2 ; ACTION {||PrintTXT4_1_3_2(), DC_GetRefresh(GetList)}; PARENT oToolBar DCADDBUTTON CAPTION L('Печать ALL') ; SIZE LEN(L("Печать ALL"))+2 ; ACTION {||PrintALL4_1_3_2(), DC_GetRefresh(GetList)}; PARENT oToolBar **************************************************************** @1.0, 0 DCPUSHBUTTON ; CAPTION L('Классы') ; SIZE 45.8, 1 ; ACTION {||Help4132b()} @1.0,49 DCPUSHBUTTON ; CAPTION L('Интегральный критерий сходства: "Семантический резонанс знаний"'); SIZE 88.7, 1 ; ACTION {||Help4132c()} @14.2,49 DCPUSHBUTTON ; CAPTION L('Интегральный критерий сходства: "Сумма знаний"') ; SIZE 88.7, 1 ; ACTION {||Help4_1_3_2d()} **************************************************************** PRIVATE bColorBlockKor:={|| iif(Rsp2k->Korr>0 ,{GRA_CLR_RED,nil},iif(Rsp2k->Korr=0 ,{GRA_CLR_WHITE,nil},{GRA_CLR_BLUE,nil})) } // Клиффорд PRIVATE bColorBlockInf:={|| iif(Rsp2i->Sum_inf>0,{GRA_CLR_RED,nil},iif(Rsp2i->Sum_inf=0,{GRA_CLR_WHITE,nil},{GRA_CLR_BLUE,nil})) } // Клиффорд /* ----- Create browse-1: Главная БД Classes.dbf ----- */ bZag := {|| Rsp2i->(DC_SetScope(0,Classes->Kod_cls)), ; Rsp2i->(DC_SetScope(1,Classes->Kod_cls)), ; Rsp2i->(DC_DbGoTop()) , ; oBrowInf:refreshAll() , ; Rsp2k->(DC_SetScope(0,Classes->Kod_cls)), ; Rsp2k->(DC_SetScope(1,Classes->Kod_cls)), ; Rsp2k->(DC_DbGoTop()) , ; oBrowKor:refreshAll() } @ 2, 0 DCBROWSE oBrowZag ALIAS 'Classes' SIZE 45.8,25.2 ; PRESENTATION LC_BrowPres() ; // Только просмотр БД NOSOFTTRACK ; SCOPE ; ITEMMARKED {|| Eval(bZag), ; DC_GetRefresh(GetList,, ; DCGETREFRESH_TYPE_EXCLUDE,{GETLIST_BROWSE}) } DCSETPARENT oBrowZag DCBROWSECOL FIELD Classes->Kod_cls HEADER L('Код' ) WIDTH 5 DCBROWSECOL FIELD Classes->Name_cls HEADER L('Наим. класса') WIDTH 21.0 DCBROWSECOL FIELD Classes->Date HEADER L('Дата' ) WIDTH 10 DCBROWSECOL FIELD Classes->Time HEADER L('Время' ) WIDTH 9 /* Create browse-2: БД Rsp2k.dbf, связанная отношением "Один ко многим" с БД Classes.dbf*/ DCSETPARENT TO @2, 49 DCBROWSE oBrowKor ALIAS 'Rsp2k' SIZE 88.7,12.0 ; PRESENTATION LC_BrowPres() ; // Только просмотр БД NOSOFTTRACK ; SCOPE ; ITEMMARKED bItems DCSETPARENT oBrowKor DCBROWSECOL FIELD Rsp2k->Kod_obj HEADER L('Код' ) WIDTH 5 DCBROWSECOL FIELD Rsp2k->Name_obj HEADER L('Наименование объекта') WIDTH 19.0 DCBROWSECOL FIELD Rsp2k->Korr HEADER L('Сходство' ) WIDTH 6 DCBROWSECOL FIELD Rsp2k->Fakt HEADER L('Факт' ) WIDTH 1 DCBROWSECOL FIELD Rsp2k->Histogram HEADER L('Сходство' ) WIDTH 19 COLOR bColorBlockKor DCBROWSECOL FIELD Rsp2k->Date HEADER L('Дата' ) WIDTH 10 DCBROWSECOL FIELD Rsp2k->Time HEADER L('Время' ) WIDTH 9 /* Create browse-3: БД Rsp2i.dbf, связанная отношением "Один ко многим" с БД Classes.dbf*/ DCSETPARENT TO @15.2,49 DCBROWSE oBrowInf ALIAS 'Rsp2i' SIZE 88.7,12.0; PRESENTATION LC_BrowPres() ; // Только просмотр БД NOSOFTTRACK ; SCOPE ; ITEMMARKED bItems DCSETPARENT oBrowInf DCBROWSECOL FIELD Rsp2i->Kod_obj HEADER L('Код' ) WIDTH 5 DCBROWSECOL FIELD Rsp2i->Name_obj HEADER L('Наименование объекта') WIDTH 19.0 DCBROWSECOL FIELD Rsp2i->Sum_inf HEADER L('Сходство' ) WIDTH 6 DCBROWSECOL FIELD Rsp2i->Fakt HEADER L('Факт' ) WIDTH 1 DCBROWSECOL FIELD Rsp2i->Histogram HEADER L('Сходство' ) WIDTH 19 COLOR bColorBlockInf DCBROWSECOL FIELD Rsp2i->Date HEADER L('Дата' ) WIDTH 10 DCBROWSECOL FIELD Rsp2i->Time HEADER L('Время' ) WIDTH 9 SELECT Classes DCGETOPTIONS SAYFONT '10.Helv Bold' TABSTOP AUTORESIZE cTitle = L('4.1.3.2. Визуализация результатов распознавания в отношении: "Класс-объекты". Текущая модель: "')+UPPER(Ar_Model[M_CurrInf])+'"' DCREAD GUI ; FIT ; OPTIONS GetOptions ; MODAL ; TITLE cTitle ; EVAL {|o|SetAppFocus(oBrowZag:GetColumn(1))} ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ****** END OF EXAMPLE *********************** ************************************************************************************************** FUNCTION Help4132a() aHelp := {} AADD(aHelp, L('Режим: 4.1.3.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('распознавания). ')) 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('Помощь по режиму: 4.1.3.2. (C) Система "ЭЙДОС-X++"') RETURN NIL ************************************************************************************************** **************************************************************************************** FUNCTION Help4132b() aHelp := {} AADD(aHelp, L('ПОЯСНЕНИЕ ПО СМЫСЛУ ТЕРМИНА: "РАСПОЗНАВАЕМАЯ ВЫБОРКА". ')) AADD(aHelp, L('Распознаваемая выборка представляет собой описания конкретных объектов, предъявляемых системе')) AADD(aHelp, L('"Эйдос-Х++" для распознавания, идентификации и прогнозирования. Эти описания вводятся в режиме')) AADD(aHelp, L('4.1.1 или формируются другим способом, и состоят из перечисления кодов признаков(градаций ')) AADD(aHelp, L('описательных шкал) каждого объекта в соответствии с справочниками описательных шкал и градаций')) AADD(aHelp, L('(режим 2.2). При этом коды могут быть приведены в любом порядке. Коды несуществующих ')) AADD(aHelp, L('признаков, в т.ч. 0, игнорируются. Используя модель знаний, созданную в 3-й подсистеме, ')) 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('4.1.3.2. Смысл термина: "Распознаваемая выборка" (C) Система "ЭЙДОС-X++"') RETURN NIL ***************************************************************************************** ******** Помощь по режиму 4.1.3.2: смысл интегрального критерия "Семантический ******** резонанс знаний" сходства распознаваемых объектов с классами системы "Эйдос-Х++" ***************************************************************************************** FUNCTION Help4132c() aSaveH4131 := DC_DataSave() // Сохранение вычислительной среды (открытые и текущие БД и индексы) DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы cFile = "_Int_Criteria2.pdf" IF .NOT. FILE(cFile) Mess = L('В папке с исполнимым модулем системы нет файла: "#"') Mess = STRTRAN(Mess, "#", cFile) LB_Warning(Mess) ENDIF // Проверить контрольную сумму файла и если она не совпадает // выдать сообщение о том, что файл поврежден (чтобы было невозможно заменить графический файл). IF FILECHECK(cFile) = 59487304 // <<<===############### * DC_PrintPreviewAcrobat( cFile, 'Сценарный метод АСК-анализа' ) RunShell(cFile,"SumatraPDF-3.4.5-32.exe",.T.) ELSE Mess = L('Файл: "#" поврежден (CRC=$) и не может быть отображен!') Mess = STRTRAN(Mess, "#", cFile) Mess = STRTRAN(Mess, "$", ALLTRIM(STR(FILECHECK(cFile),19))) // Отображение контрольной суммы файла LB_Warning(Mess) ENDIF IF ApplChange("") // Перейти в папку выбранного приложения или выйти из системы LB_Warning(L("Необходимо задать (выбрать) хотя бы одно текущее приложение !!!")) Running(.F.) RETURN NIL ENDIF DC_DataRest( aSaveH4131 ) // Восстановление вычислительной среды (открытые и текущие БД и индексы) RETURN NIL ****************************************************************************** ******** Помощь по режиму 4.1.3.2: смысл интегрального критерия "Сумма знаний" ******** сходства распознаваемых объектов с классами системы "Эйдос-Х++" ****************************************************************************** FUNCTION Help4_1_3_2d() aSaveH4131 := DC_DataSave() // Сохранение вычислительной среды (открытые и текущие БД и индексы) DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы cFile = "_Int_Criteria1.pdf" IF .NOT. FILE(cFile) Mess = L('В папке с исполнимым модулем системы нет файла: "#"') Mess = STRTRAN(Mess, "#", cFile) LB_Warning(Mess) ENDIF // Проверить контрольную сумму файла и если она не совпадает // выдать сообщение о том, что файл поврежден (чтобы было невозможно заменить графический файл). IF FILECHECK(cFile) = 59487304 // <<<===############### * DC_PrintPreviewAcrobat( cFile, 'Сценарный метод АСК-анализа' ) RunShell(cFile,"SumatraPDF-3.4.5-32.exe",.T.) ELSE Mess = L('Файл: "#" поврежден (CRC=$) и не может быть отображен!') Mess = STRTRAN(Mess, "#", cFile) Mess = STRTRAN(Mess, "$", ALLTRIM(STR(FILECHECK(cFile),19))) // Отображение контрольной суммы файла LB_Warning(Mess) ENDIF IF ApplChange("") // Перейти в папку выбранного приложения или выйти из системы LB_Warning(L("Необходимо задать (выбрать) хотя бы одно текущее приложение !!!")) Running(.F.) RETURN NIL ENDIF DC_DataRest( aSaveH4131 ) // Восстановление вычислительной среды (открытые и текущие БД и индексы) RETURN NIL ****************************************************************************** FUNCTION Search4_1_3_2() Razrab() RETURN NIL FUNCTION FltrOn4_1_3_2() Razrab() RETURN NIL FUNCTION FltrOff4_1_3_2() Razrab() RETURN NIL FUNCTION PrintXLS4_1_3_2() Razrab() RETURN NIL FUNCTION PrintTXT4_1_3_2() Razrab() RETURN NIL ******************************************************************************************************************************************** ******** Печать выходных форм : класс (код и наименование) - коды, наименования и содержимое всех объектов с уровнем сходства выше заданного ******** Печать выходной формы: коды, наименования и содержимое всех объектов с уровнем сходства ниже заданного ******************************************************************************************************************************************** FUNCTION PrintALL4_1_3_2() mPorog = 30 @0,0 DCGROUP oGroup1 CAPTION L('Задайте порог сходства объектов с классами:') SIZE 40.0, 2.5 @1,2 DCSAY L(" ") GET mPorog PARENT oGroup1 DCREAD GUI; TO lExit ; FIT; ADDBUTTONS; MODAL; TITLE L('(c) Система "ЭЙДОС-X++"') IF lExit ** Button Ok ELSE RETURN NIL ENDIF ******************************************************************** oScrn := DC_WaitOn(L('Печать выходных форм'),,,,,,,,,,,.F.) *************************************************** ***** Печать кратких выходных форм **************** *************************************************** DIRCHANGE(Disk_dir+"\AID_DATA\Inp_rasp\") // Перейти в папку Inp_rasp mCountObjTxt = ADIR("*.TXT") // Кол-во TXT-файлов IF mCountObjTxt = 0 LB_Warning(L('В папке: '+Disk_dir+'\AID_DATA\Inp_rasp\ нет TXT-файлов', '(c) Система "ЭЙДОС-X++"')) ELSE PRIVATE aFileNameObj [mCountObjTxt] ADIR("*.txt", aFileNameObj) DIRCHANGE(M_PathAppl) // База данных неидентифицированных объектов распознаваемой выборки, // не вошедших в выходные формы (непривязанных ссылок), потом напечатать ********** Создать БД для выходной формы ************** aStructure := { { "Kod" , "N", 15, 0 }, ; // 1 { "File_name", "C", 255, 0 }, ; // 2 { "Text" , "C", 255, 0 }, ; // 3 { "Type" , "C", 13, 0 }, ; // 5 IdentObject / UnidentObject { "TextALL" , "M", 10, 0 } } // 6 MEMO-FIELD DbCreate( 'UnidentObj', aStructure ) ******************************************************* CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rso_Zag EXCLUSIVE NEW USE UnidentObj EXCLUSIVE NEW SELECT Rso_Zag DBGOTOP() DO WHILE .NOT. EOF() SELECT Rso_Zag mKodObj = Kod_obj mNameObj = ALLTRIM(Name_obj) mTextObj = ALLTRIM(FILESTR(Disk_dir+'\AID_DATA\Inp_rasp\'+aFileNameObj[mKodObj])) // Загрузка файла объектов распознаваемой выборки SELECT UnidentObj APPEND BLANK REPLACE Kod WITH mKodObj REPLACE File_name WITH mNameObj REPLACE Text WITH SUBSTR(mTextObj,1,255) REPLACE TextALL WITH mTextObj REPLACE Type WITH 'UnidentObject' SELECT Rso_Zag DBSKIP(1) ENDDO ENDIF ********** Создать БД для выходной формы ************** aStructure := { { "Kod_cls" , "N", 15, 0 }, ; // 1 { "Name_cls" , "C", 255, 0 }, ; // 2 { "Kod_objs" , "C", 255, 0 }, ; // 3 { "Urov_sxods", "C", 255, 0 }, ; // 4 { "Kobj_UrSx" , "M", 10, 0 } } // 5 MEMO-FIELD для печати текстовой формы с полной информацией DbCreate( 'Rsp2km', aStructure ) DbCreate( 'Rsp2im', aStructure ) ******************************************************* CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rsp2k EXCLUSIVE NEW USE Rsp2i EXCLUSIVE NEW USE Rsp2km EXCLUSIVE NEW USE Rsp2im EXCLUSIVE NEW USE UnidentObj EXCLUSIVE NEW SELECT Rsp2k DBGOTOP() mNameCls = '' mKodObj = Kod_obj mKodCls = Kod_cls DO WHILE .NOT. EOF() IF Korr >= mPorog mKodObj = Kod_obj mKodCls = Kod_cls mUrovSxod= ROUND(Korr,1) ****** Отметить, что объект идентифицирован SELECT UnidentObj DBGOTO(mKodObj) REPLACE Type WITH 'IdentObject' SELECT Rsp2k IF ALLTRIM(mNameCls) <> ALLTRIM(Name_cls) mNameCls = ALLTRIM(Name_cls) SELECT Rsp2km APPEND BLANK REPLACE Kod_cls WITH mKodCls REPLACE Name_cls WITH mNameCls ENDIF SELECT Rsp2km mKodObjs = ALLTRIM(Kod_objs)+' '+ALLTRIM(STR(mKodObj)) IF LEN(mKodObjs) <= 255 REPLACE Kod_objs WITH mKodObjs ENDIF mUrovSxods = ALLTRIM(Urov_sxods)+' '+ALLTRIM(STR(mUrovSxod)) IF LEN(mUrovSxods) <= 255 REPLACE Urov_sxods WITH mUrovSxods ENDIF mKobjUrSx = ALLTRIM(Kobj_UrSx)+' '+ALLTRIM(STR(mKodObj))+'('+ALLTRIM(STR(mUrovSxod,5,1))+')' // Мемо-поле REPLACE Kobj_UrSx WITH mKobjUrSx ENDIF SELECT Rsp2k DBSKIP(1) ENDDO ****** ПЕЧАТЬ ТЕКСТОВОГО ФАЙЛА ******* set device to printer set printer on set printer to ("Rsp2km.txt") set console off ?"РЕЗУЛЬТАТЫ ИДЕНТИФИКАЦИИ ОБЪЕКТОВ С КЛАССАМИ (ИНТ.КРИТ. - РЕЗОНАНС ЗНАНИЙ):" ?"НАИМЕНОВАНИЯ ФАЙЛОВ, КОДЫ КЛАССОВ И РАСПОЗНАВАЕМЫХ ОБЪЕКТОВ (УРОВНИ СХОДСТВА):" ?'показаны объекты распознаваемой выборки с уровнями сходства с классом => '+ALLTRIM(STR(mPorog)) ?'' ?REPLICATE('=',80) SELECT Rsp2km DBGOTOP() DO WHILE .NOT. EOF() ?REPLICATE('=',80) ?'КОД КЛАССА: '+ALLTRIM(STR(Kod_cls))+' НАИМЕНОВАНИЕ КЛАССА: '+ALLTRIM(Name_cls) ?REPLICATE('~',80) ?'КОДЫ РАСПОЗНАВАЕМЫХ ОБЪЕКТОВ (УРОВНИ СХОДСТВА РАСПОЗНАВАЕМЫХ ОБЪЕКТОВ С КЛАССОМ):' ?Kobj_UrSx ?REPLICATE('=',80) ?'' DBSKIP(1) ENDDO ?REPLICATE('=',80) Set device to screen Set printer off Set printer to Set console on ************************************** SELECT Rsp2i DBGOTOP() mNameCls = '' mKodObj = Kod_obj mKodCls = Kod_cls DO WHILE .NOT. EOF() IF Sum_inf >= mPorog mKodObj = Kod_obj mKodCls = Kod_cls mUrovSxod= ROUND(Sum_inf,1) ****** Отметить, что объект идентифицирован SELECT UnidentObj DBGOTO(mKodObj) REPLACE Type WITH 'IdentObject' SELECT Rsp2i IF ALLTRIM(mNameCls) <> ALLTRIM(Name_cls) mNameCls = ALLTRIM(Name_cls) SELECT Rsp2im APPEND BLANK REPLACE Kod_cls WITH mKodCls REPLACE Name_cls WITH mNameCls ENDIF SELECT Rsp2im mKodObjs = ALLTRIM(Kod_objs)+' '+ALLTRIM(STR(mKodObj)) IF LEN(mKodObjs) <= 255 REPLACE Kod_objs WITH mKodObjs ENDIF mUrovSxods = ALLTRIM(Urov_sxods)+' '+ALLTRIM(STR(mUrovSxod,5,1)) IF LEN(mUrovSxods) <= 255 REPLACE Urov_sxods WITH mUrovSxods ENDIF mKobjUrSx = ALLTRIM(Kobj_UrSx)+' '+ALLTRIM(STR(mKodObj))+'('+ALLTRIM(STR(mUrovSxod,5,1))+')' // Мемо-поле REPLACE Kobj_UrSx WITH mKobjUrSx ENDIF SELECT Rsp2i DBSKIP(1) ENDDO ****** ПЕЧАТЬ ТЕКСТОВОГО ФАЙЛА ******* set device to printer set printer on set printer to ("Rsp2im.txt") set console off ?"РЕЗУЛЬТАТЫ ИДЕНТИФИКАЦИИ ОБЪЕКТОВ С КЛАССАМИ (ИНТ.КРИТ. - СУММА ИНФОРМАЦИИ):" ?"НАИМЕНОВАНИЯ ФАЙЛОВ, КОДЫ КЛАССОВ И РАСПОЗНАВАЕМЫХ ОБЪЕКТОВ (УРОВНИ СХОДСТВА):" ?'показаны объекты распознаваемой выборки с уровнями сходства с классом => '+ALLTRIM(STR(mPorog)) ?'' ?REPLICATE('=',80) SELECT Rsp2im DBGOTOP() DO WHILE .NOT. EOF() ?REPLICATE('=',80) ?'КОД КЛАССА: '+ALLTRIM(STR(Kod_cls))+' НАИМЕНОВАНИЕ КЛАССА: '+ALLTRIM(Name_cls) ?REPLICATE('~',80) ?'КОДЫ РАСПОЗНАВАЕМЫХ ОБЪЕКТОВ (УРОВНИ СХОДСТВА РАСПОЗНАВАЕМЫХ ОБЪЕКТОВ С КЛАССОМ):' ?Kobj_UrSx ?REPLICATE('=',80) ?'' DBSKIP(1) ENDDO ?REPLICATE('=',80) Set device to screen Set printer off Set printer to Set console on ************************************** *************************************************** ***** Печать подробных выходных форм ************** *************************************************** DIRCHANGE(Disk_dir+"\AID_DATA\Inp_data\") // Перейти в папку Inp_data mCountClsTxt = ADIR("*.TXT") // Кол-во TXT-файлов DIRCHANGE(Disk_dir+"\AID_DATA\Inp_rasp\") // Перейти в папку Inp_rasp mCountObjTxt = ADIR("*.TXT") // Кол-во TXT-файлов IF mCountClsTxt = 0 LB_Warning(L('В папке: '+Disk_dir+'\AID_DATA\Inp_data\ нет TXT-файлов'), L('(c) Система "ЭЙДОС-X++"')) ELSE IF mCountObjTxt = 0 LB_Warning(L('В папке: '+Disk_dir+'\AID_DATA\Inp_rasp\ нет TXT-файлов'), L('(c) Система "ЭЙДОС-X++"')) ELSE DIRCHANGE(Disk_dir+"\AID_DATA\Inp_data\") // Перейти в папку Inp_data PRIVATE aFileNameCls [mCountClsTxt] PRIVATE aFileNameClsL[mCountClsTxt] ADIR("*.txt", aFileNameCls) FOR j=1 TO LEN(aFileNameCls) aFileNameClsL[j] = ALLTRIM(ConvToOemCP(aFileNameCls[j])) NEXT DIRCHANGE(Disk_dir+"\AID_DATA\Inp_rasp\") // Перейти в папку Inp_rasp PRIVATE aFileNameObj [mCountObjTxt] PRIVATE aFileNameObjL[mCountObjTxt] ADIR("*.txt", aFileNameObj) FOR j=1 TO LEN(aFileNameObj) aFileNameObjL[j] = ALLTRIM(ConvToOemCP(aFileNameObj[j])) NEXT DIRCHANGE(M_PathAppl) ********** Создать БД для выходной формы ************** aStructure := { { "Kod" , "N", 15, 0 }, ; // 1 { "File_name", "C", 255, 0 }, ; // 2 { "Text" , "C", 255, 0 }, ; // 3 { "Urov_sxod", "N", 5, 1 }, ; // 4 { "Type" , "C", 8, 0 }, ; // 5 Classes / Object / KobjUrSx { "TextALL" , "M", 10, 0 } } // 6 MEMO-FIELD DbCreate( 'Rsp2kT', aStructure ) DbCreate( 'Rsp2iT', aStructure ) ******************************************************* CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rso_Zag EXCLUSIVE NEW USE Rsp2km EXCLUSIVE NEW USE Rsp2im EXCLUSIVE NEW USE Rsp2kT EXCLUSIVE NEW USE Rsp2iT EXCLUSIVE NEW USE UnidentObj EXCLUSIVE NEW SELECT Rsp2km DBGOTOP() DO WHILE .NOT. EOF() mKodCls = Kod_cls mNameCls = ALLTRIM(aFileNameClsL[mKodCls]) // Сформировать имя файла mTextCls = ALLTRIM(FILESTR(Disk_dir+'\AID_DATA\Inp_data\'+aFileNameCls[mKodCls])) // Загрузка файла объекта обучающей выборки mKodObjs = Kod_objs mUrSxods = Urov_sxods mKobjUrSx= Kobj_UrSx SELECT Rsp2kT APPEND BLANK APPEND BLANK REPLACE Kod WITH mKodCls REPLACE File_name WITH mNameCls REPLACE Text WITH mTextCls REPLACE TextALL WITH mTextCls REPLACE Type WITH 'Classes' APPEND BLANK REPLACE File_name WITH mKobjUrSx REPLACE TextALL WITH mKobjUrSx REPLACE Type WITH 'KobjUrSx' aKodOrv := {} // Коды объектов распознаваемой выборки aUrSxod := {} // Уровни сходства объектов расп.выборки с классом mKodCls FOR j=1 TO NUMTOKEN(mKodObjs, ' ') AADD(aKodOrv, VAL(TOKEN(mKodObjs, ' ', j))) AADD(aUrSxod, VAL(TOKEN(mUrSxods, ' ', j))) NEXT IF LEN(aKodOrv) > 0 FOR j=1 TO LEN(aKodOrv) SELECT Rso_Zag DBGOTO(aKodOrv[j]) mNameObj = ALLTRIM(aFileNameObjL[aKodOrv[j]]) mTextObj = ALLTRIM(FILESTR(Disk_dir+'\AID_DATA\Inp_rasp\'+aFileNameObj[aKodOrv[j]])) // Загрузка файла объектов распознаваемой выборки SELECT Rsp2kT APPEND BLANK REPLACE Kod WITH aKodOrv[j] REPLACE File_name WITH mNameObj REPLACE Text WITH SUBSTR(mTextObj,1,255) REPLACE TextALL WITH mTextObj REPLACE Urov_sxod WITH aUrSxod[j] REPLACE Type WITH 'Object' NEXT ENDIF SELECT Rsp2km DBSKIP(1) ENDDO ****** ПЕЧАТЬ ТЕКСТОВОГО ФАЙЛА ******* set device to printer set printer on set printer to ("Rsp2kT.txt") set console off ?"РЕЗУЛЬТАТЫ ИДЕНТИФИКАЦИИ ОБЪЕКТОВ С КЛАССАМИ (ИНТ.КРИТ. - РЕЗОНАНС ЗНАНИЙ):" ?"КОДЫ И НАИМЕНОВАНИЯ ФАЙЛОВ КЛАССОВ И ИХ СОДЕРЖИМОЕ." ?"КОДЫ И НАИМЕНОВАНИЯ ФАЙЛОВ ОБЪЕКТОВ РАСПОЗНАВАЕМОЙ ВЫБОРКИ И ИХ СОДЕРЖИМОЕ." ?'Показаны объекты распознаваемой выборки с уровнями сходства с классом => '+ALLTRIM(STR(mPorog)) SELECT Rsp2kT DBGOTOP() DO WHILE .NOT. EOF() IF Type = 'Classes' ?'' ?REPLICATE('=',80) ?'КОД КЛАССА: '+ALLTRIM(STR(Kod))+' НАИМЕНОВАНИЕ ФАЙЛА КЛАССА: '+ALLTRIM(File_name) ?'СОДЕРЖИМОЕ ФАЙЛА:' ?ALLTRIM(TextALL) ?REPLICATE('~',80) ENDIF IF Type = 'KobjUrSx' ?'КОДЫ РАСПОЗНАВАЕМЫХ ОБЪЕКТОВ (УРОВНИ СХОДСТВА РАСПОЗНАВАЕМЫХ ОБЪЕКТОВ С КЛАССОМ):' ?ALLTRIM(TextALL) ?REPLICATE('=',80) ENDIF IF Type = 'Object' DO WHILE .NOT. EOF() .AND. Type = 'Object' ?'Сходства объекта с классом: '+ALLTRIM(STR(Urov_sxod,5,1))+'. Код объекта: '+ALLTRIM(STR(Kod))+'. Имя файла объекта:'+ALLTRIM(File_name) ?'Содержимое файла:' ?ALLTRIM(TextALL) ?REPLICATE('~',80) DBSKIP(1) ENDDO ENDIF DBSKIP(1) ENDDO ?REPLICATE('=',80) Set device to screen Set printer off Set printer to Set console on ************************************** SELECT Rsp2im DBGOTOP() DO WHILE .NOT. EOF() mKodCls = Kod_cls mNameCls = ALLTRIM(aFileNameClsL[mKodCls]) // Сформировать имя файла mTextCls = ALLTRIM(FILESTR(Disk_dir+'\AID_DATA\Inp_data\'+aFileNameCls[mKodCls])) // Загрузка файла объекта обучающей выборки mKodObjs = Kod_objs mUrSxods = Urov_sxods mKobjUrSx= Kobj_UrSx SELECT Rsp2iT APPEND BLANK APPEND BLANK REPLACE Kod WITH mKodCls REPLACE File_name WITH mNameCls REPLACE Text WITH mTextCls REPLACE TextALL WITH mTextCls REPLACE Type WITH 'Classes' APPEND BLANK REPLACE File_name WITH mKobjUrSx REPLACE TextALL WITH mKobjUrSx REPLACE Type WITH 'KobjUrSx' aKodOrv := {} // Коды объектов распознаваемой выборки aUrSxod := {} // Уровни сходства объектов расп.выборки с классом mKodCls FOR j=1 TO NUMTOKEN(mKodObjs, ' ') AADD(aKodOrv, VAL(TOKEN(mKodObjs, ' ', j))) AADD(aUrSxod, VAL(TOKEN(mUrSxods, ' ', j))) NEXT IF LEN(aKodOrv) > 0 FOR j=1 TO LEN(aKodOrv) SELECT Rso_Zag DBGOTO(aKodOrv[j]) mNameObj = ALLTRIM(aFileNameObjL[aKodOrv[j]]) mTextObj = ALLTRIM(FILESTR(Disk_dir+'\AID_DATA\Inp_rasp\'+aFileNameObj[aKodOrv[j]])) // Загрузка файла объекта распознаваемой выборки SELECT Rsp2iT APPEND BLANK REPLACE Kod WITH aKodOrv[j] REPLACE File_name WITH mNameObj REPLACE Text WITH SUBSTR(mTextObj,1,255) REPLACE TextALL WITH mTextObj REPLACE Urov_sxod WITH aUrSxod[j] REPLACE Type WITH 'Object' NEXT ENDIF SELECT Rsp2im DBSKIP(1) ENDDO ****** ПЕЧАТЬ ТЕКСТОВОГО ФАЙЛА ******* set device to printer set printer on set printer to ("Rsp2iT.txt") set console off ?"РЕЗУЛЬТАТЫ ИДЕНТИФИКАЦИИ ОБЪЕКТОВ С КЛАССАМИ (ИНТ.КРИТ. - СУММА ЗНАНИЙ):" ?"КОДЫ И НАИМЕНОВАНИЯ ФАЙЛОВ КЛАССОВ И ИХ СОДЕРЖИМОЕ." ?"КОДЫ И НАИМЕНОВАНИЯ ФАЙЛОВ ОБЪЕКТОВ РАСПОЗНАВАЕМОЙ ВЫБОРКИ И ИХ СОДЕРЖИМОЕ." ?'Показаны объекты распознаваемой выборки с уровнями сходства с классом => '+ALLTRIM(STR(mPorog)) SELECT Rsp2iT DBGOTOP() DO WHILE .NOT. EOF() IF Type = 'Classes' ?'' ?REPLICATE('=',80) ?'КОД КЛАССА: '+ALLTRIM(STR(Kod))+' НАИМЕНОВАНИЕ ФАЙЛА КЛАССА: '+ALLTRIM(File_name) ?'СОДЕРЖИМОЕ ФАЙЛА:' ?ALLTRIM(TextALL) ?REPLICATE('~',80) ENDIF IF Type = 'KobjUrSx' ?'КОДЫ РАСПОЗНАВАЕМЫХ ОБЪЕКТОВ (УРОВНИ СХОДСТВА РАСПОЗНАВАЕМЫХ ОБЪЕКТОВ С КЛАССОМ):' ?ALLTRIM(TextALL) ?REPLICATE('=',80) ENDIF IF Type = 'Object' DO WHILE .NOT. EOF() .AND. Type = 'Object' ?'Сходства объекта с классом: '+ALLTRIM(STR(Urov_sxod,5,1))+'. Код объекта: '+ALLTRIM(STR(Kod))+'. Имя файла объекта:'+ALLTRIM(File_name) ?'Содержимое файла:' ?ALLTRIM(TextALL) ?REPLICATE('~',80) DBSKIP(1) ENDDO ENDIF DBSKIP(1) ENDDO ?REPLICATE('=',80) Set device to screen Set printer off Set printer to Set console on ENDIF ENDIF ***** Еще вывести такие же формы (только коды и с текстами) по неидентифицрованным ссылкам ***** (нераспознанным объектам, т.е. у которых уровень сходства < mPorog) ################ SELECT UnidentObj DELETE FOR Type = 'IdentObject' PACK ****** ПЕЧАТЬ ТЕКСТОВОГО ФАЙЛА ******* set device to printer set printer on set printer to ("UnidentObj.txt") set console off ?"ОТЧЕТ ПО НЕИДЕНТИФИЦИРОВАННЫМ ОБЪЕКТАМ РАСПОЗНАВАЕМОЙ ВЫБОРКИ, Т.Е.ТЕМ, У КОТОРЫХ" ?"УРОВЕНЬ СХОДСТВА С КЛАССАМИ ОКАЗАЛСЯ НИЖЕ ЗАДАННОГО ПОРОГА: < "+ALLTRIM(STR(mPorog)) ?"ПРИВЕДЕНЫ КОДЫ И НАИМЕНОВАНИЯ ФАЙЛОВ ОБЪЕКТОВ РАСПОЗНАВАЕМОЙ ВЫБОРКИ И ИХ СОДЕРЖИМОЕ." ?'' SELECT UnidentObj DBGOTOP() DO WHILE .NOT. EOF() DO WHILE .NOT. EOF() ?'Код объекта: '+ALLTRIM(STR(Kod))+'. Имя файла объекта:'+ALLTRIM(File_name) ?'Содержимое файла:' ?ALLTRIM(TextALL) ?REPLICATE('~',80) DBSKIP(1) ENDDO DBSKIP(1) ENDDO ?REPLICATE('=',80) Set device to screen Set printer off Set printer to Set console on ************************************************************************** DC_Impl(oScrn) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes INDEX Classes EXCLUSIVE *SET FILTER TO Int_inf+Abs > 0 DBGOTOP();DBGOBOTTOM();DBGOTOP() USE Rsp2k INDEX Rsp2k EXCLUSIVE NEW USE Rsp2i INDEX Rsp2i EXCLUSIVE NEW aMess := {} AADD(aMess, L('РАСЧЕТ ЗАВЕРШЕН УСПЕШНО! ВЫХОДНЫЕ ФОРМЫ НАХОДЯТСЯ В ФАЙЛАХ:')) AADD(aMess, L(' ')) AADD(aMess, L(' ')) AADD(aMess, M_PathAppl+L('\Rsp2km.dbf - форма с именами файлов и кодами распозн.объектов (инт.крит. - резонанс знаний)') ) AADD(aMess, M_PathAppl+L('\Rsp2im.dbf - форма с именами файлов и кодами распозн.объектов (инт.крит. - сумма знаний)') ) AADD(aMess, M_PathAppl+L('\Rsp2kT.dbf - форма с содержимым файлов и распознаваемых объектов (инт.крит. - резонанс знаний)')) AADD(aMess, M_PathAppl+L('\Rsp2iT.dbf - форма с содержимым файлов и распознаваемых объектов (инт.крит. - сумма знаний)') ) AADD(aMess, M_PathAppl+L('\UnidentObj.dbf - форма с информацией по неидентифицированным объектам распознаваемой выборки') ) AADD(aMess, L(' ')) AADD(aMess, L('Все эти базы данных открываются в MS Excel')) AADD(aMess, L('В них есть ограничение на максимальный размер поля: 255 символов.')) AADD(aMess, L(' ')) AADD(aMess, L(' ')) AADD(aMess, M_PathAppl+L('\Rsp2km.txt - форма с именами файлов и кодами распозн.объектов (инт.крит. - резонанс знаний)') ) AADD(aMess, M_PathAppl+L('\Rsp2im.txt - форма с именами файлов и кодами распозн.объектов (инт.крит. - сумма знаний)') ) AADD(aMess, M_PathAppl+L('\Rsp2kT.txt - форма с содержимым файлов и распознаваемых объектов (инт.крит. - резонанс знаний)')) AADD(aMess, M_PathAppl+L('\Rsp2iT.txt - форма с содержимым файлов и распознаваемых объектов (инт.крит. - сумма знаний)') ) AADD(aMess, M_PathAppl+L('\UnidentObj.txt - форма с информацией по неидентифицированным объектам распознаваемой выборки') ) AADD(aMess, L(' ')) AADD(aMess, L('Все эти базы данных открываются в MS Word')) AADD(aMess, L('В текстовых выходных формах ограничения на размер текста отсутствуют.')) AADD(aMess, L('Текстовые выходные формы в DOS-кодировке.')) LB_Warning(aMess, L('(c) Система "ЭЙДОС-X++"')) RETURN NIL *********************************************************************************************** ******** 3.4. Автоматическое выполнение режимов 1-2-3, "Синтез модели с нуля" ######### ******** По очереди исполняются режимы: 3.1., 3.2. и 3.3. для заданных моделей баз знаний ******** и затем заданная делается текущей' ######### *********************************************************************************************** *FUNCTION F3_4old( Dialog, TP, Ws, oP, lO, Regim ) *Running(.T.) *PUBLIC Time_progress, Wsego, oProgress, lOk := .T., Sec_1 *IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации * LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) * Running(.F.) * RETURN NIL *ENDIF *IF Dialog * IF ApplChange("3.4()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения * ************************************************************** * ***** БД, открытые перед запуском главного меню * ***** Восстанавливать их после выхода из функций главного меню * ************************************************************** * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы * USE PathGrAp EXCLUSIVE NEW * USE Appls EXCLUSIVE NEW * USE Users EXCLUSIVE NEW * ************************************************************** * Running(.F.) * RETURN NIL * ENDIF *ELSE * IF ApplChange("") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения * PUBLIC aSaveMainM := DC_ARestore("_SaveMainM.arx") // Восстановление вычислительной среды (открытые и текущие БД и индексы) с диска * DC_DataRest( aSaveMainM ) // Восстановление вычислительной среды (открытые и текущие БД и индексы) * Running(.F.) * RETURN NIL * ENDIF *ENDIF *// Организовать отображение стадии процесса и прогноз времени исполнения ******* Задание на расчет баз знаний *IF FILE("_CalcInf.arx") // Файл с информацией о том, какие модели были рассчитаны ранее * aCalcInf = DC_ARestore("_CalcInf.arx") *ELSE * AFILL(aCalcInf, .T.) * DC_ASave(aCalcInf, "_CalcInf.arx") *ENDIF *IF FILE("_CurrInf.arx") // Файл с информацией о том, какая модель задана текущей * M_CurrInf = DC_ARestore("_CurrInf.arx") *ELSE * DC_ASave(M_CurrInf, "_CurrInf.arx") *ENDIF ******* Задание моделей знаний для расчета и задание текущей модели *@ 0, 0 DCGROUP oGroup1 CAPTION L('Задайте, какие базы знаний рассчитывать') SIZE 68 ,8.5 *@ 0,70 DCGROUP oGroup2 CAPTION L('Задайте текущую базу знаний' ) SIZE 28 ,8.5 *@10, 0 DCGROUP oGroup3 CAPTION L('Как задавать параметры синтеза моделей' ) SIZE 98.5,6 *@ 1, 3 DCCHECKBOX aCalcInf[ 4] PROMPT L('INF1 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC1') PARENT oGroup1 *@ 2, 3 DCCHECKBOX aCalcInf[ 5] PROMPT L('INF2 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC2') PARENT oGroup1 *@ 3, 3 DCCHECKBOX aCalcInf[ 6] PROMPT L('INF3 - частный критерий: Xи-квадрат, разности между факт.и ожид.абс.частотами ') PARENT oGroup1 *@ 4, 3 DCCHECKBOX aCalcInf[ 7] PROMPT L('INF4 - частный критерий: ROI (Return On Investment); вероятности из PRC1 ') PARENT oGroup1 *@ 5, 3 DCCHECKBOX aCalcInf[ 8] PROMPT L('INF5 - частный критерий: ROI (Return On Investment); вероятности из PRC2 ') PARENT oGroup1 *@ 6, 3 DCCHECKBOX aCalcInf[ 9] PROMPT L('INF6 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC1 ') PARENT oGroup1 *@ 7, 3 DCCHECKBOX aCalcInf[10] PROMPT L('INF7 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC2 ') PARENT oGroup1 *@ 1, 3 DCRADIO M_CurrInf VALUE 4 PROMPT L('INF1') PARENT oGroup2 EDITPROTECT {|| .NOT. aCalcInf[ 4] } HIDE {|| .NOT. aCalcInf[ 4] } *@ 2, 3 DCRADIO M_CurrInf VALUE 5 PROMPT L('INF2') PARENT oGroup2 EDITPROTECT {|| .NOT. aCalcInf[ 5] } HIDE {|| .NOT. aCalcInf[ 5] } *@ 3, 3 DCRADIO M_CurrInf VALUE 6 PROMPT L('INF3') PARENT oGroup2 EDITPROTECT {|| .NOT. aCalcInf[ 6] } HIDE {|| .NOT. aCalcInf[ 6] } *@ 4, 3 DCRADIO M_CurrInf VALUE 7 PROMPT L('INF4') PARENT oGroup2 EDITPROTECT {|| .NOT. aCalcInf[ 7] } HIDE {|| .NOT. aCalcInf[ 7] } *@ 5, 3 DCRADIO M_CurrInf VALUE 8 PROMPT L('INF5') PARENT oGroup2 EDITPROTECT {|| .NOT. aCalcInf[ 8] } HIDE {|| .NOT. aCalcInf[ 8] } *@ 6, 3 DCRADIO M_CurrInf VALUE 9 PROMPT L('INF6') PARENT oGroup2 EDITPROTECT {|| .NOT. aCalcInf[ 9] } HIDE {|| .NOT. aCalcInf[ 9] } *@ 7, 3 DCRADIO M_CurrInf VALUE 10 PROMPT L('INF7') PARENT oGroup2 EDITPROTECT {|| .NOT. aCalcInf[10] } HIDE {|| .NOT. aCalcInf[10] } *@ 8.7, 0 DCPUSHBUTTON ; * CAPTION L('Вид частных критериев 7 моделей знаний') ; * SIZE LEN(L('Вид частных критериев 7 моделей знаний')), 1 ; * ACTION {||Help33()} *@ 1, 3 DCSAY L('Задайте, какие базы знаний рассчитывать. Рекомендуется задать все, если это приемлемо по длительности расчетов. Затем') PARENT oGroup3 *@ 2, 3 DCSAY L('задайте одну из моделей знаний, которая будет текущей после завершения синтеза моделей. В качестве текущей можно вы-') PARENT oGroup3 *@ 3, 3 DCSAY L('брать только одну из баз знаний, которые заданы для расчета. До исследования достоверности моделей в режиме 3.5 реко-') PARENT oGroup3 *@ 4, 3 DCSAY L('мендуется задавать для расчета и делать текущей базу знаний INF1. Подробнее смысл моделей знаний, применяемых в сис-') PARENT oGroup3 *@ 5, 3 DCSAY L('теме "Эйдос-Х++", раскрыт в режиме 6.4. и публикациях, размещенных по адресу: http://www.twirpx.com/file/793311/ ') PARENT oGroup3 *DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE *DCREAD GUI ; * TO lExit ; * FIT ; * ADDBUTTONS; * OPTIONS GetOptions ; * MODAL ; * TITLE L('3.4. Задание баз знаний для расчета и работы (текущей)') ******************************************************************** * 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(aCalcInf , "_CalcInf.arx") // Файл с информацией о том, создание каких моделей было задано *DC_ASave(M_CurrInf, "_CurrInf.arx") // Файл с информацией о том, какая модель задана текущей ***** Проверка диалога **FOR j=1 TO LEN(aCalcInf) ** IF aCalcInf[j] ** LB_Warning(L("Задан Расчет модели знаний: ")+ALLTRIM(STR(j,19))) ** ELSE ** LB_Warning(L("Расчет модели знаний: ")+ALLTRIM(STR(j,19))+L(" не задан")) ** ENDIF **NEXT **LB_Warning(L("Текущей задана модель: ")+STR(M_CurrInf,19)) *IF ASCAN(aCalcInf, .T.) = 0 * LB_Warning(L("Необходимо задать хотя бы одну модель знаний для расчета !")) * Running(.F.) * RETURN NIL *ENDIF *IF M_CurrInf = 0 * LB_Warning(L("Необходимо задать хотя бы одну модель знаний в качестве текущей !")) * Running(.F.) * RETURN NIL *ELSE * IF aCalcInf[M_CurrInf] = .F. * LB_Warning(L("Модель знаний, заданная в качестве текущей, должна быть задана и для расчета !")) * Running(.F.) * RETURN NIL * ENDIF *ENDIF ***************************************************************************************************** *CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций *USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() *USE Gr_OpSc EXCLUSIVE NEW;N_Gos = RECCOUNT() *USE Obi_Zag EXCLUSIVE NEW;N_Obj = RECCOUNT() ***************************************************************************************************** // Подготовка данных для отображения графического прогресс-бар // Определить значение Wsego // Задание максимальной величины параметра Time * Wsego_Abs = N_Obj + 3*N_Cls +2*N_Gos // Задание максимальной величины параметра Time * Wsego_Prc = N_Gos // Задание максимальной величины параметра Time // Задание максимальной величины параметра Time * Wsego_Inf = IF(aCalcInf[ 4],N_Gos,0)+; // Расчет и дорасчет модели * IF(aCalcInf[ 5],N_Gos,0)+; * IF(aCalcInf[ 6],N_Gos,0)+; * IF(aCalcInf[ 7],N_Gos,0)+; * IF(aCalcInf[ 8],N_Gos,0)+; * IF(aCalcInf[ 9],N_Gos,0)+; * IF(aCalcInf[10],N_Gos,0) * Wsego = Wsego_Abs + Wsego_Prc + Wsego_Inf // Отображение стадии исполнения. Будет написано прямо в окне Progress-bar * @ 0,0 DCGROUP oGroup1 CAPTION L('Стадии исполнения процесса') FONT "6.Helv" SIZE 105,14.5 ; * PARENT oTabPage1 * @16,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" // Abs.dbf * @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 2] FONT "10.Helv" // Prc1.dbf, Prc2.dbf * @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 3] FONT "10.Helv" // БЗ-1 - Inf1~Prc1 1 * @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 4] FONT "10.Helv" // БЗ-2 - Inf2~Prc2 2 * @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 5] FONT "10.Helv" // БЗ-3 - Inf3-хи-квадрат 3 * @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 6] FONT "10.Helv" // БЗ-4 - Inf4-roi~Prc1 4 * @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 7] FONT "10.Helv" // БЗ-5 - Inf5-roi~Prc2 5 * @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 8] FONT "10.Helv" // БЗ-6 - Inf6-Dp~Prc1 6 * @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 9] FONT "10.Helv" // БЗ-7 - Inf7-Dp~Prc2 7 * @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[10] FONT "10.Helv" // 8 * @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[11] FONT "10.Helv" // 8 * @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[12] FONT "10.Helv" // 8 * @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[13] FONT "10.Helv" // 8 * 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('3.4. Расчет стат.моделей: Abs.dbf, Prc1.dbf, Prc2.dbf и заданных моделей знаний: Inf1-Inf7') ; * 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[ 2]:SetCaption(L('ШАГ 1-Й ИЗ 3: СИНТЕЗ СТАТ.МОДЕЛИ "ABS" (РАСЧЕТ МАТРИЦЫ АБСОЛЮТНЫХ ЧАСТОТ) - ИСПОЛНЕНИЕ:')) *Time_Progress = F3_1(.F., Time_Progress, Wsego, oProgress, lOk, "3_4" ) // Расчет Abs.dbf *aSay[ 2]:SetCaption(L('Шаг 1-й из 3: Синтез стат.модели "ABS" (расчет матрицы абсолютных частот) - Готово')) *FOR j=3 TO 13;aSay[j]:SetCaption(L(" "));NEXT *aSay[ 3]:SetCaption(L('ШАГ 2-Й ИЗ 3: СИНТЕЗ СТАТ.МОДЕЛЕЙ "PRC1" И "PRC2" (УСЛ.И БЕЗУСЛ.% РАСПР.) - ИСПОЛНЕНИЕ:')) *Time_Progress = F3_2(.F., Time_Progress, Wsego, oProgress, lOk, "3_4" ) // Расчет Prc1.dbf b Prc2.dbf *aSay[ 3]:SetCaption(L('Шаг 2-й из 3: Синтез стат.моделей "PRC1" и "PRC2" (усл.и безусл.% распр.) - Готово')) *Flag_Inf = .F. // Определить, задана хотя бы одна модель знаний для расчета *FOR j=4 TO 10 * IF aCalcInf[j] * Flag_Inf = .T. * EXIT * ENDIF *NEXT *IF Flag_Inf * FOR j=4 TO 13;aSay[j]:SetCaption(L(" "));NEXT * aSay[ 4]:SetCaption(L('ШАГ 3-Й ИЗ 3: СИНТЕЗ МОДЕЛЕЙ ЗНАНИЙ: INF1-INF7 - ИСПОЛНЕНИЕ:')) * Time_Progress = F3_3(.F., Time_Progress, Wsego, oProgress, lOk, "3_4" ) // Расчет баз знаний Inf1.dbf, Inf2.dbf, Inf3.dbf, Inf4.dbf, Inf5.dbf, Inf6.dbf, Inf7.dbf ** Time_Progress = F3_3(.F., Time_Progress, Wsego, oProgress, lOk, "3_5" ) // Расчет баз знаний Inf1.dbf, Inf2.dbf, Inf3.dbf, Inf4.dbf, Inf5.dbf, Inf6.dbf, Inf7.dbf * FOR j=5 TO 13;aSay[j]:SetCaption(L(" "));NEXT * aSay[ 4]:SetCaption(L('Шаг 3-й из 3: Синтез моделей знаний: INF1-INF7 - Готово')) *ENDIF ***************************************************************************************************** *Running(.T.) // Чтобы не могли запустить какой-нибудь режим пока висит окно окончания работы *oSay97:SetCaption(L("РАСЧЕТ СТАТИСТИЧЕСКИХ МОДЕЛЕЙ И МОДЕЛЕЙ ЗНАНИЙ СИCТЕМЫ ЭЙДОС-X++ ЗАВЕРШЕН !")) *oSay97:SetCaption(oSay97:caption) *oButton:SetCaption(L('&Ok')) // Деструктурирование окна отображения графического Progress-bar *oButton:activate := {||PostAppEvent(xbeP_Close,,,oDialog)} //<<<<<< Add This *DC_AppEvent( @lOk ) *oDialog:Destroy() * ************************************************************** * ***** БД, открытые перед запуском главного меню * ***** Восстанавливать их после выхода из функций главного меню * ************************************************************** * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы * USE PathGrAp EXCLUSIVE NEW * USE Appls EXCLUSIVE NEW * USE Users EXCLUSIVE NEW * ************************************************************** *Running(.F.) *RETURN NIL *************************************************************** ******** Расчет моделей 2-го и 3-го уровней ******************* *************************************************************** FUNCTION Calc_model_2nd_level(mModel, nRadioModel, nRadModelCr) StrFile(ALLTRIM(STR(nRadioModel)), '_Calc_model_2nd_level.txt') * mModel_2nd_level = VAL(FileStr('_Calc_model_2nd_level.txt')) // = 1 - создавать только базовые модели, иначе - создавать модели 2-го или 3-го уровней * DC_ASave(aModFullNm, "_aModFullNm.arx") // Наименования создаваемых моделей для режима 3.4 aModFullNm = DC_ARestore("_aModFullNm.arx") * aParModel := {} * AADD(aParModel, nRadioModel) * AADD(aParModel, nRadModelCr) * DC_ASave(aParModel, "_ParModel.arx") ** aParModel := DC_ARestore("_ParModel.arx") IF nRadioModel = 1 // Не создавать модели 2-го и 3-го уровней, т.е. создавать только базовые модели * // Полные наименования стат.моделей и моделей знаний * aModFullNm := {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 ') } * DC_ASave(aModFullNm, "_aModFullNm.arx") // Наименования создаваемых моделей для режима 3.4 * aModFullNm = DC_ARestore("_aModFullNm.arx") RETURN NIL ENDIF * ########################################################################### // Открытие текстовых баз данных ******************************************** DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения * ****** Задание на создание базовых моделей, а также моделей 2-го и 3-го уровней ******************* * CrLf = CHR(13)+CHR(10) ** @ 0, 89 DCGROUP oGroup8 CAPTION L('Какие модели создавать?') SIZE WindowWidth,17.7 * s=1;d=0.85 * nRadioModel = 1 * @s, 2 DCRADIO nRadioModel VALUE 1 PROMPT L('Создавать только базовые модели') PARENT oGroup8;s=s+d * @s, 2 DCRADIO nRadioModel VALUE 2 PROMPT L('Создавать модели 2-го уровня ') PARENT oGroup8;s=s+d // <<<===############### пока ничего вразумительного с моделями 2-го уровня не получилось * @s, 2 DCRADIO nRadioModel VALUE 3 PROMPT L('Создавать модели 3-го уровня ') PARENT oGroup8;s=s+d * nRadModelCr = 1 * @ 3.7, 2 DCGROUP oGroup13 CAPTION L('') SIZE WindowWidth-1,13.3 PARENT oGroup8 HIDE {|| .NOT.nRadioModel=1} // <<<===############### * s=1.0;d=1.00 * @s, 1 DCSAY L('Базовые модели - это модели: Prc1,Prc2,Inf1,Inf2,Inf3,') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=1 } HIDE {|| .NOT.nRadioModel=1};s=s+d * @s, 1 DCSAY L('Inf4,Inf5,Inf6, Inf7 полученные расчетным путем по ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=1 } HIDE {|| .NOT.nRadioModel=1};s=s+d * @s, 1 DCSAY L('формулам, приведенным в хелпе режима 5.5 на основе ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=1 } HIDE {|| .NOT.nRadioModel=1};s=s+d * @s, 1 DCSAY L('модели Abs. ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=1 } HIDE {|| .NOT.nRadioModel=1};s=s+d*1.5 * @s, 1 DCSAY L('Модель Abs называется матрицей абсолютных часот и ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=1 } HIDE {|| .NOT.nRadioModel=1};s=s+d * @s, 1 DCSAY L('содержит абсолютное количество встреч сочетаний ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=1 } HIDE {|| .NOT.nRadioModel=1};s=s+d * @s, 1 DCSAY L('"признак x класс", посчитанное по всей выборке. ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=1 } HIDE {|| .NOT.nRadioModel=1};s=s+d*1.5 * @s, 1 DCSAY L('Модель Abs еще называют "матрицей сопряженности" ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=1 } HIDE {|| .NOT.nRadioModel=1};s=s+d * @s, 1 DCSAY L('или "корреляционной матрицей". Формы по достовер- ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=1 } HIDE {|| .NOT.nRadioModel=1};s=s+d * @s, 1 DCSAY L('ностяи моделей формируются в режиме 3.4. ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=1 } HIDE {|| .NOT.nRadioModel=1};s=s+d * nRadModelCr = 1 * @ 3.7, 2 DCGROUP oGroup13 CAPTION L('') SIZE WindowWidth-1,13.3 PARENT oGroup8 HIDE {|| .NOT.nRadioModel=2} // <<<===############### * s=0.7;d=0.80 * @s, 1 DCSAY L('Модели 2-го уровня - это модели: Prc1,Prc2,Inf1,Inf2,') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=2 } HIDE {|| .NOT.nRadioModel=2};s=s+d * @s, 1 DCSAY L('Inf3,Inf4,Inf5,Inf6,Inf7, созданные на основе модели ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=2 } HIDE {|| .NOT.nRadioModel=2};s=s+d * @s, 1 DCSAY L('Abs путем расчета по формулам, приведенным в хелпе ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=2 } HIDE {|| .NOT.nRadioModel=2};s=s+d * @s, 1 DCSAY L('режима 5.5. Причем модель Abs сначала преобразована ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=2 } HIDE {|| .NOT.nRadioModel=2};s=s+d * @s, 1 DCSAY L('путем сравнения весов признаков с их дисперсией или ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=2 } HIDE {|| .NOT.nRadioModel=2};s=s+d * @s, 1 DCSAY L('средним модулем отклонения от среднего, причем для ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=2 } HIDE {|| .NOT.nRadioModel=2};s=s+d * @s, 1 DCSAY L('сравнения используется вычитание или деление. Затем ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=2 } HIDE {|| .NOT.nRadioModel=2};s=s+d * @s, 1 DCSAY L('находится минимальный вес и вычитается из всех весов.') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=2 } HIDE {|| .NOT.nRadioModel=2};s=s+d * @s, 1 DCSAY L('Задайте вариант расчета моделей 2-го уровня: ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=2 } HIDE {|| .NOT.nRadioModel=2};s=s+d * @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 * nRadModelCr = 1 * @ 3.7, 2 DCGROUP oGroup13 CAPTION L('') SIZE WindowWidth-1,13.3 PARENT oGroup8 HIDE {|| .NOT.nRadioModel=3} // <<<===############### * s=0.7;d=0.80 * @s, 1 DCSAY L('Модели 3-го уровня - это модели: Prc1,Prc2,Inf1,Inf2,') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=3 } HIDE {|| .NOT.nRadioModel=3};s=s+d * @s, 1 DCSAY L('Inf3,Inf4,Inf5,Inf6,Inf7, созданные на основе базовой') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=3 } HIDE {|| .NOT.nRadioModel=3};s=s+d * @s, 1 DCSAY L('модели Abs путем расчета по формулам, приведенным ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=3 } HIDE {|| .NOT.nRadioModel=3};s=s+d * @s, 1 DCSAY L('в хелпе режима 5.5. Затем все модели преобразованы ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=3 } HIDE {|| .NOT.nRadioModel=3};s=s+d * @s, 1 DCSAY L('путем сравнения весов признаков (значений градаций ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=3 } HIDE {|| .NOT.nRadioModel=3};s=s+d * @s, 1 DCSAY L('описательных шкал) с их дисперсией или с средним ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=3 } HIDE {|| .NOT.nRadioModel=3};s=s+d * @s, 1 DCSAY L('модулем отклонения от среднего, причем для самого ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=3 } HIDE {|| .NOT.nRadioModel=3};s=s+d * @s, 1 DCSAY L('сравнения используется вычитание или деление. ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=3 } HIDE {|| .NOT.nRadioModel=3};s=s+d * @s, 1 DCSAY L('Задайте вариант расчета моделей 3-го уровня: ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=3 } HIDE {|| .NOT.nRadioModel=3};s=s+d * @s, 2 DCRADIO nRadModelCr VALUE 1 PROMPT L('дисперсия, сравнение путем вычитания ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=3 } HIDE {|| .NOT.nRadioModel=3};s=s+d * @s, 2 DCRADIO nRadModelCr VALUE 2 PROMPT L('дисперсия, сравнение путем деления ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=3 } HIDE {|| .NOT.nRadioModel=3};s=s+d * @s, 2 DCRADIO nRadModelCr VALUE 3 PROMPT L('среднее, сравнение путем вычитания ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=3 } HIDE {|| .NOT.nRadioModel=3};s=s+d * @s, 2 DCRADIO nRadModelCr VALUE 4 PROMPT L('среднее, сравнение путем деления ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=3 } HIDE {|| .NOT.nRadioModel=3};s=s+d * @s, 2 DCRADIO nRadModelCr VALUE 5 PROMPT L('средн.модуль отклон.от средн., сравн.путем вычит. ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=3 } HIDE {|| .NOT.nRadioModel=3};s=s+d * @s, 2 DCRADIO nRadModelCr VALUE 6 PROMPT L('средн.модуль отклон.от средн., сравн.путем делен. ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=3 } HIDE {|| .NOT.nRadioModel=3};s=s+d ******* Посчитать и записать сумму и среднее новых значений по колонкам **** PRIVATE Ar_SummaObj[3+N_Cls] // Строка "Сумма числа объектов по классам" AFILL(Ar_SummaObj,0) Summa_Obj = 0 // Сумма Obj по всей БД Abs.txt Summa_Nij = 0 // Сумма Nij по всей БД Abs.txt PRIVATE Ar_Summ_i[N_Gos], Ar_Summ_j[N_Cls+6] // N_Cls + 1-коды, 2-наименования, 3-Summ, 4-Sred, 5-Disp, 6-средн.модулей отклонения от средн. PRIVATE Ar_Sred_i[N_Gos], Ar_Sred_j[N_Cls+6] PRIVATE Ar_Disp_i[N_Gos], Ar_Disp_j[N_Cls+6] PRIVATE Ar_ADMA_i[N_Gos] AFILL(Ar_Summ_i, 0) AFILL(Ar_Summ_j, 0) AFILL(Ar_Sred_i, 0) AFILL(Ar_Sred_j, 0) AFILL(Ar_Disp_i, 0) AFILL(Ar_Disp_j, 0) AFILL(Ar_ADMA_i, 0) mMin_Iij = +99999999999 mMax_Iij = -99999999999 DO CASE CASE nRadModelCr = 1 // дисперсия, сравнение путем вычитания oScr := DC_WaitOn(L('Идет расчет модели')+' '+ALLTRIM(STR(nRadioModel))+' '+L('-го уровня:')+' '+ALLTRIM(STR(mModel))+'/10-'+Ar_Model[mModel]+' '+L('"Дисперсия, сравнение путем вычитания". Немного подождите!'),,,,,,,,,,,.F.) * // Полные наименования стат.моделей и моделей знаний * aModFullNm := {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 ') } Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } FOR i=1 TO N_Gos // Цикл по строкам Disp_i = VAL(LC_FieldGet( Ar_Model[mModel]+".txt", nHandle[mModel], i, 2+N_Cls+3 )) For j=1 TO N_Cls // Цикл по колонкам String = STR(VAL(LC_FieldGet( Ar_Model[mModel]+".txt", nHandle[mModel], i, 2+j ))-Disp_i, 19, 7) Flag_err = LC_FieldPut( Ar_Model[mModel]+".txt", nHandle[mModel], i, 2+j, String ) * MsgBox('Строка='+ALLTRIM(STR(i))+', '+'Столбец='+ALLTRIM(STR(j))+', Значение='+ALLTRIM(String)+', '+IF(Flag_err,'Ошибка записи в БД','Записано нормально')) mValString = VAL(String) Ar_Summ_i[i] = Ar_Summ_i[i] + mValString Ar_Summ_j[j] = Ar_Summ_j[j] + mValString mMin_Iij = MIN(mMin_Iij, mValString) mMax_Iij = MAX(mMax_Iij, mValString) NEXT NEXT CASE nRadModelCr = 2 // дисперсия, сравнение путем деления oScr := DC_WaitOn(L('Идет расчет модели')+' '+ALLTRIM(STR(nRadioModel))+' '+L('-го уровня:')+' '+ALLTRIM(STR(mModel))+'/10-'+Ar_Model[mModel]+' '+L('"Дисперсия, сравнение путем деления". Немного подождите!'),,,,,,,,,,,.F.) // Полные наименования стат.моделей и моделей знаний * aModFullNm := {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 ') } Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } * IF Nij*Ni*Njo*Nobj <> 0 * Iij = LOG((Nij*Nobj)/(Ni*Njo))/LOG(2) * ENDIF FOR i=1 TO N_Gos // Цикл по строкам Disp_i = VAL(LC_FieldGet( Ar_Model[mModel]+".txt", nHandle[mModel], i, 2+N_Cls+3 )) IF Disp_i <> 0 For j=1 TO N_Cls // Цикл по колонкам * DC_DebugQout( LC_FieldGet( Ar_Model[mModel]+".txt", nHandle[mModel], i, 2+j )) String = STR(VAL(LC_FieldGet( Ar_Model[mModel]+".txt", nHandle[mModel], i, 2+j ))/Disp_i - 1, 19, 7) Flag_err = LC_FieldPut( Ar_Model[mModel]+".txt", nHandle[mModel], i, 2+j, String ) * MsgBox(LC_FieldGet( Ar_Model[mModel]+".txt", nHandle[mModel], i, 2+j )) * MsgBox('Строка='+ALLTRIM(STR(i))+', '+'Столбец='+ALLTRIM(STR(j))+', Значение='+ALLTRIM(String)+', '+IF(Flag_err,'Ошибка записи в БД','Записано нормально')) mValString = VAL(String) Ar_Summ_i[i] = Ar_Summ_i[i] + mValString Ar_Summ_j[j] = Ar_Summ_j[j] + mValString mMin_Iij = MIN(mMin_Iij, mValString) mMax_Iij = MAX(mMax_Iij, mValString) NEXT ENDIF NEXT CASE nRadModelCr = 3 // среднее, сравнение путем вычитания oScr := DC_WaitOn(L('Идет расчет модели')+' '+ALLTRIM(STR(nRadioModel))+' '+L('-го уровня:')+' '+ALLTRIM(STR(mModel))+'/10-'+Ar_Model[mModel]+' '+L('"Среднее, сравнение путем вычитания". Немного подождите!'),,,,,,,,,,,.F.) // Полные наименования стат.моделей и моделей знаний * aModFullNm := {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 ') } Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } FOR i=1 TO N_Gos // Цикл по строкам Sred_i = VAL(LC_FieldGet( Ar_Model[mModel]+".txt", nHandle[mModel], i, 2+N_Cls+2 )) For j=1 TO N_Cls // Цикл по колонкам String = STR(VAL(LC_FieldGet( Ar_Model[mModel]+".txt", nHandle[mModel], i, 2+j ))-Sred_i, 19, 7) Flag_err = LC_FieldPut( Ar_Model[mModel]+".txt", nHandle[mModel], i, 2+j, String ) * MsgBox('Строка='+ALLTRIM(STR(i))+', '+'Столбец='+ALLTRIM(STR(j))+', Значение='+ALLTRIM(String)+', '+IF(Flag_err,'Ошибка записи в БД','Записано нормально')) mValString = VAL(String) Ar_Summ_i[i] = Ar_Summ_i[i] + mValString Ar_Summ_j[j] = Ar_Summ_j[j] + mValString mMin_Iij = MIN(mMin_Iij, mValString) mMax_Iij = MAX(mMax_Iij, mValString) NEXT NEXT CASE nRadModelCr = 4 // среднее, сравнение путем деления oScr := DC_WaitOn(L('Идет расчет модели')+' '+ALLTRIM(STR(nRadioModel))+' '+L('-го уровня:')+' '+ALLTRIM(STR(mModel))+'/10-'+Ar_Model[mModel]+' '+L('"Среднее, сравнение путем деления". Немного подождите!'),,,,,,,,,,,.F.) // Полные наименования стат.моделей и моделей знаний * aModFullNm := {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 ') } Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } * IF Nij*Ni*Njo*Nobj <> 0 * Iij = LOG((Nij*Nobj)/(Ni*Njo))/LOG(2) * ENDIF FOR i=1 TO N_Gos // Цикл по строкам Sred_i = VAL(LC_FieldGet( Ar_Model[mModel]+".txt", nHandle[mModel], i, 2+N_Cls+2 )) IF Sred_i <> 0 For j=1 TO N_Cls // Цикл по колонкам * DC_DebugQout( LC_FieldGet( Ar_Model[mModel]+".txt", nHandle[mModel], i, 2+j )) String = STR(VAL(LC_FieldGet( Ar_Model[mModel]+".txt", nHandle[mModel], i, 2+j ))/Sred_i - 1, 19, 7) Flag_err = LC_FieldPut( Ar_Model[mModel]+".txt", nHandle[mModel], i, 2+j, String ) * MsgBox(LC_FieldGet( Ar_Model[mModel]+".txt", nHandle[mModel], i, 2+j )) * MsgBox('Строка='+ALLTRIM(STR(i))+', '+'Столбец='+ALLTRIM(STR(j))+', Значение='+ALLTRIM(String)+', '+IF(Flag_err,'Ошибка записи в БД','Записано нормально')) mValString = VAL(String) Ar_Summ_i[i] = Ar_Summ_i[i] + mValString Ar_Summ_j[j] = Ar_Summ_j[j] + mValString mMin_Iij = MIN(mMin_Iij, mValString) mMax_Iij = MAX(mMax_Iij, mValString) NEXT ENDIF NEXT CASE nRadModelCr = 5 // средн.модуль отклон.от средн. (среднее абсолютное отклонение), Mean Absolute Deviation (MAD), сравн.путем вычит. oScr := DC_WaitOn(L('Идет расчет модели')+' '+ALLTRIM(STR(nRadioModel))+' '+L('-го уровня:')+' '+ALLTRIM(STR(mModel))+'/10-'+Ar_Model[mModel]+' '+L('"Mean Absolute Deviation, сравнение путем вычитания". Немного подождите!'),,,,,,,,,,,.F.) // Полные наименования стат.моделей и моделей знаний * aModFullNm := {L('1. ABS - MAD.,сравн.пут.вычит.: кол.вст.соч.: "класс-признак" у объектов обуч.выборки'),; * L('2. PRC1 - MAD.,сравн.пут.вычит.: усл.вер.i-го призн.среди призн.объектов j-го класса '),; * L('3. PRC2 - MAD.,сравн.пут.вычит.: усл.вероятность i-го признака у объектов j-го класса '),; * L('4. INF1 - MAD.,сравн.пут.вычит.: количество знаний по А.Харкевичу; вероятности из PRC1'),; * L('5. INF2 - MAD.,сравн.пут.вычит.: количество знаний по А.Харкевичу; вероятности из PRC2'),; * L('6. INF3 - MAD.,сравн.пут.вычит.: Xи-квадрат, разности между факт.и ожид.абс.частотами '),; * L('7. INF4 - MAD.,сравн.пут.вычит.: ROI (Return On Investment); вероятности из PRC1 '),; * L('8. INF5 - MAD.,сравн.пут.вычит.: ROI (Return On Investment); вероятности из PRC2 '),; * L('9. INF6 - MAD.,сравн.пут.вычит.: разн.усл.и безусл.вероятностей; вероятности из PRC1 '),; * L('10.INF7 - MAD.,сравн.пут.вычит.: разн.усл.и безусл.вероятностей; вероятности из PRC2 ') } Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } FOR i=1 TO N_Gos // Цикл по строкам mMAD_i = VAL(LC_FieldGet( Ar_Model[mModel]+".txt", nHandle[mModel], i, 2+N_Cls+4 )) For j=1 TO N_Cls // Цикл по колонкам String = STR(VAL(LC_FieldGet( Ar_Model[mModel]+".txt", nHandle[mModel], i, 2+j ))-mMAD_i, 19, 7) Flag_err = LC_FieldPut( Ar_Model[mModel]+".txt", nHandle[mModel], i, 2+j, String ) * MsgBox('Строка='+ALLTRIM(STR(i))+', '+'Столбец='+ALLTRIM(STR(j))+', Значение='+ALLTRIM(String)+', '+IF(Flag_err,'Ошибка записи в БД','Записано нормально')) mValString = VAL(String) Ar_Summ_i[i] = Ar_Summ_i[i] + mValString Ar_Summ_j[j] = Ar_Summ_j[j] + mValString mMin_Iij = MIN(mMin_Iij, mValString) mMax_Iij = MAX(mMax_Iij, mValString) NEXT NEXT CASE nRadModelCr = 6 // средн.модуль отклон.от средн., сравн.путем делен. oScr := DC_WaitOn(L('Идет расчет модели')+' '+ALLTRIM(STR(nRadioModel))+' '+L('-го уровня:')+' '+ALLTRIM(STR(mModel))+'/10-'+Ar_Model[mModel]+' '+L('"Mean Absolute Deviation, сравнение путем деления". Немного подождите!'),,,,,,,,,,,.F.) // Полные наименования стат.моделей и моделей знаний * aModFullNm := {L('1. ABS - MAD.,сравн.пут.дел.: кол.вст.соч.: "класс-признак" у объектов обуч.выборки'),; * L('2. PRC1 - MAD.,сравн.пут.дел.: усл.вер.i-го призн.среди призн.объектов j-го класса '),; * L('3. PRC2 - MAD.,сравн.пут.дел.: усл.вероятность i-го признака у объектов j-го класса '),; * L('4. INF1 - MAD.,сравн.пут.дел.: количество знаний по А.Харкевичу; вероятности из PRC1'),; * L('5. INF2 - MAD.,сравн.пут.дел.: количество знаний по А.Харкевичу; вероятности из PRC2'),; * L('6. INF3 - MAD.,сравн.пут.дел.: Xи-квадрат, разности между факт.и ожид.абс.частотами '),; * L('7. INF4 - MAD.,сравн.пут.дел.: ROI (Return On Investment); вероятности из PRC1 '),; * L('8. INF5 - MAD.,сравн.пут.дел.: ROI (Return On Investment); вероятности из PRC2 '),; * L('9. INF6 - MAD.,сравн.пут.дел.: разн.усл.и безусл.вероятностей; вероятности из PRC1 '),; * L('10.INF7 - MAD.,сравн.пут.дел.: разн.усл.и безусл.вероятностей; вероятности из PRC2 ') } Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } * IF Nij*Ni*Njo*Nobj <> 0 * Iij = LOG((Nij*Nobj)/(Ni*Njo))/LOG(2) * ENDIF FOR i=1 TO N_Gos // Цикл по строкам mMAD_i = VAL(LC_FieldGet( Ar_Model[mModel]+".txt", nHandle[mModel], i, 2+N_Cls+4 )) IF mMAD_i <> 0 For j=1 TO N_Cls // Цикл по колонкам * DC_DebugQout( LC_FieldGet( Ar_Model[mModel]+".txt", nHandle[mModel], i, 2+j )) String = STR(VAL(LC_FieldGet( Ar_Model[mModel]+".txt", nHandle[mModel], i, 2+j ))/mMAD_i - 1, 19, 7) Flag_err = LC_FieldPut( Ar_Model[mModel]+".txt", nHandle[mModel], i, 2+j, String ) * MsgBox(LC_FieldGet( Ar_Model[mModel]+".txt", nHandle[mModel], i, 2+j )) * MsgBox('Строка='+ALLTRIM(STR(i))+', '+'Столбец='+ALLTRIM(STR(j))+', Значение='+ALLTRIM(String)+', '+IF(Flag_err,'Ошибка записи в БД','Записано нормально')) mValString = VAL(String) Ar_Summ_i[i] = Ar_Summ_i[i] + mValString Ar_Summ_j[j] = Ar_Summ_j[j] + mValString mMin_Iij = MIN(mMin_Iij, mValString) mMax_Iij = MAX(mMax_Iij, mValString) NEXT ENDIF NEXT ENDCASE * DC_ASave(aModFullNm, "_aModFullNm.arx") // Наименования создаваемых моделей для режима 3.4 * aModFullNm = DC_ARestore("_aModFullNm.arx") ** Просуммировать mMin_Iij ко всем значениям Iij и посчитать суммы по строкам и колонкам IF nRadioModel = 2 // Создавать модели 2-го уровня IF mModel = 1 * IF mMin_Iij < 0 PRIVATE Ar_SummaObj[3+N_Cls] // Строка "Сумма числа объектов по классам" AFILL(Ar_SummaObj,0) Summa_Obj = 0 // Сумма Obj по всей БД Abs.txt Summa_Nij = 0 // Сумма Nij по всей БД Abs.txt PRIVATE Ar_Summ_i[N_Gos], Ar_Summ_j[N_Cls+6] // N_Cls + 1-коды, 2-наименования, 3-Summ, 4-Sred, 5-Disp, 6-средн.модулей отклонения от средн. PRIVATE Ar_Sred_i[N_Gos], Ar_Sred_j[N_Cls+6] PRIVATE Ar_Disp_i[N_Gos], Ar_Disp_j[N_Cls+6] PRIVATE Ar_ADMA_i[N_Gos] AFILL(Ar_Summ_i, 0) AFILL(Ar_Summ_j, 0) AFILL(Ar_Sred_i, 0) AFILL(Ar_Sred_j, 0) AFILL(Ar_Disp_i, 0) AFILL(Ar_Disp_j, 0) AFILL(Ar_ADMA_i, 0) FOR i=1 TO N_Gos // Цикл по строкам For j=1 TO N_Cls // Цикл по колонкам mValString = VAL(LC_FieldGet( Ar_Model[mModel]+".txt", nHandle[mModel], i, 2+j )) - mMin_Iij Flag_err = LC_FieldPut( Ar_Model[mModel]+".txt", nHandle[mModel], i, 2+j, STR(mValString, 19, 7)) Ar_Summ_i[i] = Ar_Summ_i[i] + mValString Ar_Summ_j[j] = Ar_Summ_j[j] + mValString NEXT NEXT * ENDIF ENDIF ENDIF *** Записать сумму значений по строкам *** FOR i=1 TO N_Gos // Цикл по строкам Flag_err = LC_FieldPut( Ar_Model[mModel]+".txt", nHandle[mModel], i, 2+N_Cls+1, STR(Ar_Summ_i[i], 19, 7) ) NEXT *** Записать сумму значений по колонкам *** For j=1 TO N_Cls // Цикл по колонкам Flag_err = LC_FieldPut( Ar_Model[mModel]+".txt", nHandle[mModel], N_Gos+1, 2+j, STR(Ar_Summ_j[j], 19, 7) ) NEXT PostCalcINF(mModel) DC_Impl(oScr) RETURN NIL **************************************************************************************************************** ******** 3.5. Синтез и верификация заданных из 3 стат.моделей и 7 моделей знаний ******** Оценивается внутренняя достоверность (адекватность) заданных стат.моделей и моделей знаний. ******** Для этого в каждой заданной модели обучающая выборка копируется в распознаваемую, проводится ******** распознавание и подсчитывается количество верно идентифицированных, верно не идентифицированных, ******** ошибочно идентифицированных и ошибочно не идентифицированных объектов (ошибки 1-го и 2-го рода). ******** Для распознавания могут быть использованы статистические базы: Abs, Prc1, Prc2 и базы знаний: ******** Inf1~Prc1, Inf2~Prc2, Inf3-хи-квадрат, Inf4-roi~Prc1, Inf5-roi~Prc2, Inf6-Dp~Prc1, Inf7-Dp~Prc2. **************************************************************************************************************** FUNCTION F3_5(mProcessor, mSintRec, mRegim, mModel) * F3_5('GPU' ,'SintRec','3.5' ,'ALL') LOCAL GetList := {}, aPres, oBrowse, oToolBar, aColors, bColor, GetOptions *LOCAL Mess97, Mess98, Mess99 *PUBLIC Time_progress:=0, Wsego, oProgress, lOk := .T., Sec_1, Regim := "3_5" PRIVATE Time_progress:=0, Wsego, oProgress, lOk := .T., Sec_1, Regim := "3_5" Running(.T.) aSaveF35 := DC_DataSave() // Сохранение вычислительной среды (открытые и текущие БД и индексы) * DC_DataRest( aSaveF35 ) // Восстановление вычислительной среды (открытые и текущие БД и индексы) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF *IF ApplChange("3.5()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения * Running(.F.) * RETURN NIL *ENDIF IF ApplChange("") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF ****** Задание на расчет баз знаний * IF FILE("_CalcInf.arx") // Файл с информацией о том, какие модели были рассчитаны ранее * aCalcInf = DC_ARestore("_CalcInf.arx") * ELSE * DC_ASave(aCalcInf, "_CalcInf.arx") * ENDIF * IF ASCAN(aCalcInf, .T.) = 0 * LB_Warning(L("Нет просчитанных моделей. Необходимо выполнить синтез моделей в 3-й подсистеме!") Running(.F.) * RETURN NIL * ENDIF Regim = "3_5" IF FILE("_CurrInf.arx") // Файл с информацией о том, какая модель задана текущей M_CurrInf = DC_ARestore("_CurrInf.arx") ELSE DC_ASave(M_CurrInf, "_CurrInf.arx") ENDIF ****** Задание на верификацию баз знаний IF FILE("_VerifInf.arx") // Файл с информацией о том, какие модели были верифицированы ранее aVerifInf = DC_ARestore("_VerifInf.arx") ELSE AFILL(aVerifInf, .T.) DC_ASave(aVerifInf, "_VerifInf.arx") ENDIF *********************************************************************************************************************** mTitleName = L('3.5. Синтез и верификация моделей') IF EMPTY(mRegim) mProcessor = 'CPU' mSintRec = 'SintRec' mRegim = '3.5' mModel = 'ALL' ELSE DO CASE CASE mRegim = '3.1' mTitleName = L('3.1. Ускоренный синтез всех моделей') CASE mRegim = '3.2' mTitleName = L('3.2. Верификация всех моделей на GPU') CASE mRegim = '3.3' mTitleName = L('3.3. Синтез и верификация всех моделей на GPU') CASE mRegim = '3.5' .OR. LEN(ALLTRIM(mRegim)) = 0 mTitleName = L('3.5. Синтез и верификация моделей') CASE mRegim = '3.6' mTitleName = L('3.6. Обнаружение, удаление и типизация артефактов') CASE mRegim = '3.7.9' mTitleName = L('3.7.9. Корректировка экспертных оценок: объект => класс') CASE mRegim = '3.7.6' mTitleName = L('3.6. Обнаружение, удаление и типизация артефактов') CASE mRegim = '4.2.2.4' mTitleName = L('3.6. Обнаружение, удаление и типизация артефактов') ENDCASE ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций // Почему-то дает ошибку при повторном запуске ################################## USE Obi_Zag EXCLUSIVE NEW mN1 = 1 mN2 = RECCOUNT() nRadio1 = 1 nRadio2 = 1 nRadio3 = 1 nRadioM = 1 nRadioP = 1 N_CopyObj = 0 mPerDel = 10 StrFile(ALLTRIM(STR(mPerDel,17,7)),'_PerDel.txt') *IF nRadio1 = 6 .OR. ( nRadioM = 3 .AND. mRegim <> '3.7.9' ) PUBLIC nRadioModel := 1, nRadModelCr := 1 mAlgorithm = 2 mVisualization = 2 mFonAbs = 0 StrFile(ALLTRIM(STR(mAlgorithm,1)),'_Algorithm.txt') StrFile(ALLTRIM(STR(mVisualization,1)),'_Visualization.txt') IF mRegim = '3.5' .OR. mRegim = '3.6' // Диалог только если распознавание на CPU. Если на GPU - то параметры задаются фиксированные но теже самые, что на CPU // Диалог задания моделей для синтеза и верификации WindowWidth = 45 // Ширина самого правого окна @ 0, 0 DCGROUP oGroup1 CAPTION L('Задайте базовые модели для синтеза и верификации' ) SIZE 87,17.7 @18, 0 DCGROUP oGroup2 CAPTION L('Параметры копирования обучающей выборки в распознаваемую (бутстрепный подход):') SIZE 87,13.7 @18+ 1, 2 DCGROUP oGroup3 CAPTION L('Какие объекты обуч.выборки копировать:' ) SIZE 44, 7.7 @18+ 9, 2 DCGROUP oGroup4 CAPTION L('Удалять из обуч.выборки скопированные объекты:' ) SIZE 44, 3.7 @18+ 1,48 DCGROUP oGroup6 CAPTION L('Пояснение по алгоритму верификации:' ) SIZE 37, 7.7 @18+ 9,48 DCGROUP oGroup7 CAPTION L('Подробнее:' ) SIZE 37, 3.7 ** @ 0, 89 DCGROUP oGroup8 CAPTION L('Текущая модель' ) SIZE WindowWidth+3,17.7 @ 0, 89 DCGROUP oGroup8 CAPTION L('Какие модели создавать?' ) SIZE WindowWidth+3,17.7 @18, 89 DCGROUP oGroup9 CAPTION L('' ) SIZE WindowWidth+3, 6.7 ** @34+ 7,89 DCGROUP oGroup10 CAPTION L('Задайте процессор' ) SIZE WindowWidth+3, 6.7 @18+14, 0 DCGROUP oGroup11 CAPTION L('Использование только наиболее достоверных результатов распознавания: Rasp.dbf и целесобразность применения бутстрепного подхода') SIZE WindowWidth+92, 4.7 ** @ 2, 2 DCGROUP oGroup12 CAPTION L('Задайте алгоритм:') SIZE 23, 3.7 PARENT oGroup10 HIDE {|| .NOT.nRadioP=1} // <<<===############### ** @ 2, 2 DCGROUP oGroup12 CAPTION L('Отображать процесс?') SIZE 23, 3.7 PARENT oGroup10 HIDE {|| .NOT.nRadioP=2} // <<<===############### @ 1.0,1 DCSAY L('Базовые статистические базы:') PARENT oGroup1 @ 2.0,3 DCCHECKBOX aVerifInf[ 1] PROMPT L('1. ABS - частный критерий: количество встреч сочетаний: "класс-признак" у объектов обуч.выборки') PARENT oGroup1 ****** Задание источника данных для расчета модели ABS. ****** Во все модели после окончания их расчета добавлять последнюю строку из ABS, чтобы модели можно было копировать как файлы <<<===############### PUBLIC mCurrMod := 0 // Формировать ABS на основе обучающей выборки s=3.5; p=22; d=6.5 @s,3 DCSAY L('Задайте источник данных для расчета модели ABS:') PARENT oGroup1 s++ @s, 3 DCRADIO mCurrMod VALUE 0 PROMPT L('Обучающая выборка') PARENT oGroup1 // mCurrMod= 0, Как раньше рассчитывать модель ABS на основе обучающей выборки @s, p DCRADIO mCurrMod VALUE 1 PROMPT L('Abs' ) PARENT oGroup1;p=p+d // mCurrMod= 1, Источником данных является модель ABS, т.е. ее не надо рассчитывать, а все остальные модели рассчитывать как раньше @s, p DCRADIO mCurrMod VALUE 2 PROMPT L('Prc1') PARENT oGroup1;p=p+d // mCurrMod= 2, Источником данных является модель Prc1, т.е. надо скопировать Prc1=>ABS, а все остальные модели рассчитывать как раньше @s, p DCRADIO mCurrMod VALUE 3 PROMPT L('Prc2') PARENT oGroup1;p=p+d // mCurrMod= 3, Источником данных является модель Prc2, т.е. надо скопировать Prc2=>ABS, а все остальные модели рассчитывать как раньше @s, p DCRADIO mCurrMod VALUE 4 PROMPT L('Inf1') PARENT oGroup1;p=p+d // mCurrMod= 4, Источником данных является модель Inf1, т.е. надо скопировать Inf1=>ABS, а все остальные модели рассчитывать как раньше @s, p DCRADIO mCurrMod VALUE 5 PROMPT L('Inf2') PARENT oGroup1;p=p+d // mCurrMod= 5, Источником данных является модель Inf2, т.е. надо скопировать Inf2=>ABS, а все остальные модели рассчитывать как раньше @s, p DCRADIO mCurrMod VALUE 6 PROMPT L('Inf3') PARENT oGroup1;p=p+d // mCurrMod= 6, Источником данных является модель Inf3, т.е. надо скопировать Inf3=>ABS, а все остальные модели рассчитывать как раньше @s, p DCRADIO mCurrMod VALUE 7 PROMPT L('Inf4') PARENT oGroup1;p=p+d // mCurrMod= 7, Источником данных является модель Inf4, т.е. надо скопировать Inf4=>ABS, а все остальные модели рассчитывать как раньше @s, p DCRADIO mCurrMod VALUE 8 PROMPT L('Inf5') PARENT oGroup1;p=p+d // mCurrMod= 8, Источником данных является модель Inf5, т.е. надо скопировать Inf5=>ABS, а все остальные модели рассчитывать как раньше @s, p DCRADIO mCurrMod VALUE 9 PROMPT L('Inf6') PARENT oGroup1;p=p+d // mCurrMod= 9, Источником данных является модель Inf6, т.е. надо скопировать Inf6=>ABS, а все остальные модели рассчитывать как раньше @s, p DCRADIO mCurrMod VALUE 10 PROMPT L('Inf7') PARENT oGroup1;p=p+d // mCurrMod=10, Источником данных является модель Inf7, т.е. надо скопировать Inf7=>ABS, а все остальные модели рассчитывать как раньше s++ @s+0.35 ,3 DCSAY L("Задайте значение фона в матрице абсолютных частот:") EDITPROTECT {||.NOT.mCurrMod=0} HIDE {||.NOT.mCurrMod=0} PARENT oGroup1 @s+0.20,45 DCGET mFonAbs PICTURE "###########.#######" EDITPROTECT {||.NOT.mCurrMod=0} HIDE {||.NOT.mCurrMod=0} PARENT oGroup1 // Задавать, только если источник данных для Abs - обучающая выборка * 1234567890123456789 @s+0.20,70 DCPUSHBUTTON CAPTION L('Помощь') SIZE LEN(L('Помощь'))+7, 1.0 ACTION {||Help_AbsFon()} PARENT oGroup1 @ 7,3 DCCHECKBOX aVerifInf[ 2] PROMPT L('2. PRC1 - частный критерий: усл. вероятность i-го признака среди признаков объектов j-го класса' ) PARENT oGroup1 @ 8,3 DCCHECKBOX aVerifInf[ 3] PROMPT L('3. PRC2 - частный критерий: условная вероятность i-го признака у объектов j-го класса' ) PARENT oGroup1 @ 9.2,1 DCSAY L('Базовые системно-когнитивные модели (базы знаний):') PARENT oGroup1 @10,3 DCCHECKBOX aVerifInf[ 4] PROMPT L('4. INF1 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC1' ) PARENT oGroup1 @11,3 DCCHECKBOX aVerifInf[ 5] PROMPT L('5. INF2 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC2' ) PARENT oGroup1 @12,3 DCCHECKBOX aVerifInf[ 6] PROMPT L('6. INF3 - частный критерий: Xи-квадрат, разности между фактическими и ожидаемыми абс.частотами' ) PARENT oGroup1 @13,3 DCCHECKBOX aVerifInf[ 7] PROMPT L('7. INF4 - частный критерий: ROI (Return On Investment); вероятности из PRC1' ) PARENT oGroup1 @14,3 DCCHECKBOX aVerifInf[ 8] PROMPT L('8. INF5 - частный критерий: ROI (Return On Investment); вероятности из PRC2' ) PARENT oGroup1 @15,3 DCCHECKBOX aVerifInf[ 9] PROMPT L('9. INF6 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC1' ) PARENT oGroup1 @16,3 DCCHECKBOX aVerifInf[10] PROMPT L('10.INF7 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC2' ) PARENT oGroup1 ****** Задание моделей знаний для расчета и задание текущей модели M_CurrInf = 6 * z = 6 ** @ 0, 89 DCGROUP oGroup8 CAPTION L('Текущая модель' ) SIZE WindowWidth+3,17.7 * @ 2, z DCRADIO M_CurrInf VALUE 1 PROMPT L('1. ABS ') PARENT oGroup8 EDITPROTECT {|| .NOT. aVerifInf[ 1] } HIDE {|| .NOT. aVerifInf[ 1] } * @ 7, z DCRADIO M_CurrInf VALUE 2 PROMPT L('2. PRC1') PARENT oGroup8 EDITPROTECT {|| .NOT. aVerifInf[ 2] } HIDE {|| .NOT. aVerifInf[ 2] } * @ 8, z DCRADIO M_CurrInf VALUE 3 PROMPT L('3. PRC2') PARENT oGroup8 EDITPROTECT {|| .NOT. aVerifInf[ 3] } HIDE {|| .NOT. aVerifInf[ 3] } * @10, z DCRADIO M_CurrInf VALUE 4 PROMPT L('4. INF1') PARENT oGroup8 EDITPROTECT {|| .NOT. aVerifInf[ 4] } HIDE {|| .NOT. aVerifInf[ 4] } * @11, z DCRADIO M_CurrInf VALUE 5 PROMPT L('5. INF2') PARENT oGroup8 EDITPROTECT {|| .NOT. aVerifInf[ 5] } HIDE {|| .NOT. aVerifInf[ 5] } * @12, z DCRADIO M_CurrInf VALUE 6 PROMPT L('6. INF3') PARENT oGroup8 EDITPROTECT {|| .NOT. aVerifInf[ 6] } HIDE {|| .NOT. aVerifInf[ 6] } * @13, z DCRADIO M_CurrInf VALUE 7 PROMPT L('7. INF4') PARENT oGroup8 EDITPROTECT {|| .NOT. aVerifInf[ 7] } HIDE {|| .NOT. aVerifInf[ 7] } * @14, z DCRADIO M_CurrInf VALUE 8 PROMPT L('8. INF5') PARENT oGroup8 EDITPROTECT {|| .NOT. aVerifInf[ 8] } HIDE {|| .NOT. aVerifInf[ 8] } * @15, z DCRADIO M_CurrInf VALUE 9 PROMPT L('9. INF6') PARENT oGroup8 EDITPROTECT {|| .NOT. aVerifInf[ 9] } HIDE {|| .NOT. aVerifInf[ 9] } * @16, z DCRADIO M_CurrInf VALUE 10 PROMPT L('10.INF7') PARENT oGroup8 EDITPROTECT {|| .NOT. aVerifInf[10] } HIDE {|| .NOT. aVerifInf[10] } ****** Задание на создание базовых моделей, а также моделей 2-го и 3-го уровней ******************* CrLf = CHR(13)+CHR(10) * @ 0, 89 DCGROUP oGroup8 CAPTION L('Какие модели создавать?') SIZE WindowWidth,17.7 s=1;d=0.85 nRadioModel = 1 @s, 2 DCRADIO nRadioModel VALUE 1 PROMPT L('Создавать только базовые модели') PARENT oGroup8;s=s+d @s, 2 DCRADIO nRadioModel VALUE 2 PROMPT L('Создавать модели 2-го уровня ') PARENT oGroup8;s=s+d // <<<===############### пока ничего вразумительного с моделями 2-го уровня не получилось @s, 2 DCRADIO nRadioModel VALUE 3 PROMPT L('Создавать модели 3-го уровня ') PARENT oGroup8;s=s+d @1.5,33 DCPUSHBUTTON CAPTION L('Помощь') SIZE LEN(L('Помощь'))+7, 2.0 ACTION {||Help_NormModels()} PARENT oGroup8 nRadModelCr = 1 @ 3.7, 2 DCGROUP oGroup13 CAPTION L('') SIZE WindowWidth-1,13.3 PARENT oGroup8 HIDE {|| .NOT.nRadioModel=1} // <<<===############### s=1.0;d=1.00 @s, 1 DCSAY L('Базовые модели - это модели: Prc1,Prc2,Inf1,Inf2,Inf3,') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=1 } HIDE {|| .NOT.nRadioModel=1};s=s+d @s, 1 DCSAY L('Inf4,Inf5,Inf6, Inf7 полученные расчетным путем по ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=1 } HIDE {|| .NOT.nRadioModel=1};s=s+d @s, 1 DCSAY L('формулам, приведенным в хелпе режима 5.5 на основе ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=1 } HIDE {|| .NOT.nRadioModel=1};s=s+d @s, 1 DCSAY L('модели Abs. ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=1 } HIDE {|| .NOT.nRadioModel=1};s=s+d*1.5 @s, 1 DCSAY L('Модель Abs называется матрицей абсолютных часот и ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=1 } HIDE {|| .NOT.nRadioModel=1};s=s+d @s, 1 DCSAY L('содержит абсолютное количество встреч сочетаний ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=1 } HIDE {|| .NOT.nRadioModel=1};s=s+d @s, 1 DCSAY L('"признак x класс", посчитанное по всей выборке. ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=1 } HIDE {|| .NOT.nRadioModel=1};s=s+d*1.5 @s, 1 DCSAY L('Модель Abs еще называют "матрицей сопряженности" ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=1 } HIDE {|| .NOT.nRadioModel=1};s=s+d @s, 1 DCSAY L('или "корреляционной матрицей". Формы по достовер- ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=1 } HIDE {|| .NOT.nRadioModel=1};s=s+d @s, 1 DCSAY L('ностяи моделей формируются в режиме 3.4. ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=1 } HIDE {|| .NOT.nRadioModel=1};s=s+d nRadModelCr = 1 @ 3.7, 2 DCGROUP oGroup13 CAPTION L('') SIZE WindowWidth-1,13.3 PARENT oGroup8 HIDE {|| .NOT.nRadioModel=2} // <<<===############### s=0.7;d=0.80 @s, 1 DCSAY L('Модели 2-го уровня - это модели: Prc1,Prc2,Inf1,Inf2,') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=2 } HIDE {|| .NOT.nRadioModel=2};s=s+d @s, 1 DCSAY L('Inf3,Inf4,Inf5,Inf6,Inf7, созданные на основе модели ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=2 } HIDE {|| .NOT.nRadioModel=2};s=s+d @s, 1 DCSAY L('Abs путем расчета по формулам, приведенным в хелпе ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=2 } HIDE {|| .NOT.nRadioModel=2};s=s+d @s, 1 DCSAY L('режима 5.5. Причем модель Abs сначала преобразована ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=2 } HIDE {|| .NOT.nRadioModel=2};s=s+d @s, 1 DCSAY L('путем сравнения весов признаков с их дисперсией или ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=2 } HIDE {|| .NOT.nRadioModel=2};s=s+d @s, 1 DCSAY L('средним модулем отклонения от среднего, причем для ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=2 } HIDE {|| .NOT.nRadioModel=2};s=s+d @s, 1 DCSAY L('сравнения используется вычитание или деление. Затем ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=2 } HIDE {|| .NOT.nRadioModel=2};s=s+d @s, 1 DCSAY L('находится минимальный вес и вычитается из всех весов.') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=2 } HIDE {|| .NOT.nRadioModel=2};s=s+d @s, 1 DCSAY L('Задайте вариант расчета моделей 2-го уровня: ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=2 } HIDE {|| .NOT.nRadioModel=2};s=s+d @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 nRadModelCr = 1 @ 3.7, 2 DCGROUP oGroup13 CAPTION L('') SIZE WindowWidth-1,13.3 PARENT oGroup8 HIDE {|| .NOT.nRadioModel=3} // <<<===############### s=0.7;d=0.80 @s, 1 DCSAY L('Модели 3-го уровня - это модели: Prc1,Prc2,Inf1,Inf2,') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=3 } HIDE {|| .NOT.nRadioModel=3};s=s+d @s, 1 DCSAY L('Inf3,Inf4,Inf5,Inf6,Inf7, созданные на основе базовой') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=3 } HIDE {|| .NOT.nRadioModel=3};s=s+d @s, 1 DCSAY L('модели Abs путем расчета по формулам, приведенным ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=3 } HIDE {|| .NOT.nRadioModel=3};s=s+d @s, 1 DCSAY L('в хелпе режима 5.5. Затем все модели преобразованы ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=3 } HIDE {|| .NOT.nRadioModel=3};s=s+d @s, 1 DCSAY L('путем сравнения весов признаков (значений градаций ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=3 } HIDE {|| .NOT.nRadioModel=3};s=s+d @s, 1 DCSAY L('описательных шкал) с их дисперсией или с средним ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=3 } HIDE {|| .NOT.nRadioModel=3};s=s+d @s, 1 DCSAY L('модулем отклонения от среднего, причем для самого ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=3 } HIDE {|| .NOT.nRadioModel=3};s=s+d @s, 1 DCSAY L('сравнения используется вычитание или деление. ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=3 } HIDE {|| .NOT.nRadioModel=3};s=s+d @s, 1 DCSAY L('Задайте вариант расчета моделей 3-го уровня: ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=3 } HIDE {|| .NOT.nRadioModel=3};s=s+d @s, 2 DCRADIO nRadModelCr VALUE 1 PROMPT L('дисперсия, сравнение путем вычитания ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=3 } HIDE {|| .NOT.nRadioModel=3};s=s+d @s, 2 DCRADIO nRadModelCr VALUE 2 PROMPT L('дисперсия, сравнение путем деления ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=3 } HIDE {|| .NOT.nRadioModel=3};s=s+d @s, 2 DCRADIO nRadModelCr VALUE 3 PROMPT L('среднее, сравнение путем вычитания ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=3 } HIDE {|| .NOT.nRadioModel=3};s=s+d @s, 2 DCRADIO nRadModelCr VALUE 4 PROMPT L('среднее, сравнение путем деления ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=3 } HIDE {|| .NOT.nRadioModel=3};s=s+d @s, 2 DCRADIO nRadModelCr VALUE 5 PROMPT L('средн.модуль отклон.от средн., сравн.путем вычит. ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=3 } HIDE {|| .NOT.nRadioModel=3};s=s+d @s, 2 DCRADIO nRadModelCr VALUE 6 PROMPT L('средн.модуль отклон.от средн., сравн.путем делен. ') PARENT oGroup13 EDITPROTECT {|| .NOT.nRadioModel=3 } HIDE {|| .NOT.nRadioModel=3};s=s+d // Диалог задания параметров режима копирования обуч.выборки в распознаваемую @ 1, 2 DCRADIO nRadio1 VALUE 1 PROMPT L('Копировать всю обучающую выборку' ) PARENT oGroup3 @ 2, 2 DCRADIO nRadio1 VALUE 2 PROMPT L('Копировать только текущий объект' ) PARENT oGroup3 @ 3, 2 DCRADIO nRadio1 VALUE 3 PROMPT L('Копировать каждый N-й объект' ) PARENT oGroup3 @ 4, 2 DCRADIO nRadio1 VALUE 4 PROMPT L('Копировать N случайных объектов' ) PARENT oGroup3 @ 5, 2 DCRADIO nRadio1 VALUE 5 PROMPT L('Копировать объекты от N1 до N2 (fastest)') PARENT oGroup3 @ 6, 2 DCRADIO nRadio1 VALUE 6 PROMPT L('Вообще не менять распознаваемую выборку' ) PARENT oGroup3 @ 1, 2 DCRADIO nRadio2 VALUE 1 PROMPT L('Не удалять' ) PARENT oGroup4 @ 2, 2 DCRADIO nRadio2 VALUE 2 PROMPT L('Удалять' ) PARENT oGroup4 @ 1, 2.2 DCSAY L("Измеряется внутренняя достоверн. модели") EDITPROTECT {|| .NOT.nRadio2=1 } HIDE {|| .NOT.nRadio2=1 } PARENT oGroup7 @ 2, 2.2 DCSAY L("Измеряется внешняя достоверность модели") EDITPROTECT {|| .NOT.nRadio2=2 } HIDE {|| .NOT.nRadio2=2 } PARENT oGroup7 nRadio3 = 1 mMess = L("Использовать ту расп.выборку, что есть") @ 3 , 2.2 DCSAY L(" ") GET N_CopyObj PARENT oGroup6 PICTURE "###############" EDITPROTECT {|| .NOT.nRadio1=3 } HIDE {|| .NOT.nRadio1=3 } @ 4 , 2.2 DCSAY L(" ") GET N_CopyObj PARENT oGroup6 PICTURE "###############" EDITPROTECT {|| .NOT.nRadio1=4 } HIDE {|| .NOT.nRadio1=4 } @ 5 , 2.2 DCSAY L(" ") GET mN1 PARENT oGroup6 PICTURE "###########" EDITPROTECT {|| .NOT.nRadio1=5 } HIDE {|| .NOT.nRadio1=5 } @ 5 , 19 DCSAY L(" ") GET mN2 PARENT oGroup6 PICTURE "###########" EDITPROTECT {|| .NOT.nRadio1=5 } HIDE {|| .NOT.nRadio1=5 } @ 6.1,2.2 DCSAY mMess PARENT oGroup6 EDITPROTECT {|| .NOT.nRadio1=6 } HIDE {|| .NOT.nRadio1=6 } @18.9,49 DCPUSHBUTTON ; CAPTION L('Пояснение по алгоритму верификации') ; SIZE LEN(L('Пояснение по алгоритму верификации'))-4, 0.9 ; ACTION {||Help35()} @18+8.9,49 DCPUSHBUTTON ; CAPTION L('Подробнее') ; SIZE LEN(L('Подробнее'))+1, 0.9 ; ACTION {||Help_OiRo()} nRadioM = 1 @1.0, 2 DCSAY L("Выполнить:") PARENT oGroup9 @2.0, 2 DCRADIO nRadioM VALUE 1 PROMPT L('Синтез и верификацию') PARENT oGroup9 @3.0, 2 DCRADIO nRadioM VALUE 2 PROMPT L('Только верификацию') PARENT oGroup9 @4.0, 2 DCRADIO nRadioM VALUE 3 PROMPT L('Только синтез (xBase++)') PARENT oGroup9 @5.0, 2 DCRADIO nRadioM VALUE 4 PROMPT L('Только синтез (Python)') PARENT oGroup9 nRadioP = 1 @18+ 7,89 DCGROUP oGroup10 CAPTION L('Задайте процессор') SIZE WindowWidth+3, 6.7 @0.8, 2 DCRADIO nRadioP VALUE 1 PROMPT L('CPU') PARENT oGroup10 @0.8,15 DCRADIO nRadioP VALUE 2 PROMPT L('GPU') PARENT oGroup10 EDITPROTECT {|| .NOT.mFonAbs+mCurrMod=0} HIDE {|| .NOT.mFonAbs+mCurrMod=0} // Если mFonAbs <> 0 ВООБЩЕ НЕ СПРАШИВАТЬ ПРО GPU mAlgorithm = 2 @ 2, 2 DCGROUP oGroup12 CAPTION L('Задайте алгоритм:') SIZE WindowWidth-1, 3.7 PARENT oGroup10 HIDE {|| .NOT.nRadioP=1} // <<<===############### @ 1, 2 DCRADIO mAlgorithm VALUE 1 PROMPT L('Классика - дольше') PARENT oGroup12 EDITPROTECT {|| .NOT.nRadioP=1 } HIDE {|| .NOT.nRadioP=1} @ 2, 2 DCRADIO mAlgorithm VALUE 2 PROMPT L('Упрощенно-быстрее ') PARENT oGroup12 EDITPROTECT {|| .NOT.nRadioP=1 } HIDE {|| .NOT.nRadioP=1} mVisualization = 1 @ 2, 2 DCGROUP oGroup12 CAPTION L('Отображать процесс?') SIZE WindowWidth-1, 3.7 PARENT oGroup10 HIDE {|| .NOT.nRadioP=2} // <<<===############### @ 1, 2 DCRADIO mVisualization VALUE 1 PROMPT L('Без визуализации:' ) PARENT oGroup12 EDITPROTECT {|| .NOT.nRadioP=2 } HIDE {|| .NOT.nRadioP=2} @ 2, 2 DCRADIO mVisualization VALUE 2 PROMPT L('Визуализация 3 с.' ) PARENT oGroup12 EDITPROTECT {|| .NOT.nRadioP=2 } HIDE {|| .NOT.nRadioP=2} * StrFile(ALLTRIM(STR(mAlgorithm,1)),'_Algorithm.txt') * StrFile(ALLTRIM(STR(mVisualization,1)),'_Visualization.txt') ********************************************************************************* ********** Сокращение объема БД Rasp.dbf **************************************** // При использовании ADS это ограничение полностью преодолено ********************************************************************************* mRSVMD = GenDbfDostModObj() // Размер записи БД для измерения достоверности моделей mRSRsp = GenDbfRspC() * MsgBox(STR(mRSRsp)) mRSRsp = 50 // Размер записи БД Rasp.dbf CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Obi_Zag EXCLUSIVE NEW;N_Obj = RECCOUNT() USE Rasp EXCLUSIVE NEW;mHRsp = HEADER() USE VerModObj EXCLUSIVE NEW;mHVMO = HEADER() // Объединить все (M_VerMod) по объектам расп.выборки без итоговых строк * MsgBox(STR(mRSVMD*N_Obj*10*2 + mHVMO)+' '+STR(2*1024^3)) * MsgBox(STR(mRSVMD)+' '+STR(N_Obj)+' '+STR(mHVMO)+' '+STR(2*1024^3)) ** N_Obj - число объектов обучающей выборки ** N_Cls - число классов ** mRSRsp- размер записи БД Rasp.dbf // Измерить длину 1 записи при новой ширине полей <=====########### N_Rec = N_Obj * N_Cls // расчетное число записей в БД Rasp.dbf mFileSizeRasp = N_Rec * mRSRsp + mHRsp // Измерить длину 1 записи при новой ширине полей <=====########### ******************************************************** ** Возможно ли вообще обрабатывать БД Rasp.dbf ********* // При использовании ADS это ограничение полностью преодолено ******************************************************** IF mFileSizeRasp > 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(mFileSizeRasp))) 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 IF mRSVMD*N_Obj*10*2 + mHVMO > 2*1024^3 // ПЕРЕД ОТКРЫТИЕМ ЭТОЙ БАЗЫ ДАННЫХ ПРОВЕРЯТЬ, МЕНЬШЕ ЛИ ОНА 2 ГБ. ЕСЛИ БОЛЬШЕ - ВЫДАВАТЬ СООБЩЕНИЕ О НЕОБХОДИМОСТИ ЗАДАТЬ ПАРАМЕТР, УМЕНЬШАЮЩИЙ ЧИСЛО ЗАПИСЕЙ ТАК, ЧТОБЫ БД БЫЛА < 2ГБ aMess := {} AADD(aMess, L('При использовании всей обучающей выборки из')+' '+ALLTRIM(STR(N_Obj))+' '+L('объектов размер БД "VerModObj.dbf" ')) AADD(aMess, L('для оценки достоверности моделей достигает')+' '+ALLTRIM(STR(mRSVMD*N_Obj*10*2+mHVMO))+' '+L('байт, что больше 2 Гб и недопустимо.')) AADD(aMess, L('Поэтому необходимо использовать БУТСТРЕПНЫЙ подход для оценки достоверности моделей')) AADD(aMess, L('и задать в режиме 3.5 количество объектов распознаваемой выборки, НЕ БОЛЕЕ:')+' '+ALLTRIM(STR(INT((2*1024^3-mHVMO)/(mRSVMD*10*2))))+'.') AADD(aMess, L('Тогда БД оценки достоверности распознавания объектов "VerModObj.dbf" будет меньше 2 Гб!')) AADD(aMess, L('Можно также выбрать режим только синтеза моделей, а их верификацию провести позже')) AADD(aMess, L('на распознаваемой выборке - подмножестве обучающей выборки или созданной другим путем.')) LB_Warning(aMess, L('3.5. Синтез и верификация моделей')) * ************************************************************** * ***** БД, открытые перед запуском главного меню * ***** Восстанавливать их после выхода из функций главного меню * ************************************************************** * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы * USE PathGrAp EXCLUSIVE NEW * USE Appls EXCLUSIVE NEW * USE Users EXCLUSIVE NEW * ************************************************************** * Running(.F.) ** RETURN NIL * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * QUIT ENDIF @1, 2 DCSAY L("Расчетный размер БД результатов распознавания Rasp.dbf равен")+' '+ALLTRIM(STR(mFileSizeRasp))+' '+; L('байт, т.е.:')+' '+ALLTRIM(STR(mFileSizeRasp/(2*1024^3)*100,15,7))+' '+L('% от MAX-возможного, (от 2Гб)') PARENT oGroup11 * @1, 2 DCSAY L("Расчетный размер БД результатов распознавания Rasp.dbf равен")+' '+ALLTRIM(STR(mFileSizeRasp))+' '+L('байт') PARENT oGroup11 // При использовании ADS это ограничение полностью преодолено * mPerDel = 100 * IF mFileSizeRasp > 1*1024^3 // Экспериментально путем расчетов определить максимальный размер БД Rasp.dbf. При ADS и использовании обработки ошибок при расчетах выходных форм это не играет роли * mPerDel = 0.5*1024^3 / mFileSizeRasp * 100 // Оставить 0.5 Гб ИЛИ МЕНЬШЕ, т.е. СТОЛЬКО, СКОЛЬКО надо, чтобы рассчитывались все 11 выходных форм на основе Rasp.dbf * ENDIF * mPerDelMax = mPerDel * mPerDel = 100 mPerDel = 0 * @2 , 2 DCSAY L("Задайте, сколько % от исходной БД Rasp.dbf ОСТАВИТЬ, удаляя наименее достоверные результаты распознавания: ") PARENT oGroup11 @2 , 2 DCSAY L('УЧИТЫВАТЬ только наиболее достоверные результаты распознавания с МОДУЛЕМ инт.крит. "Резонанс знаний" выше: ') PARENT oGroup11 @1.85, 91 DCSAY L('') GET mPerDel PICTURE "###.#######" PARENT oGroup11 // Можно только уменьшать этот % @2 ,107 DCSAY ' % ' PARENT oGroup11 // ПЕРЕД ОТКРЫТИЕМ ЭТОЙ БАЗЫ ДАННЫХ ПРОВЕРЯТЬ, МЕНЬШЕ ЛИ ОНА 2 ГБ. ЕСЛИ БОЛЬШЕ - ВЫДАВАТЬ СООБЩЕНИЕ О НЕОБХОДИМОСТИ ЗАДАТЬ ПАРАМЕТР, УМЕНЬШАЮЩИЙ ЧИСЛО ЗАПИСЕЙ ТАК, ЧТОБЫ БД БЫЛА < 2ГБ IF mRSVMD*N_Obj*10*2 + mHVMO > 2*1024^3 mMess = L('Рекомендуется применить бутстрепный подход (объектов обучающей выборки <=')+' '+ALLTRIM(STR(INT((2*1024^3-mHVMO)/(mRSVMD*10*2))))+' '+L(') или выполнить только синтез моделей.') @3, 2 DCSAY mMess PARENT oGroup11 FONT '9.Arial Bold' COLOR BD_CANDYRED SAYSIZE 0 ELSE mMess = L('В примении бутстрепного подхода нет необходимости. Синтез и верификация моделей будут выполнены на основе всей выборки.') @3, 2 DCSAY mMess PARENT oGroup11 SAYSIZE 0 ENDIF * MsgBox(STR(mRSVMD*N_Obj*10*2 + mHVMO)+' '+STR(2*1024^3)) ********************************************************************************* DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; OPTIONS GetOptions ; ADDBUTTONS; MODAL ; TITLE mTitleName ***************************************************************** 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 ***************************************************************** mPerDel = IF(mPerDel > 0, mPerDel, 0) * IF mPerDel > mPerDelMax // Если пользователь увеличил % остающихся результатов распознавания, то не делать этого, т.к. посчитано уже максимальное количество * mPerDel = mPerDelMax * aMess := {} * AADD(aMess, '% остающихся результатов распознавания остается ') * AADD(aMess, 'расчетным, т.к. может его можно только уменьшать') * LB_Warning(aMess, L('4.1.2. Пакетное распознавание')) * ENDIF StrFile(ALLTRIM(STR(mPerDel,17,7)),'_PerDel.txt') ENDIF StrFile(ALLTRIM(STR(nRadioModel)), '_Calc_model_2nd_level.txt') * mModel_2nd_level = VAL(FileStr('_Calc_model_2nd_level.txt')) // = 1 - создавать только базовые модели, иначе - создавать модели 2-го или 3-го уровней mModel_2nd_level = nRadioModel aParModel := {} AADD(aParModel, nRadioModel) AADD(aParModel, nRadModelCr) DC_ASave(aParModel, "_ParModel.arx") * aParModel := DC_ARestore("_ParModel.arx") * 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 **** Сделать разные наименования частных критериев при разных способах нормализации как в функции Calc_model_2nd_level() <<<===########################## // Полные наименования базовых стат.моделей и моделей знаний IF nRadioModel = 1 aModFullNm := {L('1. ABS_basic_level - частный критерий: количество встреч сочетаний: "класс-признак" у объектов обуч.выборки'),; L('2. PRC1_basic_level - частный критерий: усл. вероятность i-го признака среди признаков объектов j-го класса '),; L('3. PRC2_basic_level - частный критерий: условная вероятность i-го признака у объектов j-го класса '),; L('4. INF1_basic_level - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC1 '),; L('5. INF2_basic_level - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC2 '),; L('6. INF3_basic_level - частный критерий: Xи-квадрат, разности между фактическими и ожидаемыми абс.частотами '),; L('7. INF4_basic_level - частный критерий: ROI (Return On Investment); вероятности из PRC1 '),; L('8. INF5_basic_level - частный критерий: ROI (Return On Investment); вероятности из PRC2 '),; L('9. INF6_basic_level - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC1 '),; L('10.INF7_basic_level - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC2 ') } ELSE DO CASE CASE nRadModelCr = 1 // дисперсия, сравнение путем вычитания aModFullNm := {'1. ABS_' +ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - дисп.,сравн.пут.вычит.: кол.вст.соч.: "класс-признак" у объектов обуч.выборки'),; '2. PRC1_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - дисп.,сравн.пут.вычит.: усл.вер.i-го призн.среди призн.объектов j-го класса '),; '3. PRC2_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - дисп.,сравн.пут.вычит.: усл.вероятность i-го признака у объектов j-го класса '),; '4. INF1_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - дисп.,сравн.пут.вычит.: количество знаний по А.Харкевичу; вероятности из PRC1'),; '5. INF2_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - дисп.,сравн.пут.вычит.: количество знаний по А.Харкевичу; вероятности из PRC2'),; '6. INF3_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - дисп.,сравн.пут.вычит.: Xи-квадрат, разности между факт.и ожид.абс.частотами '),; '7. INF4_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - дисп.,сравн.пут.вычит.: ROI (Return On Investment); вероятности из PRC1 '),; '8. INF5_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - дисп.,сравн.пут.вычит.: ROI (Return On Investment); вероятности из PRC2 '),; '9. INF6_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - дисп.,сравн.пут.вычит.: разн.усл.и безусл.вероятностей; вероятности из PRC1 '),; '10.INF7_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - дисп.,сравн.пут.вычит.: разн.усл.и безусл.вероятностей; вероятности из PRC2 ') } CASE nRadModelCr = 2 // дисперсия, сравнение путем деления aModFullNm := {'1. ABS_' +ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - дисп.,сравн.пут.дел.: кол.вст.соч.: "класс-признак" у объектов обуч.выборки'),; '2. PRC1_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - дисп.,сравн.пут.дел.: усл.вер.i-го призн.среди призн.объектов j-го класса '),; '3. PRC2_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - дисп.,сравн.пут.дел.: усл.вероятность i-го признака у объектов j-го класса '),; '4. INF1_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - дисп.,сравн.пут.дел.: количество знаний по А.Харкевичу; вероятности из PRC1'),; '5. INF2_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - дисп.,сравн.пут.дел.: количество знаний по А.Харкевичу; вероятности из PRC2'),; '6. INF3_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - дисп.,сравн.пут.дел.: Xи-квадрат, разности между факт.и ожид.абс.частотами '),; '7. INF4_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - дисп.,сравн.пут.дел.: ROI (Return On Investment); вероятности из PRC1 '),; '8. INF5_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - дисп.,сравн.пут.дел.: ROI (Return On Investment); вероятности из PRC2 '),; '9. INF6_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - дисп.,сравн.пут.дел.: разн.усл.и безусл.вероятностей; вероятности из PRC1 '),; '10.INF7_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - дисп.,сравн.пут.дел.: разн.усл.и безусл.вероятностей; вероятности из PRC2 ') } CASE nRadModelCr = 3 // среднее, сравнение путем вычитания aModFullNm := {'1. ABS_' +ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - средн.,сравн.пут.вычит.: кол.вст.соч.: "класс-признак" у объектов обуч.выборки'),; '2. PRC1_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - средн.,сравн.пут.вычит.: усл.вер.i-го призн.среди призн.объектов j-го класса '),; '3. PRC2_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - средн.,сравн.пут.вычит.: усл.вероятность i-го признака у объектов j-го класса '),; '4. INF1_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - средн.,сравн.пут.вычит.: количество знаний по А.Харкевичу; вероятности из PRC1'),; '5. INF2_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - средн.,сравн.пут.вычит.: количество знаний по А.Харкевичу; вероятности из PRC2'),; '6. INF3_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - средн.,сравн.пут.вычит.: Xи-квадрат, разности между факт.и ожид.абс.частотами '),; '7. INF4_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - средн.,сравн.пут.вычит.: ROI (Return On Investment); вероятности из PRC1 '),; '8. INF5_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - средн.,сравн.пут.вычит.: ROI (Return On Investment); вероятности из PRC2 '),; '9. INF6_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - средн.,сравн.пут.вычит.: разн.усл.и безусл.вероятностей; вероятности из PRC1 '),; '10.INF7_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - средн.,сравн.пут.вычит.: разн.усл.и безусл.вероятностей; вероятности из PRC2 ') } CASE nRadModelCr = 4 // среднее, сравнение путем деления aModFullNm := {'1. ABS_' +ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - средн.,сравн.пут.дел.: кол.вст.соч.: "класс-признак" у объектов обуч.выборки'),; '2. PRC1_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - средн.,сравн.пут.дел.: усл.вер.i-го призн.среди призн.объектов j-го класса '),; '3. PRC2_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - средн.,сравн.пут.дел.: усл.вероятность i-го признака у объектов j-го класса '),; '4. INF1_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - средн.,сравн.пут.дел.: количество знаний по А.Харкевичу; вероятности из PRC1'),; '5. INF2_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - средн.,сравн.пут.дел.: количество знаний по А.Харкевичу; вероятности из PRC2'),; '6. INF3_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - средн.,сравн.пут.дел.: Xи-квадрат, разности между факт.и ожид.абс.частотами '),; '7. INF4_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - средн.,сравн.пут.дел.: ROI (Return On Investment); вероятности из PRC1 '),; '8. INF5_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - средн.,сравн.пут.дел.: ROI (Return On Investment); вероятности из PRC2 '),; '9. INF6_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - средн.,сравн.пут.дел.: разн.усл.и безусл.вероятностей; вероятности из PRC1 '),; '10.INF7_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - средн.,сравн.пут.дел.: разн.усл.и безусл.вероятностей; вероятности из PRC2 ') } CASE nRadModelCr = 5 // средн.модуль отклон.от средн. (среднее абсолютное отклонение), Mean Absolute Deviation (MAD), сравн.путем вычит. aModFullNm := {'1. ABS_' +ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - MAD.,сравн.пут.вычит.: кол.вст.соч.: "класс-признак" у объектов обуч.выборки'),; '2. PRC1_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - MAD.,сравн.пут.вычит.: усл.вер.i-го призн.среди призн.объектов j-го класса '),; '3. PRC2_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - MAD.,сравн.пут.вычит.: усл.вероятность i-го признака у объектов j-го класса '),; '4. INF1_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - MAD.,сравн.пут.вычит.: количество знаний по А.Харкевичу; вероятности из PRC1'),; '5. INF2_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - MAD.,сравн.пут.вычит.: количество знаний по А.Харкевичу; вероятности из PRC2'),; '6. INF3_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - MAD.,сравн.пут.вычит.: Xи-квадрат, разности между факт.и ожид.абс.частотами '),; '7. INF4_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - MAD.,сравн.пут.вычит.: ROI (Return On Investment); вероятности из PRC1 '),; '8. INF5_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - MAD.,сравн.пут.вычит.: ROI (Return On Investment); вероятности из PRC2 '),; '9. INF6_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - MAD.,сравн.пут.вычит.: разн.усл.и безусл.вероятностей; вероятности из PRC1 '),; '10.INF7_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - MAD.,сравн.пут.вычит.: разн.усл.и безусл.вероятностей; вероятности из PRC2 ') } CASE nRadModelCr = 6 // средн.модуль отклон.от средн., сравн.путем делен. aModFullNm := {'1. ABS_' +ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - MAD.,сравн.пут.дел.: кол.вст.соч.: "класс-признак" у объектов обуч.выборки'),; '2. PRC1_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - MAD.,сравн.пут.дел.: усл.вер.i-го призн.среди призн.объектов j-го класса '),; '3. PRC2_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - MAD.,сравн.пут.дел.: усл.вероятность i-го признака у объектов j-го класса '),; '4. INF1_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - MAD.,сравн.пут.дел.: количество знаний по А.Харкевичу; вероятности из PRC1'),; '5. INF2_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - MAD.,сравн.пут.дел.: количество знаний по А.Харкевичу; вероятности из PRC2'),; '6. INF3_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - MAD.,сравн.пут.дел.: Xи-квадрат, разности между факт.и ожид.абс.частотами '),; '7. INF4_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - MAD.,сравн.пут.дел.: ROI (Return On Investment); вероятности из PRC1 '),; '8. INF5_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - MAD.,сравн.пут.дел.: ROI (Return On Investment); вероятности из PRC2 '),; '9. INF6_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - MAD.,сравн.пут.дел.: разн.усл.и безусл.вероятностей; вероятности из PRC1 '),; '10.INF7_'+ALLTRIM(STR(nRadioModel))+'nd_level_'+aTypeModel[nRadModelCr]+L(' - MAD.,сравн.пут.дел.: разн.усл.и безусл.вероятностей; вероятности из PRC2 ') } ENDCASE ENDIF DC_ASave(aModFullNm, "_aModFullNm.arx") // Наименования создаваемых моделей для режима 3.4 * aModFullNm = DC_ARestore("_aModFullNm.arx") StrFile(ALLTRIM(STR(mAlgorithm,1)),'_Algorithm.txt') StrFile(ALLTRIM(STR(mVisualization,1)),'_Visualization.txt') StrFile(ALLTRIM(STR(mFonAbs,19,7)),'_FonAbs.txt') *mFonAbs = VAL(FileStr('_FonAbs.txt')) mProcessor = IF(nRadioP=1,'CPU','GPU') // <<<===################### IF mSintRec = 'Sint' nRadioM = 3 ENDIF IF mSintRec = 'SintPython' nRadioM = 4 ENDIF *IF mProcessor = 'GPU' // Синтез и распознавание на GPU - параметры задаются фиксированные * DO CASE * CASE mSintRec = 'Sint' * nRadioM = 3 * CASE mSintRec = 'Rec' * nRadioM = 2 * CASE mSintRec = 'SintRec' * nRadioM = 1 * ENDCASE * AFILL(aVerifInf, .T.) // Все модели * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * USE Obi_Zag EXCLUSIVE NEW * mN1 = 1 * mN2 = RECCOUNT() * nRadio1 := 1 // Копировать всю обучающую выборку * nRadio2 := 1 // Не удалять скопированные в распознаваемую выборку объекты обучающей выборки * nRadio3 := 1 // Стирать расп.выборку перед копированием * nRadioP := 2 // Расчеты проводить на графическом процессоре (GPU) * N_CopyObj = 0 // Даже на GPU не всегда надо распознавать все объекты *ENDIF IF nRadio1 = 5 // Копировать все объекты от N1 до N2 IF mN2 < mN1 LB_Warning(L("Неверно задан диапазон объектов для верификации модели: N1 должен быть <= N2 !"),L('3.5. Выбор моделей для синтеза и верификации')) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ENDIF DC_ASave(M_CurrInf, "_CurrInf.arx") Pos = ASCAN(aVerifInf, .T.) IF Pos > 0 .AND. M_CurrInf > 0 * M_CurrInf = Pos ELSE LB_Warning(L("Необходимо задать хотя бы одну модель для расчета и верификации!"),L('3.5. Выбор моделей для синтеза и верификации')) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF DC_ASave(aVerifInf , "_VerifInf.arx") // Файл с информацией о том, создание каких моделей было задано ***************************************************************************************************** oScr := DC_WaitOn(L('Немного подождите. Идет подготовка к ЗАГРУЗКЕ мастера подготовки ЗАПУСКА мастера подготовки ИСПОЛНЕНИЯ режима синтеза и верификации моделей !!!')) Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } M_Inf = UPPER(Ar_Model[M_CurrInf]) PUBLIC a1 := 0, b1 := 0, c1 := 0 // Процесс синтеза и верификации заданных моделей ***************************************************************************************************** ***************************************************************************************************** // Подготовка данных для отображения графического прогресс-бар // Определить значение Wsego IF ApplChange("") // Перейти в папку выбранного приложения или выйти из системы DC_Impl(oScr) // Немного подождите. Идет подготовка к синтезу и верификации моделей LB_Warning(L("Необходимо задать (выбрать) хотя бы одно текущее приложение !!!")) Running(.F.) RETURN NIL ENDIF // Переиндексация БД приложения GenNtxClass() // Классификационные шкалы и градации GenNtxOpSc() // Описательные шкалы GenNtxGrOpSc() // Градации описательных шкал GenNtxObiZag() // Заголовки объектов обучающей выборки GenNtxObiKcl() // Коды классов объектов обучающей выборки GenNtxObiKpr() // Коды признаков объектов обучающей выборки IF nRadio1 <> 6 GenNtxRsoZag() // Заголовки объектов распознаваемой выборки GenNtxRsoKcl() // Коды классов объектов распознаваемой выборки GenNtxRsoKpr() // Коды признаков объектов распознаваемой выборки ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Opis_Sc EXCLUSIVE NEW;N_Osc = RECCOUNT() USE Gr_OpSc EXCLUSIVE NEW;N_Gos = RECCOUNT() USE Obi_Zag INDEX Obi_Zag EXCLUSIVE NEW;N0_ObiZag = RECCOUNT() USE Obi_Kcl INDEX Obi_Kcl EXCLUSIVE NEW;N0_ObiKcl = RECCOUNT() USE Obi_Kpr INDEX Obi_Kpr EXCLUSIVE NEW;N0_ObiKpr = RECCOUNT() USE Rso_Zag INDEX Rso_Zag EXCLUSIVE NEW USE Rso_Kcl INDEX Rso_Kcl EXCLUSIVE NEW USE Rso_Kpr INDEX Rso_Kpr EXCLUSIVE NEW Flag = .F. IF N0_ObiZag = 0 LB_Warning(L("База данных заголовков объектов обучающей выборки пуста !!!")) Flag = .T. ENDIF IF N0_ObiKcl = 0 LB_Warning(L("База данных кодов классов объектов обучающей выборки пуста !!!")) Flag = .T. ENDIF IF N0_ObiKpr = 0 LB_Warning(L("База данных кодов признаков объектов обучающей выборки пуста !!!")) Flag = .T. ENDIF IF Flag DC_Impl(oScr) // Немного подождите. Идет подготовка к синтезу и верификации моделей Running(.F.) RETURN NIL ENDIF // Подготовка данных для отображения графического прогресс-бар // Определить значение Wsego Ar_RndObj := {} DO CASE CASE nRadio1 = 1 // Копировать всю обучающую выборку ######################## SELECT Obi_zag;N_ObiZag = RECCOUNT() SET FILTER TO DBGOTOP();DBGOBOTTOM();DBGOTOP() SELECT Obi_Kcl;N_ObiKcl = RECCOUNT() SET FILTER TO DBGOTOP();DBGOBOTTOM();DBGOTOP() SELECT Obi_Kpr;N_ObiKpr = RECCOUNT() SET FILTER TO DBGOTOP();DBGOBOTTOM();DBGOTOP() DC_Impl(oScr) // Немного подождите. Идет подготовка к синтезу и верификации моделей CASE nRadio1 = 2 // Копировать только текущий объект SELECT Obi_zag SET FILTER TO M_KodObj = Kod_obj DBGOTOP();DBGOBOTTOM();DBGOTOP() COUNT TO N_ObiZag SELECT Obi_Kcl SET FILTER TO M_KodObj = Kod_obj DBGOTOP();DBGOBOTTOM();DBGOTOP() COUNT TO N_ObiKcl SELECT Obi_Kpr SET FILTER TO M_KodObj = Kod_obj DBGOTOP();DBGOBOTTOM();DBGOTOP() COUNT TO N_ObiKpr DC_Impl(oScr) // Немного подождите. Идет подготовка к синтезу и верификации моделей CASE nRadio1 = 3 // Копировать каждый N-й объект ############################ не работает IF 0 < N_CopyObj .AND. N_CopyObj <= N0_ObiZag SELECT Obi_zag // Если код объекта обуч.выборки нацело делится на N_CopyObj, то копировать этот объект SET FILTER TO Kod_obj = N_CopyObj*INT(Kod_obj/N_CopyObj) DBGOTOP();DBGOBOTTOM();DBGOTOP() COUNT TO N_ObiZag SELECT Obi_Kcl // Если код объекта обуч.выборки нацело делится на N_CopyObj, то копировать этот объект SET FILTER TO Kod_obj = N_CopyObj*INT(Kod_obj/N_CopyObj) DBGOTOP();DBGOBOTTOM();DBGOTOP() COUNT TO N_ObiKcl SELECT Obi_Kpr // Если код объекта обуч.выборки нацело делится на N_CopyObj, то копировать этот объект SET FILTER TO Kod_obj = N_CopyObj*INT(Kod_obj/N_CopyObj) DBGOTOP();DBGOBOTTOM();DBGOTOP() COUNT TO N_ObiKpr ELSE Mess = L("Каждый N-й объект обуч.выборки: это значит каждый 2-й, 3-й, ..., N-й, где N<=# !!!") Mess = STRTRAN(Mess,"#", ALLTRIM(STR(N0_ObiZag,19))) LB_Warning(Mess) ENDIF DC_Impl(oScr) // Немного подождите. Идет подготовка к синтезу и верификации моделей CASE nRadio1 = 4 // Копировать N случайных объектов (по-другому отобр.прогн.времени исп.) // Сформировать массив кодов случайных объектов обучающей выборки без повторов из N элементов DC_Impl(oScr) // Немного подождите. Идет подготовка к синтезу и верификации моделей oScr := DC_WaitOn(L('Формирование массива случайных кодов объектов обучающей выборки без повторов из')+' '+ALLTRIM(STR(N_CopyObj))+' '+L('элементов'),,,,,,,,,,,.F.) mNumPP = 0 DO WHILE LEN(Ar_RndObj) < N_CopyObj // В массиве еще нет N_CopyObj элементов? <<<===################# по сути зависает при большом числе объектов N_CopyObj mNumPP++ // Случайный номер записи от 1 до N0_ObiZag (N0_ObiZag - кол-во объектов обуч.выборки). ОЧЕНЬ ХОРОШИЙ ГЕНЕРАТОР СЛУЧАЙНЫХ ЧИСЕЛ С ВНЕШНИМ ИСТОЧНИКОМ ЭНТРОПИИ <<<== mTime = ALLTRIM(STR(SECONDS()*100)) // Текущее время в сотых долях секунды от начала суток mTime = SUBSTR(mTime,1,AT('.',mTime)-1) mNormT = VAL(SUBSTR(mTime,LEN(mTime)-2,3)) // Три последних знака текущего времени mNormR = RANDOM()%999 M_KodObj = 1+INT((mNormT*mNormR)/998001*N0_ObiZag) // Нормировка текущего времени от 1 до N0_ObiZag * MsgBox(STR(mNumPP)+', mTime='+mTime+', mNormT='+ALLTRIM(STR(mNormT,9))+', mNormR='+ALLTRIM(STR(mNormR,9))+', M_KodObj='+ALLTRIM(STR(M_KodObj))) IF ASCAN(Ar_RndObj, M_KodObj) = 0 // Номер этого объекта еще не разыгрывался? AADD (Ar_RndObj, M_KodObj) ENDIF ENDDO ASORT(Ar_RndObj) DC_Impl(oScr) * DC_DebugQout( Ar_RndObj ) K_cls = N0_ObiKcl / N0_ObiZag // Сколько строк в БД кодов классов приходится в среднем на один объект обуч.выборки K_gos = N0_ObiKpr / N0_ObiZag // Сколько строк в БД кодов признаков приходится в среднем на один объект обуч.выборки N_ObiZag = N_CopyObj // Количество случайно выбранных объектов N_ObiKcl = K_cls * N_CopyObj // Оценка числа записей в БД кодов классов, приходящихся на случайно выбранные объекты N_ObiKpr = K_gos * N_CopyObj // Оценка числа записей в БД кодов признаков, приходящихся на случайно выбранные объекты CASE nRadio1 = 5 // Копировать все объекты в диапазоне от N1 до N2 <<<===############## SELECT Obi_zag DBGOTO(mN1);M_KodObj1 = Kod_obj DBGOTO(mN2);M_KodObj2 = Kod_obj SET FILTER TO M_KodObj1 <= Kod_Obj .AND. Kod_Obj <= M_KodObj2 DBGOTOP();DBGOBOTTOM();DBGOTOP() COUNT TO N_ObiZag SELECT Obi_Kcl SET FILTER TO M_KodObj1 <= Kod_Obj .AND. Kod_Obj <= M_KodObj2 DBGOTOP();DBGOBOTTOM();DBGOTOP() COUNT TO N_ObiKcl SELECT Obi_Kpr SET FILTER TO M_KodObj1 <= Kod_Obj .AND. Kod_Obj <= M_KodObj2 DBGOTOP();DBGOBOTTOM();DBGOTOP() COUNT TO N_ObiKpr DC_Impl(oScr) // Немного подождите. Идет подготовка к синтезу и верификации моделей CASE nRadio1 = 6 // Не менять распознаваемую выборку SELECT Rso_zag;N_ObiZag = RECCOUNT() SET FILTER TO DBGOTOP();DBGOBOTTOM();DBGOTOP() SELECT Rso_Kcl;N_ObiKcl = RECCOUNT() SET FILTER TO DBGOTOP();DBGOBOTTOM();DBGOTOP() SELECT Rso_Kpr;N_ObiKpr = RECCOUNT() SET FILTER TO DBGOTOP();DBGOBOTTOM();DBGOTOP() DC_Impl(oScr) // Немного подождите. Идет подготовка к синтезу и верификации моделей ENDCASE DO CASE CASE nRadio3 = 1 // Стирать расп.выборку перед копированием IF nRadio1 <> 6 SELECT Rso_Zag;ZAP SELECT Rso_Kcl;ZAP SELECT Rso_Kpr;ZAP M_MaxKodObj = 0 ELSE SELECT Rso_zag DBGOBOTTOM() M_MaxKodObj = Kod_Obj ENDIF CASE nRadio3 = 2 // Дополнять расп.выборку SELECT Rso_zag DBGOBOTTOM() M_MaxKodObj = Kod_Obj ENDCASE Ar_KodObjOld := {} // Коды объектов исходной выборки Ar_KodObjNew := {} // Коды объектов результирующей выборки // Перенести информацию о заданных для верификации моделях в файл о моделях для рассчета // и посчитать, сколько моделей задано для расчета и верификации PUBLIC aCalcInf[LEN(aVerifInf)] N_ModAll = 0 FOR j=1 TO LEN(aVerifInf) aCalcInf[j] = aVerifInf[j] M_ModAll = IF(aVerifInf[j],++N_ModAll,N_ModAll) // Inf# NEXT DC_ASave(aCalcInf , "_CalcInf.arx") // Файл с информацией о том, создание каких моделей было задано * LB_Warning(STR(N_ModAll,19)) // Progress_bar сдвигать столько раз, сколько операций выполняется с N_ModAll моделями K=IF(nRadioM = 1, 1, 0) // Расчет "Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" * Wsego = 1 + N_ModAll*K + N_ModAll + N_ModAll + 2*N_ModAll + N_ModAll + 1 + 2*N_ModAll * Copy Расчет Сделать Провести Верификация Объединение Печать Расчет достоверности * Oi->Ro моделей текущей распознав. для 2 инт.кр БД DostRsp# форм по классам DO CASE CASE nRadioM = 1 // Синтез и верификация статистических и системно-когнитивных моделей Wsego = 1 + N_ModAll*K + N_ModAll + N_ModAll + 2*N_ModAll + 1 + 1 + 1 + 2 + 1 * Copy Расчет Сделать Провести Верификация Объединение Печать Расчет достоверности Запись диапазонов Присвоение * Oi->Ro моделей текущей распознав. для 2 инт.кр БД DostRsp# форм по классам кодов градаций заданной модели * кл.и оп.шкал статуса текущей CASE nRadioM = 2 // Верификация заданных статистических и системно-когнитивных моделей Wsego = 0 + 0 + N_ModAll + N_ModAll + 2*N_ModAll + 1 + 1 + 1 + 2 + 1 * Copy Расчет Сделать Провести Верификация Объединение Печать Расчет достоверности Запись диапазонов Присвоение * Oi->Ro моделей текущей распознав. для 2 инт.кр БД DostRsp# форм по классам кодов градаций заданной модели * кл.и оп.шкал статуса текущей IF nRadioM <> 6 // Копировать обучающую выборку в распознаваемую Wsego = Wsego + 1 ENDIF CASE nRadioM = 3 // Синтез заданных статистических и системно-когнитивных моделей на xBase++ Wsego = 0 + N_ModAll*K + N_ModAll + 0 + 0 + 0 + 0 + 0 + 0 + 1 * Copy Расчет Сделать Провести Верификация Объединение Печать Расчет достоверности Запись диапазонов Присвоение * Oi->Ro моделей текущей распознав. для 2 инт.кр БД DostRsp# форм по классам кодов градаций заданной модели * кл.и оп.шкал статуса текущей CASE nRadioM = 4 // Синтез заданных статистических и системно-когнитивных моделей на Питоне Razrab() Running(.F.) RETURN NIL ENDCASE IF mRegim <> '3.7.9' * MsgBox(mRegim) // Отображение стадии исполнения. Будет написано прямо в окне Progress-bar d = 0 @ 0,0 DCGROUP oGroup1 CAPTION L('Стадии исполнения процесса') FONT "6.Helv" SIZE 105+d,19.5 PARENT oTabPage1 @21,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" // 1. Копирование всей обучающей выборки в распознаваемую @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 2] FONT "10.Helv" // 2. Расчет стат.модели ABS @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 3] FONT "10.Helv" // 3. Расчет стат.моделей PRC1 и PRC2 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 4] FONT "10.Helv" // 4. Расчет моделей знаний INF-1INF7 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 5] FONT "10.Helv" // Начало цикла по частным и интегральным критериям---- @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 6] FONT "10.Helv" // 5. Задание модели № M_NumMod в качестве текущей @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 7] FONT "10.Helv" // 6. Пакетное распознавание в модели № M_NumMod @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 8] FONT "10.Helv" // 7. Измерение достоверности модели: № M_NumMod @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 9] FONT "10.Helv" // Конец цикла по частным и интегральным критериям---- @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[10] FONT "10.Helv" // 8. Объединение БД DostRsp# в БД DostRasp @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[11] FONT "10.Helv" // 9. Печать сводной формы по результатам верификации моделей @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[12] FONT "10.Helv" // 10.Запись информации о верифицированных моделях @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[13] FONT "10.Helv" // 11.Этапы распознавания @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[14] FONT "10.Helv" // 12.Сделать заданную модель текущей @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[15] FONT "10.Helv" // 13. @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[16] FONT "10.Helv" // 14. @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[17] FONT "10.Helv" // 15. @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[18] FONT "10.Helv" // 16. 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() ENDIF ***************************************************************************************************** Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } M_Inf = UPPER(Ar_Model[M_CurrInf]) // Начало отсчета времени для прогнозирования длительности исполнения 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 IF nRadio1 = 6 .OR. nRadioM = 3 **** Копировать не надо IF mRegim <> '3.7.9' aSay[ 1]:SetCaption(L('Шаг 1-й из 11: Копирование обуч.выборки в расп. Этот шаг при заданных опциях пропускается')) ENDIF ELSE IF mRegim <> '3.7.9' aSay[ 1]:SetCaption(L('ШАГ 1-Й ИЗ 11: КОПИРОВАНИЕ ОБУЧАЮЩЕЙ ВЫБОРКИ В РАСПОЗНАВАЕМУЮ - ИСПОЛНЕНИЕ:')) ENDIF GenNtxObiZag() // Заголовки объектов обучающей выборки GenNtxObiKcl() // Коды классов объектов обучающей выборки GenNtxObiKpr() // Коды признаков объектов обучающей выборки // А если расп.выборки вообще не было, а задано ее дополнять? Режим дополнения расп.выборки надо закрыть IF nRadio1 <> 6 .AND. nRadio1 <> 1 GenDbfRsoZag() // Заголовки объектов распознаваемой выборки GenDbfRsoKcl() // Коды классов объектов распознаваемой выборки GenDbfRsoKpr() // Коды признаков объектов распознаваемой выборки ENDIF // Копирование обучающей выборки в распознаваемую в заданном режиме // с предварительным стиранием расп.выборки (без диалога) IF nRadio1 <> 6 CopyOiRo(.F., nRadio1, nRadio2, nRadio3, "3_5", mN1, mN2) // <<<===################## ENDIF * IF nRadio1 = 1 .AND. nRadio2 = 1 .AND. nRadio3 = 1 ** oScr := DC_WaitOn(L('Идет процесс копирования обучающей выборки в распознаваемую. Немного подождите!')) * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * COPY FILE ("Obi_Zag.dbf") TO ("Rso_Zag.dbf") * COPY FILE ("ObI_Kcl.dbf") TO ("Rso_Kcl.dbf") * COPY FILE ("Obi_Kpr.dbf") TO ("Rso_Kpr.dbf") ** DC_Impl(oScr) * ENDIF IF mRegim <> '3.7.9' aSay[ 1]:SetCaption(L("Шаг 1-й из 11: Копирование обучающей выборки в распознаваемую - Готово")) ENDIF ENDIF GenDbfDostModCls() // Создать БД для измерения достоверности моделей GenDbfDostModObj() // Создать БД для измерения достоверности моделей IF mRegim <> '3.7.9' lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) ENDIF *############################################################################################################################### * СИНТЕЗ МОДЕЛЕЙ НА CPU. ЗДЕСЬ СДЕЛАТЬ ВАРИАНТ СИНТЕЗА МОДЕЛЕЙ НА GPU. ВЫБОР ПО ПАРАМЕТРУ, ЗАДАННОМУ ПРИ ОБРАЩЕНИИ К F3_5() *############################################################################################################################### *MsgBox(mProcessor) IF nRadioM <> 2 // Расчет "Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } IF mCurrMod > 0 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('Перед запуском данного режима с копированием модели: "')+Ar_Model[mCurrMod]+L('.txt" в модель "Abs.txt"')) 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 ENDIF DO CASE CASE mProcessor = 'CPU' // ********************************************************** IF aVerifInf[1] // Если модель N Num_mod задана для верификации FOR j=2 TO 18;aSay[j]:SetCaption(L(" "));NEXT IF mRegim <> '3.7.9' DO CASE CASE mCurrMod = 0 // Как раньше рассчитывать модель ABS на основе обучающей выборки aSay[ 2]:SetCaption(L('ШАГ 2-Й ИЗ 11: СИНТЕЗ СТАТ.МОДЕЛИ "ABS" (РАСЧЕТ МАТРИЦЫ АБСОЛЮТНЫХ ЧАСТОТ) - ИСПОЛНЕНИЕ:')) Time_Progress = F3_1CPU(.F., Time_Progress, Wsego, oProgress, lOk, "3_5" ) // Расчет Abs.dbf lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) aSay[ 2]:SetCaption(L('Шаг 2-й из 11: Синтез стат.модели "ABS" (расчет матрицы абсолютных частот) - Готово')) CASE mCurrMod = 1 // Источником данных является модель ABS, т.е. ее не надо рассчитывать, а все остальные модели рассчитывать как раньше, т.е. когда mCurrMod= 0 mMess = 'ШАГ 2-Й ИЗ 11: ИСТОЧНИКОМ ДАННЫХ ЯВЛЯЕТСЯ МОДЕЛЬ "ABS", Т.Е. ЕЕ НЕ НАДО РАССЧИТЫВАТЬ:' // Если она существует aSay[ 2]:SetCaption(L(mMess)) lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) mMess = 'Шаг 2-й из 11: Источником данных является модель "ABS", ее не надо рассчитывать - Готово' aSay[ 2]:SetCaption(L(mMess)) CASE mCurrMod >= 2 // Источником данных является модель Prc1, т.е. надо скопировать Prc1=>ABS, а все остальные модели рассчитывать как раньше Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } mModel = Ar_Model[mCurrMod]+'.txt' mMess = 'ШАГ 2-Й ИЗ 11: КОПИРОВАНИЕ СТАТ.МОДЕЛИ "'+mModel+'" В СТАТ.МОДЕЛИ "ABS" - ИСПОЛНЕНИЕ:' aSay[ 2]:SetCaption(L(mMess)) COPY FILE (mModel) TO ("Abs.txt") lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) mMess = 'Шаг 2-й из 11: Копирование стат.модели "'+mModel+'" в стат.модель "ABS" - Готово' aSay[ 2]:SetCaption(L(mMess)) ENDCASE ENDIF ENDIF IF aVerifInf[2] .OR. aVerifInf[3] // Если модель N Num_mod задана для верификации FOR j=3 TO 18;aSay[j]:SetCaption(L(" "));NEXT IF mRegim <> '3.7.9' aSay[ 3]:SetCaption(L('ШАГ 3-Й ИЗ 11: СИНТЕЗ СТАТ.МОДЕЛЕЙ "PRC1" И "PRC2" (УСЛ.БЕЗУСЛ.% РАСПР.) - ИСПОЛНЕНИЕ:')) Time_Progress = F3_2CPU(.F., Time_Progress, Wsego, oProgress, lOk, "3_5" ) // Расчет Prc1.dbf b Prc2.dbf lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) aSay[ 3]:SetCaption(L('Шаг 3-й из 11: Синтез стат.моделей "PRC1" и "PRC2" (усл.безусл.% распр.) - Готово')) ENDIF ENDIF Flag_Inf = .F. // Определить, задана хотя бы одна модель знаний для расчета и верификации FOR j=4 TO 10 IF aVerifInf[j] Flag_Inf = .T. ENDIF NEXT IF Flag_Inf FOR j=4 TO 18;aSay[j]:SetCaption(L(" "));NEXT IF mRegim <> '3.7.9' aSay[ 4]:SetCaption(L('ШАГ 4-Й ИЗ 11: СИНТЕЗ МОДЕЛЕЙ ЗНАНИЙ: INF1-INF7 - ИСПОЛНЕНИЕ:')) Time_Progress = F3_3CPU(.F., Time_Progress, Wsego, oProgress, lOk, "3_5" ) // Расчет баз знаний Inf1.dbf, Inf2.dbf, Inf3.dbf, Inf4.dbf, Inf5.dbf, Inf6.dbf, Inf7.dbf FOR j=4 TO 10 IF aVerifInf[j] lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) ENDIF NEXT aSay[ 4]:SetCaption(L('Шаг 4-й из 11: Синтез моделей знаний: INF1-INF7 - Готово')) ENDIF ENDIF CASE mProcessor = 'GPU' // ********************************************************** ****** Обработка ошибки ****************** bError := ErrorBlock( {|e| Break(e)} ) // установить новый кодовый блок обработки ошибок BEGIN SEQUENCE // код нормального исполнения *** код нормального исполнения ****** Формирование и запись txt-файла параметров модуля синтеза моделей ************************* cFile = "Model_sint_settings.txt" // <===######################################################## aPar := {} * 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,'_') 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) ************************************************************************************************** * Отразить нужные aSay[] IF mRegim <> '3.7.9' aSay[ 2]:SetCaption(L('ШАГ 2-Й ИЗ 11: СИНТЕЗ СТАТ.МОДЕЛИ "ABS" (РАСЧЕТ МАТРИЦЫ АБСОЛЮТНЫХ ЧАСТОТ) - ИСПОЛНЕНИЕ:')) aSay[ 3]:SetCaption(L('ШАГ 3-Й ИЗ 11: СИНТЕЗ СТАТ.МОДЕЛЕЙ "PRC1" И "PRC2" (УСЛ.БЕЗУСЛ.% РАСПР.) - ИСПОЛНЕНИЕ:')) aSay[ 4]:SetCaption(L('ШАГ 4-Й ИЗ 11: СИНТЕЗ СИСТЕМНО-КОГНИТИВНЫХ МОДЕЛЕЙ: INF1-INF7 - ИСПОЛНЕНИЕ:')) ENDIF LC_RunShell("Model_sint.exe", 89882657) // Модуль синтеза моделей *########################################################################################## *** ИСПРАВИТЬ МОДЕЛЬ PRC2, посчитанную на GPU: КАК В F3_2CPU (НА СТР.14011) *** <<<===#####, в т.ч. добавить 4-ю строку из Abs.txt во ВСЕ остальные модели *########################################################################################## * 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 10 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 * DC_Impl(oScr) * oScr := DC_WaitOn(L('Дорасчет всех моделей Prc#, Inf#. Немного подождите'),,,,,,,,,,,.F.) IF NObj > 0 FOR z=1 TO LEN(Ar_Model) *** Запись 4-й строки из Abs, Prc# и Inf# LC_FieldPut( Ar_Model[z]+".txt", nHandle[z], N_Gos+4, 2, "Сумма числа объектов обуч.выборки" ) // Для того, чтобы можно было копировать модели в Abs как файлы FOR j=1 TO N_Cls // №10, N_Cls ############################### NObj_j = VAL(LC_FieldGet( Ar_Model[1]+".txt", nHandle[1], N_Gos+4, 2+j )) // Сумма NObj_j из Abs.txt IF NObj_j <> 0 String = STR(NObj_j , aInfStruct[2+j,3], aInfStruct[2+j,4] ) LC_FieldPut( Ar_Model[z]+".txt", nHandle[z], N_Gos+4, 2+j, String ) ENDIF NEXT // Summa количества Obj по всей БД Abs.dbf и нули в полях Sredn и Disp String = STR(NObj, aInfStruct[3+N_Cls,3], aInfStruct[3+N_Cls,4]) LC_FieldPut( Ar_Model[z]+".txt", nHandle[z], 4+N_Gos,3+N_Cls, String ) // Запись поля Summa в БД (корректная) <<<===############ String = STR(0 , aInfStruct[3+N_Cls,3], aInfStruct[3+N_Cls,4]) LC_FieldPut( Ar_Model[z]+".txt", nHandle[z], 4+N_Gos,4+N_Cls, String ) // Запись поля Sredn в БД (корректная) <<<===############ String = STR(0 , aInfStruct[3+N_Cls,3], aInfStruct[3+N_Cls,4]) LC_FieldPut( Ar_Model[z]+".txt", nHandle[z], 4+N_Gos,5+N_Cls, String ) // Запись поля Disp в БД (корректная) <<<===############ NEXT ENDIF *########################################################################################## IF mRegim <> '3.7.9' * Отразить нужные aSay[ и Time_Progress ( <===############################################# lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) aSay[ 2]:SetCaption(L('Шаг 2-й из 11: Синтез стат.модели "ABS" (расчет матрицы абсолютных частот) - Готово')) lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) aSay[ 3]:SetCaption(L('Шаг 3-й из 11: Синтез стат.моделей "PRC1" и "PRC2" (усл.безусл.% распр.) - Готово')) FOR j=4 TO 10 lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) NEXT aSay[ 4]:SetCaption(L('Шаг 4-й из 11: Синтез системно-когнитивных моделей: INF1-INF7 - Готово')) ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций FOR z=1 TO 10 FClose( nHandle[z] ) // Закрытие dbf и txt баз данных ###################################### NEXT 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 ENDIF *############################################################################################################################### *Расчет моделей 3-го типа *IF nRadioModel = 2 * Calc_model_2nd_level(1, 2, nRadModelCr) * Calc_model_2nd_level(2, 2, nRadModelCr) * Calc_model_2nd_level(3, 2, nRadModelCr) * Calc_model_2nd_level(4, 2, nRadModelCr) * Calc_model_2nd_level(5, 2, nRadModelCr) * Calc_model_2nd_level(6, 2, nRadModelCr) * Calc_model_2nd_level(7, 2, nRadModelCr) * Calc_model_2nd_level(8, 2, nRadModelCr) * Calc_model_2nd_level(9, 2, nRadModelCr) * Calc_model_2nd_level(10,2, nRadModelCr) * ENDIF *############################################################################################################################### IF nRadioM <> 3 // nRadioM = 1 - и синтез, и верификация, = 2 - только верификация, = 3 - только синтез ******************************************************************************************************************* ********* ВЕРИФИКАЦИЯ МОДЕЛЕЙ ************************************************************************************* ******************************************************************************************************************* // Полные наименования стат.моделей и моделей знаний *aModFullNm := {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 ') } FOR j=5 TO 18;aSay[j]:SetCaption(L(" "));NEXT IF mRegim <> '3.7.9' aSay[ 5]:SetCaption(L('НАЧАЛО ЦИКЛА ПО ЧАСТНЫМ И ИНТЕГРАЛЬНЫМ КРИТЕРИЯМ - ИСПОЛНЕНИЕ:')+REPLICATE("-",80)) ENDIF *############################################################################################################################################################# * ВЕРИФИКАЦИЯ МОДЕЛЕЙ НА CPU. ЗДЕСЬ СДЕЛАТЬ ВАРИАНТ СИНТЕЗА МОДЕЛЕЙ НА GPU. ВЫБОР ПО ПАРАМЕТРУ, ЗАДАННОМУ ПРИ ОБРАЩЕНИИ К F3_5() * СДЕЛАТЬ ВАРИАНТ СИНТЕЗА ВСЕХ МОДЕЛЕЙ НА GPU ДО НАЧАЛА ЦИКЛА ПО МОДЕЛЯМ И ИНТ.КРИТЕРИЯМ. А ПОТОМ ПРОСТО ИСПОЛЬЗОВАТЬ БД, СОЗДАННЫЕ GPU-МОДУЛЕМ РАСПОЗНАВАНИЯ *############################################################################################################################################################# FOR M_NumMod = 1 TO LEN(Ar_Model) // Цикл по всем моделям IF aVerifInf[M_NumMod] // Если модель N Num_mod задана для верификации *############################################################################################################################### *Расчет моделей 3-го типа *IF nRadioModel = 3 * Calc_model_2nd_level(M_NumMod, nRadioModel, nRadModelCr) *ENDIF *############################################################################################################################### FOR j=6 TO 18;aSay[j]:SetCaption(L(" "));NEXT Mess = L('ШАГ 5-Й ИЗ 11: ЗАДАНИЕ МОДЕЛИ "#" В КАЧЕСТВЕ ТЕКУЩЕЙ - ИСПОЛНЕНИЕ:') Mess = STRTRAN(Mess,"#", UPPER(Ar_Model[M_NumMod])) aSay[ 6]:SetCaption(Mess) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций F5_6(M_NumMod,.F.,"3_5") // Сделать текущей модель M_NumMod (без диалога, но с отображением стадии исполнения) lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций Mess = L('Шаг 5-й из 11: Задание модели "#" в качестве текущей - Готово') Mess = STRTRAN(Mess,"#", UPPER(Ar_Model[M_NumMod])) aSay[ 6]:SetCaption(Mess) ****************************************************************************************** ****************************************************************************************** FOR j=7 TO 18;aSay[j]:SetCaption(L(" "));NEXT Mess = L('ШАГ 6-Й ИЗ 11: ПАКЕТНОЕ РАСПОЗНАВАНИЕ В МОДЕЛИ "#" - ИСПОЛНЕНИЕ:') // ############################## Mess = STRTRAN(Mess,"#", UPPER(Ar_Model[M_NumMod])) aSay[ 7]:SetCaption(Mess) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций F4_1_2(M_NumMod,.F.,"3_5",mProcessor,mAlgorithm,mVisualization) // Провести распознавание в текущей модели (без диалога, но с отображением стадии исполнения) включить Model_rec.exe в состав F4_1_2 <===####### lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) Mess = L('Шаг 6-й из 11: Пакетное распознавание в модели "#" - Готово') Mess = STRTRAN(Mess,"#", UPPER(Ar_Model[M_NumMod])) aSay[ 7]:SetCaption(Mess) ****************************************************************************************** ****************************************************************************************** FOR M_IntKrit = 1 TO 2 // 1. Корреляция. 2. Сумма DO CASE CASE M_NumMod = 1 M_NameIntKrit = IF(M_IntKrit=1,L("Корреляция абс.частот с обр.объекта"),L("Сумма абс.частот по признакам объекта")) CASE M_NumMod = 2 .OR. M_NumMod = 3 M_NameIntKrit = IF(M_IntKrit=1,L("Корреляция усл.отн.частот с обр.объекта"),L("Сумма усл.отн.частот по признакам объекта")) CASE M_NumMod > 3 M_NameIntKrit = IF(M_IntKrit=1,L("Семантический резонанс знаний"),L("Сумма знаний")) ENDCASE FOR j=8 TO 18;aSay[j]:SetCaption(L(" "));NEXT Mess = L('ШАГ 7-Й ИЗ 11: ИЗМЕРЕНИЕ ДОСТОВЕРНОСТИ МОДЕЛИ: "#" - ИНТ.КРИТЕРИЙ: "$" - ИСПОЛНЕНИЕ:') Mess = STRTRAN(Mess,"#", UPPER(Ar_Model[M_NumMod])) Mess = STRTRAN(Mess,"$", M_NameIntKrit) aSay[ 8]:SetCaption(Mess) ******************************************************** // ИЗМЕРИТЬ ДОСТОВЕРНОСТЬ ИДЕНТИФИКАЦИИ КЛАССОВ В МОДЕЛИ С ИНТ.КРИТ. в моей метрике и F-мере Ван Ризбергена и занести информацию в БД ***************** GenValidModCls(M_NumMod, M_IntKrit) ******************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rso_zag EXCLUSIVE NEW;N_Obj = RECCOUNT() USE Dost_modCls EXCLUSIVE NEW USE VerModClsIT EXCLUSIVE NEW SELECT VerModClsIT DBGOBOTTOM() // ModIntKrit Код: ##_####_#, где: // ##-числовой номер модели и инт.критерия {1-20}, // ####-модель {Abs,Prc1,Prc2,Inf1,Inf2,Inf3,Inf4,Inf5,Inf6,Inf7}, // #-инт.крит.: {k,i} REPLACE ModIntKrit WITH STRTRAN(STR(2*M_NumMod-IF(M_IntKrit=1,1,0),2)," ","0")+"_"+Ar_Model[M_NumMod]+"_"+IF(M_IntKrit=1,"k","i") REPLACE Name_Mod WITH aModFullNm[M_NumMod] REPLACE Int_krit WITH M_NameIntKrit * Структура базы данных N°=22: Dost_modCls.dbf * ============================================================================ * | N | Имя поля | Тип | Ширина | Дес. | Примечание | * ============================================================================ * | 1 | TYPE_MODEL | C | 250 | 0 | * | 2 | INT_KRIT | C | 40 | 0 | * | 3 | N_LOGOBJ | N | 15 | 0 | 3. Количество логических объектов расп.выборки, фактически относящихся к классу (TP+FN) * | 4 | N_T_IDENT | N | 15 | 0 | 4. Количество верно идентифицированных объектов расп.выборки (TP) * | 5 | N_F_NIDENT | N | 15 | 0 | 5. Количество ошибочно неидентифицированных объектов расп.выборки (FN) * | 6 | N_F_IDENT | N | 15 | 0 | 6. Количество ошибочно идентифицированных объектов расп.выборки (FP) * | 7 | N_T_NIDENT | N | 15 | 0 | 7. Количество верно неидентифицированных объектов расп.выборки (TN) * | 8 | P_T_IDENT | N | 15 | 7 | 8. Вероятность верной идентификации объекта с классом с использованием модели * | 9 | P_T_NIDENT | N | 15 | 7 | 9. Вероятность верной не идентификации объекта с классом с использованием модели * | 10 | P_F_IDENT | N | 15 | 7 | 10.Вероятность ошибочной идентификации объекта с классом с использованием модели * | 11 | P_F_NIDENT | N | 15 | 7 | 11.Вероятность ошибочной не идентификации объекта с классом с использованием модели * | 12 | P_AVR_T | N | 15 | 7 | 12.Вероятность верной идентификации или неидентификации объекта с классом с использованием модели (моя мера) * | 13 | DVMOD | N | 15 | 7 | 13.M_DVMod = (NT-NF)/(NT+NF)*100 Моя мера качества модели-классификатора (в знаменателе: "всего объектов") * | 14 | PRECISION | N | 15 | 7 | 14.Precision = TP/(TP+FP) - точность * | 15 | RECALL | N | 15 | 7 | 15.Recall = TP/(TP+FN) - полнота * | 16 | F_MERA | N | 15 | 7 | 16.F-mera = 2*(Precision*Recall)/(Precision+Recall) (мультиклассовый вариант) * | 17 | S_T_IDENT | N | 15 | 7 | 17.Сумма модулей уровней сходства верно идентифицированных объектов расп.выборки (STP - истино-положительное решение) * | 18 | S_F_NIDENT | N | 15 | 7 | 18.Сумма модулей уровней сходства ошибочно неидентифицированных объектов расп.выборки (SFN - ложно-отрицательное решение) * | 19 | S_F_IDENT | N | 15 | 7 | 19.Сумма модулей уровней сходства ошибочно идентифицированных объектов расп.выборки (SFP - ложно-положительное решение) * | 20 | S_T_NIDENT | N | 15 | 7 | 20.Сумма модулей уровней сходства верно неидентифицированных объектов расп.выборки (STN - истино-отрицательное решение) * | 21 | SPRECISION | N | 15 | 7 | 21.SPrecision = STP/(STP+SFP) - точность с учетом уровней сходства * | 22 | SRECALL | N | 15 | 7 | 22.SRecall = STP/(STP+SFN) - полнота с учетом уровней сходства * | 23 | L1_mera | N | 15 | 7 | 23.L1-mera = 2*(SPrecision*SRecall)/(SPrecision+SRecall) (L1-мера проф.Е.В.Луценко - нечеткое мультиклассовое обобщение * | 24 | DATE | C | 10 | 0 | 24. Date Дата формирования записи БД * | 25 | TIME | C | 8 | 0 | 25. Time Время формирования записи БД * ============================================================================ * В С Е Г О длина записи: 624 байтов. | * ============================================================================ * Структура базы данных N°=74: VerModClsIT.dbf * ============================================================================ * | N | Имя поля | Тип | Ширина | Дес. | Примечание | * ============================================================================ * | 1 | MODINTKRIT | C | 9 | 0 | 1. ModIntKrit Код: ##_####_#, где: ##-числовой номер модели и инт.критерия {1-20}, ####-модель {Abs,Prc1,Prc2,Inf1,Inf2,Inf3,Inf4,Inf5,Inf6,Inf7}, #-инт.крит.: {k,i} * | 2 | NAME_MOD | C | 250 | 0 | 2. Код класса * | 3 | INT_KRIT | C | 40 | 0 | 3. Наименование класса * | 4 | DIFVALMOD | N | 15 | 7 | 4. DifValMod Достоверность идентификации класса (с учетом всех верно и ошибочно идентифицированных и неидентифицированных логических объектов)) * | 5 | AVRURSX_T | N | 15 | 7 | 5. AvrUrSx_T Средний модуль уровней сходства ВЕРНО идентифицированных и неидентифицированных объектов * | 6 | AVRURSX_F | N | 15 | 7 | 6. AvrUrSx_F Средний модуль уровней сходства ОШИБОЧНО идентифицированных и неидентифицированных объектов * | 7 | DIFAVRURSX | N | 15 | 7 | 7. DifAvrUrSx Разность средних модулей уровней сходства ВЕРНО и ОШИБОЧНО идентифицированных и неидентифицированных объектов * | 8 | N_LOGOBJ | N | 15 | 0 | 8. N_LogObj Количество объектов расп.выборки, фактически относящихся к классу * | 9 | N_T_IDENT | N | 15 | 0 | 9. N_T_Ident Количество верно идентифицированных объектов расп.выборки (TP - истино-положительное решение) * | 10 | N_F_NIDENT | N | 15 | 0 | 10. N_F_NIdent Количество ошибочно неидентифицированных объектов расп.выборки (FN - ложно-отрицательное решение) * | 11 | N_F_IDENT | N | 15 | 0 | 11. N_F_Ident Количество ошибочно идентифицированных объектов расп.выборки (FP - ложно-положительное решение) * | 12 | N_T_NIDENT | N | 15 | 0 | 12. N_T_NIdent Количество верно неидентифицированных объектов расп.выборки (TN - истино-отрицательное решение) * | 13 | DVMOD | N | 15 | 7 | 13. M_DVMod = (NT-NF)/(NT+NF)*100 Дифференциальная валидность (достоверность) модели (по классу) (в знаменателе: "всего объектов"). NT = N_T_id+N_T_nid: Количество ВЕРНО идентифицированных и неидентифицированных объектов, NF = N_F_id+N_F_nid: Количество ОШИБОЧНО идентифицированных и неидентифицированных объектов * | 14 | PRECISION | N | 15 | 7 | 14. Precision = TP/(TP+FP) - точность * | 15 | RECALL | N | 15 | 7 | 15. Recall = TP/(TP+FN) - полнота * | 16 | F_MERA | N | 15 | 7 | 16. F-mera = 2*(Precision*Recall)/(Precision+Recall) (мультиклассовый вариант) * | 17 | P_T_IDENT | N | 15 | 7 | 17. P_T_Ident Вероятность верной идентификации объекта с классом с использованием модели * | 18 | P_T_NIDENT | N | 15 | 7 | 18. P_T_NIdent Вероятность верной не идентификации объекта с классом с использованием модели * | 19 | P_F_IDENT | N | 15 | 7 | 19. P_F_Ident Вероятность ошибочной идентификации объекта с классом с использованием модели * | 20 | P_F_NIDENT | N | 15 | 7 | 20. P_F_NIdent Вероятность ошибочной не идентификации объекта с классом с использованием модели * | 21 | P_SLUG_ID | N | 15 | 7 | 21. P_SlUg_Id Вероятность случайного угадывания принадлежности объектов к классам * | 22 | P_SLUG_NID | N | 15 | 7 | 22. P_SlUg_NId Вероятность случайного угадывания непринадлежности объектов к классам * | 23 | EFFMOD_ID | N | 15 | 7 | 23. EffMod_Id Эффективность модели при идентификации: отношение вероятности верной идентификации при использовании модели к вероятности случайного угадывания принадлежности объекта к классу * | 24 | EFFMOD_NID | N | 15 | 7 | 24. EffMod_NId Эффективность модели при неидентификации: отношение вероятности верной неидентификации при использовании модели к вероятности случайного угадывания непринадлежности объекта к классу * | 25 | AVR_EFFMOD | N | 15 | 7 | 25. Avr_EffMod Средняя эффективность модели: (EffMod_Id+EffMod_NId)/2 * | 26 | S_T_IDENT | N | 15 | 7 | 26. Сумма модулей уровней сходства верно идентифицированных объектов расп.выборки (STP - истино-положительное решение) * | 27 | S_F_NIDENT | N | 15 | 7 | 27. Сумма модулей уровней сходства ошибочно неидентифицированных объектов расп.выборки (SFN - ложно-отрицательное решение) * | 28 | S_F_IDENT | N | 15 | 7 | 28. Сумма модулей уровней сходства ошибочно идентифицированных объектов расп.выборки (SFP - ложно-положительное решение) * | 29 | S_T_NIDENT | N | 15 | 7 | 29. Сумма модулей уровней сходства верно неидентифицированных объектов расп.выборки (STN - истино-отрицательное решение) * | 30 | SPRECISION | N | 15 | 7 | 30. SPrecision = STP/(STP+SFP) - точность с учетом уровней сходства * | 31 | SRECALL | N | 15 | 7 | 31. SRecall = STP/(STP+SFN) - полнота с учетом уровней сходства * | 32 | L1_mera | N | 15 | 7 | 32. L1-mera = 2*(SPrecision*SRecall)/(SPrecision+SRecall) (L1-мера проф.Е.В.Луценко - нечеткое мультиклассовое обобщение * | 33 | DATE | C | 10 | 0 | 33. Date Дата формирования записи БД * | 34 | TIME | C | 8 | 0 | 34. Time Время формирования записи БД * В С Е Г О длина записи: 753 байтов. | * ============================================================================ mN_LogObj = N_T_Ident+N_F_NIdent mN_T_Ident = N_T_Ident // Количество верно идентифицированных объектов расп.выборки (TP) mN_F_NIdent = N_F_NIdent // Количество ошибочно неидентифицированных объектов расп.выборки (FN) mN_F_Ident = N_F_Ident // Количество ошибочно идентифицированных объектов расп.выборки (FP) mN_T_NIdent = N_T_NIdent // Количество верно неидентифицированных объектов расп.выборки (TN) mS_T_Ident = S_T_Ident // Сумма модулей уровней сходства верно идентифицированных объектов расп.выборки (TP) mS_F_NIdent = S_F_NIdent // Сумма модулей уровней сходства ошибочно неидентифицированных объектов расп.выборки (FN) mS_F_Ident = S_F_Ident // Сумма модулей уровней сходства ошибочно идентифицированных объектов расп.выборки (FP) mS_T_NIdent = S_T_NIdent // Сумма модулей уровней сходства верно неидентифицированных объектов расп.выборки (TN) mP_T_Ident = P_T_Ident // Вероятность верной идентификации объекта с классом с использованием модели mP_T_NIdent = P_T_NIdent // Вероятность верной не идентификации объекта с классом с использованием модели mP_F_Ident = P_F_Ident // Вероятность ошибочной идентификации объекта с классом с использованием модели mP_F_NIdent = P_F_NIdent // Вероятность ошибочной не идентификации объекта с классом с использованием модели mDVMod = DVMod // M_DVMod = (NT-NF)/(NT+NF)*100 Моя мера качества модели-классификатора (в знаменателе: "всего объектов") mPrecision = Precision // Precision = TP/(TP+FP) - точность mRecall = Recall // Recall = TP/(TP+FN) - полнота mF_mera = F_mera // F-mera = 2*(Precision*Recall)/(Precision+Recall) ( мультиклассовый вариант) mSPrecision = SPrecision // SPrecision = STP/(STP+SFP) - точность mSRecall = SRecall // SRecall = STP/(STP+SFN) - полнота mL1_mera = L1_mera // L1-mera = 2*(SPrecision*SRecall)/(SPrecision+Recall) (нечеткий мультиклассовый вариант) ****** Заполнить базу для отображения качества моделей (классификаторов) в режиме 4.1.3.6 SELECT Dost_modCls APPEND BLANK REPLACE Type_model WITH aModFullNm[M_NumMod] REPLACE Int_krit WITH M_NameIntKrit REPLACE N_LogObj WITH mN_LogObj // Количество объектов расп.выборки, фактически относящихся к классу (TP+FN) REPLACE N_T_Ident WITH mN_T_Ident // Количество верно идентифицированных объектов расп.выборки (TP) REPLACE N_F_NIdent WITH mN_F_NIdent // Количество ошибочно неидентифицированных объектов расп.выборки (FN) REPLACE N_F_Ident WITH mN_F_Ident // Количество ошибочно идентифицированных объектов расп.выборки (FP) REPLACE N_T_NIdent WITH mN_T_NIdent // Количество верно неидентифицированных объектов расп.выборки (TN) REPLACE S_T_Ident WITH mS_T_Ident // Количество верно идентифицированных объектов расп.выборки (STP) REPLACE S_F_NIdent WITH mS_F_NIdent // Количество ошибочно неидентифицированных объектов расп.выборки (SFN) REPLACE S_F_Ident WITH mS_F_Ident // Количество ошибочно идентифицированных объектов расп.выборки (SFP) REPLACE S_T_NIdent WITH mS_T_NIdent // Количество верно неидентифицированных объектов расп.выборки (STN) REPLACE P_T_Ident WITH mP_T_Ident // Вероятность верной идентификации объекта с классом с использованием модели REPLACE P_T_NIdent WITH mP_T_NIdent // Вероятность верной не идентификации объекта с классом с использованием модели REPLACE P_F_Ident WITH mP_F_Ident // Вероятность ошибочной идентификации объекта с классом с использованием модели REPLACE P_F_NIdent WITH mP_F_NIdent // Вероятность ошибочной не идентификации объекта с классом с использованием модели REPLACE DVMod WITH mDVMod // M_DVMod = (NT-NF)/(NT+NF)*100 Моя мера качества модели-классификатора (в знаменателе: "всего объектов") REPLACE Precision WITH mPrecision // Precision = TP/(TP+FP) - точность REPLACE Recall WITH mRecall // Recall = TP/(TP+FN) - полнота REPLACE F_mera WITH mF_mera // F-mera = 2*(Precision*Recall)/(Precision+Recall) ( мультиклассовый вариант) REPLACE SPrecision WITH msPrecision // SPrecision = STP/(STP+SFP) - точность REPLACE SRecall WITH msRecall // SRecall = STP/(STP+SFN) - полнота REPLACE L1_mera WITH mL1_mera // L1-mera = 2*(SPrecision*SRecall)/(SPrecision+SRecall) (нечеткий мультиклассовый вариант) REPLACE A_T_IDENT WITH S_T_IDENT /N_T_IDENT REPLACE A_F_NIDENT WITH S_F_NIDENT/N_F_NIDENT REPLACE A_F_IDENT WITH S_F_IDENT /N_F_IDENT REPLACE A_T_NIDENT WITH S_T_NIDENT/N_T_NIDENT REPLACE APRECISION WITH A_T_IDENT/(A_T_IDENT+A_F_IDENT) REPLACE ARECALL WITH A_T_IDENT/(A_T_IDENT+A_F_NIDENT) REPLACE L2_mera WITH 2*(APRECISION*ARECALL)/(APRECISION+ARECALL) // L2-mera = 2*(APrecision*ARecall)/(APrecision+ARecall) (нечеткий мультиклассовый вариант) REPLACE P_Avr_T WITH (P_T_Ident+P_T_NIdent)/2 // Средняя вероятность верной идентификации или неидентификации объекта с классом с использованием модели REPLACE Date WITH DTOC(DATE()) REPLACE Time WITH TIME() ******************************************************** // ИЗМЕРИТЬ ДОСТОВЕРНОСТЬ ИДЕНТИФИКАЦИИ ОБЪЕКТОВ В МОДЕЛИ С ИНТ.КРИТ. в моей метрике и F-мере Ван Ризбергена и занести информацию в БД ***************** GenValidModObj(M_NumMod, M_IntKrit) ******************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rso_zag EXCLUSIVE NEW;N_Obj = RECCOUNT() USE Dost_modObj EXCLUSIVE NEW USE VerModObjIT EXCLUSIVE NEW SELECT VerModObjIT DBGOBOTTOM() // ModIntKrit Код: ##_####_#, где: // ##-числовой номер модели и инт.критерия {1-20}, // ####-модель {Abs,Prc1,Prc2,Inf1,Inf2,Inf3,Inf4,Inf5,Inf6,Inf7}, // #-инт.крит.: {k,i} REPLACE ModIntKrit WITH STRTRAN(STR(2*M_NumMod-IF(M_IntKrit=1,1,0),2)," ","0")+"_"+Ar_Model[M_NumMod]+"_"+IF(M_IntKrit=1,"k","i") REPLACE Name_Mod WITH aModFullNm[M_NumMod] REPLACE Int_krit WITH M_NameIntKrit *cFileName := "Dost_mod" *aStructure := { { "Type_model", "C",250, 0 }, ; * { "Int_krit" , "C", 40, 0 }, ; * { "N_T_Ident" , "N", 15, 0 }, ; // Количество верно идентифицированных объектов расп.выборки (TP) * { "N_F_NIdent", "N", 15, 0 }, ; // Количество ошибочно неидентифицированных объектов расп.выборки (FN) * { "N_F_Ident" , "N", 15, 0 }, ; // Количество ошибочно идентифицированных объектов расп.выборки (FP) * { "N_T_NIdent", "N", 15, 0 }, ; // Количество верно неидентифицированных объектов расп.выборки (TN) * { "P_T_Ident" , "N", 15, 7 }, ; // Вероятность верной идентификации объекта с классом с использованием модели * { "P_T_NIdent", "N", 15, 7 }, ; // Вероятность верной не идентификации объекта с классом с использованием модели * { "P_F_Ident" , "N", 15, 7 }, ; // Вероятность ошибочной идентификации объекта с классом с использованием модели * { "P_F_NIdent", "N", 15, 7 }, ; // Вероятность ошибочной не идентификации объекта с классом с использованием модели * { "P_Avr_T" , "N", 15, 7 }, ; // Вероятность верной идентификации или неидентификации объекта с классом с использованием модели (моя мера) * { "DVMod" , "N", 15, 7 }, ; // M_DVMod = (NT-NF)/(NT+NF)*100 Моя мера качества модели-классификатора (в знаменателе: "всего объектов") * { "Precision" , "N", 15, 7 }, ; // Precision = TP/(TP+FP) - точность * { "Recall" , "N", 15, 7 }, ; // Recall = TP/(TP+FN) - полнота * { "F_mera" , "N", 15, 7 }, ; // F-mera = 2*(Precision*Recall)/(Precision+Recall) (мультиклассовый вариант) * { "Date" , "C", 10, 0 }, ; * { "Time" , "C", 8, 0 } } mN_T_Ident = N_T_Ident // Количество верно идентифицированных объектов расп.выборки (TP) mN_F_NIdent = N_F_NIdent // Количество ошибочно неидентифицированных объектов расп.выборки (FN) mN_F_Ident = N_F_Ident // Количество ошибочно идентифицированных объектов расп.выборки (FP) mN_T_NIdent = N_T_NIdent // Количество верно неидентифицированных объектов расп.выборки (TN) mP_T_Ident = P_T_Ident // Вероятность верной идентификации объекта с классом с использованием модели mP_T_NIdent = P_T_NIdent // Вероятность верной не идентификации объекта с классом с использованием модели mP_F_Ident = P_F_Ident // Вероятность ошибочной идентификации объекта с классом с использованием модели mP_F_NIdent = P_F_NIdent // Вероятность ошибочной не идентификации объекта с классом с использованием модели mDVMod = DVMod // M_DVMod = (NT-NF)/(NT+NF)*100 Моя мера качества модели-классификатора (в знаменателе: "всего объектов") mPrecision = Precision // Precision = TP/(TP+FP) - точность mRecall = Recall // Recall = TP/(TP+FN) - полнота mF_mera = F_mera // F-mera = 2*(Precision*Recall)/(Precision+Recall) (мультиклассовый вариант) ****** Заполнить базу для отображения качества моделей (классификаторов) в режиме 4.1.3.6 SELECT Dost_modObj APPEND BLANK REPLACE Type_model WITH aModFullNm[M_NumMod] REPLACE Int_krit WITH M_NameIntKrit REPLACE N_T_Ident WITH mN_T_Ident // Количество верно идентифицированных объектов расп.выборки (TP) REPLACE N_F_NIdent WITH mN_F_NIdent // Количество ошибочно неидентифицированных объектов расп.выборки (FN) REPLACE N_F_Ident WITH mN_F_Ident // Количество ошибочно идентифицированных объектов расп.выборки (FP) REPLACE N_T_NIdent WITH mN_T_NIdent // Количество верно неидентифицированных объектов расп.выборки (TN) REPLACE P_T_Ident WITH mP_T_Ident // Вероятность верной идентификации объекта с классом с использованием модели REPLACE P_T_NIdent WITH mP_T_NIdent // Вероятность верной не идентификации объекта с классом с использованием модели REPLACE P_F_Ident WITH mP_F_Ident // Вероятность ошибочной идентификации объекта с классом с использованием модели REPLACE P_F_NIdent WITH mP_F_NIdent // Вероятность ошибочной не идентификации объекта с классом с использованием модели REPLACE DVMod WITH mDVMod // M_DVMod = (NT-NF)/(NT+NF)*100 Моя мера качества модели-классификатора (в знаменателе: "всего объектов") REPLACE Precision WITH mPrecision // Precision = TP/(TP+FP) - точность REPLACE Recall WITH mRecall // Recall = TP/(TP+FN) - полнота REPLACE F_mera WITH mF_mera // F-mera = 2*(Precision*Recall)/(Precision+Recall) (мультиклассовый вариант) REPLACE P_Avr_T WITH (P_T_Ident+P_T_NIdent)/2 // Средняя вероятность верной идентификации или неидентификации объекта с классом с использованием модели REPLACE Date WITH DTOC(DATE()) REPLACE Time WITH TIME() lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) Mess = L('Шаг 7-й из 11: Измерение достоверности модели: "#" - Интегральный критерий: "$" - Готово') Mess = STRTRAN(Mess,"#", Ar_Model[M_NumMod]) Mess = STRTRAN(Mess,"$", M_NameIntKrit) aSay[ 8]:SetCaption(Mess) NEXT ****************************************************************************************** ENDIF NEXT FOR j=9 TO 18;aSay[j]:SetCaption(L(" "));NEXT aSay[9]:SetCaption(L('КОНЕЦ ЦИКЛА ПО ЧАСТНЫМ И ИНТЕГРАЛЬНЫМ КРИТЕРИЯМ - ГОТОВО:')+REPLICATE("-",80)) // Объединить БД DostRsp# в БД DostRasp CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE DostRasp EXCLUSIVE NEW;ZAP aSay[10]:SetCaption(L("ШАГ 8-Й ИЗ 11: ОБЪЕДИНЕНИЕ БД DostRsp# В БД DostRasp")) FOR M_NumMod = 1 TO LEN(Ar_Model) // Цикл по всем моделям IF aVerifInf[M_NumMod] // Если модель N Num_mod задана для верификации M_DostRsp := "DostRsp"+ALLTRIM(STR(M_NumMod,3)) // Имя текущей БД достоверности распознавания в текущей модели * LB_Warning(M_DostRsp) * Mess = L("Шаг 8-й ИЗ 11: Объединение БД # из $ в БД DostRasp." * Mess = STRTRAN(Mess,"#", M_DostRsp) * Mess = STRTRAN(Mess,"$", ALLTRIM(STR(M_NumMod,19))) * aSay[10]:SetCaption(Mess) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (M_DostRsp) EXCLUSIVE NEW USE DostRasp EXCLUSIVE NEW SELECT (M_DostRsp) DBGOTOP() DO WHILE .NOT. EOF() Ar := {} FOR j=1 TO FCOUNT() AADD(Ar, FIELDGET(j)) * DC_DebugQout( { Alias(), FCOUNT(), j, Ar[j] } ) NEXT SELECT DostRasp APPEND BLANK FOR j=1 TO FCOUNT() * DC_DebugQout( { Alias(), FCOUNT(), j, Ar[j] } ) FIELDPUT(j, Ar[j]) NEXT SELECT (M_DostRsp) DBSKIP(1) ENDDO * lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) ENDIF NEXT lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) aSay[10]:SetCaption(L("Шаг 8-й из 11: Объединение БД DostRsp# в БД DostRasp - Готово ")) *aSay[ 1]:SetCaption(L("Шаг 1-й из 11: Копирование обучающей выборки в распознаваемую - Готово")) aSay[11]:SetCaption(L("ШАГ 9-Й ИЗ 11: ПЕЧАТЬ СВОДНОЙ ФОРМЫ ПО РЕЗУЛЬТАТАМ ВЕРИФИКАЦИИ МОДЕЛЕЙ")) // ########################################################################## // Сделать экспорт БД по достоверности моделей: DostRasp, Dost_mod, VerModClsIT // в Excel и сообщить пользователю об этом с именами файлов и путями на них *** Загрузить полный путь на текущее приложение, *** т.к. DC_WorkArea2Excel работает только с полным конкретным указанием путей * DC_ASave(M_PathAppl, "_PathAppl.arx") // Записывается в ApplChange("") * M_PathAppl = DC_ARestore("_PathAppl.arx") *DC_LoadRdds() *CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций *USE Dost_modCls EXCLUSIVE NEW VIA 'DBFNTX' *SELECT Dost_modCls *aFields := { 'Наименование модели' ,; * 'Интегральный критерий' ,; * 'Вероятность верной идентификации' ,; * 'Вероятность верной неидентификации',; * 'Средняя вер-ть верного результата' ,; * 'Дата' ,; * 'Время' } aFields := { "Type_model", ; "Int_krit" , ; "P_T_Ident" , ; "P_T_NIdent", ; "P_Avr_T" , ; "Date" , ; "Time" } *cExcelFile := M_PathAppl + '\Dost_mod.xls' *DC_WorkArea2Excel( DC_CurPath() + '\Dost_mod.xls' ) *DC_WorkArea2Excel(cExcelFile,,,,aFields) *LC_RunUrl(Disk_dir+'Dost_mod.XLS') *** Эти файлы тоже преобразовать в Excel *** Как сделать русские наименования столбцов? *USE VerModClsIT EXCLUSIVE NEW *USE DostRasp EXCLUSIVE NEW lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) aSay[11]:SetCaption(L("Шаг 9-й из 11: Печать сводной формы по результатам верификации моделей - Готово ")) *aSay[ 1]:SetCaption(L("Шаг 1-й из 11: Копирование обучающей выборки в распознаваемую - Готово")) // Подготовка формы для режима: 4.1.3.8. Достоверность идент.классов в различных моделях aSay[12]:SetCaption(L('ШАГ 10-Й ИЗ 11: СОЗДАНИЕ ФОРМЫ: "ДОСТОВЕРНОСТЬ ИДЕНТ.КЛАССОВ В РАЗЛИЧНЫХ МОДЕЛЯХ"')) // Определение максимальной длины наименования класса CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW SELECT Classes DBGOTOP() MN = 15 DO WHILE .NOT. EOF() MN = MAX(MN, LEN(ALLTRIM(Name_cls))) DBSKIP(1) ENDDO // Создание БД Dost_cls.dbf Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } ********** Dost_cls.dbf - достоверность распознавания класса в модели с инт.критерием aStructure := { { "Kod_cls" , "N", 15, 0},; // 1 { "Name_cls" , "C", MN, 0},; // 2 { "Max_Dost" , "N", 15, 7},; // 3 { "Mod_MaxD", "C", 15, 0},; // 4 { "IKr_MaxD", "C", 8, 7} } // 5 FOR M_IntKrit = 1 TO 2 FOR j=1 TO LEN(Ar_Model) FieldName = Ar_Model[j]+IF(M_IntKrit=1,"k","i") AADD(aStructure, { FieldName , "N", 15, 7 }) NEXT NEXT DbCreate( "Dost_clsL1.dbf", aStructure ) // Качество классификатора L1-мера, нормированная к {-1,+1} DbCreate( "Dost_clsL2.dbf", aStructure ) // Качество классификатора L1-мера, нормированная к { 0 ,1} DbCreate( "Dost_clsF.dbf" , aStructure ) // Качество классификатора F-мера, нормированная к { 0 ,1} CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Dost_clsL1 EXCLUSIVE NEW USE Dost_clsL2 EXCLUSIVE NEW USE Dost_clsF EXCLUSIVE NEW SELECT Dost_clsL1 FOR M_NMod = 1 TO LEN(Ar_Model) // Начало цикла по моделям и БД VerMod##c Как при объединении IF aVerifInf[M_NMod] // Если модель N Num_mod задана для верификации FOR M_IntKrit = 1 TO 2 // Начало цикла по инт.критериям M_VerMod := "VerModCls"+STRTRAN(STR(M_NMod,2)," ","0")+IF(M_IntKrit=1,"k","i") USE (M_VerMod) EXCLUSIVE NEW NEXT ENDIF NEXT // Заполнение БД информацией о классах из БД Classes SELECT Classes DBGOTOP() DO WHILE .NOT. EOF() Dost_clsL1->(DBAPPEND()) Dost_clsL1->Kod_cls := Classes->Kod_cls Dost_clsL1->Name_cls := Classes->(ALLTRIM(Name_cls)) Dost_clsL2->(DBAPPEND()) Dost_clsL2->Kod_cls := Classes->Kod_cls Dost_clsL2->Name_cls := Classes->(ALLTRIM(Name_cls)) Dost_clsF ->(DBAPPEND()) Dost_clsF ->Kod_cls := Classes->Kod_cls Dost_clsF ->Name_cls := Classes->(ALLTRIM(Name_cls)) Classes->(DBSKIP(1)) ENDDO Dost_clsL1->(DBAPPEND()) Dost_clsL1->Name_cls := "Средневзвешенное:" Dost_clsL2->(DBAPPEND()) Dost_clsL2->Name_cls := "Средневзвешенное:" Dost_clsF ->(DBAPPEND()) Dost_clsF ->Name_cls := "Средневзвешенное:" SELECT Dost_clsL1 PRIVATE Ar[FCOUNT()] FOR j=3 TO FCOUNT();Ar[j] = 0;NEXT FOR M_NMod = 1 TO LEN(Ar_Model) // Начало цикла по моделям и БД VerMod## как при объединении IF aVerifInf[M_NMod] // Если модель N Num_mod задана для верификации FOR M_IntKrit = 1 TO 2 // Начало цикла по инт.критериям // Заполнение БД БД Dost_cls из VerMod## данными по дифф.валидности модели при данном инт.крит.по данному классу M_VerMod := "VerModCls"+STRTRAN(STR(M_NMod,2)," ","0")+IF(M_IntKrit=1,"k","i") SELECT (M_VerMod) DBGOTOP() DO WHILE .NOT. EOF() M_KodCls = Kod_cls M_DifValMod = DifValMod M_DVMod = DVMod M_F_mera = F_mera SELECT Dost_clsL1 IF M_KodCls > 0 DBGOTO(M_KodCls) // Срока по классу ELSE DBGOBOTTOM() // Итоговая строка ENDIF FIELDPUT(5+M_NMod+IF(M_IntKrit=1,0,10),M_DifValMod) SELECT Dost_clsL2 IF M_KodCls > 0 DBGOTO(M_KodCls) // Срока по классу ELSE DBGOBOTTOM() // Итоговая строка ENDIF FIELDPUT(5+M_NMod+IF(M_IntKrit=1,0,10),M_DVMod) SELECT Dost_clsF IF M_KodCls > 0 DBGOTO(M_KodCls) // Срока по классу ELSE DBGOBOTTOM() // Итоговая строка ENDIF FIELDPUT(5+M_NMod+IF(M_IntKrit=1,0,10),M_F_mera) SELECT (M_VerMod) DBSKIP(1) ENDDO * lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) NEXT // Конец цикла по инт.критериям c ENDIF NEXT // Конец цикла по моделям VerMod##c // Цикл по БД Dost_cls и заполнение столбцов 3-5 данными о макс.диф.вал. с применением L-меры и F-меры, // модели и инт.крит., при которых она обеспечивается по данному классу SELECT Dost_clsL1 DBGOTOP() DO WHILE .NOT. EOF() M_MaxDost = -9999999 M_ModMaxD = "" M_IKrMaxD = "" FOR j=1 TO 2*LEN(Ar_Model) MD = FIELDGET(5+j) IF MD > M_MaxDost M_MaxDost = MD M_FieldName = FIELDNAME(5+j) M_ModMaxD = SUBSTR(M_FieldName,1,LEN(M_FieldName)-1) M_IKrMaxD = IF(SUBSTR(M_FieldName,LEN(M_FieldName),1)="k","Резонанс", "Сумма") ENDIF NEXT // Записать M_MaxDost и др. Dost_clsL1->Max_dost := M_MaxDost Dost_clsL1->Mod_MaxD := M_ModMaxD Dost_clsL1->IKr_MaxD := M_IKrMaxD DBSKIP(1) ENDDO SELECT Dost_clsL2 DBGOTOP() DO WHILE .NOT. EOF() M_MaxDost = -9999999 M_ModMaxD = "" M_IKrMaxD = "" FOR j=1 TO 2*LEN(Ar_Model) MD = FIELDGET(5+j) IF MD > M_MaxDost M_MaxDost = MD M_FieldName = FIELDNAME(5+j) M_ModMaxD = SUBSTR(M_FieldName,1,LEN(M_FieldName)-1) M_IKrMaxD = IF(SUBSTR(M_FieldName,LEN(M_FieldName),1)="k","Резонанс", "Сумма") ENDIF NEXT // Записать M_MaxDost и др. Dost_clsL2->Max_dost := M_MaxDost Dost_clsL2->Mod_MaxD := M_ModMaxD Dost_clsL2->IKr_MaxD := M_IKrMaxD DBSKIP(1) ENDDO SELECT Dost_clsF DBGOTOP() DO WHILE .NOT. EOF() M_MaxDost = -9999999 M_ModMaxD = "" M_IKrMaxD = "" FOR j=1 TO 2*LEN(Ar_Model) MD = FIELDGET(5+j) IF MD > M_MaxDost M_MaxDost = MD M_FieldName = FIELDNAME(5+j) M_ModMaxD = SUBSTR(M_FieldName,1,LEN(M_FieldName)-1) M_IKrMaxD = IF(SUBSTR(M_FieldName,LEN(M_FieldName),1)="k","Резонанс", "Сумма") ENDIF NEXT // Записать M_MaxDost и др. Dost_clsF->Max_dost := M_MaxDost Dost_clsF->Mod_MaxD := M_ModMaxD Dost_clsF->IKr_MaxD := M_IKrMaxD DBSKIP(1) ENDDO *########################################################################################################## ********************* Достоверность идент.объектов в различных моделях ************************************ *########################################################################################################## // Определение максимальной длины наименования объекта CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rso_Zag EXCLUSIVE NEW SELECT Rso_Zag DBGOTOP() MN = 15 DO WHILE .NOT. EOF() MN = MAX(MN, LEN(ALLTRIM(Name_obj))) DBSKIP(1) ENDDO // Создание БД Dost_obj.dbf Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } ********** Dost_cls.dbf - достоверность распознавания класса в модели с инт.критерием aStructure := { { "Kod_obj" , "N", 15, 0},; // 1 { "Name_obj", "C", MN, 0},; // 2 { "Max_Dost", "N", 15, 7},; // 3 { "Mod_MaxD", "C", 15, 0},; // 4 { "IKr_MaxD", "C", 8, 7} } // 5 FOR M_IntKrit = 1 TO 2 FOR j=1 TO LEN(Ar_Model) FieldName = Ar_Model[j]+IF(M_IntKrit=1,"k","i") AADD(aStructure, { FieldName , "N", 19, 7 }) NEXT NEXT DbCreate( "Dost_objL1", aStructure ) // Качество классификатора L1-мера, нормированная к {-1,+1} DbCreate( "Dost_objL2", aStructure ) // Качество классификатора L1-мера, нормированная к { 0 ,1} DbCreate( "Dost_objF" , aStructure ) // Качество классификатора F-мера, нормированная к { 0 ,1} CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rso_Zag EXCLUSIVE NEW;N_Obj = RECCOUNT() USE Dost_objL1 EXCLUSIVE NEW USE Dost_objL2 EXCLUSIVE NEW USE Dost_objF EXCLUSIVE NEW SELECT Dost_objL1 FOR M_NMod = 1 TO LEN(Ar_Model) // Начало цикла по моделям и БД VerMod##c Как при объединении IF aVerifInf[M_NMod] // Если модель N Num_mod задана для верификации FOR M_IntKrit = 1 TO 2 // Начало цикла по инт.критериям M_VerMod := "VerModObj"+STRTRAN(STR(M_NMod,2)," ","0")+IF(M_IntKrit=1,"k","i") USE (M_VerMod) EXCLUSIVE NEW NEXT ENDIF NEXT // Заполнение БД информацией оо объектах из БД Rso_Zag SELECT Rso_Zag DBGOTOP() DO WHILE .NOT. EOF() Dost_objL1->(DBAPPEND()) Dost_objL1->Kod_obj := Rso_Zag->Kod_obj Dost_objL1->Name_obj := Rso_Zag->(ALLTRIM(Name_obj)) Dost_objL2->(DBAPPEND()) Dost_objL2->Kod_obj := Rso_Zag->Kod_obj Dost_objL2->Name_obj := Rso_Zag->(ALLTRIM(Name_obj)) Dost_objF ->(DBAPPEND()) Dost_objF ->Kod_obj := Rso_Zag->Kod_obj Dost_objF ->Name_obj := Rso_Zag->(ALLTRIM(Name_obj)) Rso_Zag->(DBSKIP(1)) ENDDO Dost_objL1->(DBAPPEND()) Dost_objL1->Name_obj := "Средневзвешенное:" Dost_objL2->(DBAPPEND()) Dost_objL2->Name_obj := "Средневзвешенное:" Dost_objF ->(DBAPPEND()) Dost_objF ->Name_obj := "Средневзвешенное:" SELECT Dost_objL1 PRIVATE Ar[FCOUNT()] FOR j=3 TO FCOUNT();Ar[j] = 0;NEXT FOR M_NMod = 1 TO LEN(Ar_Model) // Начало цикла по моделям и БД VerMod## как при объединении IF aVerifInf[M_NMod] // Если модель N Num_mod задана для верификации FOR M_IntKrit = 1 TO 2 // Начало цикла по инт.критериям // Заполнение БД БД Dost_obj из VerMod## данными по дифф.валидности модели при данном инт.крит.по данному объекту M_VerMod := "VerModObj"+STRTRAN(STR(M_NMod,2)," ","0")+IF(M_IntKrit=1,"k","i") SELECT (M_VerMod) DBGOTOP() DO WHILE .NOT. EOF() M_Kodobj = Kod_obj M_DifValMod = DifValMod M_DVMod = DVMod M_F_mera = F_mera SELECT Dost_objL1 IF M_Kodobj > 0 DBGOTO(M_Kodobj) // Срока по классу ELSE DBGOBOTTOM() // Итоговая строка ENDIF FIELDPUT(5+M_NMod+IF(M_IntKrit=1,0,10),M_DifValMod) SELECT Dost_objL2 IF M_Kodobj > 0 DBGOTO(M_Kodobj) // Срока по классу ELSE DBGOBOTTOM() // Итоговая строка ENDIF FIELDPUT(5+M_NMod+IF(M_IntKrit=1,0,10),M_DVMod) SELECT Dost_objF IF M_Kodobj > 0 DBGOTO(M_Kodobj) // Срока по классу ELSE DBGOBOTTOM() // Итоговая строка ENDIF FIELDPUT(5+M_NMod+IF(M_IntKrit=1,0,10),M_F_mera) SELECT (M_VerMod) DBSKIP(1) ENDDO * lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) NEXT // Конец цикла по инт.критериям c ENDIF NEXT // Конец цикла по моделям VerMod##c // Цикл по БД Dost_obj и заполнение столбцов 3-5 данными о макс.диф.вал. с применением L-меры и F-меры, // модели и инт.крит., при которых она обеспечивается по данному классу SELECT Dost_objL1 DBGOTOP() DO WHILE .NOT. EOF() M_MaxDost = -9999999 M_ModMaxD = "" M_IKrMaxD = "" FOR j=1 TO 2*LEN(Ar_Model) MD = FIELDGET(5+j) IF MD > M_MaxDost M_MaxDost = MD M_FieldName = FIELDNAME(5+j) M_ModMaxD = SUBSTR(M_FieldName,1,LEN(M_FieldName)-1) M_IKrMaxD = IF(SUBSTR(M_FieldName,LEN(M_FieldName),1)="k","Резонанс", "Сумма") ENDIF NEXT // Записать M_MaxDost и др. Dost_objL1->Max_dost := M_MaxDost Dost_objL1->Mod_MaxD := M_ModMaxD Dost_objL1->IKr_MaxD := M_IKrMaxD DBSKIP(1) ENDDO SELECT Dost_objL2 DBGOTOP() DO WHILE .NOT. EOF() M_MaxDost = -9999999 M_ModMaxD = "" M_IKrMaxD = "" FOR j=1 TO 2*LEN(Ar_Model) MD = FIELDGET(5+j) IF MD > M_MaxDost M_MaxDost = MD M_FieldName = FIELDNAME(5+j) M_ModMaxD = SUBSTR(M_FieldName,1,LEN(M_FieldName)-1) M_IKrMaxD = IF(SUBSTR(M_FieldName,LEN(M_FieldName),1)="k","Резонанс", "Сумма") ENDIF NEXT // Записать M_MaxDost и др. Dost_objL2->Max_dost := M_MaxDost Dost_objL2->Mod_MaxD := M_ModMaxD Dost_objL2->IKr_MaxD := M_IKrMaxD DBSKIP(1) ENDDO SELECT Dost_objF DBGOTOP() DO WHILE .NOT. EOF() M_MaxDost = -9999999 M_ModMaxD = "" M_IKrMaxD = "" FOR j=1 TO 2*LEN(Ar_Model) MD = FIELDGET(5+j) IF MD > M_MaxDost M_MaxDost = MD M_FieldName = FIELDNAME(5+j) M_ModMaxD = SUBSTR(M_FieldName,1,LEN(M_FieldName)-1) M_IKrMaxD = IF(SUBSTR(M_FieldName,LEN(M_FieldName),1)="k","Резонанс", "Сумма") ENDIF NEXT // Записать M_MaxDost и др. Dost_objF->Max_dost := M_MaxDost Dost_objF->Mod_MaxD := M_ModMaxD Dost_objF->IKr_MaxD := M_IKrMaxD DBSKIP(1) ENDDO ************************************************ *** Дорасчет в БД L2-меры: *** - VerModCls *** - VerModClsIT *** - DostModCls ************************************************ *aStructure := { { "Type_model" , "C",250, 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.Сумма модулей уровней сходства верно идентифицированных объектов расп.выборки (STP) * { "S_F_NIdent" , "N", 15, 7 }, ; // 18.Сумма модулей уровней сходства ошибочно неидентифицированных объектов расп.выборки (SFN) * { "S_F_Ident" , "N", 15, 7 }, ; // 19.Сумма модулей уровней сходства ошибочно идентифицированных объектов расп.выборки (SFP) * { "S_T_NIdent" , "N", 15, 7 }, ; // 20.Сумма модулей уровней сходства верно неидентифицированных объектов расп.выборки (STN) * { "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.Время формирования записи БД CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE VerModCls EXCLUSIVE NEW USE VerModClsIT EXCLUSIVE NEW *USE DostModCls EXCLUSIVE NEW SELECT VerModCls DBGOTOP() DO WHILE .NOT. EOF() REPLACE A_T_IDENT WITH S_T_IDENT /N_T_IDENT REPLACE A_F_NIDENT WITH S_F_NIDENT/N_F_NIDENT REPLACE A_F_IDENT WITH S_F_IDENT /N_F_IDENT REPLACE A_T_NIDENT WITH S_T_NIDENT/N_T_NIDENT REPLACE APRECISION WITH A_T_IDENT/(A_T_IDENT+A_F_IDENT) REPLACE ARECALL WITH A_T_IDENT/(A_T_IDENT+A_F_NIDENT) REPLACE L2_mera WITH 2*(APRECISION*ARECALL)/(APRECISION+ARECALL) // L2-mera = 2*(APrecision*ARecall)/(APrecision+ARecall) (нечеткий мультиклассовый вариант) DBSKIP(1) ENDDO SELECT VerModClsIT DBGOTOP() DO WHILE .NOT. EOF() REPLACE A_T_IDENT WITH S_T_IDENT /N_T_IDENT REPLACE A_F_NIDENT WITH S_F_NIDENT/N_F_NIDENT REPLACE A_F_IDENT WITH S_F_IDENT /N_F_IDENT REPLACE A_T_NIDENT WITH S_T_NIDENT/N_T_NIDENT REPLACE APRECISION WITH A_T_IDENT/(A_T_IDENT+A_F_IDENT) REPLACE ARECALL WITH A_T_IDENT/(A_T_IDENT+A_F_NIDENT) REPLACE L2_mera WITH 2*(APRECISION*ARECALL)/(APRECISION+ARECALL) // L2-mera = 2*(APrecision*ARecall)/(APrecision+ARecall) (нечеткий мультиклассовый вариант) DBSKIP(1) ENDDO *SELECT DostModCls *DBGOTOP() *DO WHILE .NOT. EOF() * * REPLACE A_T_IDENT WITH S_T_IDENT /N_T_IDENT * REPLACE A_F_NIDENT WITH S_F_NIDENT/N_F_NIDENT * REPLACE A_F_IDENT WITH S_F_IDENT /N_F_IDENT * REPLACE A_T_NIDENT WITH S_T_NIDENT/N_T_NIDENT * REPLACE APRECISION WITH A_T_IDENT/(A_T_IDENT+A_F_IDENT) * REPLACE ARECALL WITH A_T_IDENT/(A_T_IDENT+A_F_NIDENT) * REPLACE L2_mera WITH 2*(APRECISION*ARECALL)/(APRECISION+ARECALL) // L2-mera = 2*(APrecision*ARecall)/(APrecision+ARecall) (нечеткий мультиклассовый вариант) * * DBSKIP(1) *ENDDO lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) aSay[12]:SetCaption(L('Шаг 10-й из 11: Создание формы: "Достоверность идент.классов в различных моделях" - Готово ')) *aSay[ 1]:SetCaption(L("Шаг 1-й из 11: Копирование обучающей выборки в распознаваемую - Готово")) *LB_Warning(STR(Wsego,19)+STR(Time_Progress,19)) M_CurrInf = DC_ARestore("_CurrInf.arx") aSay[13]:SetCaption(L('ШАГ 11-Й ИЗ 11: "ПРИСВОЕНИЕ ЗАДАННОЙ МОДЕЛИ:')+' '+Ar_Model[M_CurrInf]+' '+L('СТАТУСА ТЕКУЩЕЙ"')) ***** Восстановление БД Classes и Attributes *********** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Class_Sc EXCLUSIVE NEW USE Gr_ClSc EXCLUSIVE NEW USE Classes EXCLUSIVE NEW MinMaxGrClSc() lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Opis_Sc EXCLUSIVE NEW USE Gr_OpSc EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW MinMaxGrOpSc() lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) M_CurrInf = DC_ARestore("_CurrInf.arx") F5_6(M_CurrInf,.F.,"3_5") // Сделать заданную модель текущей lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) aSay[13]:SetCaption(L('Шаг 11-й из 11: "Присвоение заданной модели:')+' '+Ar_Model[M_CurrInf]+' '+L('статуса текущей" - Готово ')) *aSay[ 1]:SetCaption(L("Шаг 1-й из 11: Копирование обучающей выборки в распознаваемую - Готово")) DC_ASave(aVerifInf, "_VerifInf.arx") // Запись информации о верифицированных моделях *############################################################################################################################################################################################# * @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 Name_SS = "Dost_modCls.dbf" IF mModel_2nd_level = 1 Name_DD = "Dost_modCls_basic_level.dbf" ELSE Name_DD = "Dost_modCls_"+ALLTRIM(STR(mModel_2nd_level))+'nd_level_'+aTypeModel[mRadModelCr]+".dbf" ENDIF *LB_Warning(L("Источник: "+Name_SS+", приемник: "+Name_DD)) COPY FILE (Name_SS) TO (Name_DD) ********* Поиск баз данных по достоверности в папке текущего приложения aDost_modCls := {} // Массив коротких имен файлов баз данных по достоверности aDbfName = DIRECTORY( "Dost_modCls_*.dbf" ) IF LEN(aDbfName) > 0 FOR f = 1 TO LEN(aDbfName) mLongName = aDbfName[f,1] mPos = AT( '.dbf', mLongName) AADD(aDost_modCls, SUBSTR(mLongName, 1, mPos-1) ) NEXT ENDIF * DC_DebugQout( aDost_modCls ) * MsgBox('STOP') CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE DostRasp EXCLUSIVE NEW USE Dost_modCls EXCLUSIVE NEW USE Dost_modClsALL EXCLUSIVE NEW;ZAP // Объединенная база данных по достоверности моделей разных уровней и разных способов нормализации ****************************************************************************************************** ******** Объединить базы данных по достоверности моделей разных уровней и разных способов нормализации ****************************************************************************************************** IF LEN(aDost_modCls) > 0 oScr := DC_WaitOn('Идет объединение базы данных по достоверности моделей разных уровней и разных способов нормализации. Немного подождите!',,,,,,,,,,,.F.) FOR d=1 TO LEN(aDost_modCls) maDost_modCls = aDost_modCls[d] * MsgBox (maDost_modCls) USE (maDost_modCls) EXCLUSIVE NEW NEXT * DC_DebugQout( aDost_modCls ) * MsgBox('STOP') FOR d=1 TO LEN(aDost_modCls) maDost_modCls = aDost_modCls[d] * MsgBox (maDost_modCls) SELECT (maDost_modCls) DBGOTOP() DO WHILE .NOT. EOF() aRecord := {} FOR j=1 TO FCOUNT() AADD(aRecord, FIELDGET(j)) NEXT SELECT Dost_modClsALL APPEND BLANK FOR j=1 TO LEN(aRecord) FIELDPUT(j, aRecord[j]) NEXT SELECT (maDost_modCls) DBSKIP(1) ENDDO NEXT CLOSE Dost_modClsALL COPY FILE ("Dost_modClsALL.dbf") TO ("Dost_modClsALL.xls") DC_Impl(oScr) ENDIF *############################################################################################################################################################################################# ENDIF // Если есть распознавание #################### DO CASE CASE nRadioM = 1 oSay97:SetCaption(L("Синтез и верификация статистических и системно-когнитивных моделей упешно завершены !!!")) CASE nRadioM = 2 oSay97:SetCaption(L("Верификация заданных статистических и системно-когнитивных моделей упешно завершена !!!")) CASE nRadioM = 3 IF mRegim <> '3.7.9' oSay97:SetCaption(L("Синтез заданных статистических и системно-когнитивных моделей упешно завершен !!!")) ENDIF ENDCASE Running(.T.) // Чтобы не могли запустить какой-нибудь режим пока висит окно окончания работы IF mRegim <> '3.7.9' 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 *InfKritRnd() // Расчет информационного критерия качества шума ****************************************** ****** Обработка ошибки ****************** bError := ErrorBlock( {|e| Break(e)} ) // установить новый кодовый блок обработки ошибок BEGIN SEQUENCE // код нормального исполнения *** код нормального исполнения IF mProcessor = 'CPU' CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций FOR z=1 TO LEN(nHandle) FClose( nHandle[z] ) // Закрытие dbf и txt баз данных ###################################### NEXT ENDIF RECOVER // код обработки ошибки * EXIT ENDSEQUENCE ErrorBlock( bError ) // переустановить старый кодовый ****************************************** ****************************************** IF nRadioM <> 3 ********* Прописывает для числовых шкал в БД Classes и Attributes минимальное, максимальное и среднее значение всех градаций MinMaxAvr() * MsgBox(IF(FlagRsp,'.T.','.F.')) IF FlagRsp = .F. // .T. - удалось полностью записать базу данных результатов (она меньше 2Гб), .F. - не удалось (база больше 2Гб) 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 StrFile("35", "Rasp.txt") // Запись текстового файла с информацией о том, что был выполнен режим 3.5 IF mRegim <> '3.7.9' ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** ENDIF Running(.F.) RETURN NIL ******************************************************************************************************* FUNCTION Help35() aHelp := {} AADD(aHelp, L('Оценивается достоверность заданных стат.моделей и моделей знаний. Для этого обучающая')) AADD(aHelp, L('выборка копируется в распознаваемую в заданном режиме, осуществляется синтез заданных')) AADD(aHelp, L('моделей, а затем в каждой из них проводится распознавание и подсчитывается количество')) AADD(aHelp, L('верно идентифицированных, верно не идентифицированных, ошибочно идентифицированных и ')) AADD(aHelp, L('ошибочно не идентифицированных объектов (ошибки 1-го и 2-го рода). Для верификации ')) AADD(aHelp, L('могут быть заданы стат.модели: Abs, Prc1, Prc2 и модели знаний: Inf1~Prc1, Inf2~Prc2,')) AADD(aHelp, L('Inf3-хи-квадрат, Inf4-roi~Prc1, Inf5-roi~Prc2, Inf6-Dp~Prc1, Inf7-Dp~Prc2. ')) 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('3.5. Пояснение по алгоритму верификации моделей') RETURN NIL ************************************************************************************************** FUNCTION Help_AbsFon() aHelp := {} AADD(aHelp, L('МОДЕЛЬ ABS С НЕНУЛЕВЫМ ФОНОВЫМ ЗНАЧЕНИЕМ:')) AADD(aHelp, L('Если задана опция синтеза модели Abs на основе обучающей выборки (по умолчанию), то ')) AADD(aHelp, L('есть возможность в качестве начальных значений элементов матрицы абсолютных частот ')) AADD(aHelp, L('задать не нули (по умолчанию), а другие фоновые значения. К этим фоновым значениям ')) AADD(aHelp, L('и будут суммироваться абсолютные частоты. Это значит, что при малых частотах и/или ')) AADD(aHelp, L('при отсутствии всех сочетаний значений градаций классификационных и описательных ')) AADD(aHelp, L('шкал в обучающей выборке в модели Abs не будет ячеек со значениями равными нулю. ')) AADD(aHelp, L('')) AADD(aHelp, L('ИЕРАРХИЧЕСКИЕ ИТЕРАЦИОННЫЕ МОДЕЛИ:')) AADD(aHelp, L('Если модели в приложении создаются впервые, то расчет модели Abs (матрицы абсолютных ')) AADD(aHelp, L('частот) возможен только на основе обучающей выборки. Но если модели уже созданы, то ')) AADD(aHelp, L('в системе "Эйдос" есть возможность не рассчитывать модель Abs на основе обучающей ')) AADD(aHelp, L('выборки, а скопировать ее из одной из ранее созданных статистических или системно- ')) AADD(aHelp, L('когнитивных моделей: Abs, Prc1, Prc2, Inf1, Inf2, Inf3, Inf4, Inf5, Inf6, Inf7. ')) AADD(aHelp, L('Например, если Abs скопировать из Prc1 или Prc2, т.е. перейти от абсолютных условных ')) AADD(aHelp, L('и безусловных частот к относительным, то полностью решается проблема несбалансирован-')) AADD(aHelp, L('ности исходных данных, заключающаяся в том, что по разным классам сильно отличается ')) AADD(aHelp, L('количество объектов обучающей выборки. Если же скопировать Abs из какой-либо модели ')) AADD(aHelp, L('Inf1,Inf2,Inf3,Inf4,Inf5,Inf6,Inf7, то кроме проблемы несбалансированности данных ')) AADD(aHelp, L('решается и проблема их несопоставимости, если они в разных типах шкал, номинальных, ')) AADD(aHelp, L('порядковых и числовых и в разных единицах измерения. После синтеза моделей на основе ')) AADD(aHelp, L('матрицы абсолютных частот Abs можно повторять эту операцию сколько угодно, получая ')) AADD(aHelp, L('таким образом, все новые и новые иерархические итерационные модели. ')) AADD(aHelp, L('')) AADD(aHelp, L('Ненулевой фон и иерархические итерационные модели не работают на GPU. ')) 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 MODAL TITLE L('3.5. Пояснение по алгоритму синтеза моделей') RETURN NIL ************************************************************************************************** FUNCTION Help_NormModels() aHelp := {} AADD(aHelp, L('В данном режиме генерируются улучшенные матричные статистические и системно-когнитивные модели АСК-анализа и системы Эйдос. ')) AADD(aHelp, L('К 10 базовым моделям, включающим в частности количество информации по Харкевичу, хи-квадрат и ROI, были добавлены еще 120 моделей ')) AADD(aHelp, L('2-го и 3-го уровней, некоторые из которых имеют более высокую достоверность по F-мере Ван Ризбергена, чем базовые модели. ')) AADD(aHelp, L('')) AADD(aHelp, L('Модели 2-го уровня формируются путем создания 6 производных матриц из базовой матрицы абсолютных частот (Abs) через сравнение ')) AADD(aHelp, L('значений с такими метриками, как среднее, среднее абсолютное отклонение (MAD) или среднеквадратичное отклонение по признакам. ')) AADD(aHelp, L('Сравнение проводится методом вычитания или деления. Это позволяет учитывать не только абсолютные значения, но и их отклонения ')) AADD(aHelp, L('относительно центральных тенденций, что усиливает чувствительность моделей к локальным особенностям данных. На основе этих ')) AADD(aHelp, L('производных матриц строятся 60 моделей 2-го уровня, которые демонстрируют повышенную достоверность по F-мере Ван Ризбергена. ')) AADD(aHelp, L('')) AADD(aHelp, L('Модели 3-го уровня фокусируются на анализе коэффициентов взаимосвязи между признаками и классами. Каждая из 10 базовых моделей ')) AADD(aHelp, L('преобразуется в 6 производных путем сравнения частных критериев (например, коэффициентов корреляции) с теми же статистическими ')) AADD(aHelp, L('метриками (среднее, MAD, среднеквадратичное отклонение). Это позволяет улавливать нелинейные зависимости и повышать устойчивость ')) AADD(aHelp, L('моделей к шуму в данных. В результате формируется 60 моделей 3-го уровня, которые дополняют анализ за счет учета внутренних связей')) AADD(aHelp, L('между переменными. ')) AADD(aHelp, L('')) AADD(aHelp, L('Модели 2-го и 3-го уровней в рамках АСК-анализа и системы "Эйдос" обеспечивают улучшение точности и надежности прогнозирования ')) 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-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 MODAL TITLE L('3.5. Пояснение по алгоритму синтеза моделей') RETURN NIL ************************************************************************************************** ****************************************************************************** ******** Расчет отчета по дифференциальной и интегральной достоверности модели ****************************************************************************** FUNCTION GenValidModCls(M_NumMod, M_IntKrit) IF ApplChange("") // Перейти в папку выбранного приложения или выйти из системы LB_Warning(L("Необходимо задать (выбрать) хотя бы одно текущее приложение !!!")) Running(.F.) RETURN NIL ENDIF GenDbfVerModCls(M_NumMod, M_IntKrit) // Создать БД для измерения достоверности моделей // Имя БД, созданной GenDbfValSys, с результами оценки достоверности модели по инт.критерию M_VerMod := "VerModCls"+STRTRAN(STR(M_NumMod,2)," ","0")+IF(M_IntKrit=1,"k","i") // Формирование имен файлов с результатами распознавания // <===################## при GPU - сформировать эти БД из Rasp.dbf M_Rsp1 = "Rsp1"+IF(M_IntKrit=1,"k","i") M_Rsp2 = "Rsp2"+IF(M_IntKrit=1,"k","i") M_Rsp_it1 = "Rsp" +IF(M_IntKrit=1,"k","i")+"1" M_Rsp_it2 = "Rsp" +IF(M_IntKrit=1,"k","i")+"2" ** Генерация БД ValidSys.dbf IF .NOT. FILE(M_Rsp2+".dbf") Mess = L("СФОРМИРУЙТЕ РАСПОЗНАВАЕМУЮ ВЫБОРКУ И ВЫПОЛНИТЕ РАСПОЗНАВАНИЕ!!!") // <===################## LB_Warning(Mess) RETURN NIL ENDIF ***** АЛГОРИТМ СДЕЛАН НА ОСНОВЕ АЛГОРИТМА ФОРМИРОВАНИЯ RASP_IT2 ***** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes INDEX Cls_kod EXCLUSIVE NEW USE (M_VerMod) EXCLUSIVE NEW;ZAP SELECT Classes SET ORDER TO 1 DBGOTOP() DO WHILE .NOT. EOF() M_Kod = Kod_cls M_Name = Name_cls SELECT (M_VerMod) APPEND BLANK REPLACE KOD_CLS WITH M_Kod REPLACE NAME_CLS WITH M_Name SELECT Classes DBSKIP(1) ENDDO ***** Заполняем базу итогов данными из (M_Rsp2).dbf **** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (M_Rsp2) EXCLUSIVE NEW INDEX ON STR(Kod_cls,19) TO Rsp2_cls CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (M_VerMod) EXCLUSIVE NEW INDEX ON STR(Kod_cls,19) TO Ver_cls ***** Начало цикла по БД результатов распознавания CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes INDEX Cls_kod EXCLUSIVE NEW;N_Cls = RECCOUNT() // Количество классов 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 (M_Rsp2) INDEX Rsp2_cls EXCLUSIVE NEW USE (M_VerMod) INDEX Ver_cls EXCLUSIVE NEW USE VerModCls EXCLUSIVE NEW // Объединить все (M_VerMod) по классам без итоговых строк USE VerModClsIT EXCLUSIVE NEW // Объединить все (M_VerMod) итоговые строки без классов ****** Расчет интегрального качества распознавания класса N°Cls *************** * Структура базы данных N°=53: VerModCls.dbf * ============================================================================ * | N | Имя поля | Тип | Ширина | Дес. | Примечание | * ============================================================================ * | 1 | MODINTKRIT | C | 9 | 0 | 1. ModIntKrit Код: ##_####_#, где: ##-числовой номер модели и инт.критерия {1-20}, ####-модель {Abs,Prc1,Prc2,Inf1,Inf2,Inf3,Inf4,Inf5,Inf6,Inf7}, #-инт.крит.: {k,i} * | 2 | KOD_CLS | N | 15 | 0 | 2. Код класса * | 3 | NAME_CLS | C | 35 | 0 | 3. Наименование класса * | 4 | DIFVALMOD | N | 15 | 7 | 4. DifValMod Достоверность идентификации класса (с учетом всех верно и ошибочно идентифицированных и неидентифицированных логических объектов)) * | 5 | AVRURSX_T | N | 15 | 7 | 5. AvrUrSx_T Средний модуль уровней сходства ВЕРНО идентифицированных и неидентифицированных объектов * | 6 | AVRURSX_F | N | 15 | 7 | 6. AvrUrSx_F Средний модуль уровней сходства ОШИБОЧНО идентифицированных и неидентифицированных объектов * | 7 | DIFAVRURSX | N | 15 | 7 | 7. DifAvrUrSx Разность средних модулей уровней сходства ВЕРНО и ОШИБОЧНО идентифицированных и неидентифицированных объектов * | 8 | N_LOGOBJ | N | 15 | 7 | 8. N_LogObj Количество объектов расп.выборки, фактически относящихся к классу * | 9 | N_T_IDENT | N | 15 | 7 | 9. N_T_Ident Количество верно идентифицированных объектов расп.выборки (TP - истино-положительное решение) * | 10 | N_F_NIDENT | N | 15 | 7 | 10. N_F_NIdent Количество ошибочно неидентифицированных объектов расп.выборки (FN - ложно-отрицательное решение) * | 11 | N_F_IDENT | N | 15 | 7 | 11. N_F_Ident Количество ошибочно идентифицированных объектов расп.выборки (FP - ложно-положительное решение) * | 12 | N_T_NIDENT | N | 15 | 7 | 12. N_T_NIdent Количество верно неидентифицированных объектов расп.выборки (TN - истино-отрицательное решение) * | 13 | DVMOD | N | 15 | 7 | 13. M_DVMod = (NT-NF)/(NT+NF)*100 Дифференциальная валидность (достоверность) модели (по классу) (в знаменателе: "всего объектов"). NT = N_T_id+N_T_nid: Количество ВЕРНО идентифицированных и неидентифицированных объектов, NF = N_F_id+N_F_nid: Количество ОШИБОЧНО идентифицированных и неидентифицированных объектов * | 14 | PRECISION | N | 15 | 7 | 14. Precision = TP/(TP+FP) - точность * | 15 | RECALL | N | 15 | 7 | 15. Recall = TP/(TP+FN) - полнота * | 16 | F_MERA | N | 15 | 7 | 16. F-mera = 2*(Precision*Recall)/(Precision+Recall) (мультиклассовый вариант) * | 17 | P_T_IDENT | N | 15 | 7 | 17. P_T_Ident Вероятность верной идентификации объекта с классом с использованием модели * | 18 | P_T_NIDENT | N | 15 | 7 | 18. P_T_NIdent Вероятность верной не идентификации объекта с классом с использованием модели * | 19 | P_F_IDENT | N | 15 | 7 | 19. P_F_Ident Вероятность ошибочной идентификации объекта с классом с использованием модели * | 20 | P_F_NIDENT | N | 15 | 7 | 20. P_F_NIdent Вероятность ошибочной не идентификации объекта с классом с использованием модели * | 21 | P_SLUG_ID | N | 15 | 7 | 21. P_SlUg_Id Вероятность случайного угадывания принадлежности объектов к классам * | 22 | P_SLUG_NID | N | 15 | 7 | 22. P_SlUg_NId Вероятность случайного угадывания непринадлежности объектов к классам * | 23 | EFFMOD_ID | N | 15 | 7 | 23. EffMod_Id Эффективность модели при идентификации: отношение вероятности верной идентификации при использовании модели к вероятности случайного угадывания принадлежности объекта к классу * | 24 | EFFMOD_NID | N | 15 | 7 | 24. EffMod_NId Эффективность модели при неидентификации: отношение вероятности верной неидентификации при использовании модели к вероятности случайного угадывания непринадлежности объекта к классу * | 25 | AVR_EFFMOD | N | 15 | 7 | 25. Avr_EffMod Средняя эффективность модели: (EffMod_Id+EffMod_NId)/2 * | 26 | S_T_IDENT | N | 15 | 7 | 26.Сумма модулей уровней сходства верно идентифицированных объектов расп.выборки (STP - истино-положительное решение) * | 27 | S_F_NIDENT | N | 15 | 7 | 27.Сумма модулей уровней сходства ошибочно неидентифицированных объектов расп.выборки (SFN - ложно-отрицательное решение) * | 28 | S_F_IDENT | N | 15 | 7 | 28.Сумма модулей уровней сходства ошибочно идентифицированных объектов расп.выборки (SFP - ложно-положительное решение) * | 29 | S_T_NIDENT | N | 15 | 7 | 29.Сумма модулей уровней сходства верно неидентифицированных объектов расп.выборки (STN - истино-отрицательное решение) * | 30 | SPRECISION | N | 15 | 7 | 30.SPrecision = STP/(STP+SFP) - точность с учетом уровней сходства * | 31 | SRECALL | N | 15 | 7 | 31.SRecall = STP/(STP+SFN) - полнота с учетом уровней сходства * | 32 | L1_mera | N | 15 | 7 | 32.L1-mera = 2*(SPrecision*SRecall)/(SPrecision+SRecall) (L1-мера проф.Е.В.Луценко - нечеткое мультиклассовое обобщение * | 33 | DATE | C | 10 | 0 | 33. Date Дата формирования записи БД * | 34 | TIME | C | 8 | 0 | 34. Time Время формирования записи БД * ============================================================================ * В С Е Г О длина записи: 513 байтов. | * ============================================================================ PRIVATE A_Rec[34] // Массив для текущей записи по классу PRIVATE A_Wsg[34] // Массив для итоговой записи по всем классам AFILL(A_Rec,0) // Массив для текущей записи по классу AFILL(A_Wsg,0) // Массив для итоговой записи по всем классам SELECT (M_VerMod) SET ORDER TO 1 DBGOTOP() N_LogObjALL = 0 // Суммарное количество логических объектов по всей выборке DO WHILE .NOT. EOF() M_KodCls = Kod_cls ******** Расчет дифференциальной достоверности модели по классу (качество распознавания класса) AFILL(A_Rec,0) // Массив для текущей записи по классу N_LogObjCLS = 0 // Суммарное количество логических объектов по классу SELECT (M_Rsp2);SET ORDER TO 1;T=DBSEEK(STR(M_KodCls,19)) IF T * | 26 | S_T_IDENT | N | 15 | 7 | 26.Сумма модулей уровней сходства верно идентифицированных объектов расп.выборки (STP - истино-положительное решение) * | 27 | S_F_NIDENT | N | 15 | 7 | 27.Сумма модулей уровней сходства ошибочно неидентифицированных объектов расп.выборки (SFN - ложно-отрицательное решение) * | 28 | S_F_IDENT | N | 15 | 7 | 28.Сумма модулей уровней сходства ошибочно идентифицированных объектов расп.выборки (SFP - ложно-положительное решение) * | 29 | S_T_NIDENT | N | 15 | 7 | 29.Сумма модулей уровней сходства верно неидентифицированных объектов расп.выборки (STN - истино-отрицательное решение) DO WHILE Kod_cls=M_KodCls .AND. .NOT. EOF() DO CASE CASE M_IntKrit = 1 // Подсчет по инт.критерию "Корреляция" DO CASE CASE Korr > 0 * | 9 | N_T_IDENT | N | 15 | 7 | 9. N_T_Ident Количество верно идентифицированных объектов расп.выборки (TP - истино-положительное решение) * | 10 | N_F_NIDENT | N | 15 | 7 | 10. N_F_NIdent Количество ошибочно неидентифицированных объектов расп.выборки (FN - ложно-отрицательное решение) * | 11 | N_F_IDENT | N | 15 | 7 | 11. N_F_Ident Количество ошибочно идентифицированных объектов расп.выборки (FP - ложно-положительное решение) * | 12 | N_T_NIDENT | N | 15 | 7 | 12. N_T_NIdent Количество верно неидентифицированных объектов расп.выборки (TN - истино-отрицательное решение) IF LEN(ALLTRIM(Fakt)) > 0 A_Rec[ 9] = A_Rec[ 9] + 1 // 9. N_T_Ident Количество верно идентифицированных объектов расп.выборки (TP - истино-положительное решение) * A_Rec[26] = A_Rec[26] + 1 // 26. S_T_IDENT Сумма модулей уровней сходства верно идентифицированных объектов расп.выборки (STP - истино-положительное решение) A_Rec[ 5] = A_Rec[ 5] + ABS(Korr)/100 // 5. AvrUrSx_T Средний модуль уровней сходства ВЕРНО идентифицированных и неидентифицированных объектов A_Rec[26] = A_Rec[26] + ABS(Korr)/100 // 26. S_T_IDENT Сумма модулей уровней сходства верно идентифицированных объектов расп.выборки (STP - истино-положительное решение) ++N_LogObjCLS // Суммарное количество логических объектов по классу ++N_LogObjALL // Суммарное количество логических объектов по всей выборке ELSE * | 9 | N_T_IDENT | N | 15 | 7 | 9. N_T_Ident Количество верно идентифицированных объектов расп.выборки (TP - истино-положительное решение) * | 10 | N_F_NIDENT | N | 15 | 7 | 10. N_F_NIdent Количество ошибочно неидентифицированных объектов расп.выборки (FN - ложно-отрицательное решение) * | 11 | N_F_IDENT | N | 15 | 7 | 11. N_F_Ident Количество ошибочно идентифицированных объектов расп.выборки (FP - ложно-положительное решение) * | 12 | N_T_NIDENT | N | 15 | 7 | 12. N_T_NIdent Количество верно неидентифицированных объектов расп.выборки (TN - истино-отрицательное решение) A_Rec[11] = A_Rec[11] + 1 // 11. N_F_Ident Количество ошибочно идентифицированных объектов расп.выборки (FP - ложно-положительное решение) * A_Rec[28] = A_Rec[28] + 1 // 28. S_F_IDENT Сумма модулей уровней сходства ошибочно идентифицированных объектов расп.выборки (SFP - ложно-положительное решение) A_Rec[ 6] = A_Rec[ 6] + ABS(Korr)/100 // 6. AvrUrSx_F Средний модуль уровней сходства ОШИБОЧНО идентифицированных и неидентифицированных объектов A_Rec[28] = A_Rec[28] + ABS(Korr)/100 // 28. S_F_IDENT Сумма модулей уровней сходства ошибочно идентифицированных объектов расп.выборки (SFP - ложно-положительное решение) ENDIF CASE Korr <= 0 IF LEN(ALLTRIM(Fakt)) > 0 * | 9 | N_T_IDENT | N | 15 | 7 | 9. N_T_Ident Количество верно идентифицированных объектов расп.выборки (TP - истино-положительное решение) * | 10 | N_F_NIDENT | N | 15 | 7 | 10. N_F_NIdent Количество ошибочно неидентифицированных объектов расп.выборки (FN - ложно-отрицательное решение) * | 11 | N_F_IDENT | N | 15 | 7 | 11. N_F_Ident Количество ошибочно идентифицированных объектов расп.выборки (FP - ложно-положительное решение) * | 12 | N_T_NIDENT | N | 15 | 7 | 12. N_T_NIdent Количество верно неидентифицированных объектов расп.выборки (TN - истино-отрицательное решение) A_Rec[10] = A_Rec[10] + 1 // 10. N_F_NIdent Количество ошибочно неидентифицированных объектов расп.выборки (FN - ложно-отрицательное решение) * A_Rec[27] = A_Rec[27] + 1 // 27. S_F_NIDENT Сумма модулей уровней сходства ошибочно неидентифицированных объектов расп.выборки (SFN - ложно-отрицательное решение) A_Rec[ 6] = A_Rec[ 6] + ABS(Korr)/100 // 6. AvrUrSx_F Средний модуль уровней сходства ОШИБОЧНО идентифицированных и неидентифицированных объектов A_Rec[27] = A_Rec[27] + ABS(Korr)/100 // 27. S_F_NIDENT Сумма модулей уровней сходства ошибочно неидентифицированных объектов расп.выборки (SFN - ложно-отрицательное решение) ++N_LogObjCLS // Суммарное количество логических объектов по классу ++N_LogObjALL // Суммарное количество логических объектов по всей выборке ELSE * | 9 | N_T_IDENT | N | 15 | 7 | 9. N_T_Ident Количество верно идентифицированных объектов расп.выборки (TP - истино-положительное решение) * | 10 | N_F_NIDENT | N | 15 | 7 | 10. N_F_NIdent Количество ошибочно неидентифицированных объектов расп.выборки (FN - ложно-отрицательное решение) * | 11 | N_F_IDENT | N | 15 | 7 | 11. N_F_Ident Количество ошибочно идентифицированных объектов расп.выборки (FP - ложно-положительное решение) * | 12 | N_T_NIDENT | N | 15 | 7 | 12. N_T_NIdent Количество верно неидентифицированных объектов расп.выборки (TN - истино-отрицательное решение) A_Rec[12] = A_Rec[12] + 1 // 12. N_T_NIdent Количество верно неидентифицированных объектов расп.выборки (TN - истино-отрицательное решение) * A_Rec[29] = A_Rec[29] + 1 // 29. S_T_NIDENT Сумма модулей уровней сходства верно неидентифицированных объектов расп.выборки (STN - истино-отрицательное решение) A_Rec[ 5] = A_Rec[ 5] + ABS(Korr)/100 // 5. AvrUrSx_T Средний модуль уровней сходства ВЕРНО идентифицированных и неидентифицированных объектов A_Rec[29] = A_Rec[29] + ABS(Korr)/100 // 29. S_T_NIDENT Сумма модулей уровней сходства верно неидентифицированных объектов расп.выборки (STN - истино-отрицательное решение) ENDIF ENDCASE CASE M_IntKrit = 2 // Подсчет по инт.критерию "Сумма" DO CASE CASE Sum_inf > 0 IF LEN(ALLTRIM(Fakt)) > 0 * | 9 | N_T_IDENT | N | 15 | 7 | 9. N_T_Ident Количество верно идентифицированных объектов расп.выборки (TP - истино-положительное решение) * | 10 | N_F_NIDENT | N | 15 | 7 | 10. N_F_NIdent Количество ошибочно неидентифицированных объектов расп.выборки (FN - ложно-отрицательное решение) * | 11 | N_F_IDENT | N | 15 | 7 | 11. N_F_Ident Количество ошибочно идентифицированных объектов расп.выборки (FP - ложно-положительное решение) * | 12 | N_T_NIDENT | N | 15 | 7 | 12. N_T_NIdent Количество верно неидентифицированных объектов расп.выборки (TN - истино-отрицательное решение) A_Rec[ 9] = A_Rec[ 9] + 1 // 9. N_T_Ident Количество верно идентифицированных объектов расп.выборки (TP - истино-положительное решение) * A_Rec[26] = A_Rec[26] + 1 // 26. Сумма модулей уровней сходства верно идентифицированных объектов расп.выборки (STP - истино-положительное решение) A_Rec[ 5] = A_Rec[ 5] + ABS(Sum_inf)/100 // 5. AvrUrSx_T Средний модуль уровней сходства ВЕРНО идентифицированных и неидентифицированных объектов A_Rec[26] = A_Rec[26] + ABS(Sum_inf)/100 // 26. Сумма модулей уровней сходства верно идентифицированных объектов расп.выборки (STP - истино-положительное решение) ++N_LogObjCLS // Суммарное количество логических объектов по классу ++N_LogObjALL // Суммарное количество логических объектов по всей выборке ELSE * | 9 | N_T_IDENT | N | 15 | 7 | 9. N_T_Ident Количество верно идентифицированных объектов расп.выборки (TP - истино-положительное решение) * | 10 | N_F_NIDENT | N | 15 | 7 | 10. N_F_NIdent Количество ошибочно неидентифицированных объектов расп.выборки (FN - ложно-отрицательное решение) * | 11 | N_F_IDENT | N | 15 | 7 | 11. N_F_Ident Количество ошибочно идентифицированных объектов расп.выборки (FP - ложно-положительное решение) * | 12 | N_T_NIDENT | N | 15 | 7 | 12. N_T_NIdent Количество верно неидентифицированных объектов расп.выборки (TN - истино-отрицательное решение) A_Rec[11] = A_Rec[11] + 1 // 11. N_F_Ident Количество ошибочно идентифицированных объектов расп.выборки (FP - ложно-положительное решение) * A_Rec[28] = A_Rec[28] + 1 // 28. Сумма модулей уровней сходства ошибочно идентифицированных объектов расп.выборки (SFP - ложно-положительное решение) A_Rec[ 6] = A_Rec[ 6] + ABS(Sum_inf)/100 // 6. AvrUrSx_F Средний модуль уровней сходства ОШИБОЧНО идентифицированных и неидентифицированных объектов A_Rec[28] = A_Rec[28] + ABS(Sum_inf)/100 // 28. Сумма модулей уровней сходства ошибочно идентифицированных объектов расп.выборки (SFP - ложно-положительное решение) ENDIF CASE Sum_inf <= 0 IF LEN(ALLTRIM(Fakt)) > 0 * | 9 | N_T_IDENT | N | 15 | 7 | 9. N_T_Ident Количество верно идентифицированных объектов расп.выборки (TP - истино-положительное решение) * | 10 | N_F_NIDENT | N | 15 | 7 | 10. N_F_NIdent Количество ошибочно неидентифицированных объектов расп.выборки (FN - ложно-отрицательное решение) * | 11 | N_F_IDENT | N | 15 | 7 | 11. N_F_Ident Количество ошибочно идентифицированных объектов расп.выборки (FP - ложно-положительное решение) * | 12 | N_T_NIDENT | N | 15 | 7 | 12. N_T_NIdent Количество верно неидентифицированных объектов расп.выборки (TN - истино-отрицательное решение) A_Rec[10] = A_Rec[10] + 1 // 10. N_F_NIdent Количество ошибочно неидентифицированных объектов расп.выборки (FN - ложно-отрицательное решение) * A_Rec[27] = A_Rec[27] + 1 // 27. Сумма модулей уровней сходства ошибочно неидентифицированных объектов расп.выборки (SFN - ложно-отрицательное решение) A_Rec[ 6] = A_Rec[ 6] + ABS(Sum_inf)/100 // 6. AvrUrSx_F Средний модуль уровней сходства ОШИБОЧНО идентифицированных и неидентифицированных объектов A_Rec[27] = A_Rec[27] + ABS(Sum_inf)/100 // 27. Сумма модулей уровней сходства ошибочно неидентифицированных объектов расп.выборки (SFN - ложно-отрицательное решение) ++N_LogObjCLS // Суммарное количество логических объектов по классу ++N_LogObjALL // Суммарное количество логических объектов по всей выборке ELSE * | 9 | N_T_IDENT | N | 15 | 7 | 9. N_T_Ident Количество верно идентифицированных объектов расп.выборки (TP - истино-положительное решение) * | 10 | N_F_NIDENT | N | 15 | 7 | 10. N_F_NIdent Количество ошибочно неидентифицированных объектов расп.выборки (FN - ложно-отрицательное решение) * | 11 | N_F_IDENT | N | 15 | 7 | 11. N_F_Ident Количество ошибочно идентифицированных объектов расп.выборки (FP - ложно-положительное решение) * | 12 | N_T_NIDENT | N | 15 | 7 | 12. N_T_NIdent Количество верно неидентифицированных объектов расп.выборки (TN - истино-отрицательное решение) A_Rec[12] = A_Rec[12] + 1 // 12. N_T_NIdent Количество верно неидентифицированных объектов расп.выборки (TN - истино-отрицательное решение) * A_Rec[29] = A_Rec[29] + 1 // 29. Сумма модулей уровней сходства верно неидентифицированных объектов расп.выборки (STN - истино-отрицательное решение) A_Rec[ 5] = A_Rec[ 5] + ABS(Sum_inf)/100 // 5. AvrUrSx_T Средний модуль уровней сходства ВЕРНО идентифицированных и неидентифицированных объектов A_Rec[29] = A_Rec[29] + ABS(Sum_inf)/100 // 29. Сумма модулей уровней сходства верно неидентифицированных объектов расп.выборки (STN - истино-отрицательное решение) ENDIF ENDCASE ENDCASE DBSKIP(1) ENDDO *********************************************************************************************************************************** ** Мой вариант метрики (старый) *************************************************************************************************** ** Сумма верно идентифицированных и неидентифицированных объектов ** минус ошибочно идентифицированных и неидентифицированных объектов ** деленная на количество объектов (среднее на объект) в процентах * NT = N_T_id+N_T_nid // Количество ВЕРНО идентифицированных и неидентифицированных объектов * NF = N_F_id+N_F_nid // Количество ОШИБОЧНО идентифицированных и неидентифицированных объектов NT = A_Rec[ 9] + A_Rec[12] // Количество ВЕРНО идентифицированных и неидентифицированных объектов NF = A_Rec[11] + A_Rec[10] // Количество ОШИБОЧНО идентифицированных и неидентифицированных объектов *********************************************************************************************************************************** * M_DVMod = (NT-NF)/(NT+NF)*100 // Дифференциальная валидность (достоверность) модели (по классу) (в знаменателе: "всего объектов") *********************************************************************************************************************************** ****** Занесение информации в БД ValidSys SELECT (M_VerMod) ** Мой вариант метрики ************************************************************************************************************ * REPLACE DifValMod WITH M_DVMod // Дифференциальная валидность (достоверность) модели (по классу), нормированная к {-1,+1} * REPLACE DVMod WITH (1+M_DVMod)/2 // Дифференциальная валидность (достоверность) модели (по классу), нормированная к { 0, 1} * | 5 | AVRURSX_T | N | 15 | 7 | 5. AvrUrSx_T Средний модуль уровней сходства ВЕРНО идентифицированных и неидентифицированных объектов * | 6 | AVRURSX_F | N | 15 | 7 | 6. AvrUrSx_F Средний модуль уровней сходства ОШИБОЧНО идентифицированных и неидентифицированных объектов * | 7 | DIFAVRURSX | N | 15 | 7 | 7. DifAvrUrSx Разность средних модулей уровней сходства ВЕРНО и ОШИБОЧНО идентифицированных и неидентифицированных объектов REPLACE AvrUrSx_T WITH IF(NT>0,A_Rec[ 5]/NT,0) // Средний модуль уровней сходства ВЕРНО идентифицированных и неидентифицированных объектов REPLACE AvrUrSx_F WITH IF(NF>0,A_Rec[ 6]/NF,0) // Средний модуль уровней сходства ОШИБОЧНО идентифицированных и неидентифицированных объектов REPLACE DifAvrUrSx WITH AvrUrSx_T-AvrUrSx_F // Разность средних модулей уровней сходства ВЕРНО и ОШИБОЧНО идентифицированных и неидентифицированных объектов REPLACE N_LogObj WITH N_LogObjCLS // Количество логических объектов, фактически относящихся к классу: те, что к нему верно отнесены + те, которые к нему ошибочно не отнесены * | 9 | N_T_IDENT | N | 15 | 7 | 9. N_T_Ident Количество верно идентифицированных объектов расп.выборки (TP - истино-положительное решение) * | 10 | N_F_NIDENT | N | 15 | 7 | 10. N_F_NIdent Количество ошибочно неидентифицированных объектов расп.выборки (FN - ложно-отрицательное решение) * | 11 | N_F_IDENT | N | 15 | 7 | 11. N_F_Ident Количество ошибочно идентифицированных объектов расп.выборки (FP - ложно-положительное решение) * | 12 | N_T_NIDENT | N | 15 | 7 | 12. N_T_NIdent Количество верно неидентифицированных объектов расп.выборки (TN - истино-отрицательное решение) REPLACE N_T_IDENT WITH A_Rec[ 9] // 9. N_T_Ident Количество верно идентифицированных объектов расп.выборки (TP - истино-положительное решение) REPLACE N_F_NIDENT WITH A_Rec[10] // 10. N_F_NIdent Количество ошибочно неидентифицированных объектов расп.выборки (FN - ложно-отрицательное решение) REPLACE N_F_IDENT WITH A_Rec[11] // 11. N_F_Ident Количество ошибочно идентифицированных объектов расп.выборки (FP - ложно-положительное решение) REPLACE N_T_NIDENT WITH A_Rec[12] // 12. N_T_NIdent Количество верно неидентифицированных объектов расп.выборки (TN - истино-отрицательное решение) REPLACE P_T_Ident WITH N_T_Ident /N_LogObj * 100 // Вероятность верной идентификации объекта с классом ###### в % REPLACE P_F_NIdent WITH N_F_NIdent/N_LogObj * 100 // Вероятность ошибочной не идентификации объекта с классом ###### REPLACE P_F_Ident WITH N_F_Ident /(N_Obj-N_LogObj) * 100 // Вероятность ошибочной идентификации объекта с классом ###### REPLACE P_T_NIdent WITH N_T_NIdent/(N_Obj-N_LogObj) * 100 // Вероятность верной не идентификации объекта с классом ###### *********************************************************************************************************************************** ** F-мера Ван Ризбергена ********************************************************************************************************** *********************************************************************************************************************************** TP = N_T_Ident // 9. N_T_Ident Количество верно идентифицированных объектов расп.выборки (TP - истино-положительное решение) FN = N_F_NIdent // 10. N_F_NIdent Количество ошибочно неидентифицированных объектов расп.выборки (FN - ложно-отрицательное решение) FP = N_F_Ident // 11. N_F_Ident Количество ошибочно идентифицированных объектов расп.выборки (FP - ложно-положительное решение) TN = N_T_NIdent // 12. N_T_NIdent Количество верно неидентифицированных объектов расп.выборки (TN - истино-отрицательное решение) REPLACE Precision WITH TP/(TP+FP) // 14. Precision = TP/(TP+FP) - точность REPLACE Recall WITH TP/(TP+FN) // 15. Recall = TP/(TP+FN) - полнота REPLACE F_mera WITH 2*(Precision*Recall)/(Precision+Recall) // 16. F-mera = 2*(Precision*Recall)/(Precision+Recall) (мультиклассовый вариант) *********************************************************************************************************************************** ** Мой вариант метрики (старый) в терминах F-меры ********************************************************************************* ** Сумма числа верно идентифицированных и неидентифицированных объектов ** минус число ошибочно идентифицированных и неидентифицированных объектов ** деленная на количество объектов (среднее на объект). Есть две нормировки: {-1, +1} и {0, 1} M_DVMod = ( TP + TN - FP - FN ) / ( TP + TN + FP + FN ) // !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! REPLACE DifValMod WITH M_DVMod // Дифференциальная валидность (достоверность) модели (по классу), нормированная к {-1, +1} REPLACE DVMod WITH (1+M_DVMod)/2 // Дифференциальная валидность (достоверность) модели (по классу), нормированная к {0, 1} *********************************************************************************************************************************** SlUg_T_id = N_LogObj /N_Obj * 100 // Вероятность случайного угадывания принадлежности объектов к классам ######### в % SlUg_T_nid = (100-SlUg_T_id) // Вероятность случайного угадывания непринадлежности объектов к классам REPLACE P_SlUg_Id WITH SlUg_T_id // Вероятность случайного угадывания принадлежности объектов к классам REPLACE P_SlUg_NId WITH SlUg_T_nid // Вероятность случайного угадывания непринадлежности объектов к классам REPLACE EffMod_Id WITH P_T_Ident / SlUg_T_id // Эффективность модели при идентификации: // отношение вероятности верной идентификации с использованием модели // к вероятности случайного угадывания принадлежности объекта к классу REPLACE EffMod_NId WITH P_T_NIdent / SlUg_T_nid // Эффективность модели при неидентификации: // отношение вероятности верной неидентификации с использованием модели // к вероятности случайного угадывания непринадлежности объекта к классу REPLACE Avr_EffMod WITH (EffMod_Id+EffMod_NId)/2 * | 26 | S_T_IDENT | N | 15 | 7 | 26.Сумма модулей уровней сходства верно идентифицированных объектов расп.выборки (STP - истино-положительное решение) * | 27 | S_F_NIDENT | N | 15 | 7 | 27.Сумма модулей уровней сходства ошибочно неидентифицированных объектов расп.выборки (SFN - ложно-отрицательное решение) * | 28 | S_F_IDENT | N | 15 | 7 | 28.Сумма модулей уровней сходства ошибочно идентифицированных объектов расп.выборки (SFP - ложно-положительное решение) * | 29 | S_T_NIDENT | N | 15 | 7 | 29.Сумма модулей уровней сходства верно неидентифицированных объектов расп.выборки (STN - истино-отрицательное решение) REPLACE S_T_IDENT WITH A_Rec[26] // 26.Сумма модулей уровней сходства верно идентифицированных объектов расп.выборки (STP - истино-положительное решение) REPLACE S_F_NIDENT WITH A_Rec[27] // 27.Сумма модулей уровней сходства ошибочно неидентифицированных объектов расп.выборки (SFN - ложно-отрицательное решение) REPLACE S_F_IDENT WITH A_Rec[28] // 28.Сумма модулей уровней сходства ошибочно идентифицированных объектов расп.выборки (SFP - ложно-положительное решение) REPLACE S_T_NIDENT WITH A_Rec[29] // 29.Сумма модулей уровней сходства верно неидентифицированных объектов расп.выборки (STN - истино-отрицательное решение) * | 30 | SPRECISION | N | 15 | 7 | 30.SPrecision = STP/(STP+SFP) - точность с учетом уровней сходства * | 31 | SRECALL | N | 15 | 7 | 31.SRecall = STP/(STP+SFN) - полнота с учетом уровней сходства * | 32 | L1_mera | N | 15 | 7 | 32.L1-mera = 2*(SPrecision*SRecall)/(SPrecision+SRecall) (L1-мера проф.Е.В.Луценко - нечеткое мультиклассовое обобщение *********************************************************************************************************************************** ** L1-мера проф.Е.В.Луценко - нечеткое мультиклассовое обобщение F-меры Ван Ризбергена ********************************************* *********************************************************************************************************************************** STP = S_T_Ident // 26. S_T_Ident Сумма модулей уровней сходства верно идентифицированных объектов расп.выборк (TP - истино-положительное решение) SFN = S_F_NIdent // 27. S_F_NIdent Сумма модулей уровней сходства ошибочно неидентифицированных объектов расп.выборк (FN - ложно-отрицательное решение) SFP = S_F_Ident // 28. S_F_Ident Сумма модулей уровней сходства ошибочно идентифицированных объектов расп.выборк (FP - ложно-положительное решение) STN = S_T_NIdent // 29. S_T_NIdent Сумма модулей уровней сходства верно неидентифицированных объектов расп.выборк (TN - истино-отрицательное решение) REPLACE SPrecision WITH STP/(STP+SFP) // 30.SPrecision = STP/(STP+SFP) - точность с учетом уровней сходства REPLACE SRecall WITH STP/(STP+SFN) // 31.SRecall = STP/(STP+SFN) - полнота с учетом уровней сходства REPLACE L1_mera WITH 2*(SPrecision*SRecall)/(SPrecision+SRecall) // 32.L1-mera = 2*(SPrecision*SRecall)/(SPrecision+SRecall) (L1-мера проф.Е.В.Луценко - нечеткое мультиклассовое обобщение F-меры Ван Ризбергена) REPLACE A_T_IDENT WITH S_T_IDENT /N_T_IDENT REPLACE A_F_NIDENT WITH S_F_NIDENT/N_F_NIDENT REPLACE A_F_IDENT WITH S_F_IDENT /N_F_IDENT REPLACE A_T_NIDENT WITH S_T_NIDENT/N_T_NIDENT REPLACE APRECISION WITH A_T_IDENT/(A_T_IDENT+A_F_IDENT) REPLACE ARECALL WITH A_T_IDENT/(A_T_IDENT+A_F_NIDENT) REPLACE L2_mera WITH 2*(APRECISION*ARECALL)/(APRECISION+ARECALL) // L2-mera = 2*(APrecision*ARecall)/(APrecision+ARecall) (нечеткий мультиклассовый вариант) *********************************************************************************************************************************** REPLACE Date WITH DTOC(DATE()) REPLACE Time WITH TIME() ENDIF ******************************************************************** ****** Переписать информацию по классу из (M_VerMod) в VerModCls.dbf ******************************************************************** SELECT (M_VerMod) Ar := {} FOR j=1 TO FCOUNT()-2 AADD(Ar, FIELDGET(j)) NEXT SELECT VerModCls APPEND BLANK FOR j=1 TO LEN(Ar) FIELDPUT(j,Ar[j]) NEXT // ModIntKrit Код: ##_####_#, где: // ##-числовой номер модели и инт.критерия {1-20}, // ####-модель {Abs,Prc1,Prc2,Inf1,Inf2,Inf3,Inf4,Inf5,Inf6,Inf7}, // #-инт.крит.: {k,i} REPLACE ModIntKrit WITH STRTRAN(STR(2*M_NumMod-IF(M_IntKrit=1,1,0),2)," ","0")+"_"+Ar_Model[M_NumMod]+"_"+IF(M_IntKrit=1,"k","i") SELECT (M_VerMod) DBSKIP(1) ENDDO ******* Определение количества логических объетов по классам другим способом *SELECT Rso_Zag *SET ORDER TO 1 *DBGOTOP() *DO WHILE .NOT. EOF() * M_KodObj = Kod_obj * // Формирование массива кодов классов текущего объекта обучающей выборки * SELECT Rso_Kcl;SET ORDER TO 1;T=DBSEEK(STR(M_KodObj,19)) * IF T * Ar_Kcl := {} * DO WHILE M_KodObj = Kod_Obj .AND. .NOT. EOF() // Начало цикла по записям БД кодов классов текущего объекта * FOR j=2 TO 5 * M_Kcl = FIELDGET(j) * IF VALTYPE(M_Kcl) = "N" * IF 0 < M_Kcl .AND. M_Kcl <= N_Cls * IF ASCAN(Ar_Kcl, M_Kcl) = 0 * AADD (Ar_Kcl, M_Kcl) * ENDIF * ENDIF * ENDIF * NEXT * DBSKIP(1) * ENDDO * ENDIF * SELECT (M_VerMod);SET ORDER TO 1 * FOR j=1 TO LEN(Ar_Kcl) * T=DBSEEK(STR(Ar_Kcl[j],19)) * IF T * M_NLogObj = N_LogObj * REPLACE N_LogObj WITH M_NLogObj + 1 * ENDIF * NEXT * SELECT Rso_Zag * DBSKIP(1) *ENDDO * Структура базы данных N°=53: VerModCls.dbf * ============================================================================ * | N | Имя поля | Тип | Ширина | Дес. | Примечание | * ============================================================================ * | 1 | MODINTKRIT | C | 9 | 0 | 1. ModIntKrit Код: ##_####_#, где: ##-числовой номер модели и инт.критерия {1-20}, ####-модель {Abs,Prc1,Prc2,Inf1,Inf2,Inf3,Inf4,Inf5,Inf6,Inf7}, #-инт.крит.: {k,i} * | 2 | KOD_CLS | N | 15 | 0 | 2. Код класса * | 3 | NAME_CLS | C | 35 | 0 | 3. Наименование класса * | 4 | DIFVALMOD | N | 15 | 7 | 4. DifValMod Достоверность идентификации класса (с учетом всех верно и ошибочно идентифицированных и неидентифицированных логических объектов)) * | 5 | AVRURSX_T | N | 15 | 7 | 5. AvrUrSx_T Средний модуль уровней сходства ВЕРНО идентифицированных и неидентифицированных объектов * | 6 | AVRURSX_F | N | 15 | 7 | 6. AvrUrSx_F Средний модуль уровней сходства ОШИБОЧНО идентифицированных и неидентифицированных объектов * | 7 | DIFAVRURSX | N | 15 | 7 | 7. DifAvrUrSx Разность средних модулей уровней сходства ВЕРНО и ОШИБОЧНО идентифицированных и неидентифицированных объектов * | 8 | N_LOGOBJ | N | 15 | 7 | 8. N_LogObj Количество объектов расп.выборки, фактически относящихся к классу * | 9 | N_T_IDENT | N | 15 | 7 | 9. N_T_Ident Количество верно идентифицированных объектов расп.выборки (TP - истино-положительное решение) * | 10 | N_F_NIDENT | N | 15 | 7 | 10. N_F_NIdent Количество ошибочно неидентифицированных объектов расп.выборки (FN - ложно-отрицательное решение) * | 11 | N_F_IDENT | N | 15 | 7 | 11. N_F_Ident Количество ошибочно идентифицированных объектов расп.выборки (FP - ложно-положительное решение) * | 12 | N_T_NIDENT | N | 15 | 7 | 12. N_T_NIdent Количество верно неидентифицированных объектов расп.выборки (TN - истино-отрицательное решение) * | 13 | DVMOD | N | 15 | 7 | 13. M_DVMod = (NT-NF)/(NT+NF)*100 Дифференциальная валидность (достоверность) модели (по классу) (в знаменателе: "всего объектов"). NT = N_T_id+N_T_nid: Количество ВЕРНО идентифицированных и неидентифицированных объектов, NF = N_F_id+N_F_nid: Количество ОШИБОЧНО идентифицированных и неидентифицированных объектов * | 14 | PRECISION | N | 15 | 7 | 14. Precision = TP/(TP+FP) - точность * | 15 | RECALL | N | 15 | 7 | 15. Recall = TP/(TP+FN) - полнота * | 16 | F_MERA | N | 15 | 7 | 16. F-mera = 2*(Precision*Recall)/(Precision+Recall) (мультиклассовый вариант) * | 17 | P_T_IDENT | N | 15 | 7 | 17. P_T_Ident Вероятность верной идентификации объекта с классом с использованием модели * | 18 | P_T_NIDENT | N | 15 | 7 | 18. P_T_NIdent Вероятность верной не идентификации объекта с классом с использованием модели * | 19 | P_F_IDENT | N | 15 | 7 | 19. P_F_Ident Вероятность ошибочной идентификации объекта с классом с использованием модели * | 20 | P_F_NIDENT | N | 15 | 7 | 20. P_F_NIdent Вероятность ошибочной не идентификации объекта с классом с использованием модели * | 21 | P_SLUG_ID | N | 15 | 7 | 21. P_SlUg_Id Вероятность случайного угадывания принадлежности объектов к классам * | 22 | P_SLUG_NID | N | 15 | 7 | 22. P_SlUg_NId Вероятность случайного угадывания непринадлежности объектов к классам * | 23 | EFFMOD_ID | N | 15 | 7 | 23. EffMod_Id Эффективность модели при идентификации: отношение вероятности верной идентификации при использовании модели к вероятности случайного угадывания принадлежности объекта к классу * | 24 | EFFMOD_NID | N | 15 | 7 | 24. EffMod_NId Эффективность модели при неидентификации: отношение вероятности верной неидентификации при использовании модели к вероятности случайного угадывания непринадлежности объекта к классу * | 25 | AVR_EFFMOD | N | 15 | 7 | 25. Avr_EffMod Средняя эффективность модели: (EffMod_Id+EffMod_NId)/2 * | 26 | S_T_IDENT | N | 15 | 7 | 26.Сумма модулей уровней сходства верно идентифицированных объектов расп.выборки (STP - истино-положительное решение) * | 27 | S_F_NIDENT | N | 15 | 7 | 27.Сумма модулей уровней сходства ошибочно неидентифицированных объектов расп.выборки (SFN - ложно-отрицательное решение) * | 28 | S_F_IDENT | N | 15 | 7 | 28.Сумма модулей уровней сходства ошибочно идентифицированных объектов расп.выборки (SFP - ложно-положительное решение) * | 29 | S_T_NIDENT | N | 15 | 7 | 29.Сумма модулей уровней сходства верно неидентифицированных объектов расп.выборки (STN - истино-отрицательное решение) * | 30 | SPRECISION | N | 15 | 7 | 30.SPrecision = STP/(STP+SFP) - точность с учетом уровней сходства * | 31 | SRECALL | N | 15 | 7 | 31.SRecall = STP/(STP+SFN) - полнота с учетом уровней сходства * | 32 | L1_mera | N | 15 | 7 | 32.L1-mera = 2*(SPrecision*SRecall)/(SPrecision+SRecall) (L1-мера проф.Е.В.Луценко - нечеткое мультиклассовое обобщение * | 33 | DATE | C | 10 | 0 | 33. Date Дата формирования записи БД * | 34 | TIME | C | 8 | 0 | 34. Time Время формирования записи БД * ============================================================================ * В С Е Г О длина записи: 513 байтов. | * ============================================================================ ***** Дорасчет сводных по всем классам показателей по форме валидности для данной модели и инт.критерия ***** Итоговую строку считать как средневзвешенную: ***** каждый показатель: суммировать призведение значения показателя на число лог.объектов по всем классам ***** а потом делить их на суммарное количество логических объектов и занести в БД * N_LogObjALL // Суммарное количество логических объектов по всей выборке AFILL(A_Wsg,0) // Массив для итоговой записи по всем классам ****** Расчет ************************************* SELECT (M_VerMod) DBGOTOP() DO WHILE .NOT. EOF() * | 4 | DIFVALMOD | N | 15 | 7 | 4. DifValMod Достоверность идентификации класса (с учетом всех верно и ошибочно идентифицированных и неидентифицированных логических объектов)) * | 5 | AVRURSX_T | N | 15 | 7 | 5. AvrUrSx_T Средний модуль уровней сходства ВЕРНО идентифицированных и неидентифицированных объектов * | 6 | AVRURSX_F | N | 15 | 7 | 6. AvrUrSx_F Средний модуль уровней сходства ОШИБОЧНО идентифицированных и неидентифицированных объектов * | 7 | DIFAVRURSX | N | 15 | 7 | 7. DifAvrUrSx Разность средних модулей уровней сходства ВЕРНО и ОШИБОЧНО идентифицированных и неидентифицированных объектов FOR j=4 TO 7 A_Wsg[j] = A_Wsg[j] + FIELDGET(j) * N_LogObj NEXT * | 8 | N_LOGOBJ | N | 15 | 7 | 8. N_LogObj Количество объектов расп.выборки, фактически относящихся к классу * | 9 | N_T_IDENT | N | 15 | 7 | 9. N_T_Ident Количество верно идентифицированных объектов расп.выборки (TP - истино-положительное решение) * | 10 | N_F_NIDENT | N | 15 | 7 | 10. N_F_NIdent Количество ошибочно неидентифицированных объектов расп.выборки (FN - ложно-отрицательное решение) * | 11 | N_F_IDENT | N | 15 | 7 | 11. N_F_Ident Количество ошибочно идентифицированных объектов расп.выборки (FP - ложно-положительное решение) * | 12 | N_T_NIDENT | N | 15 | 7 | 12. N_T_NIdent Количество верно неидентифицированных объектов расп.выборки (TN - истино-отрицательное решение) FOR j=8 TO 12 // F-мера A_Wsg[j] = A_Wsg[j] + FIELDGET(j) NEXT * | 26 | S_T_IDENT | N | 15 | 7 | 26.Сумма модулей уровней сходства верно идентифицированных объектов расп.выборки * | 27 | S_F_NIDENT | N | 15 | 7 | 27.Сумма модулей уровней сходства ошибочно неидентифицированных объектов расп.выборки * | 28 | S_F_IDENT | N | 15 | 7 | 28.Сумма модулей уровней сходства ошибочно идентифицированных объектов расп.выборки * | 29 | S_T_NIDENT | N | 15 | 7 | 29.Сумма модулей уровней сходства верно неидентифицированных объектов расп.выборки FOR j=26 TO 29 A_Wsg[j] = A_Wsg[j] + FIELDGET(j) NEXT * | 30 | SPRECISION | N | 15 | 7 | 30.SPrecision = STP/(STP+SFP) - точность с учетом уровней сходства * | 31 | SRECALL | N | 15 | 7 | 31.SRecall = STP/(STP+SFN) - полнота с учетом уровней сходства * | 32 | L1_mera | N | 15 | 7 | 32.L1-mera = 2*(SPrecision*SRecall)/(SPrecision+SRecall) (L1-мера проф.Е.В.Луценко - нечеткое мультиклассовое обобщение FOR j=30 TO 32 // L1-мера A_Wsg[j] = A_Wsg[j] + FIELDGET(j) NEXT * | 13 | DVMOD | N | 15 | 7 | 13. M_DVMod = (NT-NF)/(NT+NF)*100 Дифференциальная валидность (достоверность) модели (по классу) (в знаменателе: "всего объектов"). NT = N_T_id+N_T_nid: Количество ВЕРНО идентифицированных и неидентифицированных объектов, NF = N_F_id+N_F_nid: Количество ОШИБОЧНО идентифицированных и неидентифицированных объектов * | 14 | PRECISION | N | 15 | 7 | 14. Precision = TP/(TP+FP) - точность * | 15 | RECALL | N | 15 | 7 | 15. Recall = TP/(TP+FN) - полнота * | 16 | F_MERA | N | 15 | 7 | 16. F-mera = 2*(Precision*Recall)/(Precision+Recall) (мультиклассовый вариант) * | 17 | P_T_IDENT | N | 15 | 7 | 17. P_T_Ident Вероятность верной идентификации объекта с классом с использованием модели * | 18 | P_T_NIDENT | N | 15 | 7 | 18. P_T_NIdent Вероятность верной не идентификации объекта с классом с использованием модели * | 19 | P_F_IDENT | N | 15 | 7 | 19. P_F_Ident Вероятность ошибочной идентификации объекта с классом с использованием модели * | 20 | P_F_NIDENT | N | 15 | 7 | 20. P_F_NIdent Вероятность ошибочной не идентификации объекта с классом с использованием модели * | 21 | P_SLUG_ID | N | 15 | 7 | 21. P_SlUg_Id Вероятность случайного угадывания принадлежности объектов к классам * | 22 | P_SLUG_NID | N | 15 | 7 | 22. P_SlUg_NId Вероятность случайного угадывания непринадлежности объектов к классам * | 23 | EFFMOD_ID | N | 15 | 7 | 23. EffMod_Id Эффективность модели при идентификации: отношение вероятности верной идентификации при использовании модели к вероятности случайного угадывания принадлежности объекта к классу * | 24 | EFFMOD_NID | N | 15 | 7 | 24. EffMod_NId Эффективность модели при неидентификации: отношение вероятности верной неидентификации при использовании модели к вероятности случайного угадывания непринадлежности объекта к классу * | 25 | AVR_EFFMOD | N | 15 | 7 | 25. Avr_EffMod Средняя эффективность модели: (EffMod_Id+EffMod_NId)/2 FOR j=13 TO 25 A_Wsg[j] = A_Wsg[j] + FIELDGET(j) * N_LogObj NEXT DBSKIP(1) ENDDO ****** Занесение информации в БД SELECT(M_VerMod) * // Сумму сделать только по колонкам, нужным для расчета F-критерия и L-криетрия, а для остальных, как раньше. Посчитать его для строки "Сумма" APPEND BLANK REPLACE Name_cls WITH "Ср.взв.сумма:" * | 4 | DIFVALMOD | N | 15 | 7 | 4. DifValMod Достоверность идентификации класса (с учетом всех верно и ошибочно идентифицированных и неидентифицированных логических объектов)) * | 5 | AVRURSX_T | N | 15 | 7 | 5. AvrUrSx_T Средний модуль уровней сходства ВЕРНО идентифицированных и неидентифицированных объектов * | 6 | AVRURSX_F | N | 15 | 7 | 6. AvrUrSx_F Средний модуль уровней сходства ОШИБОЧНО идентифицированных и неидентифицированных объектов * | 7 | DIFAVRURSX | N | 15 | 7 | 7. DifAvrUrSx Разность средних модулей уровней сходства ВЕРНО и ОШИБОЧНО идентифицированных и неидентифицированных объектов FOR j=4 TO 7 A_Wsg[j] = A_Wsg[j] / N_LogObjALL * FIELDPUT(j,A_Wsg[j]) NEXT * | 26 | S_T_IDENT | N | 15 | 7 | 26.Сумма модулей уровней сходства верно идентифицированных объектов расп.выборки * | 27 | S_F_NIDENT | N | 15 | 7 | 27.Сумма модулей уровней сходства ошибочно неидентифицированных объектов расп.выборки * | 28 | S_F_IDENT | N | 15 | 7 | 28.Сумма модулей уровней сходства ошибочно идентифицированных объектов расп.выборки * | 29 | S_T_NIDENT | N | 15 | 7 | 29.Сумма модулей уровней сходства верно неидентифицированных объектов расп.выборки FOR j=26 TO 29 * A_Wsg[j] = A_Wsg[j] * FIELDPUT(j,A_Wsg[j]) NEXT * ** F-мера Ван Ризбергена ********************************************************************************************************** * | 8 | N_LOGOBJ | N | 15 | 7 | 8. N_LogObj Количество объектов расп.выборки, фактически относящихся к классу * | 9 | N_T_IDENT | N | 15 | 7 | 9. N_T_Ident Количество верно идентифицированных объектов расп.выборки (TP - истино-положительное решение) * | 10 | N_F_NIDENT | N | 15 | 7 | 10. N_F_NIdent Количество ошибочно неидентифицированных объектов расп.выборки (FN - ложно-отрицательное решение) * | 11 | N_F_IDENT | N | 15 | 7 | 11. N_F_Ident Количество ошибочно идентифицированных объектов расп.выборки (FP - ложно-положительное решение) * | 12 | N_T_NIDENT | N | 15 | 7 | 12. N_T_NIdent Количество верно неидентифицированных объектов расп.выборки (TN - истино-отрицательное решение) FOR j=8 TO 12 * A_Wsg[j] = A_Wsg[j] // Всего логических объектов и TP, FN, FP, TN * FIELDPUT(j,A_Wsg[j]) NEXT * | 13 | DVMOD | N | 15 | 7 | 13. M_DVMod = (NT-NF)/(NT+NF)*100 Дифференциальная валидность (достоверность) модели (по классу) (в знаменателе: "всего объектов"). NT = N_T_id+N_T_nid: Количество ВЕРНО идентифицированных и неидентифицированных объектов, NF = N_F_id+N_F_nid: Количество ОШИБОЧНО идентифицированных и неидентифицированных объектов FOR j=13 TO 13 A_Wsg[j] = A_Wsg[j] / N_LogObjALL * FIELDPUT(j,A_Wsg[j]) NEXT ********* Расчет и запись F-меры *************************** * | 9 | N_T_IDENT | N | 15 | 7 | 9. N_T_Ident Количество верно идентифицированных объектов расп.выборки (TP - истино-положительное решение) * | 10 | N_F_NIDENT | N | 15 | 7 | 10. N_F_NIdent Количество ошибочно неидентифицированных объектов расп.выборки (FN - ложно-отрицательное решение) * | 11 | N_F_IDENT | N | 15 | 7 | 11. N_F_Ident Количество ошибочно идентифицированных объектов расп.выборки (FP - ложно-положительное решение) * | 12 | N_T_NIDENT | N | 15 | 7 | 12. N_T_NIdent Количество верно неидентифицированных объектов расп.выборки (TN - истино-отрицательное решение) * | 14 | PRECISION | N | 15 | 7 | 14. Precision = TP/(TP+FP) - точность * | 15 | RECALL | N | 15 | 7 | 15. Recall = TP/(TP+FN) - полнота * | 16 | F_MERA | N | 15 | 7 | 16. F-mera = 2*(Precision*Recall)/(Precision+Recall) (мультиклассовый вариант) A_Wsg[14] = A_Wsg[9]/(A_Wsg[9]+A_Wsg[11]) ;FIELDPUT(14,A_Wsg[14]) // Precision A_Wsg[15] = A_Wsg[9]/(A_Wsg[9]+A_Wsg[10]) ;FIELDPUT(15,A_Wsg[15]) // Recall A_Wsg[16] = 2*A_Wsg[14]*A_Wsg[15]/(A_Wsg[14]+A_Wsg[15]);FIELDPUT(16,A_Wsg[16]) // F-мера ********* Расчет и запись L-меры *************************** * | 26 | S_T_IDENT | N | 15 | 7 | 26.Сумма модулей уровней сходства верно идентифицированных объектов расп.выборки (STP - истино-положительное решение) * | 27 | S_F_NIDENT | N | 15 | 7 | 27.Сумма модулей уровней сходства ошибочно неидентифицированных объектов расп.выборки (SFN - ложно-отрицательное решение) * | 28 | S_F_IDENT | N | 15 | 7 | 28.Сумма модулей уровней сходства ошибочно идентифицированных объектов расп.выборки (SFP - ложно-положительное решение) * | 29 | S_T_NIDENT | N | 15 | 7 | 29.Сумма модулей уровней сходства верно неидентифицированных объектов расп.выборки (STN - истино-отрицательное решение) * | 30 | SPRECISION | N | 15 | 7 | 30.SPrecision = STP/(STP+SFP) - точность с учетом уровней сходства * | 31 | SRECALL | N | 15 | 7 | 31.SRecall = STP/(STP+SFN) - полнота с учетом уровней сходства * | 32 | L1_mera | N | 15 | 7 | 32.L1-mera = 2*(SPrecision*SRecall)/(SPrecision+SRecall) (L1-мера проф.Е.В.Луценко - нечеткое мультиклассовое обобщение A_Wsg[30] = A_Wsg[26]/(A_Wsg[26]+A_Wsg[28]) ;FIELDPUT(30,A_Wsg[30]) // SPrecision A_Wsg[31] = A_Wsg[26]/(A_Wsg[26]+A_Wsg[27]) ;FIELDPUT(31,A_Wsg[31]) // SRecall A_Wsg[32] = 2*A_Wsg[30]*A_Wsg[31]/(A_Wsg[30]+A_Wsg[31]);FIELDPUT(32,A_Wsg[32]) // L1-мера * | 17 | P_T_IDENT | N | 15 | 7 | 17. P_T_Ident Вероятность верной идентификации объекта с классом с использованием модели * | 18 | P_T_NIDENT | N | 15 | 7 | 18. P_T_NIdent Вероятность верной не идентификации объекта с классом с использованием модели * | 19 | P_F_IDENT | N | 15 | 7 | 19. P_F_Ident Вероятность ошибочной идентификации объекта с классом с использованием модели * | 20 | P_F_NIDENT | N | 15 | 7 | 20. P_F_NIdent Вероятность ошибочной не идентификации объекта с классом с использованием модели * | 21 | P_SLUG_ID | N | 15 | 7 | 21. P_SlUg_Id Вероятность случайного угадывания принадлежности объектов к классам * | 22 | P_SLUG_NID | N | 15 | 7 | 22. P_SlUg_NId Вероятность случайного угадывания непринадлежности объектов к классам * | 23 | EFFMOD_ID | N | 15 | 7 | 23. EffMod_Id Эффективность модели при идентификации: отношение вероятности верной идентификации при использовании модели к вероятности случайного угадывания принадлежности объекта к классу * | 24 | EFFMOD_NID | N | 15 | 7 | 24. EffMod_NId Эффективность модели при неидентификации: отношение вероятности верной неидентификации при использовании модели к вероятности случайного угадывания непринадлежности объекта к классу * | 25 | AVR_EFFMOD | N | 15 | 7 | 25. Avr_EffMod Средняя эффективность модели: (EffMod_Id+EffMod_NId)/2 FOR j=17 TO 25 A_Wsg[j] = A_Wsg[j] / N_LogObjALL * FIELDPUT(j,A_Wsg[j]) NEXT ****** Занесение информации в БД SELECT(M_VerMod) * FOR j=4 TO 32 FIELDPUT(j,A_Wsg[j]) NEXT * | 33 | DATE | C | 10 | 0 | 33. Date Дата формирования записи БД * | 34 | TIME | C | 8 | 0 | 34. Time Время формирования записи БД REPLACE Date WITH DTOC(DATE()) REPLACE Time WITH TIME() ****** Переписать все итоговые строки из БД по моделям и критериям в одну БД VerModClsIT.dbf SELECT VerModClsIT APPEND BLANK FOR j=4 TO 32 FIELDPUT(j,A_Wsg[j]) NEXT REPLACE Date WITH DTOC(DATE()) REPLACE Time WITH TIME() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций RETURN NIL ****************************************************************************** ******** Расчет отчета по дифференциальной и интегральной достоверности модели ****************************************************************************** FUNCTION GenValidModObj(M_NumMod, M_IntKrit) IF ApplChange("") // Перейти в папку выбранного приложения или выйти из системы LB_Warning(L("Необходимо задать (выбрать) хотя бы одно текущее приложение !!!")) Running(.F.) RETURN NIL ENDIF mRecSize = GenDbfVerModObj(M_NumMod, M_IntKrit) // Создать БД для измерения достоверности моделей // Имя БД, созданной GenDbfValSys, с результами оценки достоверности модели по инт.критерию M_VerMod := "VerModObj"+STRTRAN(STR(M_NumMod,2)," ","0")+IF(M_IntKrit=1,"k","i") // Формирование имен файлов с результатами распознавания M_Rsp1 = "Rsp1"+IF(M_IntKrit=1,"k","i") M_Rsp2 = "Rsp2"+IF(M_IntKrit=1,"k","i") M_Rsp_it1 = "Rsp" +IF(M_IntKrit=1,"k","i")+"1" M_Rsp_it2 = "Rsp" +IF(M_IntKrit=1,"k","i")+"2" ** Генерация БД ValidSys.dbf IF .NOT. FILE(M_Rsp1+".dbf") Mess = L("СФОРМИРУЙТЕ РАСПОЗНАВАЕМУЮ ВЫБОРКУ И ВЫПОЛНИТЕ РАСПОЗНАВАНИЕ!!!") LB_Warning(Mess) RETURN NIL ENDIF ***** АЛГОРИТМ СДЕЛАН НА ОСНОВЕ АЛГОРИТМА ФОРМИРОВАНИЯ RASP_IT1 ***** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rso_Zag EXCLUSIVE NEW // ############################################ USE (M_VerMod) EXCLUSIVE NEW;ZAP SELECT Rso_Zag SET ORDER TO 1 DBGOTOP() DO WHILE .NOT. EOF() M_Kod = Kod_obj M_Name = Name_obj SELECT (M_VerMod) APPEND BLANK // Слишком большая база данных, больше 2 Гб, вылетает. Измерять размер в цикле - будет очень медленно работать <<<===########## REPLACE KOD_OBJ WITH M_Kod REPLACE NAME_OBJ WITH M_Name SELECT Rso_Zag DBSKIP(1) ENDDO ***** Заполняем базу итогов данными из (M_Rsp1).dbf **** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (M_Rsp1) EXCLUSIVE NEW INDEX ON STR(Kod_obj,19) TO Rsp1_obj CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (M_VerMod) EXCLUSIVE NEW INDEX ON STR(Kod_obj,19) TO Ver_obj ***** Начало цикла по БД результатов распознавания CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes INDEX Cls_kod EXCLUSIVE NEW;N_Cls = RECCOUNT() // Количество классов 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 (M_Rsp1) INDEX Rsp1_obj EXCLUSIVE NEW USE (M_VerMod) INDEX Ver_obj EXCLUSIVE NEW USE VerModObj EXCLUSIVE NEW;mHeader = HEADER() // Объединить все (M_VerMod) по классам без итоговых строк USE VerModObjIT EXCLUSIVE NEW // Объединить все (M_VerMod) итоговые строки без классов ****** Расчет интегрального качества распознавания объекта N°Obj *************** * Структура базы данных N°=100: VerModObj.dbf * ============================================================================ * | N | Имя поля | Тип | Ширина | Дес. | Примечание | * ============================================================================ * | 1 | MODINTKRIT | C | 9 | 0 | * | 2 | KOD_OBJ | N | 15 | 0 | * | 3 | NAME_OBJ | C | 15 | 0 | * | 4 | DIFVALMOD | N | 15 | 7 | * | 5 | AVRURSX_T | N | 15 | 7 | * | 6 | AVRURSX_F | N | 15 | 7 | * | 7 | DIFAVRURSX | N | 15 | 7 | * | 8 | N_LOGOBJ | N | 15 | 7 | * | 9 | N_T_IDENT | N | 15 | 7 | * | 10 | N_F_NIDENT | N | 15 | 7 | * | 11 | N_F_IDENT | N | 15 | 7 | * | 12 | N_T_NIDENT | N | 15 | 7 | * | 13 | DVMOD | N | 15 | 7 | * | 14 | PRECISION | N | 15 | 7 | * | 15 | RECALL | N | 15 | 7 | * | 16 | F_MERA | N | 15 | 7 | * | 17 | P_T_IDENT | N | 15 | 7 | * | 18 | P_T_NIDENT | N | 15 | 7 | * | 19 | P_F_IDENT | N | 15 | 7 | * | 20 | P_F_NIDENT | N | 15 | 7 | * | 21 | P_SLUG_ID | N | 15 | 7 | * | 22 | P_SLUG_NID | N | 15 | 7 | * | 23 | EFFMOD_ID | N | 15 | 7 | * | 24 | EFFMOD_NID | N | 15 | 7 | * | 25 | AVR_EFFMOD | N | 15 | 7 | * | 26 | S_T_IDENT | N | 15 | 7 | * | 27 | S_F_NIDENT | N | 15 | 7 | * | 28 | S_F_IDENT | N | 15 | 7 | * | 29 | S_T_NIDENT | N | 15 | 7 | * | 30 | SPRECISION | N | 15 | 7 | * | 31 | SRECALL | N | 15 | 7 | * | 32 | L1_mera | N | 15 | 7 | * | 33 | DATE | C | 10 | 0 | * | 34 | TIME | C | 8 | 0 | * ============================================================================ * В С Е Г О длина записи: 493 байтов. | * ============================================================================ PRIVATE A_Rec[34] // Массив для текущей записи по классу PRIVATE A_Wsg[34] // Массив для итоговой записи по всем классам AFILL(A_Rec,0) // Массив для текущей записи по классу AFILL(A_Wsg,0) // Массив для итоговой записи по всем классам SELECT (M_VerMod) SET ORDER TO 1 DBGOTOP() N_LogObjALL = 0 // Суммарное количество логических объектов по всей выборке mRecno = 0 mFlag = .T. DO WHILE .NOT. EOF() M_KodObj = Kod_obj ******** Расчет дифференциальной достоверности модели по классу (качество распознавания класса) AFILL(A_Rec,0) // Массив для текущей записи по классу N_LogObjCLS = 0 // Суммарное количество логических объектов по классу SELECT (M_Rsp1);SET ORDER TO 1;T=DBSEEK(STR(M_KodObj,19)) IF T DO WHILE Kod_obj=M_KodObj .AND. .NOT. EOF() DO CASE CASE M_IntKrit = 1 // Подсчет по инт.критерию "Корреляция" DO CASE CASE Korr > 0 IF LEN(ALLTRIM(Fakt)) > 0 A_Rec[ 9] = A_Rec[ 9] + 1 // 9. N_T_Ident Количество верно идентифицированных объектов расп.выборки (TP - истино-положительное решение) * A_Rec[26] = A_Rec[26] + 1 // 26. S_T_IDENT Сумма модулей уровней сходства верно идентифицированных объектов расп.выборки (STP - истино-положительное решение) A_Rec[ 5] = A_Rec[ 5] + ABS(Korr)/100 // 5. AvrUrSx_T Средний модуль уровней сходства ВЕРНО идентифицированных и неидентифицированных объектов A_Rec[26] = A_Rec[26] + ABS(Korr)/100 // 26. S_T_IDENT Сумма модулей уровней сходства верно идентифицированных объектов расп.выборки (STP - истино-положительное решение) ++N_LogObjCLS // Суммарное количество логических объектов по классу ++N_LogObjALL // Суммарное количество логических объектов по всей выборке ELSE A_Rec[11] = A_Rec[11] + 1 // 11. N_F_Ident Количество ошибочно идентифицированных объектов расп.выборки (FP - ложно-положительное решение) * A_Rec[28] = A_Rec[28] + 1 // 28. S_F_IDENT Сумма модулей уровней сходства ошибочно идентифицированных объектов расп.выборки (SFP - ложно-положительное решение) A_Rec[ 6] = A_Rec[ 6] + ABS(Korr)/100 // 6. AvrUrSx_F Средний модуль уровней сходства ОШИБОЧНО идентифицированных и неидентифицированных объектов A_Rec[28] = A_Rec[28] + ABS(Korr)/100 // 28. S_F_IDENT Сумма модулей уровней сходства ошибочно идентифицированных объектов расп.выборки (SFP - ложно-положительное решение) ENDIF CASE Korr <= 0 IF LEN(ALLTRIM(Fakt)) > 0 A_Rec[10] = A_Rec[10] + 1 // 10. N_F_NIdent Количество ошибочно неидентифицированных объектов расп.выборки (FN - ложно-отрицательное решение) * A_Rec[27] = A_Rec[27] + 1 // 27. S_F_NIDENT Сумма модулей уровней сходства ошибочно неидентифицированных объектов расп.выборки (SFN - ложно-отрицательное решение) A_Rec[ 6] = A_Rec[ 6] + ABS(Korr)/100 // 6. AvrUrSx_F Средний модуль уровней сходства ОШИБОЧНО идентифицированных и неидентифицированных объектов A_Rec[27] = A_Rec[27] + ABS(Korr)/100 // 27. S_F_NIDENT Сумма модулей уровней сходства ошибочно неидентифицированных объектов расп.выборки (SFN - ложно-отрицательное решение) ++N_LogObjCLS // Суммарное количество логических объектов по классу ++N_LogObjALL // Суммарное количество логических объектов по всей выборке ELSE A_Rec[12] = A_Rec[12] + 1 // 12. N_T_NIdent Количество верно неидентифицированных объектов расп.выборки (TN - истино-отрицательное решение) * A_Rec[29] = A_Rec[29] + 1 // 29. S_T_NIDENT Сумма модулей уровней сходства верно неидентифицированных объектов расп.выборки (STN - истино-отрицательное решение) A_Rec[ 5] = A_Rec[ 5] + ABS(Korr)/100 // 5. AvrUrSx_T Средний модуль уровней сходства ВЕРНО идентифицированных и неидентифицированных объектов A_Rec[29] = A_Rec[29] + ABS(Korr)/100 // 29. S_T_NIDENT Сумма модулей уровней сходства верно неидентифицированных объектов расп.выборки (STN - истино-отрицательное решение) ENDIF ENDCASE CASE M_IntKrit = 2 // Подсчет по инт.критерию "Сумма" DO CASE CASE Sum_inf > 0 IF LEN(ALLTRIM(Fakt)) > 0 A_Rec[ 9] = A_Rec[ 9] + 1 // 9. N_T_Ident Количество верно идентифицированных объектов расп.выборки (TP - истино-положительное решение) * A_Rec[26] = A_Rec[26] + 1 // 26. Сумма модулей уровней сходства верно идентифицированных объектов расп.выборки (STP - истино-положительное решение) A_Rec[ 5] = A_Rec[ 5] + ABS(Sum_inf)/100 // 5. AvrUrSx_T Средний модуль уровней сходства ВЕРНО идентифицированных и неидентифицированных объектов A_Rec[26] = A_Rec[26] + ABS(Sum_inf)/100 // 26. Сумма модулей уровней сходства верно идентифицированных объектов расп.выборки (STP - истино-положительное решение) ++N_LogObjCLS // Суммарное количество логических объектов по классу ++N_LogObjALL // Суммарное количество логических объектов по всей выборке ELSE A_Rec[11] = A_Rec[11] + 1 // 11. N_F_Ident Количество ошибочно идентифицированных объектов расп.выборки (FP - ложно-положительное решение) * A_Rec[28] = A_Rec[28] + 1 // 28. Сумма модулей уровней сходства ошибочно идентифицированных объектов расп.выборки (SFP - ложно-положительное решение) A_Rec[ 6] = A_Rec[ 6] + ABS(Sum_inf)/100 // 6. AvrUrSx_F Средний модуль уровней сходства ОШИБОЧНО идентифицированных и неидентифицированных объектов A_Rec[28] = A_Rec[28] + ABS(Sum_inf)/100 // 28. Сумма модулей уровней сходства ошибочно идентифицированных объектов расп.выборки (SFP - ложно-положительное решение) ENDIF CASE Sum_inf <= 0 IF LEN(ALLTRIM(Fakt)) > 0 A_Rec[10] = A_Rec[10] + 1 // 10. N_F_NIdent Количество ошибочно неидентифицированных объектов расп.выборки (FN - ложно-отрицательное решение) * A_Rec[27] = A_Rec[27] + 1 // 27. Сумма модулей уровней сходства ошибочно неидентифицированных объектов расп.выборки (SFN - ложно-отрицательное решение) A_Rec[ 6] = A_Rec[ 6] + ABS(Sum_inf)/100 // 6. AvrUrSx_F Средний модуль уровней сходства ОШИБОЧНО идентифицированных и неидентифицированных объектов A_Rec[27] = A_Rec[27] + ABS(Sum_inf)/100 // 27. Сумма модулей уровней сходства ошибочно неидентифицированных объектов расп.выборки (SFN - ложно-отрицательное решение) ++N_LogObjCLS // Суммарное количество логических объектов по классу ++N_LogObjALL // Суммарное количество логических объектов по всей выборке ELSE A_Rec[12] = A_Rec[12] + 1 // 12. N_T_NIdent Количество верно неидентифицированных объектов расп.выборки (TN - истино-отрицательное решение) * A_Rec[29] = A_Rec[29] + 1 // 29. Сумма модулей уровней сходства верно неидентифицированных объектов расп.выборки (STN - истино-отрицательное решение) A_Rec[ 5] = A_Rec[ 5] + ABS(Sum_inf)/100 // 5. AvrUrSx_T Средний модуль уровней сходства ВЕРНО идентифицированных и неидентифицированных объектов A_Rec[29] = A_Rec[29] + ABS(Sum_inf)/100 // 29. Сумма модулей уровней сходства верно неидентифицированных объектов расп.выборки (STN - истино-отрицательное решение) ENDIF ENDCASE ENDCASE DBSKIP(1) ENDDO ** Мой вариант метрики ************************************************************************************************************ ** Сумма верно идентифицированных и неидентифицированных объектов ** минус ошибочно идентифицированных и неидентифицированных объектов ** деленная на количество объектов (среднее на объект) в процентах * NT = N_T_id+N_T_nid // Количество ВЕРНО идентифицированных и неидентифицированных объектов * NF = N_F_id+N_F_nid // Количество ОШИБОЧНО идентифицированных и неидентифицированных объектов NT = A_Rec[ 9] + A_Rec[12] // Количество ВЕРНО идентифицированных и неидентифицированных объектов NF = A_Rec[11] + A_Rec[10] // Количество ОШИБОЧНО идентифицированных и неидентифицированных объектов *********************************************************************************************************************************** * M_DVMod = (NT-NF)/(NT+NF)*100 // Дифференциальная валидность (достоверность) модели (по классу) (в знаменателе: "всего объектов") *********************************************************************************************************************************** ****** Занесение информации в БД ValidSys SELECT (M_VerMod) ** Мой вариант метрики ************************************************************************************************************ * REPLACE DifValMod WITH M_DVMod // Дифференциальная валидность (достоверность) модели (по классу), нормированная к {-1,+1} * REPLACE DVMod WITH (1+M_DVMod)/2 // Дифференциальная валидность (достоверность) модели (по классу), нормированная к { 0, 1} REPLACE AvrUrSx_T WITH IF(NT>0,A_Rec[ 5]/NT,0) // Средний модуль уровней сходства ВЕРНО идентифицированных и неидентифицированных объектов REPLACE AvrUrSx_F WITH IF(NF>0,A_Rec[ 6]/NF,0) // Средний модуль уровней сходства ОШИБОЧНО идентифицированных и неидентифицированных объектов REPLACE DifAvrUrSx WITH AvrUrSx_T-AvrUrSx_F // Разность средних модулей уровней сходства ВЕРНО и ОШИБОЧНО идентифицированных и неидентифицированных объектов REPLACE N_LogObj WITH N_LogObjCLS // Количество объектов, фактически относящихся к классу: те, что к нему верно отнесены + те, которые к нему ошибочно не отнесены REPLACE N_T_IDENT WITH A_Rec[ 9] // 9. N_T_Ident Количество верно идентифицированных объектов расп.выборки (TP - истино-положительное решение) REPLACE N_F_NIDENT WITH A_Rec[10] // 10. N_F_NIdent Количество ошибочно неидентифицированных объектов расп.выборки (FN - ложно-отрицательное решение) REPLACE N_F_IDENT WITH A_Rec[11] // 11. N_F_Ident Количество ошибочно идентифицированных объектов расп.выборки (FP - ложно-положительное решение) REPLACE N_T_NIDENT WITH A_Rec[12] // 12. N_T_NIdent Количество верно неидентифицированных объектов расп.выборки (TN - истино-отрицательное решение) REPLACE P_T_Ident WITH N_T_Ident /N_LogObj * 100 // Вероятность верной идентификации объекта с классом ###### в % REPLACE P_F_NIdent WITH N_F_NIdent/N_LogObj * 100 // Вероятность ошибочной не идентификации объекта с классом ###### REPLACE P_F_Ident WITH N_F_Ident /(N_Obj-N_LogObj) * 100 // Вероятность ошибочной идентификации объекта с классом ###### REPLACE P_T_NIdent WITH N_T_NIdent/(N_Obj-N_LogObj) * 100 // Вероятность верной не идентификации объекта с классом ###### *********************************************************************************************************************************** ** F-мера Ван Ризбергена ********************************************************************************************************** *********************************************************************************************************************************** TP = N_T_Ident // 9. N_T_Ident Количество верно идентифицированных объектов расп.выборки (TP - истино-положительное решение) FN = N_F_NIdent // 10. N_F_NIdent Количество ошибочно неидентифицированных объектов расп.выборки (FN - ложно-отрицательное решение) FP = N_F_Ident // 11. N_F_Ident Количество ошибочно идентифицированных объектов расп.выборки (FP - ложно-положительное решение) TN = N_T_NIdent // 12. N_T_NIdent Количество верно неидентифицированных объектов расп.выборки (TN - истино-отрицательное решение) REPLACE Precision WITH TP/(TP+FP) // 14. Precision = TP/(TP+FP) - точность REPLACE Recall WITH TP/(TP+FN) // 15. Recall = TP/(TP+FN) - полнота REPLACE F_mera WITH 2*(Precision*Recall)/(Precision+Recall) // 16. F-mera = 2*(Precision*Recall)/(Precision+Recall) (мультиклассовый вариант) *********************************************************************************************************************************** ** Мой вариант метрики в терминах F-меры ****************************************************************************************** ** Сумма числа верно идентифицированных и неидентифицированных объектов ** минус число ошибочно идентифицированных и неидентифицированных объектов ** деленная на количество объектов (среднее на объект). Есть две нормировки: {-1, +1} и {0, 1} M_DVMod = ( TP + TN - FP - FN ) / ( TP + TN + FP + FN ) // !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! REPLACE DifValMod WITH M_DVMod // Дифференциальная валидность (достоверность) модели (по классу), нормированная к {-1, +1} REPLACE DVMod WITH (1+M_DVMod)/2 // Дифференциальная валидность (достоверность) модели (по классу), нормированная к {0, 1} *********************************************************************************************************************************** SlUg_T_id = N_LogObj /N_Obj * 100 // Вероятность случайного угадывания принадлежности объектов к классам в % SlUg_T_nid = (100-SlUg_T_id) // Вероятность случайного угадывания непринадлежности объектов к классам REPLACE P_SlUg_Id WITH SlUg_T_id // Вероятность случайного угадывания принадлежности объектов к классам REPLACE P_SlUg_NId WITH SlUg_T_nid // Вероятность случайного угадывания непринадлежности объектов к классам REPLACE EffMod_Id WITH P_T_Ident / SlUg_T_id // Эффективность модели при идентификации: // отношение вероятности верной идентификации с использованием модели // к вероятности случайного угадывания принадлежности объекта к классу REPLACE EffMod_NId WITH P_T_NIdent / SlUg_T_nid // Эффективность модели при неидентификации: // отношение вероятности верной неидентификации с использованием модели // к вероятности случайного угадывания непринадлежности объекта к классу REPLACE Avr_EffMod WITH (EffMod_Id+EffMod_NId)/2 REPLACE S_T_IDENT WITH A_Rec[26] // 26.Сумма модулей уровней сходства верно идентифицированных объектов расп.выборки (STP - истино-положительное решение) REPLACE S_F_NIDENT WITH A_Rec[27] // 27.Сумма модулей уровней сходства ошибочно неидентифицированных объектов расп.выборки (SFN - ложно-отрицательное решение) REPLACE S_F_IDENT WITH A_Rec[28] // 28.Сумма модулей уровней сходства ошибочно идентифицированных объектов расп.выборки (SFP - ложно-положительное решение) REPLACE S_T_NIDENT WITH A_Rec[29] // 29.Сумма модулей уровней сходства верно неидентифицированных объектов расп.выборки (STN - истино-отрицательное решение) *********************************************************************************************************************************** ** L1, L2-меры проф.Е.В.Луценко - нечеткое мультиклассовое обобщение F-меры Ван Ризбергена **************************************** *********************************************************************************************************************************** STP = S_T_Ident // 26. S_T_Ident Сумма модулей уровней сходства верно идентифицированных объектов расп.выборк (TP - истино-положительное решение) SFN = S_F_NIdent // 27. S_F_NIdent Сумма модулей уровней сходства ошибочно неидентифицированных объектов расп.выборк (FN - ложно-отрицательное решение) SFP = S_F_Ident // 28. S_F_Ident Сумма модулей уровней сходства ошибочно идентифицированных объектов расп.выборк (FP - ложно-положительное решение) STN = S_T_NIdent // 29. S_T_NIdent Сумма модулей уровней сходства верно неидентифицированных объектов расп.выборк (TN - истино-отрицательное решение) REPLACE SPrecision WITH STP/(STP+SFP) // 30.SPrecision = STP/(STP+SFP) - точность с учетом уровней сходства REPLACE SRecall WITH STP/(STP+SFN) // 31.SRecall = STP/(STP+SFN) - полнота с учетом уровней сходства REPLACE L1_mera WITH 2*(SPrecision*SRecall)/(SPrecision+SRecall) // 32.L1-mera = 2*(SPrecision*SRecall)/(SPrecision+SRecall) (L1-мера проф.Е.В.Луценко - нечеткое мультиклассовое обобщение F-меры Ван Ризбергена) REPLACE A_T_IDENT WITH S_T_IDENT /N_T_IDENT REPLACE A_F_NIDENT WITH S_F_NIDENT/N_F_NIDENT REPLACE A_F_IDENT WITH S_F_IDENT /N_F_IDENT REPLACE A_T_NIDENT WITH S_T_NIDENT/N_T_NIDENT REPLACE APRECISION WITH A_T_IDENT/(A_T_IDENT+A_F_IDENT) REPLACE ARECALL WITH A_T_IDENT/(A_T_IDENT+A_F_NIDENT) REPLACE L2_mera WITH 2*(APRECISION*ARECALL)/(APRECISION+ARECALL) // L2-mera = 2*(APrecision*ARecall)/(APrecision+ARecall) (нечеткий мультиклассовый вариант) *********************************************************************************************************************************** REPLACE Date WITH DTOC(DATE()) REPLACE Time WITH TIME() ENDIF ********************************************************************* ****** Переписать информацию по объекту из (M_VerMod) в VerModObj.dbf ********************************************************************* SELECT (M_VerMod) Ar := {} FOR j=1 TO FCOUNT() AADD(Ar, FIELDGET(j)) NEXT SELECT VerModObj IF mFlag .AND. RECSIZE()*(RECCOUNT()+1)+HEADER() > 2*1024^3 // ПЕРЕД ОТКРЫТИЕМ ЭТОЙ БАЗЫ ДАННЫХ ПРОВЕРЯТЬ, МЕНЬШЕ ЛИ ОНА 2 ГБ. ЕСЛИ БОЛЬШЕ - ВЫДАВАТЬ СООБЩЕНИЕ О НЕОБХОДИМОСТИ ЗАДАТЬ ПАРАМЕТР, УМЕНЬШАЮЩИЙ ЧИСЛО ЗАПИСЕЙ ТАК, ЧТОБЫ БД БЫЛА < 2ГБ mFlag =.F. // Это сообщение выводить только один раз в цикле aMess := {} AADD(aMess, L('Размер БД достоверности моделей VerModObj.dbf достиг максимального размера')+' '+ALLTRIM(STR(INT(RECSIZE()*RECCOUNT()+HEADER())))+' '+L('байт.' )) AADD(aMess, L('Необходимо применить бутстрепный подход и для оценки достоверности моделей и выбрать')) AADD(aMess, L('в режиме 3.5 не более 179555 объектов обучающей выборки или только синтез моделей.' )) LB_Warning(aMess, L('3.5. Синтез и верификация моделей')) EXIT // Выход из цикла ELSE APPEND BLANK // <<<===############ Здесь возникает ошибка, когда очень много объектов выборки mRecno++ FOR j=1 TO LEN(Ar) FIELDPUT(j,Ar[j]) NEXT // ModIntKrit Код: ##_####_#, где: // ##-числовой номер модели и инт.критерия {1-20}, // ####-модель {Abs,Prc1,Prc2,Inf1,Inf2,Inf3,Inf4,Inf5,Inf6,Inf7}, // #-инт.крит.: {k,i} REPLACE ModIntKrit WITH STRTRAN(STR(2*M_NumMod-IF(M_IntKrit=1,1,0),2)," ","0")+"_"+Ar_Model[M_NumMod]+"_"+IF(M_IntKrit=1,"k","i") ENDIF SELECT (M_VerMod) DBSKIP(1) ENDDO ******* Определение количества логических объетов по классам другим способом *SELECT Rso_Zag *SET ORDER TO 1 *DBGOTOP() *DO WHILE .NOT. EOF() * M_KodObj = Kod_obj * // Формирование массива кодов классов текущего объекта обучающей выборки * SELECT Rso_Kcl;SET ORDER TO 1;T=DBSEEK(STR(M_KodObj,19)) * IF T * Ar_Kcl := {} * DO WHILE M_KodObj = Kod_Obj .AND. .NOT. EOF() // Начало цикла по записям БД кодов классов текущего объекта * FOR j=2 TO 5 * M_Kcl = FIELDGET(j) * IF VALTYPE(M_Kcl) = "N" * IF 0 < M_Kcl .AND. M_Kcl <= N_Cls * IF ASCAN(Ar_Kcl, M_Kcl) = 0 * AADD (Ar_Kcl, M_Kcl) * ENDIF * ENDIF * ENDIF * NEXT * DBSKIP(1) * ENDDO * ENDIF * SELECT (M_VerMod);SET ORDER TO 1 * FOR j=1 TO LEN(Ar_Kcl) * T=DBSEEK(STR(Ar_Kcl[j],19)) * IF T * M_NLogObj = N_LogObj * REPLACE N_LogObj WITH M_NLogObj + 1 * ENDIF * NEXT * SELECT Rso_Zag * DBSKIP(1) *ENDDO * Структура базы данных N°=100: VerModObj.dbf * ============================================================================ * | N | Имя поля | Тип | Ширина | Дес. | Примечание | * ============================================================================ * | 1 | MODINTKRIT | C | 9 | 0 | * | 2 | KOD_OBJ | N | 15 | 0 | * | 3 | NAME_OBJ | C | 15 | 0 | * | 4 | DIFVALMOD | N | 15 | 7 | * | 5 | AVRURSX_T | N | 15 | 7 | * | 6 | AVRURSX_F | N | 15 | 7 | * | 7 | DIFAVRURSX | N | 15 | 7 | * | 8 | N_LOGOBJ | N | 15 | 7 | * | 9 | N_T_IDENT | N | 15 | 7 | * | 10 | N_F_NIDENT | N | 15 | 7 | * | 11 | N_F_IDENT | N | 15 | 7 | * | 12 | N_T_NIDENT | N | 15 | 7 | * | 13 | DVMOD | N | 15 | 7 | * | 14 | PRECISION | N | 15 | 7 | * | 15 | RECALL | N | 15 | 7 | * | 16 | F_MERA | N | 15 | 7 | * | 17 | P_T_IDENT | N | 15 | 7 | * | 18 | P_T_NIDENT | N | 15 | 7 | * | 19 | P_F_IDENT | N | 15 | 7 | * | 20 | P_F_NIDENT | N | 15 | 7 | * | 21 | P_SLUG_ID | N | 15 | 7 | * | 22 | P_SLUG_NID | N | 15 | 7 | * | 23 | EFFMOD_ID | N | 15 | 7 | * | 24 | EFFMOD_NID | N | 15 | 7 | * | 25 | AVR_EFFMOD | N | 15 | 7 | * | 26 | S_T_IDENT | N | 15 | 7 | * | 27 | S_F_NIDENT | N | 15 | 7 | * | 28 | S_F_IDENT | N | 15 | 7 | * | 29 | S_T_NIDENT | N | 15 | 7 | * | 30 | SPRECISION | N | 15 | 7 | * | 31 | SRECALL | N | 15 | 7 | * | 32 | L1_mera | N | 15 | 7 | * | 33 | DATE | C | 10 | 0 | * | 34 | TIME | C | 8 | 0 | * ============================================================================ * В С Е Г О длина записи: 493 байтов. | * ============================================================================ ***** Дорасчет сводных по всем классам показателей по форме валидности для данной модели и инт.критерия ***** Итоговую строку считать как средневзвешенную: ***** каждый показатель: суммировать призведение значения показателя на число лог.объектов по всем классам ***** а потом делить их на суммарное количество логических объектов и занести в БД * N_LogObjALL // Суммарное количество логических объектов по всей выборке AFILL(A_Wsg,0) // Массив для итоговой записи по всем классам ****** Расчет ************************************* SELECT (M_VerMod) DBGOTOP() DO WHILE .NOT. EOF() FOR j=4 TO 7 A_Wsg[j] = A_Wsg[j] + FIELDGET(j) * N_LogObj NEXT FOR j=8 TO 12 // F-мера A_Wsg[j] = A_Wsg[j] + FIELDGET(j) NEXT FOR j=26 TO 29 A_Wsg[j] = A_Wsg[j] + FIELDGET(j) NEXT FOR j=30 TO 32 // L1-мера A_Wsg[j] = A_Wsg[j] + FIELDGET(j) NEXT FOR j=13 TO 25 A_Wsg[j] = A_Wsg[j] + FIELDGET(j) * N_LogObj NEXT DBSKIP(1) ENDDO ****** Занесение информации в БД SELECT(M_VerMod) * APPEND BLANK REPLACE Name_obj WITH "Ср.взв.сумма:" FOR j=4 TO 7 A_Wsg[j] = A_Wsg[j] / N_LogObjALL * FIELDPUT(j,A_Wsg[j]) NEXT FOR j=26 TO 29 * A_Wsg[j] = A_Wsg[j] * FIELDPUT(j,A_Wsg[j]) NEXT FOR j=8 TO 12 * A_Wsg[j] = A_Wsg[j] // Всего логических объектов и TP, FN, FP, TN * FIELDPUT(j,A_Wsg[j]) NEXT FOR j=13 TO 13 A_Wsg[j] = A_Wsg[j] / N_LogObjALL * FIELDPUT(j,A_Wsg[j]) NEXT A_Wsg[14] = A_Wsg[9]/(A_Wsg[9]+A_Wsg[11]) ;FIELDPUT(14,A_Wsg[14]) // Precision A_Wsg[15] = A_Wsg[9]/(A_Wsg[9]+A_Wsg[10]) ;FIELDPUT(15,A_Wsg[15]) // Recall A_Wsg[16] = 2*A_Wsg[14]*A_Wsg[15]/(A_Wsg[14]+A_Wsg[15]);FIELDPUT(16,A_Wsg[16]) // F-мера A_Wsg[30] = A_Wsg[26]/(A_Wsg[26]+A_Wsg[28]) ;FIELDPUT(30,A_Wsg[30]) // SPrecision A_Wsg[31] = A_Wsg[26]/(A_Wsg[26]+A_Wsg[27]) ;FIELDPUT(31,A_Wsg[31]) // SRecall A_Wsg[32] = 2*A_Wsg[30]*A_Wsg[31]/(A_Wsg[30]+A_Wsg[31]);FIELDPUT(32,A_Wsg[32]) // L1-мера FOR j=17 TO 25 A_Wsg[j] = A_Wsg[j] / N_LogObjALL * FIELDPUT(j,A_Wsg[j]) NEXT ****** Занесение информации в БД SELECT(M_VerMod) * FOR j=4 TO 32 FIELDPUT(j,A_Wsg[j]) NEXT REPLACE Date WITH DTOC(DATE()) REPLACE Time WITH TIME() ****** Переписать все итоговые строки из БД по моделям и критериям в одну БД VerModClsIT.dbf SELECT VerModObjIT APPEND BLANK FOR j=4 TO 32 FIELDPUT(j,A_Wsg[j]) NEXT REPLACE Date WITH DTOC(DATE()) REPLACE Time WITH TIME() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций RETURN NIL ******** Расчет интегрального качества распознавания объектов N°Ist *************** ******** Модифицированный вариант для "Эйдос-астра" FUNCTION DOSTOVER1(M_KodObj) S_T_id = 0 // Сумма уровней сходства верно идентифицированных классов S_T_nid = 0 // Сумма уровней сходства верно неидентифицированных классов S_F_id = 0 // Сумма уровней сходства ошибочно идентифицированных классов S_F_nid = 0 // Сумма уровней сходства ошибочно неидентифицированных классов N_T_id = 0 // Количество верно идентифицированных классов N_T_nid = 0 // Количество верно неидентифицированных классов N_F_id = 0 // Количество ошибочно идентифицированных классов N_F_nid = 0 // Количество ошибочно неидентифицированных классов M_DostS = 0 // Достоверность с учетом уровня сходства объектов с классами M_DostN = 0 // Достоверность с учетом количества логических объектов M_NObj = 0 // Количество классов в карточке идентификации респондента M_Alias = SELECT() M_Recno = RECNO() IF R_Dost = "Y" SELECT Rasp1;SET ORDER TO 1;T=DBSEEK(STR(M_KodObj,19)) IF T SET ORDER TO DO WHILE .NOT. EOF() .AND. Kod_obj=M_KodObj DO CASE CASE Korr > 0 IF ASCAN(Ar_Kcl, Kod_cls) > 0 S_T_id = S_T_id + Korr ++N_T_id ELSE S_F_id = S_F_id + Korr ++N_F_id ENDIF CASE Korr < 0 IF ASCAN(Ar_Kcl, Kod_cls) > 0 S_F_nid = S_F_nid + ABS(Korr) ++N_F_nid ELSE S_T_nid = S_T_nid + ABS(Korr) ++N_T_nid ENDIF ENDCASE ++M_NObj DBSKIP(1) ENDDO ** Сумма верно идентифицированных и неидентифицированных классов ** минус ошибочно идентифицированных и неидентифицированных классов ** деленная на количество классов (среднее на класс) M_DostS = (S_T_id+S_T_nid-S_F_id-S_F_nid)/M_NObj // Моя метрика, сходная с F-мерой M_DostN = (N_T_id+N_T_nid-N_F_id-N_F_nid)/M_NObj ** M_NObj = N_T_id+N_T_nid+N_F_id+N_F_nid // Должно быть так, если все верно ENDIF ENDIF SELECT(M_Alias) DBGOTO(M_Recno) RETURN(M_DostS) ******** Расчет интегрального качества распознавания класса N°Obj ******** Модифицированный вариант для "Эйдос-астра" FUNCTION DOSTOVER2(M_KodCls) S_T_id = 0 // Сумма уровней сходства верно идентифицированных объектов S_T_nid = 0 // Сумма уровней сходства верно неидентифицированных объектов S_F_id = 0 // Сумма уровней сходства ошибочно идентифицированных объектов S_F_nid = 0 // Сумма уровней сходства ошибочно неидентифицированных объектов N_T_id = 0 // Количество верно идентифицированных объектов N_T_nid = 0 // Количество верно неидентифицированных объектов N_F_id = 0 // Количество ошибочно идентифицированных объектов N_F_nid = 0 // Количество ошибочно неидентифицированных объектов M_DostS = 0 // Достоверность с учетом уровня сходства объектов с классами M_DostN = 0 // Достоверность с учетом количества логических объектов M_NResp = 0 // Кол-во объектов в карточке идентификации класса M_Alias = SELECT() M_Recno = RECNO() R_Dost = "Y" IF R_Dost = "Y" SELECT (M_Rsp2);SET ORDER TO 1;T=DBSEEK(STR(M_KodCls,4)) IF T SET ORDER TO DO WHILE .NOT. EOF() .AND. Kod_cls=M_KodCls M_KodObj = Kod_obj SELECT Rso_zag;SET ORDER TO 1;T = DBSEEK(STR(M_KodObj,19)) PUBLIC Ar_Kcl := {} IF T ***** Массив кодов классов, к которым действительно относится данный источник FOR j=3 TO FCOUNT()-4 M_kkl = FIELDGET(j) IF M_kkl > 0 IF ASCAN(Ar_Kcl, M_kkl) = 0 AADD(Ar_Kcl, M_kkl) ENDIF ENDIF NEXT ENDIF SELECT (M_Rsp2) DO CASE CASE Korr > 0 IF ASCAN(Ar_Kcl, Kod_cls) > 0 S_T_id = S_T_id + Korr ++N_T_id ELSE S_F_id = S_F_id + Korr ++N_F_id ENDIF CASE Korr < 0 IF ASCAN(Ar_Kcl, Kod_cls) > 0 S_F_nid = S_F_nid + ABS(Korr) ++N_F_nid ELSE S_T_nid = S_T_nid + ABS(Korr) ++N_T_nid ENDIF ENDCASE ++M_NResp DBSKIP(1) ENDDO ** Сумма верно идентифицированных и неидентифицированных объектов ** минус ошибочно идентифицированных и неидентифицированных объектов ** деленная на количество логических объектов (среднее на респондента) M_DostS = (S_T_id+S_T_nid-S_F_id-S_F_nid)/M_NResp M_DostN = (N_T_id+N_T_nid-N_F_id-N_F_nid)/M_NResp ** M_NResp = N_T_id+N_T_nid+N_F_id+N_F_nid // Должно быть так, если все верно ENDIF ENDIF SELECT(M_Alias) DBGOTO(M_Recno) RETURN(M_DostS) ******** Генерация индексных массивов БД валидности FUNCTION GenNTXVal() aSaveGN13 := DC_DataSave() IF FILE("ValidSys.dbf") CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE ValidSys EXCLUSIVE NEW Fm="F1КодF2НаименованиеF3Верн.идентификацияF4Ошиб.неидентификацияF5Общ.достоверность" * USE ValidSys INDEX VAL_kod,VAL_name,VAL_totn,VAL_fnot,VAL_dost EXCLUSIVE NEW INDEX ON STR(Kod_cls,19) TO VAL_kod INDEX ON Name_cls TO VAL_name INDEX ON STR(99999999.9999999-SLAPrOtn,19,7) TO VAL_totn * 123456789012345678 INDEX ON STR(99999999.9999999-SLAOSHNOTN,19,7) TO VAL_fnot INDEX ON STR(99999999.9999999-S_DOST_ID,19,7) TO VAL_dost CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций ENDIF DC_DataRest( aSaveGN13 ) RETURN NIL *********************************************************************************************************** ******** Генерация БД Dost_modCls.dbf ************* *********************************************************************************************************** FUNCTION GenDbfDostModCls() aSaveGenDbf := DC_DataSave() ***** Precision = TP/(TP+FP) - точность ***** Recall = TP/(TP+FN) - полнота ***** F-mera = 2*(Precision*Recall)/(Precision+Recall) ** Мой вариант метрики ************************************************************************************************************ ** Сумма верно идентифицированных и неидентифицированных объектов ** минус ошибочно идентифицированных и неидентифицированных объектов ** деленная на количество объектов (среднее на объект) в процентах * NT = N_T_id+N_T_nid // Количество ВЕРНО идентифицированных и неидентифицированных объектов * NF = N_F_id+N_F_nid // Количество ОШИБОЧНО идентифицированных и неидентифицированных объектов * NT = A_Rec[ 9] + A_Rec[12] // Количество ВЕРНО идентифицированных и неидентифицированных объектов * NF = A_Rec[11] + A_Rec[10] // Количество ОШИБОЧНО идентифицированных и неидентифицированных объектов * *********************************************************************************************************************************** * M_DVMod = (NT-NF)/(NT+NF)*100 // Дифференциальная валидность (достоверность) модели (по классу) (в знаменателе: "всего объектов") * *********************************************************************************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций aStructure := { { "Type_model" , "C",250, 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( "Dost_modClsALL.dbf", aStructure, "DBFNTX" ) aStructure := { { "ModIntKrit" , "C", 9, 0 }, ; // 1. Код: ##_####_#, где: ##-номер модели, ##-модель {Abs,Prc1,Prc2,Inf1,Inf2,Inf3,Inf4,Inf5,Inf6,Inf7}, #-инт.крит.: {k,i} { "Name_mod" , "C",250, 0 }, ; // 2. Наименование модели { "Int_krit" , "C", 40, 0 }, ; // 3. Наименование инт.критерия { "DifValMod" , "N", 15, 7 }, ; // 4. Достоверность идентификации класса (с учетом всех верно и ошибочно идентифицированных и неидентифицированных логических объектов)) { "AvrUrSx_T" , "N", 15, 7 }, ; // 5. Средний модуль уровней сходства ВЕРНО идентифицированных и неидентифицированных объектов { "AvrUrSx_F" , "N", 15, 7 }, ; // 6. Средний модуль уровней сходства ОШИБОЧНО идентифицированных и неидентифицированных объектов { "DifAvrUrSx" , "N", 15, 7 }, ; // 7. Разность средних модулей уровней сходства ВЕРНО и ОШИБОЧНО идентифицированных и неидентифицированных объектов { "N_LogObj" , "N", 15, 0 }, ; // 8. Количество объектов расп.выборки, фактически относящихся к классу { "N_T_Ident" , "N", 15, 0 }, ; // 9. Количество верно идентифицированных объектов расп.выборки { "N_F_NIdent" , "N", 15, 0 }, ; // 10.Количество ошибочно неидентифицированных объектов расп.выборки { "N_F_Ident" , "N", 15, 0 }, ; // 11.Количество ошибочно идентифицированных объектов расп.выборки { "N_T_NIdent" , "N", 15, 0 }, ; // 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) (мультиклассовый вариант) { "P_T_Ident" , "N", 15, 7 }, ; // 17.Вероятность верной идентификации объекта с классом с использованием модели { "P_T_NIdent" , "N", 15, 7 }, ; // 18.Вероятность верной не идентификации объекта с классом с использованием модели { "P_F_Ident" , "N", 15, 7 }, ; // 19.Вероятность ошибочной идентификации объекта с классом с использованием модели { "P_F_NIdent" , "N", 15, 7 }, ; // 20.Вероятность ошибочной не идентификации объекта с классом с использованием модели { "P_SlUg_Id" , "N", 15, 7 }, ; // 21.Вероятность случайного угадывания принадлежности объектов к классам { "P_SlUg_NId" , "N", 15, 7 }, ; // 22.Вероятность случайного угадывания непринадлежности объектов к классам { "EffMod_Id" , "N", 15, 7 }, ; // 23.Эффективность модели при идентификации: отношение вероятности верной идентификации при использовании модели к вероятности случайного угадывания принадлежности объекта к классу { "EffMod_NId" , "N", 15, 7 }, ; // 24.Эффективность модели при неидентификации: отношение вероятности верной неидентификации при использовании модели к вероятности случайного угадывания непринадлежности объекта к классу { "Avr_EffMod" , "N", 15, 7 }, ; // 25.Средняя эффективность модели: (EffMod_Id+EffMod_NId)/2 { "S_T_Ident" , "N", 15, 7 }, ; // 26.Сумма модулей уровней сходства верно идентифицированных объектов расп.выборки { "S_F_NIdent" , "N", 15, 7 }, ; // 27.Сумма модулей уровней сходства ошибочно неидентифицированных объектов расп.выборки { "S_F_Ident" , "N", 15, 7 }, ; // 28.Сумма модулей уровней сходства ошибочно идентифицированных объектов расп.выборки { "S_T_NIdent" , "N", 15, 7 }, ; // 29.Сумма модулей уровней сходства верно неидентифицированных объектов расп.выборки { "SPrecision" , "N", 15, 7 }, ; // 30.SPrecision = STP/(STP+SFP) - точность с учетом уровней сходства { "SRecall" , "N", 15, 7 }, ; // 31.SRecall = STP/(STP+SFN) - полнота с учетом уровней сходства { "L1_mera" , "N", 15, 7 }, ; // 32.L1-mera = 2*(SPrecision*SRecall)/(SPrecision+SRecall) (L1-мера проф.Е.В.Луценко - нечеткое мультиклассовое обобщение F-меры Ван Ризбергена) { "A_T_IDENT" , "N", 15, 7 }, ; // 33.Среднее модулей уровней сходства верно идентифицированных объектов расп.выборки (ATP=STP/TP) { "A_F_NIDENT" , "N", 15, 7 }, ; // 34.Среднее модулей уровней сходства ошибочно неидентифицированных объектов расп.выборки (AFN=SFN/FN) { "A_F_IDENT " , "N", 15, 7 }, ; // 35.Среднее модулей уровней сходства ошибочно идентифицированных объектов расп.выборки (AFP=SFP/FP) { "A_T_NIDENT" , "N", 15, 7 }, ; // 36.Среднее модулей уровней сходства верно неидентифицированных объектов расп.выборки (ATN=STN/TN) { "APRECISION" , "N", 15, 7 }, ; // 37.APrecision = ATP/(ATP+AFP) - точность с учетом уровней сходства { "ARECALL" , "N", 15, 7 }, ; // 38.ARecall = ATP/(ATP+AFN) - полнота с учетом уровней сходства { "L2_MERA" , "N", 15, 7 }, ; // 39.L2-mera = 2*(APrecision*ARecall)/(APrecision+ARecall) (L2-мера проф.Е.В.Луценко - нечеткое мультиклассовое обобщение { "Date" , "C", 10, 0 }, ; // 40.Дата формирования записи БД { "Time" , "C", 8, 0 } } // 41.Время формирования записи БД DbCreate( "VerModClsIT.dbf", aStructure ) // Сводная форма по достоверности всех моделей по всем инт.критериям ***** Определение фактической максимальной длины наименования класса CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW SELECT Classes ML = 15 DBGOTOP() DO WHILE .NOT. EOF() ML = MAX(ML, LEN(ALLTRIM(Name_cls))) DBSKIP(1) ENDDO CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций aStructure := { { "ModIntKrit" , "C", 9, 0 }, ; // 1. Код: ##_####_#, где: ##-номер модели, ##-модель {Abs,Prc1,Prc2,Inf1,Inf2,Inf3,Inf4,Inf5,Inf6,Inf7}, #-инт.крит.: {k,i} { "Kod_cls" , "N", 15, 0 }, ; // 2. Код класса { "Name_cls" , "C", ML, 0 }, ; // 3. Наименование класса { "DifValMod" , "N", 15, 7 }, ; // 4. Достоверность идентификации класса (с учетом всех верно и ошибочно идентифицированных и неидентифицированных логических объектов)) { "AvrUrSx_T" , "N", 15, 7 }, ; // 5. Средний модуль уровней сходства ВЕРНО идентифицированных и неидентифицированных объектов { "AvrUrSx_F" , "N", 15, 7 }, ; // 6. Средний модуль уровней сходства ОШИБОЧНО идентифицированных и неидентифицированных объектов { "DifAvrUrSx" , "N", 15, 7 }, ; // 7. Разность средних модулей уровней сходства ВЕРНО и ОШИБОЧНО идентифицированных и неидентифицированных объектов { "N_LogObj" , "N", 15, 7 }, ; // 8. Количество логических объектов расп.выборки, фактически относящихся к классу { "N_T_Ident" , "N", 15, 7 }, ; // 9. Количество верно идентифицированных объектов расп.выборки { "N_F_NIdent" , "N", 15, 7 }, ; // 10.Количество ошибочно неидентифицированных объектов расп.выборки { "N_F_Ident" , "N", 15, 7 }, ; // 11.Количество ошибочно идентифицированных объектов расп.выборки { "N_T_NIdent" , "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) (мультиклассовый вариант) { "P_T_Ident" , "N", 15, 7 }, ; // 17.Вероятность верной идентификации объекта с классом с использованием модели { "P_T_NIdent" , "N", 15, 7 }, ; // 18.Вероятность верной не идентификации объекта с классом с использованием модели { "P_F_Ident" , "N", 15, 7 }, ; // 19.Вероятность ошибочной идентификации объекта с классом с использованием модели { "P_F_NIdent" , "N", 15, 7 }, ; // 20.Вероятность ошибочной не идентификации объекта с классом с использованием модели { "P_SlUg_Id" , "N", 15, 7 }, ; // 21.Вероятность случайного угадывания принадлежности объектов к классам { "P_SlUg_NId" , "N", 15, 7 }, ; // 22.Вероятность случайного угадывания непринадлежности объектов к классам { "EffMod_Id" , "N", 15, 7 }, ; // 23.Эффективность модели при идентификации: отношение вероятности верной идентификации при использовании модели к вероятности случайного угадывания принадлежности объекта к классу { "EffMod_NId" , "N", 15, 7 }, ; // 24.Эффективность модели при неидентификации: отношение вероятности верной неидентификации при использовании модели к вероятности случайного угадывания непринадлежности объекта к классу { "Avr_EffMod" , "N", 15, 7 }, ; // 25.Средняя эффективность модели: (EffMod_Id+EffMod_NId)/2 { "S_T_Ident" , "N", 15, 7 }, ; // 26.Сумма модулей уровней сходства верно идентифицированных объектов расп.выборки { "S_F_NIdent" , "N", 15, 7 }, ; // 27.Сумма модулей уровней сходства ошибочно неидентифицированных объектов расп.выборки { "S_F_Ident" , "N", 15, 7 }, ; // 28.Сумма модулей уровней сходства ошибочно идентифицированных объектов расп.выборки { "S_T_NIdent" , "N", 15, 7 }, ; // 29.Сумма модулей уровней сходства верно неидентифицированных объектов расп.выборки { "SPrecision" , "N", 15, 7 }, ; // 30.SPrecision = STP/(STP+SFP) - точность с учетом уровней сходства { "SRecall" , "N", 15, 7 }, ; // 31.SRecall = STP/(STP+SFN) - полнота с учетом уровней сходства { "L1_mera" , "N", 15, 7 }, ; // 32.L1-mera = 2*(SPrecision*SRecall)/(SPrecision+SRecall) (L1-мера проф.Е.В.Луценко - нечеткое мультиклассовое обобщение F-меры Ван Ризбергена) { "A_T_IDENT" , "N", 15, 7 }, ; // 33.Среднее модулей уровней сходства верно идентифицированных объектов расп.выборки (ATP=STP/TP) { "A_F_NIDENT" , "N", 15, 7 }, ; // 34.Среднее модулей уровней сходства ошибочно неидентифицированных объектов расп.выборки (AFN=SFN/FN) { "A_F_IDENT " , "N", 15, 7 }, ; // 35.Среднее модулей уровней сходства ошибочно идентифицированных объектов расп.выборки (AFP=SFP/FP) { "A_T_NIDENT" , "N", 15, 7 }, ; // 36.Среднее модулей уровней сходства верно неидентифицированных объектов расп.выборки (ATN=STN/TN) { "APRECISION" , "N", 15, 7 }, ; // 37.APrecision = ATP/(ATP+AFP) - точность с учетом уровней сходства { "ARECALL" , "N", 15, 7 }, ; // 38.ARecall = ATP/(ATP+AFN) - полнота с учетом уровней сходства { "L2_MERA" , "N", 15, 7 }, ; // 39.L2-mera = 2*(APrecision*ARecall)/(APrecision+ARecall) (L2-мера проф.Е.В.Луценко - нечеткое мультиклассовое обобщение { "Date" , "C", 10, 0 }, ; // 40.Дата формирования записи БД { "Time" , "C", 8, 0 } } // 41.Время формирования записи БД DbCreate( "VerModCls.dbf", aStructure ) // Сводная форма по достоверности идент.по всем классам во всех моделях и со всеми DC_DataRest( aSaveGenDbf ) RETURN NIL *********************************************************************************************************** ******** Генерация БД Dost_modObj.dbf ************* *********************************************************************************************************** FUNCTION GenDbfDostModObj() aSaveGenDbf := DC_DataSave() ***** Precision = TP/(TP+FP) - точность ***** Recall = TP/(TP+FN) - полнота ***** F-mera = 2*(Precision*Recall)/(Precision+Recall) ** Мой вариант метрики ************************************************************************************************************ ** Сумма верно идентифицированных и неидентифицированных объектов ** минус ошибочно идентифицированных и неидентифицированных объектов ** деленная на количество объектов (среднее на объект) в процентах * NT = N_T_id+N_T_nid // Количество ВЕРНО идентифицированных и неидентифицированных объектов * NF = N_F_id+N_F_nid // Количество ОШИБОЧНО идентифицированных и неидентифицированных объектов * NT = A_Rec[ 9] + A_Rec[12] // Количество ВЕРНО идентифицированных и неидентифицированных объектов * NF = A_Rec[11] + A_Rec[10] // Количество ОШИБОЧНО идентифицированных и неидентифицированных объектов * *********************************************************************************************************************************** * M_DVMod = (NT-NF)/(NT+NF)*100 // Дифференциальная валидность (достоверность) модели (по классу) (в знаменателе: "всего объектов") * *********************************************************************************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций ********* Создать БД Dost_mod.dbf и ее индексные массивы Avr_EffMod aStructure := { { "Type_model" , "C",250, 0 }, ; { "Int_krit" , "C", 40, 0 }, ; { "N_T_Ident" , "N", 15, 0 }, ; // Количество верно идентифицированных объектов расп.выборки (TP) { "N_F_NIdent" , "N", 15, 0 }, ; // Количество ошибочно неидентифицированных объектов расп.выборки (FN) { "N_F_Ident" , "N", 15, 0 }, ; // Количество ошибочно идентифицированных объектов расп.выборки (FP) { "N_T_NIdent" , "N", 15, 0 }, ; // Количество верно неидентифицированных объектов расп.выборки (TN) { "P_T_Ident" , "N", 15, 7 }, ; // Вероятность верной идентификации объекта с классом с использованием модели { "P_T_NIdent" , "N", 15, 7 }, ; // Вероятность верной не идентификации объекта с классом с использованием модели { "P_F_Ident" , "N", 15, 7 }, ; // Вероятность ошибочной идентификации объекта с классом с использованием модели { "P_F_NIdent" , "N", 15, 7 }, ; // Вероятность ошибочной не идентификации объекта с классом с использованием модели { "P_Avr_T" , "N", 15, 7 }, ; // Вероятность верной идентификации или неидентификации объекта с классом с использованием модели (моя мера) { "DVMod" , "N", 15, 7 }, ; // M_DVMod = (NT-NF)/(NT+NF)*100 Моя мера качества модели-классификатора (в знаменателе: "всего объектов") { "Precision" , "N", 15, 7 }, ; // Precision = TP/(TP+FP) - точность { "Recall" , "N", 15, 7 }, ; // Recall = TP/(TP+FN) - полнота { "F_mera" , "N", 15, 7 }, ; // F-mera = 2*(Precision*Recall)/(Precision+Recall) (мультиклассовый вариант) { "S_T_Ident" , "N", 15, 7 }, ; // 26.Сумма модулей уровней сходства верно идентифицированных объектов расп.выборки { "S_F_NIdent" , "N", 15, 7 }, ; // 27.Сумма модулей уровней сходства ошибочно неидентифицированных объектов расп.выборки { "S_F_Ident" , "N", 15, 7 }, ; // 28.Сумма модулей уровней сходства ошибочно идентифицированных объектов расп.выборки { "S_T_NIdent" , "N", 15, 7 }, ; // 29.Сумма модулей уровней сходства верно неидентифицированных объектов расп.выборки { "SPrecision" , "N", 15, 7 }, ; // 30.SPrecision = STP/(STP+SFP) - точность с учетом уровней сходства { "SRecall" , "N", 15, 7 }, ; // 31.SRecall = STP/(STP+SFN) - полнота с учетом уровней сходства { "L1_mera" , "N", 15, 7 }, ; // 32.L-mera = 2*(SPrecision*SRecall)/(SPrecision+SRecall) (L1-мера проф.Е.В.Луценко - нечеткое мультиклассовое обобщение F-меры Ван Ризбергена) { "A_T_IDENT" , "N", 15, 7 }, ; // 33.Среднее модулей уровней сходства верно идентифицированных объектов расп.выборки (ATP=STP/TP) { "A_F_NIDENT" , "N", 15, 7 }, ; // 34.Среднее модулей уровней сходства ошибочно неидентифицированных объектов расп.выборки (AFN=SFN/FN) { "A_F_IDENT " , "N", 15, 7 }, ; // 35.Среднее модулей уровней сходства ошибочно идентифицированных объектов расп.выборки (AFP=SFP/FP) { "A_T_NIDENT" , "N", 15, 7 }, ; // 36.Среднее модулей уровней сходства верно неидентифицированных объектов расп.выборки (ATN=STN/TN) { "APRECISION" , "N", 15, 7 }, ; // 37.APrecision = ATP/(ATP+AFP) - точность с учетом уровней сходства { "ARECALL" , "N", 15, 7 }, ; // 38.ARecall = ATP/(ATP+AFN) - полнота с учетом уровней сходства { "L2_MERA" , "N", 15, 7 }, ; // 39.L2-mera = 2*(APrecision*ARecall)/(APrecision+ARecall) (L2-мера проф.Е.В.Луценко - нечеткое мультиклассовое обобщение { "Date" , "C", 10, 0 }, ; { "Time" , "C", 8, 0 } } DbCreate( "Dost_modObj.dbf", aStructure, "DBFNTX" ) aStructure := { { "ModIntKrit" , "C", 9, 0 }, ; // 1. Код: ##_####_#, где: ##-номер модели, ##-модель {Abs,Prc1,Prc2,Inf1,Inf2,Inf3,Inf4,Inf5,Inf6,Inf7}, #-инт.крит.: {k,i} { "Name_mod" , "C",250, 0 }, ; // 2. Наименование модели { "Int_krit" , "C", 40, 0 }, ; // 3. Наименование инт.критерия { "DifValMod" , "N", 15, 7 }, ; // 4. Достоверность идентификации класса (с учетом всех верно и ошибочно идентифицированных и неидентифицированных логических объектов)) { "AvrUrSx_T" , "N", 15, 7 }, ; // 5. Средний модуль уровней сходства ВЕРНО идентифицированных и неидентифицированных объектов { "AvrUrSx_F" , "N", 15, 7 }, ; // 6. Средний модуль уровней сходства ОШИБОЧНО идентифицированных и неидентифицированных объектов { "DifAvrUrSx" , "N", 15, 7 }, ; // 7. Разность средних модулей уровней сходства ВЕРНО и ОШИБОЧНО идентифицированных и неидентифицированных объектов { "N_LogObj" , "N", 15, 0 }, ; // 8. Количество объектов расп.выборки, фактически относящихся к классу { "N_T_Ident" , "N", 15, 0 }, ; // 9. Количество верно идентифицированных объектов расп.выборки { "N_F_NIdent" , "N", 15, 0 }, ; // 10.Количество ошибочно неидентифицированных объектов расп.выборки { "N_F_Ident" , "N", 15, 0 }, ; // 11.Количество ошибочно идентифицированных объектов расп.выборки { "N_T_NIdent" , "N", 15, 0 }, ; // 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) (мультиклассовый вариант) { "P_T_Ident" , "N", 15, 7 }, ; // 17.Вероятность верной идентификации объекта с классом с использованием модели { "P_T_NIdent" , "N", 15, 7 }, ; // 18.Вероятность верной не идентификации объекта с классом с использованием модели { "P_F_Ident" , "N", 15, 7 }, ; // 19.Вероятность ошибочной идентификации объекта с классом с использованием модели { "P_F_NIdent" , "N", 15, 7 }, ; // 20.Вероятность ошибочной не идентификации объекта с классом с использованием модели { "P_SlUg_Id" , "N", 15, 7 }, ; // 21.Вероятность случайного угадывания принадлежности объектов к классам { "P_SlUg_NId" , "N", 15, 7 }, ; // 22.Вероятность случайного угадывания непринадлежности объектов к классам { "EffMod_Id" , "N", 15, 7 }, ; // 23.Эффективность модели при идентификации: отношение вероятности верной идентификации при использовании модели к вероятности случайного угадывания принадлежности объекта к классу { "EffMod_NId" , "N", 15, 7 }, ; // 24.Эффективность модели при неидентификации: отношение вероятности верной неидентификации при использовании модели к вероятности случайного угадывания непринадлежности объекта к классу { "Avr_EffMod" , "N", 15, 7 }, ; // 25.Средняя эффективность модели: (EffMod_Id+EffMod_NId)/2 { "S_T_Ident" , "N", 15, 7 }, ; // 26.Сумма модулей уровней сходства верно идентифицированных объектов расп.выборки { "S_F_NIdent" , "N", 15, 7 }, ; // 27.Сумма модулей уровней сходства ошибочно неидентифицированных объектов расп.выборки { "S_F_Ident" , "N", 15, 7 }, ; // 28.Сумма модулей уровней сходства ошибочно идентифицированных объектов расп.выборки { "S_T_NIdent" , "N", 15, 7 }, ; // 29.Сумма модулей уровней сходства верно неидентифицированных объектов расп.выборки { "SPrecision" , "N", 15, 7 }, ; // 30.SPrecision = STP/(STP+SFP) - точность с учетом уровней сходства { "SRecall" , "N", 15, 7 }, ; // 31.SRecall = STP/(STP+SFN) - полнота с учетом уровней сходства { "L1_mera" , "N", 15, 7 }, ; // 32.L-mera = 2*(SPrecision*SRecall)/(SPrecision+SRecall) (L1-мера проф.Е.В.Луценко - нечеткое мультиклассовое обобщение F-меры Ван Ризбергена) { "A_T_IDENT" , "N", 15, 7 }, ; // 33.Среднее модулей уровней сходства верно идентифицированных объектов расп.выборки (ATP=STP/TP) { "A_F_NIDENT" , "N", 15, 7 }, ; // 34.Среднее модулей уровней сходства ошибочно неидентифицированных объектов расп.выборки (AFN=SFN/FN) { "A_F_IDENT " , "N", 15, 7 }, ; // 35.Среднее модулей уровней сходства ошибочно идентифицированных объектов расп.выборки (AFP=SFP/FP) { "A_T_NIDENT" , "N", 15, 7 }, ; // 36.Среднее модулей уровней сходства верно неидентифицированных объектов расп.выборки (ATN=STN/TN) { "APRECISION" , "N", 15, 7 }, ; // 37.APrecision = ATP/(ATP+AFP) - точность с учетом уровней сходства { "ARECALL" , "N", 15, 7 }, ; // 38.ARecall = ATP/(ATP+AFN) - полнота с учетом уровней сходства { "L2_MERA" , "N", 15, 7 }, ; // 39.L2-mera = 2*(APrecision*ARecall)/(APrecision+ARecall) (L2-мера проф.Е.В.Луценко - нечеткое мультиклассовое обобщение { "Date" , "C", 10, 0 }, ; // 33.Дата формирования записи БД { "Time" , "C", 8, 0 } } // 34.Время формирования записи БД DbCreate( "VerModObjIT.dbf", aStructure ) // Сводная форма по достоверности всех моделей по всем инт.критериям ***** Определение фактической максимальной длины наименования класса CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rso_Zag EXCLUSIVE NEW SELECT Rso_Zag ML = 15 DBGOTOP() DO WHILE .NOT. EOF() ML = MAX(ML, LEN(ALLTRIM(Name_obj))) * MsgBox(Name_obj+STR(LEN(ALLTRIM(Name_obj)))) DBSKIP(1) ENDDO CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций *MsgBox(STR(ML)) aStructure := { { "ModIntKrit" , "C", 9, 0 }, ; // 1. Код: ##_####_#, где: ##-номер модели, ##-модель {Abs,Prc1,Prc2,Inf1,Inf2,Inf3,Inf4,Inf5,Inf6,Inf7}, #-инт.крит.: {k,i} { "Kod_obj" , "N", 15, 0 }, ; // 2. Код объекта { "Name_obj" , "C", ML, 0 }, ; // 3. Наименование объекта { "DifValMod" , "N", 15, 7 }, ; // 4. Достоверность идентификации объекта (с учетом всех верно и ошибочно идентифицированных и неидентифицированных логических объектов)) { "AvrUrSx_T" , "N", 15, 7 }, ; // 5. Средний модуль уровней сходства ВЕРНО идентифицированных и неидентифицированных объектов { "AvrUrSx_F" , "N", 15, 7 }, ; // 6. Средний модуль уровней сходства ОШИБОЧНО идентифицированных и неидентифицированных объектов { "DifAvrUrSx" , "N", 15, 7 }, ; // 7. Разность средних модулей уровней сходства ВЕРНО и ОШИБОЧНО идентифицированных и неидентифицированных объектов { "N_LogObj" , "N", 15, 0 }, ; // 8. Количество объектов расп.выборки, фактически относящихся к классу { "N_T_Ident" , "N", 15, 0 }, ; // 9. Количество верно идентифицированных объектов расп.выборки { "N_F_NIdent" , "N", 15, 0 }, ; // 10.Количество ошибочно неидентифицированных объектов расп.выборки { "N_F_Ident" , "N", 15, 0 }, ; // 11.Количество ошибочно идентифицированных объектов расп.выборки { "N_T_NIdent" , "N", 15, 0 }, ; // 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) (мультиклассовый вариант) { "P_T_Ident" , "N", 15, 7 }, ; // 17.Вероятность верной идентификации объекта с классом с использованием модели { "P_T_NIdent" , "N", 15, 7 }, ; // 18.Вероятность верной не идентификации объекта с классом с использованием модели { "P_F_Ident" , "N", 15, 7 }, ; // 19.Вероятность ошибочной идентификации объекта с классом с использованием модели { "P_F_NIdent" , "N", 15, 7 }, ; // 20.Вероятность ошибочной не идентификации объекта с классом с использованием модели { "P_SlUg_Id" , "N", 15, 7 }, ; // 21.Вероятность случайного угадывания принадлежности объектов к классам { "P_SlUg_NId" , "N", 15, 7 }, ; // 22.Вероятность случайного угадывания непринадлежности объектов к классам { "EffMod_Id" , "N", 15, 7 }, ; // 23.Эффективность модели при идентификации: отношение вероятности верной идентификации при использовании модели к вероятности случайного угадывания принадлежности объекта к классу { "EffMod_NId" , "N", 15, 7 }, ; // 24.Эффективность модели при неидентификации: отношение вероятности верной неидентификации при использовании модели к вероятности случайного угадывания непринадлежности объекта к классу { "Avr_EffMod" , "N", 15, 7 }, ; // 25.Средняя эффективность модели: (EffMod_Id+EffMod_NId)/2 { "S_T_Ident" , "N", 15, 7 }, ; // 26.Сумма модулей уровней сходства верно идентифицированных объектов расп.выборки { "S_F_NIdent" , "N", 15, 7 }, ; // 27.Сумма модулей уровней сходства ошибочно неидентифицированных объектов расп.выборки { "S_F_Ident" , "N", 15, 7 }, ; // 28.Сумма модулей уровней сходства ошибочно идентифицированных объектов расп.выборки { "S_T_NIdent" , "N", 15, 7 }, ; // 29.Сумма модулей уровней сходства верно неидентифицированных объектов расп.выборки { "SPrecision" , "N", 15, 7 }, ; // 30.SPrecision = STP/(STP+SFP) - точность с учетом уровней сходства { "SRecall" , "N", 15, 7 }, ; // 31.SRecall = STP/(STP+SFN) - полнота с учетом уровней сходства { "L1_mera" , "N", 15, 7 }, ; // 32.L-mera = 2*(SPrecision*SRecall)/(SPrecision+SRecall) (L1-мера проф.Е.В.Луценко - нечеткое мультиклассовое обобщение F-меры Ван Ризбергена) { "A_T_IDENT" , "N", 15, 7 }, ; // 33.Среднее модулей уровней сходства верно идентифицированных объектов расп.выборки (ATP=STP/TP) { "A_F_NIDENT" , "N", 15, 7 }, ; // 34.Среднее модулей уровней сходства ошибочно неидентифицированных объектов расп.выборки (AFN=SFN/FN) { "A_F_IDENT " , "N", 15, 7 }, ; // 35.Среднее модулей уровней сходства ошибочно идентифицированных объектов расп.выборки (AFP=SFP/FP) { "A_T_NIDENT" , "N", 15, 7 }, ; // 36.Среднее модулей уровней сходства верно неидентифицированных объектов расп.выборки (ATN=STN/TN) { "APRECISION" , "N", 15, 7 }, ; // 37.APrecision = ATP/(ATP+AFP) - точность с учетом уровней сходства { "ARECALL" , "N", 15, 7 }, ; // 38.ARecall = ATP/(ATP+AFN) - полнота с учетом уровней сходства { "L2_MERA" , "N", 15, 7 }, ; // 39.L2-mera = 2*(APrecision*ARecall)/(APrecision+ARecall) (L2-мера проф.Е.В.Луценко - нечеткое мультиклассовое обобщение { "Date" , "C", 10, 0 }, ; // 33.Дата формирования записи БД { "Time" , "C", 8, 0 } } // 34.Время формирования записи БД DbCreate( "VerModObj.dbf", aStructure ) // Сводная форма по достоверности идент.по всем классам во всех моделях и со всеми CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE VerModObj EXCLUSIVE NEW mRSVMD = RECSIZE() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DC_DataRest( aSaveGenDbf ) RETURN(mRSVMD) // Вернуть размер записи в байтах *********************************************************************************************************** ******** Генерация БД VerModCls.dbf ************* *********************************************************************************************************** FUNCTION GenDbfVerModCls(M_NumMod, M_IntKrit) aSaveGDVS := DC_DataSave() ***** Определение фактической максимальной длины наименования класса CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW SELECT Classes ML = 15 DBGOTOP() DO WHILE .NOT. EOF() ML = MAX(ML, LEN(ALLTRIM(Name_cls))) DBSKIP(1) ENDDO CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций // Сделать формирование имен этих БД по типу: VerMod##@, где 1-й ##-номер модели (01-10), а @-й интегр.критерий {k, i} cFileName := "VerModCls"+STRTRAN(STR(M_NumMod,2)," ","0")+IF(M_IntKrit=1,"k","i")+".dbf" aStructure := { { "ModIntKrit" , "C", 9, 0 }, ; // 1. Код: ##_####_#, где: ##-номер модели, ##-модель {Abs,Prc1,Prc2,Inf1,Inf2,Inf3,Inf4,Inf5,Inf6,Inf7}, #-инт.крит.: {k,i} { "Kod_cls" , "N", 15, 0 }, ; // 2. Код класса { "Name_cls" , "C", ML, 0 }, ; // 3. Наименование класса { "DifValMod" , "N", 15, 7 }, ; // 4. Достоверность идентификации класса (с учетом всех верно и ошибочно идентифицированных и неидентифицированных логических объектов)) { "AvrUrSx_T" , "N", 15, 7 }, ; // 5. Средний модуль уровней сходства ВЕРНО идентифицированных и неидентифицированных объектов { "AvrUrSx_F" , "N", 15, 7 }, ; // 6. Средний модуль уровней сходства ОШИБОЧНО идентифицированных и неидентифицированных объектов { "DifAvrUrSx" , "N", 15, 7 }, ; // 7. Разность средних модулей уровней сходства ВЕРНО и ОШИБОЧНО идентифицированных и неидентифицированных объектов { "N_LogObj" , "N", 15, 7 }, ; // 8. Количество логических объектов расп.выборки, фактически относящихся к классу { "N_T_Ident" , "N", 15, 7 }, ; // 9. Количество верно идентифицированных объектов расп.выборки { "N_F_NIdent" , "N", 15, 7 }, ; // 10.Количество ошибочно неидентифицированных объектов расп.выборки { "N_F_Ident" , "N", 15, 7 }, ; // 11.Количество ошибочно идентифицированных объектов расп.выборки { "N_T_NIdent" , "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) (мультиклассовый вариант) { "P_T_Ident" , "N", 15, 7 }, ; // 17.Вероятность верной идентификации объекта с классом с использованием модели { "P_T_NIdent" , "N", 15, 7 }, ; // 18.Вероятность верной не идентификации объекта с классом с использованием модели { "P_F_Ident" , "N", 15, 7 }, ; // 19.Вероятность ошибочной идентификации объекта с классом с использованием модели { "P_F_NIdent" , "N", 15, 7 }, ; // 20.Вероятность ошибочной не идентификации объекта с классом с использованием модели { "P_SlUg_Id" , "N", 15, 7 }, ; // 21.Вероятность случайного угадывания принадлежности объектов к классам { "P_SlUg_NId" , "N", 15, 7 }, ; // 22.Вероятность случайного угадывания непринадлежности объектов к классам { "EffMod_Id" , "N", 15, 7 }, ; // 23.Эффективность модели при идентификации: отношение вероятности верной идентификации при использовании модели к вероятности случайного угадывания принадлежности объекта к классу { "EffMod_NId" , "N", 15, 7 }, ; // 24.Эффективность модели при неидентификации: отношение вероятности верной неидентификации при использовании модели к вероятности случайного угадывания непринадлежности объекта к классу { "Avr_EffMod" , "N", 15, 7 }, ; // 25.Средняя эффективность модели: (EffMod_Id+EffMod_NId)/2 { "S_T_Ident" , "N", 15, 7 }, ; // 26.Сумма модулей уровней сходства верно идентифицированных объектов расп.выборки { "S_F_NIdent" , "N", 15, 7 }, ; // 27.Сумма модулей уровней сходства ошибочно неидентифицированных объектов расп.выборки { "S_F_Ident" , "N", 15, 7 }, ; // 28.Сумма модулей уровней сходства ошибочно идентифицированных объектов расп.выборки { "S_T_NIdent" , "N", 15, 7 }, ; // 29.Сумма модулей уровней сходства верно неидентифицированных объектов расп.выборки { "SPrecision" , "N", 15, 7 }, ; // 30.SPrecision = STP/(STP+SFP) - точность с учетом уровней сходства { "SRecall" , "N", 15, 7 }, ; // 31.SRecall = STP/(STP+SFN) - полнота с учетом уровней сходства { "L1_mera" , "N", 15, 7 }, ; // 32.L1-mera = 2*(SPrecision*SRecall)/(SPrecision+SRecall) (L1-мера проф.Е.В.Луценко - нечеткое мультиклассовое обобщение F-меры Ван Ризбергена) { "A_T_IDENT" , "N", 15, 7 }, ; // 33.Среднее модулей уровней сходства верно идентифицированных объектов расп.выборки (ATP=STP/TP) { "A_F_NIDENT" , "N", 15, 7 }, ; // 34.Среднее модулей уровней сходства ошибочно неидентифицированных объектов расп.выборки (AFN=SFN/FN) { "A_F_IDENT " , "N", 15, 7 }, ; // 35.Среднее модулей уровней сходства ошибочно идентифицированных объектов расп.выборки (AFP=SFP/FP) { "A_T_NIDENT" , "N", 15, 7 }, ; // 36.Среднее модулей уровней сходства верно неидентифицированных объектов расп.выборки (ATN=STN/TN) { "APRECISION" , "N", 15, 7 }, ; // 37.APrecision = ATP/(ATP+AFP) - точность с учетом уровней сходства { "ARECALL" , "N", 15, 7 }, ; // 38.ARecall = ATP/(ATP+AFN) - полнота с учетом уровней сходства { "L2_MERA" , "N", 15, 7 }, ; // 39.L2-mera = 2*(APrecision*ARecall)/(APrecision+ARecall) (L2-мера проф.Е.В.Луценко - нечеткое мультиклассовое обобщение { "Date" , "C", 10, 0 }, ; // 33.Дата формирования записи БД { "Time" , "C", 8, 0 } } // 34.Время формирования записи БД DbCreate( cFileName, aStructure ) // Форма по достоверности идент.по всем классам в одной модели с одним инт.критерием DC_DataRest( aSaveGDVS ) RETURN NIL *********************************************************************************************************** ******** Генерация БД VerModObj.dbf ************* *********************************************************************************************************** FUNCTION GenDbfVerModObj(M_NumMod, M_IntKrit) aSaveGDVS := DC_DataSave() ***** Определение фактической максимальной длины наименования класса CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rso_Zag EXCLUSIVE NEW SELECT Rso_Zag ML = 15 DBGOTOP() DO WHILE .NOT. EOF() ML = MAX(ML, LEN(ALLTRIM(Name_obj))) DBSKIP(1) ENDDO CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций // Сделать формирование имен этих БД по типу: VerMod##@, где 1-й ##-номер модели (01-10), а @-й интегр.критерий {k, i} cFileName := "VerModObj"+STRTRAN(STR(M_NumMod,2)," ","0")+IF(M_IntKrit=1,"k","i")+".dbf" aStructure := { { "ModIntKrit" , "C", 9, 0 }, ; // 1. Код: ##_####_#, где: ##-номер модели, ##-модель {Abs,Prc1,Prc2,Inf1,Inf2,Inf3,Inf4,Inf5,Inf6,Inf7}, #-инт.крит.: {k,i} { "Kod_obj" , "N", 15, 0 }, ; // 2. Код класса { "Name_obj" , "C", ML, 0 }, ; // 3. Наименование класса { "DifValMod" , "N", 15, 7 }, ; // 4. Достоверность идентификации класса (с учетом всех верно и ошибочно идентифицированных и неидентифицированных логических объектов)) { "AvrUrSx_T" , "N", 15, 7 }, ; // 5. Средний модуль уровней сходства ВЕРНО идентифицированных и неидентифицированных объектов { "AvrUrSx_F" , "N", 15, 7 }, ; // 6. Средний модуль уровней сходства ОШИБОЧНО идентифицированных и неидентифицированных объектов { "DifAvrUrSx" , "N", 15, 7 }, ; // 7. Разность средних модулей уровней сходства ВЕРНО и ОШИБОЧНО идентифицированных и неидентифицированных объектов { "N_LogObj" , "N", 15, 0 }, ; // 8. Количество объектов расп.выборки, фактически относящихся к классу { "N_T_Ident" , "N", 15, 0 }, ; // 9. Количество верно идентифицированных объектов расп.выборки { "N_F_NIdent" , "N", 15, 0 }, ; // 10.Количество ошибочно неидентифицированных объектов расп.выборки { "N_F_Ident" , "N", 15, 0 }, ; // 11.Количество ошибочно идентифицированных объектов расп.выборки { "N_T_NIdent" , "N", 15, 0 }, ; // 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) (мультиклассовый вариант) { "P_T_Ident" , "N", 15, 7 }, ; // 17.Вероятность верной идентификации объекта с классом с использованием модели { "P_T_NIdent" , "N", 15, 7 }, ; // 18.Вероятность верной не идентификации объекта с классом с использованием модели { "P_F_Ident" , "N", 15, 7 }, ; // 19.Вероятность ошибочной идентификации объекта с классом с использованием модели { "P_F_NIdent" , "N", 15, 7 }, ; // 20.Вероятность ошибочной не идентификации объекта с классом с использованием модели { "P_SlUg_Id" , "N", 15, 7 }, ; // 21.Вероятность случайного угадывания принадлежности объектов к классам { "P_SlUg_NId" , "N", 15, 7 }, ; // 22.Вероятность случайного угадывания непринадлежности объектов к классам { "EffMod_Id" , "N", 15, 7 }, ; // 23.Эффективность модели при идентификации: отношение вероятности верной идентификации при использовании модели к вероятности случайного угадывания принадлежности объекта к классу { "EffMod_NId" , "N", 15, 7 }, ; // 24.Эффективность модели при неидентификации: отношение вероятности верной неидентификации при использовании модели к вероятности случайного угадывания непринадлежности объекта к классу { "Avr_EffMod" , "N", 15, 7 }, ; // 25.Средняя эффективность модели: (EffMod_Id+EffMod_NId)/2 { "S_T_Ident" , "N", 15, 7 }, ; // 26.Сумма модулей уровней сходства верно идентифицированных объектов расп.выборки { "S_F_NIdent" , "N", 15, 7 }, ; // 27.Сумма модулей уровней сходства ошибочно неидентифицированных объектов расп.выборки { "S_F_Ident" , "N", 15, 7 }, ; // 28.Сумма модулей уровней сходства ошибочно идентифицированных объектов расп.выборки { "S_T_NIdent" , "N", 15, 7 }, ; // 29.Сумма модулей уровней сходства верно неидентифицированных объектов расп.выборки { "SPrecision" , "N", 15, 7 }, ; // 30.SPrecision = STP/(STP+SFP) - точность с учетом уровней сходства { "SRecall" , "N", 15, 7 }, ; // 31.SRecall = STP/(STP+SFN) - полнота с учетом уровней сходства { "L1_mera" , "N", 15, 7 }, ; // 32.L-mera = 2*(SPrecision*SRecall)/(SPrecision+SRecall) (L1-мера проф.Е.В.Луценко - нечеткое мультиклассовое обобщение F-меры Ван Ризбергена) { "A_T_IDENT" , "N", 15, 7 }, ; // 33.Среднее модулей уровней сходства верно идентифицированных объектов расп.выборки (ATP=STP/TP) { "A_F_NIDENT" , "N", 15, 7 }, ; // 34.Среднее модулей уровней сходства ошибочно неидентифицированных объектов расп.выборки (AFN=SFN/FN) { "A_F_IDENT " , "N", 15, 7 }, ; // 35.Среднее модулей уровней сходства ошибочно идентифицированных объектов расп.выборки (AFP=SFP/FP) { "A_T_NIDENT" , "N", 15, 7 }, ; // 36.Среднее модулей уровней сходства верно неидентифицированных объектов расп.выборки (ATN=STN/TN) { "APRECISION" , "N", 15, 7 }, ; // 37.APrecision = ATP/(ATP+AFP) - точность с учетом уровней сходства { "ARECALL" , "N", 15, 7 }, ; // 38.ARecall = ATP/(ATP+AFN) - полнота с учетом уровней сходства { "L2_MERA" , "N", 15, 7 }, ; // 39.L2-mera = 2*(APrecision*ARecall)/(APrecision+ARecall) (L2-мера проф.Е.В.Луценко - нечеткое мультиклассовое обобщение { "Date" , "C", 10, 0 }, ; // 33.Дата формирования записи БД { "Time" , "C", 8, 0 } } // 34.Время формирования записи БД * Уточнить размеры полей по факту и сделать их минимальными DbCreate( cFileName, aStructure ) // Форма по достоверности идент.по всем классам в одной модели с одним инт.критерием CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (cFileName) EXCLUSIVE NEW mRecSize = RECSIZE() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DC_DataRest( aSaveGDVS ) RETURN(mRecSize) // Вернуть размер записи в байтах ************************************************************************ ******** Факториал ***************************************************** ******** Для больших чисел использовать приближенную формулу Стирлинга ************************************************************************ FUNCTION F(n) RETURN(Fact(n)) FUNCTION Ff(n) p = 3.14159265358979323846 e = 2.71828182845904523536 IF n < 171 F=1 FOR z=1 TO n F=F*z NEXT ELSE // формула Муавра-Стирлинга укоряет (приближенные) расчеты для больших чисел, но не решает саму проблему больших чисел F=SQRT(2*p*n)*(n^n)*e^(-n)*(1+1/(12*n)+1/(288*n^2)-139/(51840*n^3)-571/(2488320*n^4)+163879/(209018880*n^5)+5246819/(75246796800*n^6)) ENDIF RETURN(F) ******** Сумма числа сочетаний из n по m, где m меняется от 1 до Ur_slog FUNCTION Summa_Cnm(N_PrMn, Ur_slog) * Cnm = n!/(m!(n-m)!) Sum_Cnm = 0 FOR m=1 TO Ur_slog Sum_Cnm = Sum_Cnm + F(N_PrMn)/(F(m)*F(N_PrMn-m)) NEXT RETURN(Sum_Cnm) ******** Формирование БД ObuchInf() ***************** FUNCTION ADD_ObInf(M_UrSlogObj) DO CASE CASE M_UrSlogObj = 1 Ar_GenObj := {} FOR i1= 1 TO LEN(Ar_prch) AADD(Ar_GenObj,Ar_prch[i1]) APPEND BLANK REPLACE Obj_name WITH "Obj_"+ALLTRIM(STR(++N,5)) FOR j=1 TO M_UrSlogObj Mfn = "PrCh"+ALLTRIM(STR(j,2)) REPLACE &Mfn WITH Ar_GenObj[j] NEXT Ar_GenObj := {} NEXT CASE M_UrSlogObj = 2 Ar_GenObj := {} FOR i1= 1 TO LEN(Ar_prch) FOR i2=i1+1 TO LEN(Ar_prch) AADD(Ar_GenObj,Ar_prch[i1]) AADD(Ar_GenObj,Ar_prch[i2]) APPEND BLANK REPLACE Obj_name WITH "Obj_"+ALLTRIM(STR(++N,5)) FOR j=1 TO M_UrSlogObj Mfn = "PrCh"+ALLTRIM(STR(j,2)) REPLACE &Mfn WITH Ar_GenObj[j] NEXT Ar_GenObj := {} NEXT NEXT CASE M_UrSlogObj = 3 Ar_GenObj := {} FOR i1= 1 TO LEN(Ar_prch) FOR i2=i1+1 TO LEN(Ar_prch) FOR i3=i2+1 TO LEN(Ar_prch) AADD(Ar_GenObj,Ar_prch[i1]) AADD(Ar_GenObj,Ar_prch[i2]) AADD(Ar_GenObj,Ar_prch[i3]) APPEND BLANK REPLACE Obj_name WITH "Obj_"+ALLTRIM(STR(++N,5)) FOR j=1 TO M_UrSlogObj Mfn = "PrCh"+ALLTRIM(STR(j,2)) REPLACE &Mfn WITH Ar_GenObj[j] NEXT Ar_GenObj := {} NEXT NEXT NEXT CASE M_UrSlogObj = 4 Ar_GenObj := {} FOR i1= 1 TO LEN(Ar_prch) FOR i2=i1+1 TO LEN(Ar_prch) FOR i3=i2+1 TO LEN(Ar_prch) FOR i4=i3+1 TO LEN(Ar_prch) AADD(Ar_GenObj,Ar_prch[i1]) AADD(Ar_GenObj,Ar_prch[i2]) AADD(Ar_GenObj,Ar_prch[i3]) AADD(Ar_GenObj,Ar_prch[i4]) APPEND BLANK REPLACE Obj_name WITH "Obj_"+ALLTRIM(STR(++N,5)) FOR j=1 TO M_UrSlogObj Mfn = "PrCh"+ALLTRIM(STR(j,2)) REPLACE &Mfn WITH Ar_GenObj[j] NEXT Ar_GenObj := {} NEXT NEXT NEXT NEXT CASE M_UrSlogObj = 5 Ar_GenObj := {} FOR i1= 1 TO LEN(Ar_prch) FOR i2=i1+1 TO LEN(Ar_prch) FOR i3=i2+1 TO LEN(Ar_prch) FOR i4=i3+1 TO LEN(Ar_prch) FOR i5=i4+1 TO LEN(Ar_prch) AADD(Ar_GenObj,Ar_prch[i1]) AADD(Ar_GenObj,Ar_prch[i2]) AADD(Ar_GenObj,Ar_prch[i3]) AADD(Ar_GenObj,Ar_prch[i4]) AADD(Ar_GenObj,Ar_prch[i5]) APPEND BLANK REPLACE Obj_name WITH "Obj_"+ALLTRIM(STR(++N,5)) FOR j=1 TO M_UrSlogObj Mfn = "PrCh"+ALLTRIM(STR(j,2)) REPLACE &Mfn WITH Ar_GenObj[j] NEXT Ar_GenObj := {} NEXT NEXT NEXT NEXT NEXT CASE M_UrSlogObj = 6 Ar_GenObj := {} FOR i1= 1 TO LEN(Ar_prch) FOR i2=i1+1 TO LEN(Ar_prch) FOR i3=i2+1 TO LEN(Ar_prch) FOR i4=i3+1 TO LEN(Ar_prch) FOR i5=i4+1 TO LEN(Ar_prch) FOR i6=i5+1 TO LEN(Ar_prch) AADD(Ar_GenObj,Ar_prch[i1]) AADD(Ar_GenObj,Ar_prch[i2]) AADD(Ar_GenObj,Ar_prch[i3]) AADD(Ar_GenObj,Ar_prch[i4]) AADD(Ar_GenObj,Ar_prch[i5]) AADD(Ar_GenObj,Ar_prch[i6]) APPEND BLANK REPLACE Obj_name WITH "Obj_"+ALLTRIM(STR(++N,5)) FOR j=1 TO M_UrSlogObj Mfn = "PrCh"+ALLTRIM(STR(j,2)) REPLACE &Mfn WITH Ar_GenObj[j] NEXT Ar_GenObj := {} NEXT NEXT NEXT NEXT NEXT NEXT CASE M_UrSlogObj = 7 Ar_GenObj := {} FOR i1= 1 TO LEN(Ar_prch) FOR i2=i1+1 TO LEN(Ar_prch) FOR i3=i2+1 TO LEN(Ar_prch) FOR i4=i3+1 TO LEN(Ar_prch) FOR i5=i4+1 TO LEN(Ar_prch) FOR i6=i5+1 TO LEN(Ar_prch) FOR i7=i6+1 TO LEN(Ar_prch) AADD(Ar_GenObj,Ar_prch[i1]) AADD(Ar_GenObj,Ar_prch[i2]) AADD(Ar_GenObj,Ar_prch[i3]) AADD(Ar_GenObj,Ar_prch[i4]) AADD(Ar_GenObj,Ar_prch[i5]) AADD(Ar_GenObj,Ar_prch[i6]) AADD(Ar_GenObj,Ar_prch[i7]) APPEND BLANK REPLACE Obj_name WITH "Obj_"+ALLTRIM(STR(++N,5)) FOR j=1 TO M_UrSlogObj Mfn = "PrCh"+ALLTRIM(STR(j,2)) REPLACE &Mfn WITH Ar_GenObj[j] NEXT Ar_GenObj := {} NEXT NEXT NEXT NEXT NEXT NEXT NEXT CASE M_UrSlogObj = 8 Ar_GenObj := {} FOR i1= 1 TO LEN(Ar_prch) FOR i2=i1+1 TO LEN(Ar_prch) FOR i3=i2+1 TO LEN(Ar_prch) FOR i4=i3+1 TO LEN(Ar_prch) FOR i5=i4+1 TO LEN(Ar_prch) FOR i6=i5+1 TO LEN(Ar_prch) FOR i7=i6+1 TO LEN(Ar_prch) FOR i8=i7+1 TO LEN(Ar_prch) AADD(Ar_GenObj,Ar_prch[i1]) AADD(Ar_GenObj,Ar_prch[i2]) AADD(Ar_GenObj,Ar_prch[i3]) AADD(Ar_GenObj,Ar_prch[i4]) AADD(Ar_GenObj,Ar_prch[i5]) AADD(Ar_GenObj,Ar_prch[i6]) AADD(Ar_GenObj,Ar_prch[i7]) AADD(Ar_GenObj,Ar_prch[i8]) APPEND BLANK REPLACE Obj_name WITH "Obj_"+ALLTRIM(STR(++N,5)) FOR j=1 TO M_UrSlogObj Mfn = "PrCh"+ALLTRIM(STR(j,2)) REPLACE &Mfn WITH Ar_GenObj[j] NEXT Ar_GenObj := {} NEXT NEXT NEXT NEXT NEXT NEXT NEXT NEXT CASE M_UrSlogObj = 9 Ar_GenObj := {} FOR i1= 1 TO LEN(Ar_prch) FOR i2=i1+1 TO LEN(Ar_prch) FOR i3=i2+1 TO LEN(Ar_prch) FOR i4=i3+1 TO LEN(Ar_prch) FOR i5=i4+1 TO LEN(Ar_prch) FOR i6=i5+1 TO LEN(Ar_prch) FOR i7=i6+1 TO LEN(Ar_prch) FOR i8=i7+1 TO LEN(Ar_prch) FOR i9=i8+1 TO LEN(Ar_prch) AADD(Ar_GenObj,Ar_prch[i1]) AADD(Ar_GenObj,Ar_prch[i2]) AADD(Ar_GenObj,Ar_prch[i3]) AADD(Ar_GenObj,Ar_prch[i4]) AADD(Ar_GenObj,Ar_prch[i5]) AADD(Ar_GenObj,Ar_prch[i6]) AADD(Ar_GenObj,Ar_prch[i7]) AADD(Ar_GenObj,Ar_prch[i8]) AADD(Ar_GenObj,Ar_prch[i9]) APPEND BLANK REPLACE Obj_name WITH "Obj_"+ALLTRIM(STR(++N,5)) FOR j=1 TO M_UrSlogObj Mfn = "PrCh"+ALLTRIM(STR(j,2)) REPLACE &Mfn WITH Ar_GenObj[j] NEXT Ar_GenObj := {} NEXT NEXT NEXT NEXT NEXT NEXT NEXT NEXT NEXT ENDCASE RETURN NIL ******** Формирование БД Sl_Chis ***************** FUNCTION ADD_SlChis(M_UrSlogFP) DO CASE CASE M_UrSlogFP = 1 FOR i1= 1 TO LEN(Ar_GenObj) M_SlCh = Ar_GenObj[i1] AADD(Ar_Slch, M_SlCh) T=DBSEEK(STR(M_SlCh,13)) IF T=.F. APPEND BLANK REPLACE Sl_Chis WITH M_SlCh REPLACE PrCh1 WITH Ar_GenObj[i1] ENDIF NEXT CASE M_UrSlogFP = 2 FOR i1= 1 TO LEN(Ar_GenObj) FOR i2=i1+1 TO LEN(Ar_GenObj) M_SlCh = Ar_GenObj[i1]*; Ar_GenObj[i2] AADD(Ar_Slch, M_SlCh) T=DBSEEK(STR(M_SlCh,13)) IF T=.F. APPEND BLANK REPLACE Sl_Chis WITH M_SlCh REPLACE PrCh1 WITH Ar_GenObj[i1] REPLACE PrCh2 WITH Ar_GenObj[i2] ENDIF NEXT NEXT CASE M_UrSlogFP = 3 FOR i1= 1 TO LEN(Ar_GenObj) FOR i2=i1+1 TO LEN(Ar_GenObj) FOR i3=i2+1 TO LEN(Ar_GenObj) M_SlCh = Ar_GenObj[i1]*; Ar_GenObj[i2]*; Ar_GenObj[i3] AADD(Ar_Slch, M_SlCh) T=DBSEEK(STR(M_SlCh,13)) IF T=.F. APPEND BLANK REPLACE Sl_Chis WITH M_SlCh REPLACE PrCh1 WITH Ar_GenObj[i1] REPLACE PrCh2 WITH Ar_GenObj[i2] REPLACE PrCh3 WITH Ar_GenObj[i3] ENDIF NEXT NEXT NEXT CASE M_UrSlogFP = 4 FOR i1= 1 TO LEN(Ar_GenObj) FOR i2=i1+1 TO LEN(Ar_GenObj) FOR i3=i2+1 TO LEN(Ar_GenObj) FOR i4=i3+1 TO LEN(Ar_GenObj) M_SlCh = Ar_GenObj[i1]*; Ar_GenObj[i2]*; Ar_GenObj[i3]*; Ar_GenObj[i4] AADD(Ar_Slch, M_SlCh) T=DBSEEK(STR(M_SlCh,13)) IF T=.F. APPEND BLANK REPLACE Sl_Chis WITH M_SlCh REPLACE PrCh1 WITH Ar_GenObj[i1] REPLACE PrCh2 WITH Ar_GenObj[i2] REPLACE PrCh3 WITH Ar_GenObj[i3] REPLACE PrCh4 WITH Ar_GenObj[i4] ENDIF NEXT NEXT NEXT NEXT CASE M_UrSlogFP = 5 FOR i1= 1 TO LEN(Ar_GenObj) FOR i2=i1+1 TO LEN(Ar_GenObj) FOR i3=i2+1 TO LEN(Ar_GenObj) FOR i4=i3+1 TO LEN(Ar_GenObj) FOR i5=i4+1 TO LEN(Ar_GenObj) M_SlCh = Ar_GenObj[i1]*; Ar_GenObj[i2]*; Ar_GenObj[i3]*; Ar_GenObj[i4]*; Ar_GenObj[i5] AADD(Ar_Slch, M_SlCh) T=DBSEEK(STR(M_SlCh,13)) IF T=.F. APPEND BLANK REPLACE Sl_Chis WITH M_SlCh REPLACE PrCh1 WITH Ar_GenObj[i1] REPLACE PrCh2 WITH Ar_GenObj[i2] REPLACE PrCh3 WITH Ar_GenObj[i3] REPLACE PrCh4 WITH Ar_GenObj[i4] REPLACE PrCh5 WITH Ar_GenObj[i5] ENDIF NEXT NEXT NEXT NEXT NEXT CASE M_UrSlogFP = 6 FOR i1= 1 TO LEN(Ar_GenObj) FOR i2=i1+1 TO LEN(Ar_GenObj) FOR i3=i2+1 TO LEN(Ar_GenObj) FOR i4=i3+1 TO LEN(Ar_GenObj) FOR i5=i4+1 TO LEN(Ar_GenObj) FOR i6=i5+1 TO LEN(Ar_GenObj) M_SlCh = Ar_GenObj[i1]*; Ar_GenObj[i2]*; Ar_GenObj[i3]*; Ar_GenObj[i4]*; Ar_GenObj[i5]*; Ar_GenObj[i6] AADD(Ar_Slch, M_SlCh) T=DBSEEK(STR(M_SlCh,13)) IF T=.F. APPEND BLANK REPLACE Sl_Chis WITH M_SlCh REPLACE PrCh1 WITH Ar_GenObj[i1] REPLACE PrCh2 WITH Ar_GenObj[i2] REPLACE PrCh3 WITH Ar_GenObj[i3] REPLACE PrCh4 WITH Ar_GenObj[i4] REPLACE PrCh5 WITH Ar_GenObj[i5] REPLACE PrCh6 WITH Ar_GenObj[i6] ENDIF NEXT NEXT NEXT NEXT NEXT NEXT CASE M_UrSlogFP = 7 FOR i1= 1 TO LEN(Ar_GenObj) FOR i2=i1+1 TO LEN(Ar_GenObj) FOR i3=i2+1 TO LEN(Ar_GenObj) FOR i4=i3+1 TO LEN(Ar_GenObj) FOR i5=i4+1 TO LEN(Ar_GenObj) FOR i6=i5+1 TO LEN(Ar_GenObj) FOR i7=i6+1 TO LEN(Ar_GenObj) M_SlCh = Ar_GenObj[i1]*; Ar_GenObj[i2]*; Ar_GenObj[i3]*; Ar_GenObj[i4]*; Ar_GenObj[i5]*; Ar_GenObj[i6]*; Ar_GenObj[i7] AADD(Ar_Slch, M_SlCh) T=DBSEEK(STR(M_SlCh,13)) IF T=.F. APPEND BLANK REPLACE Sl_Chis WITH M_SlCh REPLACE PrCh1 WITH Ar_GenObj[i1] REPLACE PrCh2 WITH Ar_GenObj[i2] REPLACE PrCh3 WITH Ar_GenObj[i3] REPLACE PrCh4 WITH Ar_GenObj[i4] REPLACE PrCh5 WITH Ar_GenObj[i5] REPLACE PrCh6 WITH Ar_GenObj[i6] REPLACE PrCh7 WITH Ar_GenObj[i7] ENDIF NEXT NEXT NEXT NEXT NEXT NEXT NEXT CASE M_UrSlogFP = 8 FOR i1= 1 TO LEN(Ar_GenObj) FOR i2=i1+1 TO LEN(Ar_GenObj) FOR i3=i2+1 TO LEN(Ar_GenObj) FOR i4=i3+1 TO LEN(Ar_GenObj) FOR i5=i4+1 TO LEN(Ar_GenObj) FOR i6=i5+1 TO LEN(Ar_GenObj) FOR i7=i6+1 TO LEN(Ar_GenObj) FOR i8=i7+1 TO LEN(Ar_GenObj) M_SlCh = Ar_GenObj[i1]*; Ar_GenObj[i2]*; Ar_GenObj[i3]*; Ar_GenObj[i4]*; Ar_GenObj[i5]*; Ar_GenObj[i6]*; Ar_GenObj[i7]*; Ar_GenObj[i8] AADD(Ar_Slch, M_SlCh) T=DBSEEK(STR(M_SlCh,13)) IF T=.F. APPEND BLANK REPLACE Sl_Chis WITH M_SlCh REPLACE PrCh1 WITH Ar_GenObj[i1] REPLACE PrCh2 WITH Ar_GenObj[i2] REPLACE PrCh3 WITH Ar_GenObj[i3] REPLACE PrCh4 WITH Ar_GenObj[i4] REPLACE PrCh5 WITH Ar_GenObj[i5] REPLACE PrCh6 WITH Ar_GenObj[i6] REPLACE PrCh7 WITH Ar_GenObj[i7] REPLACE PrCh8 WITH Ar_GenObj[i8] ENDIF NEXT NEXT NEXT NEXT NEXT NEXT NEXT NEXT CASE M_UrSlogFP = 9 FOR i1= 1 TO LEN(Ar_GenObj) FOR i2=i1+1 TO LEN(Ar_GenObj) FOR i3=i2+1 TO LEN(Ar_GenObj) FOR i4=i3+1 TO LEN(Ar_GenObj) FOR i5=i4+1 TO LEN(Ar_GenObj) FOR i6=i5+1 TO LEN(Ar_GenObj) FOR i7=i6+1 TO LEN(Ar_GenObj) FOR i8=i7+1 TO LEN(Ar_GenObj) FOR i9=i8+1 TO LEN(Ar_GenObj) M_SlCh = Ar_GenObj[i1]*; Ar_GenObj[i2]*; Ar_GenObj[i3]*; Ar_GenObj[i4]*; Ar_GenObj[i5]*; Ar_GenObj[i6]*; Ar_GenObj[i7]*; Ar_GenObj[i8]*; Ar_GenObj[i9] AADD(Ar_Slch, M_SlCh) T=DBSEEK(STR(M_SlCh,13)) IF T=.F. APPEND BLANK REPLACE Sl_Chis WITH M_SlCh REPLACE PrCh1 WITH Ar_GenObj[i1] REPLACE PrCh2 WITH Ar_GenObj[i2] REPLACE PrCh3 WITH Ar_GenObj[i3] REPLACE PrCh4 WITH Ar_GenObj[i4] REPLACE PrCh5 WITH Ar_GenObj[i5] REPLACE PrCh6 WITH Ar_GenObj[i6] REPLACE PrCh7 WITH Ar_GenObj[i7] REPLACE PrCh8 WITH Ar_GenObj[i8] REPLACE PrCh9 WITH Ar_GenObj[i9] ENDIF NEXT NEXT NEXT NEXT NEXT NEXT NEXT NEXT NEXT ENDCASE RETURN NIL ************************************************************************************************************* ******** 4.1.3.3. Отображение итоговых результатов распознавания в наглядной форме: отображаются пары: ******** "Объект-класс" у которых наибольшее сходство по двум интегральным критериям сходства: ******** "Семантический резонанс знаний" и "Сумма знаний". Приводится информация о фактической ******** принадлежности объекта к классу. ************************************************************************************************************* FUNCTION F4_1_3_3() LOCAL GetList := {}, GetOptions, oBrowIntKr, oBrowRsoIt, bApp, bItems Running(.T.) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF ApplChange("4.1.3.3()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW Running(.F.) RETURN NIL ENDIF IF .NOT.FILE("Rsp_it.dbf") // БД подробных сжатых результатов распознавания: Rsp_it.dbf LB_Warning(L("Необходимо выполнить распознавание в режиме 4.1.2 или 3.5 !!!")) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW Running(.F.) RETURN NIL 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("Информационное сообщение")) ELSE * Mess = L("В этой модели # распознавание уже проводилось ранее") // Написать КОГДА было проведено * Mess = STRTRAN(Mess, "#", Ar_Model[M_RaspInf]) * LB_Warning(Mess, L("Информационное сообщение")) ENDIF ELSE LB_Warning(L("Необходимо выполнить распознавание в режиме 4.1.2 или 3.5 !!!"), L("Информационное сообщение")) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW Running(.F.) RETURN NIL ENDIF // Создать БД интегральных критериев CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций ********* Создать БД Appls.dbf и ее индексные массивы aStructure := { { "Kod_IntKr" , "N", 8, 0 }, ; { "Name_IntKr", "C",30, 0 } } DbCreate( "Int_krit.dbf", aStructure ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Int_krit EXCLUSIVE NEW SELECT Int_krit APPEND BLANK REPLACE Kod_IntKr WITH 1 REPLACE Name_IntKr WITH L("Семантический резонанс знаний") APPEND BLANK REPLACE Kod_IntKr WITH 2 REPLACE Name_IntKr WITH L("Сумма знаний") dbeSetDefault('DBFNTX') CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Int_krit INDEX ON Kod_IntKr TO Int_krit CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rsp_it1 NEW INDEX ON Int_Krit TO Rsp_it1 CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Int_krit INDEX Int_krit EXCLUSIVE NEW USE Rsp_it1 INDEX Rsp_it1 EXCLUSIVE NEW /* ----- Create ToolBar 2 ----- */ @ 27.2, 1 DCTOOLBAR oToolBar SIZE 131, 1.5 K=1.18 DCADDBUTTON CAPTION L('Помощь') ; SIZE K+LEN(L("Помощь")) ; ACTION {||Help22(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Помощь по режиму 2.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('Перейти на следующую запись') @0.8, 44 DCGROUP oGroup1 CAPTION L('Пояснения по смыслу частных и интегральных критериев') SIZE 86.5, 3.6 p=2 @ 1.5, P DCPUSHBUTTON ; CAPTION L('Частн.крит. 7 моделей знаний') ; SIZE LEN(L('Частн.крит. 7 моделей знаний'))-1, 1 ; PARENT oGroup1 ; ACTION {||Help33()} p=p+LEN(L('Частн.крит. 7 моделей знаний'))+1 @ 1.5, p DCPUSHBUTTON ; CAPTION L('Инт.крит.: "Сумма знаний"') ; PARENT oGroup1 ; SIZE LEN(L('Инт.крит.: "Сумма знаний"'))-1, 1 ; ACTION {||Help4_1_3_1d()} p=p+LEN(L('Инт.крит.: "Сумма знаний"'))+1 @ 1.5, p DCPUSHBUTTON ; CAPTION L('Инт.крит.: "Резонанс знаний"') ; SIZE LEN(L('Инт.крит.: "Резонанс знаний"'))-1, 1 ; PARENT oGroup1 ; ACTION {||Help4131c()} /* ----- Create browse-1 ----- */ bScale := {|| Rsp_it1->(DC_SetScope(0,Int_krit->KOD_IntKr)), ; Rsp_it1->(DC_SetScope(1,Int_krit->KOD_IntKr)), ; Rsp_it1->(DC_DbGoTop()), ; oBrowRsoIt:refreshAll() } @ 1, 0 DCBROWSE oBrowIntKr ALIAS 'Int_krit' SIZE 41.5,3.4 ; PRESENTATION LC_BrowPres() ; // Только просмотр БД NOSOFTTRACK ; SCOPE ; NOHSCROLL NOVSCROLL ; // Убрать горизонтальную и вертикальную полосы прокрутки ITEMMARKED {|| Eval(bScale), ; DC_GetRefresh(GetList,, ; DCGETREFRESH_TYPE_EXCLUDE,{GETLIST_BROWSE}) } DCSETPARENT oBrowIntKr DCBROWSECOL FIELD Int_krit->KOD_IntKr HEADER L('Код' ) PARENT oBrowIntKr WIDTH 1 DCBROWSECOL FIELD Int_krit->NAME_IntKr HEADER L('Интегральный критерий') PARENT oBrowIntKr WIDTH 21 /* ----- Create browse-2 ----- */ DCSETPARENT TO @ 5, 0 DCBROWSE oBrowRsoIt ALIAS 'Rsp_it1' SIZE 132.7,22 ; PRESENTATION LC_BrowPres() ; // Только просмотр БД NOSOFTTRACK ; HEADLINES 4 ; // Кол-во строк в заголовке (перенос строки - ";") SCOPE ; ITEMMARKED bItems // MAX - красным, MIN - синим *DCSETFONT TO "9.Courier" DCSETPARENT oBrowRsoIt DCBROWSECOL DATA {|x|x:=Rsp_it1->Kod_Obj, IIF(Empty(x),'',Str(x,19))} HEADER L("Код;объекта;распозн.;выборки" ) PARENT oBrowRsoIt WIDTH 6 DCBROWSECOL FIELD Rsp_it1->Name_Obj HEADER L("Наименование объекта;распознаваемой выборки") PARENT oBrowRsoIt WIDTH 14 DCBROWSECOL DATA {|x|x:=Rsp_it1->Kod_ClsA, IIF(Empty(x),'',Str(x,19))} HEADER L("Код;класса;с MAX;ур.сход." ) PARENT oBrowRsoIt WIDTH 6 COLOR GRA_CLR_RED DCBROWSECOL FIELD Rsp_it1->Name_ClsA HEADER L("Наименование класса;с MAX уровнем сходства" ) PARENT oBrowRsoIt WIDTH 16 COLOR GRA_CLR_RED DCBROWSECOL DATA {|x|x:=Rsp_it1->Ur_SxodA, IIF(Empty(x),'',Str(x,8,3))} HEADER L("MAX;уровень;сходства" ) PARENT oBrowRsoIt COLOR GRA_CLR_RED FONT "9.Courier" DCBROWSECOL DATA {|x|x:=Rsp_it1->Kod_ClsB, IIF(Empty(x),'',Str(x,19))} HEADER L("Код;класса;с MIN;ур.сход." ) PARENT oBrowRsoIt WIDTH 6 COLOR GRA_CLR_BLACK DCBROWSECOL FIELD Rsp_it1->Name_ClsB HEADER L("Наименование класса;с MIN уровнем сходства" ) PARENT oBrowRsoIt WIDTH 16 COLOR GRA_CLR_BLACK DCBROWSECOL DATA {|x|x:=Rsp_it1->Ur_SxodB, IIF(Empty(x),'',Str(x,8,3))} HEADER L("MIN;уровень;сходства" ) PARENT oBrowRsoIt COLOR GRA_CLR_BLACK FONT "9.Courier" DCBROWSECOL DATA {|x|x:=Rsp_it1->Dost, IIF(Empty(x),'',Str(x,8,3))} HEADER L("Досто-;вер-;ность" ) PARENT oBrowRsoIt FONT "9.Courier" DCBROWSECOL FIELD Rsp_it1->Date HEADER L("Дата" ) PARENT oBrowRsoIt WIDTH 5 DCBROWSECOL FIELD Rsp_it1->Time HEADER L("Время" ) PARENT oBrowRsoIt WIDTH 4 DCGETOPTIONS SAYFONT '10.Helv Bold' TABSTOP AUTORESIZE cTitle = L('4.1.3.3. Итоговая наглядная форма результатов распознавания: "Объект-класс". Текущая модель: "')+UPPER(Ar_Model[M_CurrInf])+'"' DCREAD GUI ; FIT ; OPTIONS GetOptions ; MODAL ; TITLE cTitle ; EVAL {|o|SetAppFocus(oBrowIntKr:GetColumn(1))} ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ************************************************************************************************************* ******** 4.1.3.4. Отображение итоговых результатов распознавания в наглядной форме: отображаются пары: ******** "Класс-объект" у которых наибольшее сходство по двум интегральным критериям сходства: ******** "Семантический резонанс знаний" и "Сумма знаний". Приводится информация о фактической ******** принадлежности объекта к классу. ************************************************************************************************************* FUNCTION F4_1_3_4() LOCAL GetList := {}, GetOptions, oBrowIntKr, oBrowRsoIt, bApp, bItems Running(.T.) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF ApplChange("4.1.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("Rsp_it.dbf") // БД подробных сжатых результатов распознавания: Rsp_it.dbf LB_Warning(L("Необходимо выполнить распознавание в режиме 4.1.2 или 3.5 !!!")) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW Running(.F.) RETURN NIL 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("Информационное сообщение")) ELSE * Mess = L("В этой модели # распознавание уже проводилось ранее") // Написать КОГДА было проведено * Mess = STRTRAN(Mess, "#", Ar_Model[M_RaspInf]) * LB_Warning(Mess, L("Информационное сообщение")) ENDIF ELSE LB_Warning(L("Необходимо выполнить распознавание в режиме 4.1.2 или 3.5 !!!"), L("Информационное сообщение")) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW Running(.F.) RETURN NIL ENDIF // Создать БД интегральных критериев CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций ********* Создать БД Appls.dbf и ее индексные массивы aStructure := { { "Kod_IntKr" , "N", 8, 0 }, ; { "Name_IntKr", "C",30, 0 } } DbCreate( "Int_krit.dbf", aStructure ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Int_krit EXCLUSIVE NEW SELECT Int_krit APPEND BLANK REPLACE Kod_IntKr WITH 1 REPLACE Name_IntKr WITH "Семантический резонанс знаний" APPEND BLANK REPLACE Kod_IntKr WITH 2 REPLACE Name_IntKr WITH "Сумма знаний" dbeSetDefault('DBFNTX') CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Int_krit INDEX ON Kod_IntKr TO Int_krit CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rsp_it2 NEW INDEX ON Int_Krit TO Rsp_it2 CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Int_krit INDEX Int_krit EXCLUSIVE NEW USE Rsp_it2 INDEX Rsp_it2 EXCLUSIVE NEW SET FILTER TO Kod_ObjA > 0 .AND. Kod_ObjB > 0 /* ----- Create ToolBar 2 ----- */ @ 27.2, 1 DCTOOLBAR oToolBar SIZE 131, 1.5 K=1.18 DCADDBUTTON CAPTION L('Помощь') ; SIZE K+LEN(L("Помощь")) ; ACTION {||Help22(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Помощь по режиму 2.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('Перейти на следующую запись') @0.8, 44 DCGROUP oGroup1 CAPTION L('Пояснения по смыслу частных и интегральных критериев') SIZE 86.5, 3.6 p=2 @ 1.5, P DCPUSHBUTTON ; CAPTION L('Частн.крит. 7 моделей знаний') ; SIZE LEN(L('Частн.крит. 7 моделей знаний'))-1, 1 ; PARENT oGroup1 ; ACTION {||Help33()} p=p+LEN(L('Частн.крит. 7 моделей знаний'))+1 @ 1.5, p DCPUSHBUTTON ; CAPTION L('Инт.крит.: "Сумма знаний"') ; PARENT oGroup1 ; SIZE LEN(L('Инт.крит.: "Сумма знаний"'))-1, 1 ; ACTION {||Help4_1_3_1d()} p=p+LEN(L('Инт.крит.: "Сумма знаний"'))+1 @ 1.5, p DCPUSHBUTTON ; CAPTION L('Инт.крит.: "Резонанс знаний"') ; SIZE LEN(L('Инт.крит.: "Резонанс знаний"'))-1, 1 ; PARENT oGroup1 ; ACTION {||Help4131c()} /* ----- Create browse-1 ----- */ bScale := {|| Rsp_it2->(DC_SetScope(0,Int_krit->KOD_IntKr)), ; Rsp_it2->(DC_SetScope(1,Int_krit->KOD_IntKr)), ; Rsp_it2->(DC_DbGoTop()), ; oBrowRsoIt:refreshAll() } @ 1, 0 DCBROWSE oBrowIntKr ALIAS 'Int_krit' SIZE 41.5,3.4 ; PRESENTATION LC_BrowPres() ; // Только просмотр БД NOSOFTTRACK ; SCOPE ; NOHSCROLL NOVSCROLL ; // Убрать горизонтальную и вертикальную полосы прокрутки ITEMMARKED {|| Eval(bScale), ; DC_GetRefresh(GetList,, ; DCGETREFRESH_TYPE_EXCLUDE,{GETLIST_BROWSE}) } DCSETPARENT oBrowIntKr DCBROWSECOL FIELD Int_krit->KOD_IntKr HEADER L('Код' ) PARENT oBrowIntKr WIDTH 1 DCBROWSECOL FIELD Int_krit->NAME_IntKr HEADER L('Интегральный критерий') PARENT oBrowIntKr WIDTH 21 /* ----- Create browse-2 ----- */ DCSETPARENT TO @ 5, 0 DCBROWSE oBrowRsoIt ALIAS 'Rsp_it2' SIZE 132.7,22 ; PRESENTATION LC_BrowPres() ; // Только просмотр БД NOSOFTTRACK ; HEADLINES 4 ; // Кол-во строк в заголовке (перенос строки - ";") SCOPE ; ITEMMARKED bItems // MAX - красным, MIN - синим *DCSETFONT TO "9.Courier" DCSETPARENT oBrowRsoIt DCBROWSECOL DATA {|x|x:=Rsp_it2->Kod_cls, IIF(Empty(x),'',Str(x,19))} HEADER L("Код;класса" ) PARENT oBrowRsoIt WIDTH 6 DCBROWSECOL FIELD Rsp_it2->Name_Cls HEADER L("Наименование класса" ) PARENT oBrowRsoIt WIDTH 14 DCBROWSECOL DATA {|x|x:=Rsp_it2->Kod_ObjA, IIF(Empty(x),'',Str(x,19))} HEADER L("Код;объекта;с MAX;ур.сход." ) PARENT oBrowRsoIt WIDTH 6 COLOR GRA_CLR_RED DCBROWSECOL FIELD Rsp_it2->Name_ObjA HEADER L("Наименование объекта;с MAX уровнем сходства") PARENT oBrowRsoIt WIDTH 16 COLOR GRA_CLR_RED DCBROWSECOL DATA {|x|x:=Rsp_it2->Ur_SxodA, IIF(Empty(x),'',Str(x,8,3))} HEADER L("MAX;уровень;сходства" ) PARENT oBrowRsoIt COLOR GRA_CLR_RED FONT "9.Courier" DCBROWSECOL DATA {|x|x:=Rsp_it2->Kod_ObjB, IIF(Empty(x),'',Str(x,19))} HEADER L("Код;объекта;с MIN;ур.сход." ) PARENT oBrowRsoIt WIDTH 6 COLOR GRA_CLR_BLACK DCBROWSECOL FIELD Rsp_it2->Name_ObjB HEADER L("Наименование объекта;с MIN уровнем сходства") PARENT oBrowRsoIt WIDTH 16 COLOR GRA_CLR_BLACK DCBROWSECOL DATA {|x|x:=Rsp_it2->Ur_SxodB, IIF(Empty(x),'',Str(x,8,3))} HEADER L("MIN;уровень;сходства" ) PARENT oBrowRsoIt COLOR GRA_CLR_BLACK FONT "9.Courier" DCBROWSECOL DATA {|x|x:=Rsp_it2->Dost, IIF(Empty(x),'',Str(x,8,3))} HEADER L("Досто-;вер-;ность" ) PARENT oBrowRsoIt FONT "9.Courier" DCBROWSECOL FIELD Rsp_it2->Date HEADER L("Дата" ) PARENT oBrowRsoIt WIDTH 5 DCBROWSECOL FIELD Rsp_it2->Time HEADER L("Время" ) PARENT oBrowRsoIt WIDTH 4 DCGETOPTIONS SAYFONT '10.Helv Bold' TABSTOP AUTORESIZE cTitle = L('4.1.3.4. Итоговая наглядная форма результатов распознавания: "Класс-объект". Текущая модель: "')+UPPER(Ar_Model[M_CurrInf])+'"' DCREAD GUI ; FIT ; OPTIONS GetOptions ; MODAL ; TITLE cTitle ; EVAL {|o|SetAppFocus(oBrowIntKr:GetColumn(1))} ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ************************************************************************************************************* ******** 4.1.3.5. В подробной сжатой (числовой) форме приводится информация об уровне сходства всех объектов ******** со всеми классами по двум интегральным критериям сходства: "Семантический резонанс знаний" ******** и "Сумма знаний", а также о фактической принадлежности объекта к классу. ************************************************************************************************************* FUNCTION F4_1_3_5() LOCAL GetList := {}, GetOptions, oBrowIntKr, oBrowRsoIt, bApp, bItems Running(.T.) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF ApplChange("4.1.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("Rsp_it.dbf") // БД подробных сжатых результатов распознавания: Rsp_it.dbf LB_Warning(L("Необходимо выполнить распознавание в режиме 4.1.2 или 3.5 !!!")) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW Running(.F.) RETURN NIL 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("Информационное сообщение")) ELSE * Mess = L("В этой модели # распознавание уже проводилось ранее") // Написать КОГДА было проведено * Mess = STRTRAN(Mess, "#", Ar_Model[M_RaspInf]) * LB_Warning(Mess, L("Информационное сообщение")) ENDIF ELSE LB_Warning(L("Необходимо выполнить распознавание в режиме 4.1.2 или 3.5 !!!"), L("Информационное сообщение")) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW Running(.F.) RETURN NIL ENDIF // Создать БД интегральных критериев CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций ********* Создать БД Appls.dbf и ее индексные массивы aStructure := { { "Kod_IntKr" , "N", 8, 0 }, ; { "Name_IntKr", "C",30, 0 } } DbCreate( "Int_krit.dbf", aStructure ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Int_krit EXCLUSIVE NEW SELECT Int_krit APPEND BLANK REPLACE Kod_IntKr WITH 1 REPLACE Name_IntKr WITH "Семантический резонанс знаний" APPEND BLANK REPLACE Kod_IntKr WITH 2 REPLACE Name_IntKr WITH "Сумма знаний" dbeSetDefault('DBFNTX') CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Int_krit INDEX ON Kod_IntKr TO Int_krit CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rsp_it NEW INDEX ON Int_Krit TO Rsp_it CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() SET FILTER TO Abs > 0 USE Int_krit INDEX Int_krit EXCLUSIVE NEW USE Rsp_it INDEX Rsp_it EXCLUSIVE NEW **** Массив для исключения показа столбцов классов, для которых уровень сходства = -99999999 aLoc := {} SELECT Rsp_it DBGOBOTTOM() FOR j=1 TO FCOUNT() AADD(aLoc, FIELDGET(j)) NEXT /* ----- Create ToolBar 2 ----- */ @ 27.2, 1 DCTOOLBAR oToolBar SIZE 131, 1.5 K=1.18 DCADDBUTTON CAPTION L('Помощь') ; SIZE K+LEN(L("Помощь")) ; ACTION {||Help22(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Помощь по режиму 2.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('Перейти на следующую запись') @0.8, 44 DCGROUP oGroup1 CAPTION L('Пояснения по смыслу частных и интегральных критериев') SIZE 84.5, 3.6 p=2 @ 1.5, P DCPUSHBUTTON ; CAPTION L('Частн.крит. 7 моделей знаний') ; SIZE LEN(L('Частн.крит. 7 моделей знаний'))-1, 1 ; PARENT oGroup1 ; ACTION {||Help33()} p=p+LEN(L('Частн.крит. 7 моделей знаний')) @ 1.5, p DCPUSHBUTTON ; CAPTION L('Инт.крит.: "Сумма знаний"') ; PARENT oGroup1 ; SIZE LEN(L('Инт.крит.: "Сумма знаний"'))-1, 1 ; ACTION {||Help4_1_3_1d()} p=p+LEN(L('Инт.крит.: "Сумма знаний"')) @ 1.5, p DCPUSHBUTTON ; CAPTION L('Инт.крит.: "Резонанс знаний"') ; SIZE LEN(L('Инт.крит.: "Резонанс знаний"'))-1, 1 ; PARENT oGroup1 ; ACTION {||Help4131c()} /* ----- Create browse-1 ----- */ bScale := {|| Rsp_it->(DC_SetScope(0,Int_krit->KOD_IntKr)), ; Rsp_it->(DC_SetScope(1,Int_krit->KOD_IntKr)), ; Rsp_it->(DC_DbGoTop()), ; oBrowRsoIt:refreshAll() } @ 1, 0 DCBROWSE oBrowIntKr ALIAS 'Int_krit' SIZE 41.5,3.4 ; PRESENTATION LC_BrowPres() ; // Только просмотр БД NOSOFTTRACK ; SCOPE ; NOHSCROLL NOVSCROLL ; // Убрать горизонтальную и вертикальную полосы прокрутки ITEMMARKED {|| Eval(bScale), ; DC_GetRefresh(GetList,, ; DCGETREFRESH_TYPE_EXCLUDE,{GETLIST_BROWSE}) } DCSETPARENT oBrowIntKr DCBROWSECOL FIELD Int_krit->KOD_IntKr HEADER L('Код' ) PARENT oBrowIntKr WIDTH 1 DCBROWSECOL FIELD Int_krit->NAME_IntKr HEADER L('Интегральный критерий') PARENT oBrowIntKr WIDTH 21 /* ----- Create browse-2 ----- */ *SET TAG TO COMMAND aSaveRspIt := DC_DataSave() // Сохранение вычислительной среды (открытые и текущие БД и индексы) PRIVATE aHeadName[8+N_Cls] aHeadName[1] = L("Код;объекта;распозн.;выборки" ) aHeadName[2] = L("Наименование объекта;распознаваемой выборки") aHeadName[3] = L("MAX;уровень;сходства" ) aHeadName[4] = L("Код;класса;с MAX;ур.сход." ) aHeadName[5] = L("MIN;уровень;сходства" ) aHeadName[6] = L("Код;класса;с MIN;ур.сход." ) aHeadName[7] = L("Досто-;вер-;ность" ) SELECT Classes // 3. Заполнять строки заголовков целыми словами до тех пор, пока не превышена макс.ширина заголовка SELECT Classes DL = 12 // Ширина заголовка в кол-ве символов Max_HeadLines = -999999999 FOR j=1 TO N_Cls DBGOTO(j) M_NameCls = ALLTRIM(Name_cls) 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[7+j] = "" FOR s=1 TO LEN(aHeadString) aHeadName[7+j] = aHeadName[7+j] + aHeadString[s] NEXT Max_HeadLines = MAX(Max_HeadLines,LEN(aHeadString)) // Определение максимального количества строк в заголовке NEXT *aHeadName[8+N_cls] = "Инт.;крит." PRIVATE aFieldName[8+N_Cls] SELECT Rsp_it FOR j=1 TO 7+N_Cls aFieldName[j] = "Rsp_it->"+ALLTRIM(FIELDNAME(j)) NEXT *DC_DebugQout( aFieldName ) DC_DataRest( aSaveRspIt ) // Восстановление вычислительной среды (открытые и текущие БД и индексы) DCSETPARENT TO @ 5, 0 DCBROWSE oBrowRsoIt ALIAS 'Rsp_it' SIZE 132,22 ; PRESENTATION LC_BrowPres() ; // Только просмотр БД NOSOFTTRACK ; HEADLINES Max_HeadLines ; // Кол-во строк в заголовке (перенос строки - ";") SCOPE ; ITEMMARKED bItems // MAX - красным, MIN - синим *DCSETFONT TO "9.Courier" DCSETPARENT oBrowRsoIt DCBROWSECOL DATA {|x|x:=Rsp_it->Kod_Obj, IIF(Empty(x),'',Str(x,19))} HEADER L("Код;объекта;распозн.;выборки" ) PARENT oBrowRsoIt WIDTH 8 DCBROWSECOL FIELD Rsp_it->Name_Obj HEADER L("Наименование объекта;распознаваемой выборки") PARENT oBrowRsoIt WIDTH 24 DCBROWSECOL DATA {|x|x:=Rsp_it->Max_Value,IIF(Empty(x),'',Str(x,8,3))} HEADER L("MAX;уровень;сходства" ) PARENT oBrowRsoIt WIDTH 8 COLOR GRA_CLR_RED FONT "9.Courier" DCBROWSECOL DATA {|x|x:=Rsp_it->KodC_MaxV,IIF(Empty(x),'',Str(x,19))} HEADER L("Код;класса;с MAX;ур.сход." ) PARENT oBrowRsoIt WIDTH 8 COLOR GRA_CLR_RED DCBROWSECOL DATA {|x|x:=Rsp_it->Min_Value,IIF(Empty(x),'',Str(x,8,3))} HEADER L("MIN;уровень;сходства" ) PARENT oBrowRsoIt WIDTH 8 COLOR GRA_CLR_BLACK FONT "9.Courier" DCBROWSECOL DATA {|x|x:=Rsp_it->KodC_MinV,IIF(Empty(x),'',Str(x,19))} HEADER L("Код;класса;с MIN;ур.сход." ) PARENT oBrowRsoIt WIDTH 8 COLOR GRA_CLR_BLACK DCBROWSECOL DATA {|x|x:=Rsp_it->Dost, IIF(Empty(x),'',Str(x,8,3))} HEADER L("Досто-;вер-;ность" ) PARENT oBrowRsoIt WIDTH 8 FONT "9.Courier" *** Подарок от Роджера FOR j=1 TO N_Cls IF aLoc[7+j] <> -99999999 .AND. aLoc[7+j] <> 0 DCBROWSECOL DATA FieldAnchor(7+j,DL,3) HEADER aHeadName[7+j] PARENT oBrowRsoIt COLOR ColorBlock(7+j) FONT "9.Courier" * DCBROWSECOL DATA FieldAnchor(7+j,DL,3) HEADER aHeadName[7+j] PARENT oBrowRsoIt COLOR ColorBlock(7+j) FONT FontBlock(j) ENDIF NEXT DCGETOPTIONS SAYFONT '10.Helv Bold' TABSTOP AUTORESIZE cTitle = L('4.1.3.5. Подробная сжатая форма результатов распознавания. Текущая модель: "')+UPPER(Ar_Model[M_CurrInf])+'"' DCREAD GUI ; FIT ; OPTIONS GetOptions ; MODAL ; TITLE cTitle ; EVAL {|o|SetAppFocus(oBrowIntKr:GetColumn(1))} ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ******* Подарок от Роджера (исходный вариант) *FUNCTION FieldAnchor( j ) *RETURN {|x|x:=FIELDGET(j), IIF(Empty(x),'',Str(x,8,3))} ********************************************************************************************************************************* ****** Подарок от Роджера (вариант с заданием размера поля и кол-ва десятичных знаков, в т.ч. если их 0 - то выводится как целое) ********************************************************************************************************************************* FUNCTION FieldAnchor( j , mFSize, mFDeci) DO CASE CASE mFDeci > 0 RETURN {|x|x:=FIELDGET(j), IIF(Empty(x),'',Str(x,mFSize,mFDeci))} CASE mFDeci = 0 RETURN {|x|x:=FIELDGET(j), IIF(Empty(x),'',Str(x,mFSize))} ENDCASE RETURN NIL ****** Подарок от Роджера FUNCTION FldAnchINT( j ) * Если модель = 1, то 9,1, иначе 9,3 *StrFile(ALLTRIM(STR(nRadioModel)), '_Calc_model_2nd_level.txt') *mModel_2nd_level = VAL(FileStr('_Calc_model_2nd_level.txt')) // = 1 - создавать только базовые модели, иначе - создавать модели 2-го или 3-го уровней *RETURN {|x|x:=FIELDGET(j), IIF(Empty(x),'',Str(x,8))} RETURN {|x|x:=FIELDGET(j), IIF(Empty(x),'',Str(x,10,3))} ******* Кодовый блок для динамического задания цвета ячейки по ее значению FUNCTION ColorBlock( j ) RETURN {|| iif(FIELDGET(j)>0,{GRA_CLR_RED,nil},iif(FIELDGET(j)=0,{GRA_CLR_WHITE,nil},{GRA_CLR_BLACK,nil})) } ******* Кодовый блок для динамического задания шрифта ячейки по ее значению (не работает) ##################### FUNCTION FontBlock( j ) RETURN {|| iif(FIELDGET(7+j)=Max_Value,"9.Courier Bold","9.Courier") } ******************************************************************************************** ******** 5.7. Переиндексация всех баз данных ******************************************************************************************** FUNCTION F5_7() LOCAL GetList[0], lOk, aSay[30], Mess97, Mess98, Mess99, oDialog // Массив сообщений отображаемых стадий исполнения (до 30 на экране) Running(.T.) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF ApplChange("5.7()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF ******************************************************************************************** // Задание максимальной величины параметра Time Wsego = 12 // Столько 1, сколько БД // Отображение стадии исполнения. Будет написано прямо в окне Progress-bar @ 0,0 DCGROUP oGroup1 CAPTION L('Стадии исполнения процесса') FONT "6.Helv" SIZE 105,15.5 ; PARENT oTabPage1 @17,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.HelvBold" // Заголовок @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 2] FONT "10.Helv" // 1 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 3] FONT "10.Helv" // 2 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 4] FONT "10.Helv" // 3 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 5] FONT "10.HelvBold" // Заголовок @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 6] FONT "10.Helv" // 4 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 7] FONT "10.Helv" // 5 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 8] FONT "10.Helv" // 6 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 9] FONT "10.Helv" // 7 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[10] FONT "10.Helv" // 8 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[11] FONT "10.Helv" // 9 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[12] FONT "10.Helv" // 10 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[13] FONT "10.Helv" // 11 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[14] FONT "10.Helv" // 12 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('5.7. Переиндексация всех баз данных') ; 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('ПЕРЕИНДЕКСАЦИЯ ОБЩЕСИСТЕМНЫХ БАЗ ДАННЫХ:')) DIRCHANGE(Disk_dir) aSay[2]:SetCaption(L('1/12: Переиндексация общесистемной БД приложений: Appls.dbf')) GenNtxAppls() lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) aSay[2]:SetCaption(aSay[2]:caption+L(' - Готово ')) aSay[3]:SetCaption(L('2/12: Переиндексация общесистемной БД пользователей: Users.dbf')) GenNtxUsers() lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) aSay[3]:SetCaption(aSay[3]:caption+L(' - Готово ')) aSay[4]:SetCaption(L('3/12: Переиндексация общесистемной БД путей на группы приложений: PathGrAp.dbf')) GenNtxPaths() lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) aSay[4]:SetCaption(aSay[4]:caption+L(' - Готово ')) aSay[1]:SetCaption(aSay[1]:caption+L(' - Готово ')) aSay[5]:SetCaption(L('ПЕРЕИНДЕКСАЦИЯ БАЗ ДАННЫХ ТЕКУЩЕГО ПРИЛОЖЕНИЯ:')) IF ApplChange("") // Перейти в папку выбранного приложения или выйти из системы LB_Warning(L("Необходимо задать (выбрать) хотя бы одно текущее приложение !!!")) Running(.F.) RETURN NIL ENDIF aSay[6]:SetCaption(L('4/12: Переиндексация БД классов: Classes.dbf')) GenNtxClass() // Классификационные шкалы и градации GenNtxClSc() GenNtxGrClSc() lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) aSay[6]:SetCaption(aSay[6]:caption+L(' - Готово ')) aSay[7]:SetCaption(L('5/12: Переиндексация БД описательных шкал: Opis_Sc.dbf')) GenNtxOpSc() // Описательные шкалы lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) aSay[7]:SetCaption(aSay[7]:caption+L(' - Готово ')) aSay[8]:SetCaption(L('6/12: Переиндексация БД градаций описательных шкал: Gr_OpSc.dbf')) GenNtxGrOpSc() // Градации описательных шкал GenNtxAttr() lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) aSay[8]:SetCaption(aSay[8]:caption+L(' - Готово ')) aSay[9]:SetCaption(L('7/12: Переиндексация БД заголовков объектов обучающей выборки: Obi_Zag.dbf')) GenNtxObiZag() // Заголовки объектов обучающей выборки lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) aSay[9]:SetCaption(aSay[9]:caption+L(' - Готово ')) aSay[10]:SetCaption(L('8/12: Переиндексация БД кодов классов объектов обучающей выборки: ObI_Kcl.dbf')) GenNtxObiKcl() // Коды классов объектов обучающей выборки lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) aSay[10]:SetCaption(aSay[10]:caption+L(' - Готово ')) aSay[11]:SetCaption(L('9/12: Переиндексация БД кодов признаков объектов обучающей выборки: Obi_Kpr.dbf')) GenNtxObiKpr() // Коды признаков объектов обучающей выборки lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) aSay[11]:SetCaption(aSay[11]:caption+L(' - Готово ')) aSay[12]:SetCaption(L('10/12: Переиндексация БД заголовков объектов распознаваемой выборки: Rso_Zag.dbf')) GenNtxRsoZag() // Заголовки объектов распознаваемой выборки lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) aSay[12]:SetCaption(aSay[12]:caption+L(' - Готово ')) aSay[13]:SetCaption(L('11/12: Переиндексация БД кодов классов объектов распознаваемой выборки: Rso_Kcl.dbf')) GenNtxRsoKcl() // Коды классов объектов распознаваемой выборки lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) aSay[13]:SetCaption(aSay[13]:caption+L(' - Готово ')) aSay[14]:SetCaption(L('12/12: Переиндексация БД кодов признаков объектов распознаваемой выборки: Rso_Kpr.dbf')) GenNtxRsoKpr() // Коды признаков объектов распознаваемой выборки lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) aSay[14]:SetCaption(aSay[14]:caption+L(' - Готово ')) aSay[5]:SetCaption(aSay[5]:caption+L(' - Готово ')) Running(.T.) // Чтобы не могли запустить какой-нибудь режим пока висит окно окончания работы 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() ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ******************************************************************************************** // This function loads a CSV file into a work area. // The top line of the CSV file must contain the field names that match the work area. FUNCTION DC_CSV2WorkArea( cCsvFileName ) LOCAL nHandle, cLine, aTokens, aFields, lStatus, cFieldName, aStru, ; oRecord, cValue, i, nFound, nFieldType nHandle := DC_TxtOpen( cCsvFileName ) IF nHandle <= 0 RETURN .f. ENDIF oRecord := DC_DbRecord():new() cLine := DC_TxtLine( nHandle ) aFields := DC_TokenArray( cLine, ',' ) aStru := dbStruct() *dc_dbcreate( 'express2.dbf', aStru ) *DbCreate( 'express2.dbf', aStru ) USE express2 EXCLUSIVE NEW DC_TxtSkip(nHandle,1) DO WHILE !DC_TxtEof(nHandle) cLine := DC_TxtLine(nHandle) aTokens := DC_TokenArray(cLine,',') dbGoTo(0) DC_DbScatter(oRecord) FOR i := 1 TO Len(aFields) IF !Empty(cFieldName := Upper(Alltrim(aFields[i]))) .AND. Len(aTokens) == Len(aFields) IF IsFieldVar(cFieldName) nFound := AScan(aStru,{|a|Upper(Alltrim(a[1]))==cFieldName}) cValue := Alltrim(aTokens[i]) IF nFound > 0 nFieldType := aStru[nFound,2] IF nFieldType $ 'CM' oRecord:&(cFieldName) := cValue ELSEIF nFieldType == 'N' oRecord:&(cFieldName) := Val(cValue) ELSEIF nFieldType == 'L' oRecord:&(cFieldName) := ' ' + Upper(Alltrim(cValue)) + ' ' $ ' Y YES .T. TRUE T ' ELSEIF nFieldType == 'D' oRecord:&(cFieldName) := CtoD(cValue) ENDIF ENDIF ENDIF ENDIF NEXT DC_DbGather(oRecord,.t.) DC_TxtSkip(nHandle,1) ENDDO DC_TxtClose( nHandle ) RETURN .t. *********************************************************************************************************************** ******** 4.2.1. Информационные портреты классов ################ *********************************************************************************************************************** FUNCTION F4_2_1() LOCAL GetList := {}, 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.1()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF IF .NOT. FILE("Classes.dbf") // БД градаций класс.шкал: Classes.dbf LB_Warning(L("Необходимо создать базу данных классов !!!")) 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 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") * ########################################################################### // Открытие текстовых баз данных ******************************************** *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 * ########################################################################### ************************************************************* // Сформировать пустую БД InfPortCls, как часть БД Attributes aStr := { { "Kod_atr" , "N", 15, 0 }, ; { "Name_atr" , "C", mLenNameMax, 0 }, ; { "Znach" , "N", 19, 7 }, ; { "Kod_OpSc" , "N", 15, 0 }, ; { "Fltr_Wind", "C", 1, 0 } } // Для фильтра "Вписать в окно" DbCreate( "InfPortCls", aStr ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW USE InfPortCls EXCLUSIVE NEW ****** Сделать и вывести инф.портрет 1-го класса SELECT Classes DBGOTOP() @ 0,0 DCSAY {|| MessIPC } OBJECT oSay1 SAYSIZE 133 FONT "9.HelvBold" // Наименование инф.портрета InfPortCls(6) /* ----- Create ToolBar ----- */ @ 28.5, 0 DCTOOLBAR oToolBar SIZE 133, 1.5 DCADDBUTTON CAPTION L('Помощь') ; SIZE LEN(L("Помощь"))+2 ; ACTION {||Help421(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Помощь по режиму 4.2.1') DCADDBUTTON CAPTION Ar_Model[1] ; SIZE LEN(Ar_Model[1])+2 ; ACTION {||InfPortCls(1), DC_GetRefresh(GetList)}; PARENT oToolBar ; TOOLTIP L('Генерация информационного портрета в модели: ')+Ar_Model[1] DCADDBUTTON CAPTION Ar_Model[2] ; SIZE LEN(Ar_Model[2])+1 ; ACTION {||InfPortCls(2), DC_GetRefresh(GetList)}; PARENT oToolBar ; TOOLTIP L('Генерация информационного портрета в модели: ')+Ar_Model[2] DCADDBUTTON CAPTION Ar_Model[3] ; SIZE LEN(Ar_Model[3])+1 ; ACTION {||InfPortCls(3), DC_GetRefresh(GetList)}; PARENT oToolBar ; TOOLTIP L('Генерация информационного портрета в модели: ')+Ar_Model[3] DCADDBUTTON CAPTION Ar_Model[4] ; SIZE LEN(Ar_Model[4])+1 ; ACTION {||InfPortCls(4), DC_GetRefresh(GetList)}; PARENT oToolBar ; TOOLTIP L('Генерация информационного портрета в модели: ')+Ar_Model[4] DCADDBUTTON CAPTION Ar_Model[5] ; SIZE LEN(Ar_Model[5])+1 ; ACTION {||InfPortCls(5), DC_GetRefresh(GetList)}; PARENT oToolBar ; TOOLTIP L('Генерация информационного портрета в модели: ')+Ar_Model[5] DCADDBUTTON CAPTION Ar_Model[6] ; SIZE LEN(Ar_Model[6])+1 ; ACTION {||InfPortCls(6), DC_GetRefresh(GetList)}; PARENT oToolBar ; TOOLTIP L('Генерация информационного портрета в модели: ')+Ar_Model[6] DCADDBUTTON CAPTION Ar_Model[7] ; SIZE LEN(Ar_Model[7])+1 ; ACTION {||InfPortCls(7), DC_GetRefresh(GetList)}; PARENT oToolBar ; TOOLTIP L('Генерация информационного портрета в модели: ')+Ar_Model[7] DCADDBUTTON CAPTION Ar_Model[8] ; SIZE LEN(Ar_Model[8])+1 ; ACTION {||InfPortCls(8), DC_GetRefresh(GetList)}; PARENT oToolBar ; TOOLTIP L('Генерация информационного портрета в модели: ')+Ar_Model[8] DCADDBUTTON CAPTION Ar_Model[9] ; SIZE LEN(Ar_Model[9])+1 ; ACTION {||InfPortCls(9), DC_GetRefresh(GetList)}; PARENT oToolBar ; TOOLTIP L('Генерация информационного портрета в модели: ')+Ar_Model[9] DCADDBUTTON CAPTION Ar_Model[10] ; SIZE LEN(Ar_Model[10])+1 ; ACTION {||InfPortCls(10), DC_GetRefresh(GetList)}; PARENT oToolBar ; TOOLTIP L('Генерация информационного портрета в модели: ')+Ar_Model[10] DCADDBUTTON CAPTION L('MS Excel') ; SIZE LEN(L("MS Excel"))+1 ; ACTION {||Help421(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Экспорт инф.портрета в MS Excel') DCADDBUTTON CAPTION L('ВКЛ.фильтр по фактору') ; SIZE LEN(L("ВКЛ.фильтр по фактору"))-2 ; ACTION {||FltrOn421(InfPortCls->Kod_OpSc), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Включить фильтр по фактору') DCADDBUTTON CAPTION L('ВЫКЛ.фильтр по фактору') ; SIZE LEN(L("ВЫКЛ.фильтр по фактору"))-2 ; ACTION {||FltrOff421(InfPortCls->Kod_OpSc), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Выключить фильтр по фактору') DCADDBUTTON CAPTION L('Вписать в окно') ; SIZE LEN(L("Вписать в окно"))-1 ; ACTION {||WindOn421(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Вписать информационный портрет в окно') DCADDBUTTON CAPTION L('Показать ВСЕ') ; SIZE LEN(L("Показать ВСЕ")) ; ACTION {||WindOff421(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Показать все записи информационного портрета в окне') @ 0,0 DCSAY {|| MessIPC } OBJECT oSay1 SAYSIZE 133 FONT "9.HelvBold" // Наименование инф.портрета /* ----- Create browse Classes ----- */ 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 @ 1, 0 DCBROWSE oBrowse ALIAS 'Classes' SIZE 48.8,27 ; PRESENTATION aPres ; COLOR {||IIF(2*INT(Classes->Kod_cls/2)==Classes->Kod_cls,nil,{nil,GraMakeRGBColor({230,252,213})})} // Вывод строки цветом RGB 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 InfPortCls ----- */ PRIVATE bColorBlockZn:={|| iif(InfPortCls->Znach>0,{GRA_CLR_RED,nil},iif(InfPortCls->Znach=0,{GRA_CLR_BLACK,nil},{GRA_CLR_BLUE,nil})) } // Клиффорд @ 1,51 DCBROWSE oBrowIpc ALIAS 'InfPortCls' SIZE 82,27 ; PRESENTATION aPres ; DCSETPARENT oBrowIpc DCBROWSECOL FIELD InfPortCls->KOD_atr HEADER L('Код' ) WIDTH 5 ; COLOR {||IIF(AT('SPECTRINTERV:',InfPortCls->NAME_atr)=0,nil,{nil,GraMakeRGBColor({VAL(SUBSTR(InfPortCls->NAME_atr, AT('{', InfPortCls->NAME_atr)+1, AT('{', InfPortCls->NAME_atr)+ 3-AT('{', InfPortCls->NAME_atr)+1+1)),VAL(SUBSTR(InfPortCls->NAME_atr, AT('{', InfPortCls->NAME_atr)+5, AT('{', InfPortCls->NAME_atr)+ 7-AT('{', InfPortCls->NAME_atr)+5+1)),VAL(SUBSTR(InfPortCls->NAME_atr, AT('{', InfPortCls->NAME_atr)+9, AT('{', InfPortCls->NAME_atr)+11-AT('{', InfPortCls->NAME_atr)+9+1))})})} // Вывод поля цветом RGB DCBROWSECOL FIELD InfPortCls->NAME_atr HEADER L('Наименование признака') WIDTH 37 DCBROWSECOL DATA {|x|x:=InfPortCls->Znach,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.1. Информационные портреты классов'); FIT ; 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 Help421() 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('Полные наименования стат.моделей и моделей знаний, отличающихся видом частных критериев: ')) AADD(aHelp, L('1. ABS - частный критерий: количество встреч сочетаний: "класс-признак" у объектов обуч.выборки. ')) AADD(aHelp, L('2. PRC1 - частный критерий: усл. вероятность i-го признака среди признаков объектов j-го класса. ')) AADD(aHelp, L('3. PRC2 - частный критерий: условная вероятность i-го признака у объектов j-го класса. ')) AADD(aHelp, L('4. INF1 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC1. ')) AADD(aHelp, L('5. INF2 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC2. ')) AADD(aHelp, L('6. INF3 - частный критерий: Xи-квадрат, разности между фактическими и ожидаемыми абс.частотами. ')) AADD(aHelp, L('7. INF4 - частный критерий: ROI (Return On Investment); вероятности из PRC1. ')) AADD(aHelp, L('8. INF5 - частный критерий: ROI (Return On Investment); вероятности из PRC2. ')) AADD(aHelp, L('9. INF6 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC1. ')) AADD(aHelp, L('10.INF7 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC2. ')) 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('последующего нажатия кнопки: [ВКЛ. фильтр по фактору] ')) 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 MODAL TITLE L('Помощь по режиму: "4.2.1. Информационные портреты классов". (C) Система "ЭЙДОС-X++"') RETURN NIL ************************************************************************************************** ******************************************************************************** ******** Генерация информационного портрета класса в модели: Ar_Model[M_CurrInf] ******** для класса, на котором стоит курсор в БД Classes.dbf FUNCTION InfPortCls(M_CurrInf) LOCAL Getlist := {}, oProgress, oDialog SELECT Attributes;N_Gos = RECCOUNT() SELECT Classes M_Recno = RECNO() M_KodCls = Kod_cls M_NameCls = Name_cls 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) // Наименование информационного портрета @ 4,5 DCPROGRESS oProgress SIZE 70,1.1 MAXCOUNT RecCount() COLOR GRA_CLR_RED PERCENT EVERY 100 DCREAD GUI TITLE L('4.2.1. Формирование информационного портрета класса') PARENT @oDialog FIT EXIT oDialog:show() nMax = N_Gos * 2 nTime = 0 // Заполнить БД InfPortCls записями с кодами и наименованиями признаков и их значимостью SELECT InfPortCls;ZAP // Сначала скопировать все записи в отсортированном порядке, // а потом, если N_Rec > 2*N_Str, удалить столько наименее значимых, чтобы осталось 2*N_Str 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" ) DC_GetProgress(oProgress,nMax,nMax) oDialog:Destroy() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW USE InfPortCls EXCLUSIVE NEW SELECT InfPortCls SET ORDER TO SET FILTER TO Znach <> 0 DBGOTOP() SELECT Classes * SET FILTER TO Abs+Int_inf > 0 DBGOTO(M_Recno) ReTURN NIL ******** Включить фильтр инф.портрета класса по описательной шкале FUNCTION FltrOn421(mKodOpSc) SELECT InfPortCls SET ORDER TO SET FILTER TO Kod_OpSc = mKodOpSc ReTURN NIL ******** Выключить фильтр инф.портрета класса по описательной шкале FUNCTION FltrOff421(mKodOpSc) SELECT InfPortCls SET ORDER TO SET FILTER TO ReTURN NIL ******** Вписать инф.портрет класса в окно FUNCTION WindOn421() SELECT InfPortCls N_Rec = RECCOUNT() * 23 = N_Rec - N_Del // 23 - число строк в окне N_Del = N_Rec - 23 SET ORDER TO SET FILTER TO DBGOTOP() DO WHILE .NOT. EOF() REPLACE Fltr_wind WITH "#" DBSKIP(1) ENDDO // Не показывать N_Del наименее значимых записей, так, чтобы заполнить окно SELECT InfPortCls INDEX ON STR(99999999.9999999-ABS(Znach),15, 7)+STR(Kod_atr,15) TO ("IPCW"+Ar_Model[M_CurrInf]) DBGOBOTTOM() N = 0 DO WHILE .NOT. BOF() .AND. (N+1) <= N_Del REPLACE Fltr_wind WITH " " ++N DBSKIP(-1) ENDDO SET ORDER TO SET FILTER TO Fltr_wind = "#" DBGOTOP() ReTURN NIL ******** Показать все записи инф.портрета FUNCTION WindOff421() SELECT InfPortCls SET ORDER TO;SET FILTER TO DBGOTOP() ReTURN NIL *********************************************************************************************************************** ******** 4.3.1. Информационные портреты признаков ############# *********************************************************************************************************************** FUNCTION F4_3_1() LOCAL GetList := {}, 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.1()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF IF .NOT. FILE("Attributes.dbf") // БД градаций опис.шкал: Attributes.dbf LB_Warning(L("Необходимо создать базу данных признаков !!!")) 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 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") * ########################################################################### // Открытие текстовых баз данных ******************************************** *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 * ########################################################################### // Сформировать пустую БД InfPortAtr, как часть БД Attributes aStr := { { "Kod_cls" , "N", 15, 0 }, ; { "Name_cls" , "C", mLenNameMax, 0 }, ; { "Znach" , "N", 19, 7 }, ; { "Kod_ClSc" , "N", 15, 0 }, ; { "Fltr_Wind", "C", 1, 0 } } // Для фильтра "Вписать в окно" DbCreate( "InfPortAtr", aStr ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW USE InfPortAtr EXCLUSIVE NEW ****** Сделать и вывести инф.портрет 1-го атрибута SELECT Attributes DBGOTOP() @ 0,0 DCSAY {|| MessIPA } OBJECT oSay1 SAYSIZE 133 FONT "9.HelvBold" // Наименование инф.портрета InfPortAtr(6) /* ----- Create ToolBar ----- */ @ 28.5, 0 DCTOOLBAR oToolBar SIZE 133, 1.5 DCADDBUTTON CAPTION L('Помощь') ; SIZE LEN(L("Помощь"))+2 ; ACTION {||Help431(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Помощь по режиму 4.2.1') DCADDBUTTON CAPTION Ar_Model[1] ; SIZE LEN(Ar_Model[1])+2 ; ACTION {||InfPortAtr(1), DC_GetRefresh(GetList)}; PARENT oToolBar ; TOOLTIP L('Генерация информационного портрета в модели: ')+Ar_Model[1] DCADDBUTTON CAPTION Ar_Model[2] ; SIZE LEN(Ar_Model[2])+0.5 ; ACTION {||InfPortAtr(2), DC_GetRefresh(GetList)}; PARENT oToolBar ; TOOLTIP L('Генерация информационного портрета в модели: ')+Ar_Model[2] DCADDBUTTON CAPTION Ar_Model[3] ; SIZE LEN(Ar_Model[3])+0.5 ; ACTION {||InfPortAtr(3), DC_GetRefresh(GetList)}; PARENT oToolBar ; TOOLTIP L('Генерация информационного портрета в модели: ')+Ar_Model[3] DCADDBUTTON CAPTION Ar_Model[4] ; SIZE LEN(Ar_Model[4])+0.5 ; ACTION {||InfPortAtr(4), DC_GetRefresh(GetList)}; PARENT oToolBar ; TOOLTIP L('Генерация информационного портрета в модели: ')+Ar_Model[4] DCADDBUTTON CAPTION Ar_Model[5] ; SIZE LEN(Ar_Model[5])+0.5 ; ACTION {||InfPortAtr(5), DC_GetRefresh(GetList)}; PARENT oToolBar ; TOOLTIP L('Генерация информационного портрета в модели: ')+Ar_Model[5] DCADDBUTTON CAPTION Ar_Model[6] ; SIZE LEN(Ar_Model[6])+0.5 ; ACTION {||InfPortAtr(6), DC_GetRefresh(GetList)}; PARENT oToolBar ; TOOLTIP L('Генерация информационного портрета в модели: ')+Ar_Model[6] DCADDBUTTON CAPTION Ar_Model[7] ; SIZE LEN(Ar_Model[7])+0.5 ; ACTION {||InfPortAtr(7), DC_GetRefresh(GetList)}; PARENT oToolBar ; TOOLTIP L('Генерация информационного портрета в модели: ')+Ar_Model[7] DCADDBUTTON CAPTION Ar_Model[8] ; SIZE LEN(Ar_Model[8])+0.5 ; ACTION {||InfPortAtr(8), DC_GetRefresh(GetList)}; PARENT oToolBar ; TOOLTIP L('Генерация информационного портрета в модели: ')+Ar_Model[8] DCADDBUTTON CAPTION Ar_Model[9] ; SIZE LEN(Ar_Model[9])+0.5 ; ACTION {||InfPortAtr(9), DC_GetRefresh(GetList)}; PARENT oToolBar ; TOOLTIP L('Генерация информационного портрета в модели: ')+Ar_Model[9] DCADDBUTTON CAPTION Ar_Model[10] ; SIZE LEN(Ar_Model[10])+0.5 ; ACTION {||InfPortAtr(10), DC_GetRefresh(GetList)}; PARENT oToolBar ; TOOLTIP L('Генерация информационного портрета в модели: ')+Ar_Model[10] DCADDBUTTON CAPTION L('MS Excel') ; SIZE LEN(L("MS Excel"))+0.5 ; ACTION {||Help431(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Экспорт инф.портрета в MS Excel') DCADDBUTTON CAPTION L('ВКЛ.фильтр по кл.шкале') ; SIZE LEN(L("ВКЛ.фильтр по кл.шкале"))-0.5 ; ACTION {||FltrOn431(InfPortAtr->Kod_ClSc), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Включить фильтр по классификационной шкале') DCADDBUTTON CAPTION L('ВЫКЛ.фильтр по кл.шкале') ; SIZE LEN(L("ВЫКЛ.фильтр по кл.шкале"))-1 ; ACTION {||FltrOff431(InfPortAtr->Kod_ClSc), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Выключить фильтр по классификационной шкале') DCADDBUTTON CAPTION L('Вписать в окно') ; SIZE LEN(L("Вписать в окно"))-1 ; ACTION {||WindOn431(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Вписать информационный портрет в окно') DCADDBUTTON CAPTION L('Показать ВСЕ') ; SIZE LEN(L("Показать ВСЕ")) ; ACTION {||WindOff431(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Показать все записи информационного портрета в окне') @ 0,0 DCSAY {|| MessIPA } OBJECT oSay1 SAYSIZE 133 FONT "9.HelvBold" // Наименование инф.портрета /* ----- Create browse Attributes ----- */ 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 @ 1, 0 DCBROWSE oBrowse ALIAS 'Attributes' SIZE 48.8,27 ; PRESENTATION aPres ; 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 InfPortAtr ----- */ PRIVATE bColorBlockZn:={|| iif(InfPortAtr->Znach>0,{GRA_CLR_RED,nil},iif(InfPortAtr->Znach=0,{GRA_CLR_BLACK,nil},{GRA_CLR_BLUE,nil})) } // Клиффорд @ 1,51 DCBROWSE oBrowIpa ALIAS 'InfPortAtr' SIZE 82,27 ; PRESENTATION aPres * COLOR {||IIF(2*INT(RECNO()/2)==RECNO(),nil,{nil,GraMakeRGBColor({230,252,213})})} // Вывод строки цветом RGB DCSETPARENT oBrowIpa DCBROWSECOL FIELD InfPortAtr->KOD_cls HEADER L('Код' ) WIDTH 5 DCBROWSECOL FIELD InfPortAtr->NAME_cls HEADER L('Наименование класса') WIDTH 37 DCBROWSECOL DATA {|x|x:=InfPortAtr->Znach,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.1. Информационные портреты признаков'); FIT ; 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 Help431() 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(' ')) AADD(aHelp, L('Полные наименования стат.моделей и моделей знаний, отличающихся видом частных критериев: ')) AADD(aHelp, L('1. ABS - частный критерий: количество встреч сочетаний: "класс-признак" у объектов обуч.выборки. ')) AADD(aHelp, L('2. PRC1 - частный критерий: усл. вероятность i-го признака среди признаков объектов j-го класса. ')) AADD(aHelp, L('3. PRC2 - частный критерий: условная вероятность i-го признака у объектов j-го класса. ')) AADD(aHelp, L('4. INF1 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC1. ')) AADD(aHelp, L('5. INF2 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC2. ')) AADD(aHelp, L('6. INF3 - частный критерий: Xи-квадрат, разности между фактическими и ожидаемыми абс.частотами. ')) AADD(aHelp, L('7. INF4 - частный критерий: ROI (Return On Investment); вероятности из PRC1. ')) AADD(aHelp, L('8. INF5 - частный критерий: ROI (Return On Investment); вероятности из PRC2. ')) AADD(aHelp, L('9. INF6 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC1. ')) AADD(aHelp, L('10.INF7 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC2. ')) 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(' окне и последующего нажатия кнопки: [ВКЛ.фильтр по кл.шкале] ')) 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 MODAL TITLE L('Помощь по режиму: "4.3.1. Информационные портреты признаков". (C) Система "ЭЙДОС-X++"') RETURN NIL ************************************************************************************************** ******** Генерация информационного портрета признака в модели: Ar_Model[M_CurrInf] ******** для класса, на котором стоит курсор в БД Attributes.dbf FUNCTION InfPortAtr(M_CurrInf) LOCAL Getlist := {}, oProgress, oDialog SELECT Attributes M_Recno = RECNO() M_KodAtr = Kod_atr M_NameAtr = Name_atr PUBLIC MessIPA := 'Инф.портрет признака: '+ALLTRIM(STR(M_KodAtr, 15))+' "'+ALLTRIM(M_NameAtr)+'" в модели: '+ALLTRIM(STR(M_CurrInf, 15))+' "'+UPPER(Ar_Model[M_CurrInf]+'"') *LB_Warning(MessIPA) DC_GetRefresh(oSay1) // Наименование информационного портрета @ 4,5 DCPROGRESS oProgress SIZE 70,1.1 MAXCOUNT RecCount() COLOR GRA_CLR_RED PERCENT EVERY 100 DCREAD GUI TITLE L('4.3.1. Формирование информационного портрета признака') PARENT @oDialog FIT EXIT oDialog:show() // Заполнить БД InfPortAtr записями с кодами и наименованиями классов и их значимостью SELECT InfPortAtr;ZAP nMax = N_Gos * 2 nTime = 0 // Сначала скопировать все записи в отсортированном порядке, // а потом, если N_Rec > 2*N_Str, удалить столько наименее значимых, чтобы осталось 2*N_Str 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" ) DC_GetProgress(oProgress,nMax,nMax) oDialog:Destroy() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW USE InfPortAtr EXCLUSIVE NEW SELECT InfPortAtr SET ORDER TO SET FILTER TO Znach <> 0 DBGOTOP() SELECT Attributes *SET FILTER TO Abs+Int_inf > 0 DBGOTO(M_Recno) ReTURN NIL ******** Включить фильтр инф.портрета класса по описательной шкале FUNCTION FltrOn431(mKodClSc) SELECT InfPortAtr SET ORDER TO SET FILTER TO Kod_ClSc = mKodClSc ReTURN NIL ******** Выключить фильтр инф.портрета класса по описательной шкале FUNCTION FltrOff431(mKodClSc) SELECT InfPortAtr SET ORDER TO SET FILTER TO ReTURN NIL ******** Вписать инф.портрет класса в окно FUNCTION WindOn431() SELECT InfPortAtr N_Rec = RECCOUNT() * 23 = N_Rec - N_Del // 23 - число строк в окне N_Del = N_Rec - 23 SET ORDER TO SET FILTER TO DBGOTOP() DO WHILE .NOT. EOF() REPLACE Fltr_wind WITH "#" DBSKIP(1) ENDDO // Не показывать N_Del наименее значимых записей, так, чтобы заполнить окно SELECT InfPortAtr INDEX ON STR(99999999.9999999-ABS(Znach),19, 7)+STR(Kod_cls,15) TO ("IPCW"+Ar_Model[M_CurrInf]) DBGOBOTTOM() N = 0 DO WHILE .NOT. BOF() .AND. (N+1) <= N_Del REPLACE Fltr_wind WITH " " ++N DBSKIP(-1) ENDDO SET ORDER TO SET FILTER TO Fltr_wind = "#" DBGOTOP() ReTURN NIL ******** Показать все записи инф.портрета FUNCTION WindOff431() SELECT InfPortAtr SET ORDER TO SET FILTER TO DBGOTOP() ReTURN NIL ****************************************************************************** // Копирование всех записей одной базы данных в другую с добавлением или без ****************************************************************************** FUNCTION LC_CopyDBase(cSource, cTarget, AddRec) FOR nRec = 1 TO (cSource)->(RECCOUNT()) (cSource)->(DBGOTO(nRec)) LC_CopyRecord(cSource, cTarget, AddRec) NEXT (cTarget)->(DBGOTOP()) RETURN NIL ****************************************************************************** // Копирование текущей записи одной базы данных в другую с добавлением или без ****************************************************************************** FUNCTION LC_CopyRecord(cSource, cTarget, AddRec) LOCAL i, aRpl := {} M_Recno = (cSource)->(RECNO()) FOR j := 1 TO (cSource)->(FCOUNT()) AADD(aRpl,(cSource)->(FIELDGET(j))) NEXT IF AddRec (cTarget)->(DBAPPEND()) ELSE (cTarget)->(DBGOTO(M_Recno)) ENDIF FOR j := 1 TO LEN(aRpl) (cTarget)->(FIELDPUT(j,aRpl[j])) NEXT RETURN NIL ******** ForProgress FUNCTION ForProgress() LOCAL Getlist := {}, oProgress, oDialog Mess = L('N.N. Подготовка к визуализации модели: "')+UPPER(ALLTRIM(Ar_Model[M_NumModel]))+'"' @ 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) DC_GetProgress(oProgress, ++nTime, nMax) DC_GetProgress(oProgress,nMax,nMax) oDialog:Destroy() RETURN NIL ********************** ******* Работающий c БД cAlias (исходный вариант) *STATIC FUNCTION FieldAnchorA( j, cAlias ) *RETURN {|x|x:=(cAlias)->(FIELDGET(j)), IIF(Empty(x),'',Str(x,8,3))} ****** Работающий c БД cAlias ****** вариант, в котором задается размер поля для отображения и число десятичных знаков, в т.ч. если 0-то выводится как целое) STATIC FUNCTION FieldAnchorA( j, cAlias, mFSize, mFDeci ) IF mFDeci > 0 RETURN {|x|x:=(cAlias)->(FIELDGET(j)), IIF(Empty(x),'',Str(x,mFSize,mFDeci))} ELSE RETURN {|x|x:=(cAlias)->(FIELDGET(j)), IIF(Empty(x),'',Str(x,mFSize))} ENDIF RETURN NIL ******************************************************************************************* FUNCTION SetModel(mNumMod) StrFile(ALLTRIM(STR(mNumMod)), '_NumMod.txt') *mNumMod = VAL(FileStr('_NumMod.txt')) DC_ASave(mNumMod , "_NumMod.arx") *mNumMod = DC_ARestore("_NumMod.arx") RETURN NIL *************************************************************************************************** ******** Задать размер интервала сглаживания и разрешение графической формы при выводе ******** частотных распределений истинных и ложных положительных и отрицательных решений и 2.3.2.12 *************************************************************************************************** FUNCTION SetIntSglag(aInputArray) *PUBLIC mWindow := 17 mWindow = aInputArray[1] @ 1, 0 DCGROUP oGroup1 CAPTION L('') SIZE 55.0, 2.5 @ 1, 2 DCSAY L("Задайте размер интервала сглаживания:") PARENT oGroup1;@ 1,34 DCGET mWindow PICTURE "####" PARENT oGroup1 IF aInputArray[1] * aInputArray[2] > 0 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) mXSize = aInputArray[2] mYSize = aInputArray[3] mLineWidth = aInputArray[4] mGamma = aInputArray[5] mAlfa = aInputArray[6] @ 4, 0 DCGROUP oGroup2 CAPTION L('Задайте размер изображения в пикселях (не более 4K):') SIZE 55.0, 3.5 @ 1, 2 DCSAY L("Размер по X:") PARENT oGroup2;@ 1,34 DCGET mXSize PICTURE "####" PARENT oGroup2 @ 2, 2 DCSAY L("Размер по Y:") PARENT oGroup2;@ 2,34 DCGET mYSize PICTURE "####" PARENT oGroup2 @ 8, 0 DCGROUP oGroup3 CAPTION L('Задайте параметры сглаженной кривой прогнозируемых ЗМТ:') SIZE 55.0, 5.7 @ 1, 3 DCSAY L('Интервал сглаживания:') PARENT oGroup3;@ 1,34 DCGET mWindow PICTURE "####" PARENT oGroup3 @ 2, 3 DCSAY L('Толщина линии:') PARENT oGroup3;@ 2,34 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 IF LEN(cExcelFakt) > 0 @14, 0 DCGROUP oGroup4 CAPTION L('Задайте интервал сглаживания кривой фактических ЗМТ:') SIZE 55.0, 2.7 @ 1, 3 DCSAY L('Интервал сглаживания:') PARENT oGroup4;@ 1,34 DCGET mAlfa PICTURE "####" PARENT oGroup4 ENDIF ENDIF DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; ADDBUTTONS; OPTIONS GetOptions ; MODAL ; TITLE L('(C) Система "Эйдос"') ******************************************************************** IF lExit ** Button Ok ELSE RETURN NIL ENDIF ******************************************************************** IF mWindow < 0 mWindow = 17 aMess := {} AADD(aMess, L('Интервал сглаживания должен быть > 0.')) // https://habr.com/post/134375/ AADD(aMess, L('Поэтому он был принят равным:')+' '+ALLTRIM(STR(mWindow))) LB_Warning(aMess) ENDIF IF mWindow = 1 aMess := {} AADD(aMess, L('Сглаживание с интервалом = 1')) // https://habr.com/post/134375/ AADD(aMess, L('- это отсутствие сглаживания')) LB_Warning(aMess) ENDIF IF mWindow = 2 * INT( mWindow / 2 ) mWindow++ aMess := {} AADD(aMess, L('Интервал сглаживания должен быть нечетным для симметрии.')) // https://habr.com/post/134375/ AADD(aMess, L('Поэтому он был увеличен на 1 и был приянт равным:')+' '+ALLTRIM(STR(mWindow))) LB_Warning(aMess) ENDIF aOutputArray := {} mWindow = IF(mWindow>0,mWindow, 7) // Окно может быть только больше нуля mWindow = IF(mWindow=2*INT(mWindow/2),mWindow++, mWindow) // Окно может быть только нечетным AADD(aOutputArray, mWindow) IF aInputArray[1] * aInputArray[2] > 0 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) // Окно может быть только нечетным AADD(aOutputArray, mXSize ) AADD(aOutputArray, mYSize ) AADD(aOutputArray, mLineWidth) AADD(aOutputArray, mGamma ) AADD(aOutputArray, mAlfa ) ENDIF ReTURN(aOutputArray) ******************************************************************************************* ******** 4.1.3.6. Обобщ.форма по достов.моделей при разн.инт.крит. ******* Отображаются обобщенные результаты измерения достоверности идентификации ******* по всем моделям и интегральным критериям из БД: Dost_mod.DBF' ******************************************************************************************* FUNCTION F4_1_3_6(mPar) LOCAL GetList := {}, aPres, oBrowse, oToolBar, aColors, bColor, GetOptions PUBLIC mWindow := 17 // Интервал сглаживания Running(.T.) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF mRegim = IF(mPar='4.1.3.6.', 'F4.1.3.6()', 'F3.4()') mFlag = .F. IF ApplChange(mRegim) // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения mFlag = .T. ENDIF IF .NOT. FILE('Dost_modCls.dbf') .OR. .NOT. FILE('DostRasp.dbf') LB_Warning(L("Необходимо выполнить режим: 3.5. Синтез и верификация моделей")) mFlag = .T. ENDIF IF .NOT. FILE("Rasp.txt") LB_Warning(L("Необходимо выполнить режим: 3.5. Синтез и верификация моделей")) mFlag = .T. ELSE * StrFile("35", "Rasp.txt") // Запись текстового файла с информацией о том, что был выполнен режим 3.5 mRasp = FileStr("Rasp.txt") IF mRasp <> '35' LB_Warning(L("Необходимо выполнить режим: 3.5. Синтез и верификация моделей")) 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 *################################################################ <<<===############# Здесь был блок, который теперь в конце 3.5, если было распознавние ****** Поиск строк с максимальным значением F-меры, L1-меры и L2-меры CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE DostRasp EXCLUSIVE NEW USE Dost_modCls EXCLUSIVE NEW SELECT Dost_modCls DBGOTOP() M_MaxValF = -9999999999 DO WHILE .NOT. EOF() M_MaxValF = MAX(M_MaxValF, Dost_modCls->F_mera) DBSKIP(1) ENDDO DBGOTOP() M_MaxValL1 = -9999999999 DO WHILE .NOT. EOF() M_MaxValL1 = MAX(M_MaxValL1, Dost_modCls->L1_mera) DBSKIP(1) ENDDO DBGOTOP() M_MaxValL2 = -9999999999 DO WHILE .NOT. EOF() M_MaxValL2 = MAX(M_MaxValL2, Dost_modCls->L2_mera) DBSKIP(1) ENDDO DBGOTOP() /* ----- Create ToolBar ----- */ *** Задать модель ********************************** PUBLIC Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } *** Задать тип графика частотного распределения ***************** mLen1 = LEN(L("Помощь по мерам достоверности")) mLen2 = LEN(L("Помощь по частотным распределениям")) @ 28.5, 0 DCTOOLBAR oToolBar SIZE mLen1, 1.5 DCADDBUTTON CAPTION L('Помощь по мерам достоверности') ; SIZE mLen1-2 ; ACTION {||Help4136(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Помощь по мерам достоверности') @ 28.5, mLen1+3 DCTOOLBAR oToolBar SIZE mLen2, 1.5 DCADDBUTTON CAPTION L('Помощь по частотным распределениям') ; SIZE mLen2-2 ; ACTION {||Help41311(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Помощь по частотным распределениям') @ 28.5, mLen1+mLen2+6 DCTOOLBAR oToolBar SIZE LEN(L("TP,TN,FP,FN"))+LEN(L("(TP-FP), (TN-FN)"))+LEN(L("(T-F)/(T+F)*100")), 1.5 DCADDBUTTON CAPTION L('TP,TN,FP,FN') ; SIZE LEN(L("TP,TN,FP,FN"))+2 ; ACTION {||Graph41311(1,mPar), DC_GetRefresh(GetList)} ; PARENT oToolBar ; FONT '9.Arial Bold' ; TOOLTIP L('Графики частотных распределений: TP,TN,FP,FN в зависимости от уровня сходства') DCADDBUTTON CAPTION L('(TP-FP),(TN-FN)') ; SIZE LEN(L("(TP-FP),(TN-FN)"))-2 ; ACTION {||Graph41311(2,mPar), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Графики частотных распределений: (TP-FP),(TN-FN) в зависимости от уровня сходства') DCADDBUTTON CAPTION L('(T-F)/(T+F)*100') ; SIZE LEN(L("(T-F)/(T+F)*100"))-2 ; ACTION {||Graph41311(3,mPar), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Графики частотных распределений: (TP-FP)/(TP+FP)*100 и (TN-FN)/(TN+FN)*100 в зависимости от уровня сходства') *** Задать интервал сглаживания в отдельном окошке, как "Вписать в окно", по умолчанию без сглаживания (1) <===################ @ 28.5, mLen1+mLen2+6+LEN(L("TP,TN,FP,FN"))+LEN(L("(TP-FP), (TN-FN)"))+LEN(L("(T-F)/(T+F)*100"))+3 DCTOOLBAR oToolBar SIZE 30, 1.5 PRIVATE aInput[3] aInput[1] = mWindow aInput[2] = 0 aInput[3] = 0 DCADDBUTTON CAPTION L('Задать интервал сглаживания') ; SIZE LEN(L("Задать интервал сглаживания"))-1 ; ACTION {||SetIntSglag(aInput), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Задать интервал сглаживания') *@ 28.5, mLen1+mLen2+6+LEN(L("TP,TN,FP,FN"))+LEN(L("(TP-FP), (TN-FN)"))+LEN(L("(T-F)/(T+F)*100"))+LEN(L('Задать интервал сглаживания'))+5 DCTOOLBAR oToolBar SIZE 64.8, 1.5 *DCADDBUTTON CAPTION L('Объединить БД по дост.моделей разных уровней и способов нормализации') ; * SIZE 64.8 ; * ACTION {||AddDost_modCls(), DC_GetRefresh(GetList)} ; * PARENT oToolBar ; * TOOLTIP L('Объединить БД по дост.моделей разных уровней и способов нормализации') /* ----- Create browse ----- */ 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 *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}))) } // Клиффорд *@ .. DCBROWSE .. COLOR {||IIF(Recno()%2==0,{nil,GRA_CLR_PALEGRAY},{nil,GRA_CLR_WHITE})} // Управление фоном отображения строки от Роджера DO CASE CASE M_MaxValF <= M_MaxValL1 .AND. M_MaxValL1 <= M_MaxValL2 @ 1, 0 DCBROWSE oBrowse ALIAS 'Dost_modCls' SIZE 210,27 ; PRESENTATION LC_BrowPres() ; // Только просмотр БД Users HEADLINES 4 ; // Кол-во строк в заголовке FREEZELEFT {1,2} ; // При горизонтальной прокрутке не прокручивать первые 2 колонки COLOR {||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})))} CASE M_MaxValF <= M_MaxValL2 .AND. M_MaxValL2 <= M_MaxValL1 @ 1, 0 DCBROWSE oBrowse ALIAS 'Dost_modCls' SIZE 210,27 ; PRESENTATION LC_BrowPres() ; // Только просмотр БД Users HEADLINES 4 ; // Кол-во строк в заголовке FREEZELEFT {1,2} ; // При горизонтальной прокрутке не прокручивать первые 2 колонки COLOR {||IIF(L1_mera=M_MaxValL1, {nil,aColor[107]},IIF(L2_mera=M_MaxValL2,{nil,aColor[153]},IIF(F_mera=M_MaxValF,{nil,aColor[33]},{nil,GRA_CLR_WHITE})))} CASE M_MaxValL1 <= M_MaxValF .AND. M_MaxValF <= M_MaxValL2 @ 1, 0 DCBROWSE oBrowse ALIAS 'Dost_modCls' SIZE 210,27 ; PRESENTATION LC_BrowPres() ; // Только просмотр БД Users HEADLINES 4 ; // Кол-во строк в заголовке FREEZELEFT {1,2} ; // При горизонтальной прокрутке не прокручивать первые 2 колонки COLOR {||IIF(L2_mera=M_MaxValL2, {nil,aColor[153]},IIF(F_mera =M_MaxValF,{nil,aColor[33]},IIF(L1_mera=M_MaxValL1,{nil,aColor[107]},{nil,GRA_CLR_WHITE})))} CASE M_MaxValL1 <= M_MaxValL2 .AND. M_MaxValL2 <= M_MaxValF @ 1, 0 DCBROWSE oBrowse ALIAS 'Dost_modCls' SIZE 210,27 ; PRESENTATION LC_BrowPres() ; // Только просмотр БД Users HEADLINES 4 ; // Кол-во строк в заголовке FREEZELEFT {1,2} ; // При горизонтальной прокрутке не прокручивать первые 2 колонки COLOR {||IIF(F_mera=M_MaxValF, {nil,aColor[33]},IIF(L2_mera=M_MaxValL2,{nil,aColor[153]},IIF(L1_mera=M_MaxValL1,{nil,aColor[107]},{nil,GRA_CLR_WHITE})))} CASE M_MaxValL2 <= M_MaxValF .AND. M_MaxValF <= M_MaxValL1 @ 1, 0 DCBROWSE oBrowse ALIAS 'Dost_modCls' SIZE 210,27 ; PRESENTATION LC_BrowPres() ; // Только просмотр БД Users HEADLINES 4 ; // Кол-во строк в заголовке FREEZELEFT {1,2} ; // При горизонтальной прокрутке не прокручивать первые 2 колонки COLOR {||IIF(L1_mera=M_MaxValL1, {nil,aColor[107]},IIF(F_mera=M_MaxValF,{nil,aColor[33]},IIF(L2_mera=M_MaxValL2,{nil,aColor[153]},{nil,GRA_CLR_WHITE})))} CASE M_MaxValL2 <= M_MaxValL1 .AND. M_MaxValL1 <= M_MaxValF @ 1, 0 DCBROWSE oBrowse ALIAS 'Dost_modCls' SIZE 210,27 ; PRESENTATION LC_BrowPres() ; // Только просмотр БД Users HEADLINES 4 ; // Кол-во строк в заголовке FREEZELEFT {1,2} ; // При горизонтальной прокрутке не прокручивать первые 2 колонки COLOR {||IIF(F_mera=M_MaxValF, {nil,aColor[33]},IIF(L1_mera=M_MaxValL1,{nil,aColor[107]},IIF(L2_mera =M_MaxValL2,{nil,aColor[153]},{nil,GRA_CLR_WHITE})))} ENDCASE * Структура базы данных N°=22: Dost_modCls.dbf * ============================================================================ * | N | Имя поля | Тип | Ширина | Дес. | Примечание | * ============================================================================ * | 1 | TYPE_MODEL | C | 250 | 0 | * | 2 | INT_KRIT | C | 40 | 0 | * | 3 | N_LOGOBJ | N | 15 | 0 | 3. Количество логических объектов расп.выборки, фактически относящихся к классу (TP+FN) * | 4 | N_T_IDENT | N | 15 | 0 | 4. Количество верно идентифицированных объектов расп.выборки (TP) * | 5 | N_F_NIDENT | N | 15 | 0 | 5. Количество ошибочно неидентифицированных объектов расп.выборки (FN) * | 6 | N_F_IDENT | N | 15 | 0 | 6. Количество ошибочно идентифицированных объектов расп.выборки (FP) * | 7 | N_T_NIDENT | N | 15 | 0 | 7. Количество верно неидентифицированных объектов расп.выборки (TN) * | 8 | P_T_IDENT | N | 15 | 7 | 8. Вероятность верной идентификации объекта с классом с использованием модели * | 9 | P_T_NIDENT | N | 15 | 7 | 9. Вероятность верной не идентификации объекта с классом с использованием модели * | 10 | P_F_IDENT | N | 15 | 7 | 10.Вероятность ошибочной идентификации объекта с классом с использованием модели * | 11 | P_F_NIDENT | N | 15 | 7 | 11.Вероятность ошибочной не идентификации объекта с классом с использованием модели * | 12 | P_AVR_T | N | 15 | 7 | 12.Вероятность верной идентификации или неидентификации объекта с классом с использованием модели (моя мера) * | 13 | DVMOD | N | 15 | 7 | 13.M_DVMod = (NT-NF)/(NT+NF)*100 Моя мера качества модели-классификатора (в знаменателе: "всего объектов") * | 14 | PRECISION | N | 15 | 7 | 14.Precision = TP/(TP+FP) - точность * | 15 | RECALL | N | 15 | 7 | 15.Recall = TP/(TP+FN) - полнота * | 16 | F_MERA | N | 15 | 7 | 16.F-mera = 2*(Precision*Recall)/(Precision+Recall) (мультиклассовый вариант) * | 17 | S_T_IDENT | N | 15 | 7 | 17.Сумма модулей уровней сходства верно идентифицированных объектов расп.выборки (STP) * | 18 | S_F_NIDENT | N | 15 | 7 | 18.Сумма модулей уровней сходства ошибочно неидентифицированных объектов расп.выборки (SFN) * | 19 | S_F_IDENT | N | 15 | 7 | 19.Сумма модулей уровней сходства ошибочно идентифицированных объектов расп.выборки (SFP) * | 20 | S_T_NIDENT | N | 15 | 7 | 20.Сумма модулей уровней сходства верно неидентифицированных объектов расп.выборки (STN) * | 21 | SPRECISION | N | 15 | 7 | 21.SPrecision = STP/(STP+SFP) - точность с учетом уровней сходства * | 22 | SRECALL | N | 15 | 7 | 22.SRecall = STP/(STP+SFN) - полнота с учетом уровней сходства * | 23 | L1_MERA | N | 15 | 7 | 23.L1-mera = 2*(SPrecision*SRecall)/(SPrecision+SRecall) (L1-мера проф.Е.В.Луценко - нечеткое мультиклассовое обобщение * | 24 | A_T_IDENT | N | 15 | 7 | 17.Среднее модулей уровней сходства верно идентифицированных объектов расп.выборки (ATP=STP/TP) * | 25 | A_F_NIDENT | N | 15 | 7 | 18.Среднее модулей уровней сходства ошибочно неидентифицированных объектов расп.выборки (AFN=SFN/FN) * | 26 | A_F_IDENT | N | 15 | 7 | 19.Среднее модулей уровней сходства ошибочно идентифицированных объектов расп.выборки (AFP=SFP/FP) * | 27 | A_T_NIDENT | N | 15 | 7 | 20.Среднее модулей уровней сходства верно неидентифицированных объектов расп.выборки (ATN=STN/TN) * | 28 | APRECISION | N | 15 | 7 | 21.APrecision = ATP/(ATP+AFP) - точность с учетом уровней сходства * | 29 | ARECALL | N | 15 | 7 | 22.ARecall = ATP/(ATP+AFN) - полнота с учетом уровней сходства * | 30 | L2_MERA | N | 15 | 7 | 23.L2-mera = 2*(APrecision*ARecall)/(APrecision+ARecall) (L2-мера проф.Е.В.Луценко - нечеткое мультиклассовое обобщение * | 31 | DATE | C | 10 | 0 | 24. Date Дата формирования записи БД * | 32 | TIME | C | 8 | 0 | 25. Time Время формирования записи БД * ============================================================================ * В С Е Г О длина записи: 624 байтов. | * ============================================================================ * ############################################################################################################################################# * ПОСЧИТАТЬ И ОТОБРАЗИТЬ СРЕДНИЕ МОДУЛИ УРОВНИ СХОДСТВА ДЛЯ ВЕРНО И ОШИБОЧНО ИДЕНТИФИЦИРОВАННЫХ И НЕИДЕНТИФИЦРОВАННЫХ ОБЪЕКТОВ И L2-МЕРУ ИЗ НИХ * ############################################################################################################################################# *TP - истино-положительное решение; *TN - истино-отрицательное решение; *FP - ложно-положительное решение; *FN - ложно-отрицательное решение. WNF = 10 *Цвет шрифта соотвествует строкам с максимальным значенем в нужной колонке *DCBROWSECOL FIELD Dost_modCls->Type_Model HEADER L("Наименование модели;и частного критерия" ) PARENT oBrowse COLOR bColorBlock WIDTH 31 *DCBROWSECOL FIELD Dost_modCls->Int_Krit HEADER L("Интегральный критерий" ) PARENT oBrowse COLOR bColorBlock WIDTH 15 *DCBROWSECOL DATA FieldAnchor( 3, 9,0) HEADER L("Всего;логических;объектов;выборки" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor( 4, 9,0) HEADER L("Число истино-;положительных;решений (TP)" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor( 7, 9,0) HEADER L("Число истино-;отрицательных;решений (TN)" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor( 6, 9,0) HEADER L("Число ложно- ;положительных;решений (FP)" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor( 5, 9,0) HEADER L("Число ложно- ;отрицательных;решений (FN)" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(14, 9,3) HEADER L("Точность;модели" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(15, 9,3) HEADER L("Полнота ;модели" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(16, 9,3) HEADER L("F-мера ;Ван;Ризбергена" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF COLOR {||{nil,aColor[33]}} *DCBROWSECOL DATA FieldAnchor(17,10,3) HEADER L("Сумма модулей;уровней сходства;истино-положит.;решений (STP)" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(20,10,3) HEADER L("Сумма модулей;уровней сходства;истино-отрицат.;решений (STN)" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(19,10,3) HEADER L("Сумма модулей;уровней сходства;ложно-положит.;решений (SFP)" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(18,10,3) HEADER L("Сумма модулей;уровней сходства;ложно-отрицат.;решений (SFN)" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(21, 9,3) HEADER L("S-Точность;модели" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(22, 9,3) HEADER L("S-Полнота ;модели" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(23, 9,3) HEADER L("L1-мера ;проф.;Е.В.Луценко" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF COLOR {||{nil,aColor[107]}} *DCBROWSECOL DATA FieldAnchor(24, 9,3) HEADER L("Средний модуль;уровней сходства;истино-положит.;решений;(ATP=STP/TP)") PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(27, 9,3) HEADER L("Средний модуль;уровней сходства;истино-отрицат.;решений;(ATN=STN/TN)") PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(26, 9,3) HEADER L("Средний модуль;уровней сходства;ложно-положит.;решений;(AFP=SFP/FP)" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(25, 9,3) HEADER L("Средний модуль;уровней сходства;ложно-отрицат.;решений;(AFN=SFN/FN)" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(28, 9,3) HEADER L("A-Точность;модели;APrecision;= ATP/(ATP+AFP)" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(29, 9,3) HEADER L("A-Полнота ;модели;ARecall;= ATP/(ATP+AFN)" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(30, 9,3) HEADER L("L2-мера ;проф.;Е.В.Луценко" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF COLOR {||{nil,aColor[153]}} *DCBROWSECOL DATA FieldAnchor( 8, 9,3) HEADER L("Процент;правильной;идентификации" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor( 9, 9,3) HEADER L("Процент;правильной;не идентификации" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(10, 9,3) HEADER L("Процент;ошибочной ;идентификации" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(11, 9,3) HEADER L("Процент;ошибочной ;не идентификации" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(12, 9,3) HEADER L("Процент;правильных;результатов" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL FIELD Dost_modCls->Date HEADER L("Дата;получения;результата" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 10 *DCBROWSECOL FIELD Dost_modCls->Time HEADER L("Время;получения;результата" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 8 **StrFile(ALLTRIM(STR(nRadioModel)), '_Calc_model_2nd_level.txt') * mModel_2nd_level = VAL(FileStr('_Calc_model_2nd_level.txt')) // = 1 - создавать только базовые модели, иначе - создавать модели 2-го или 3-го уровней **DC_ASave(aModFullNm, "_aModFullNm.arx") // Наименования создаваемых моделей для режима 3.4 * aModFullNm = DC_ARestore("_aModFullNm.arx") *mMaxLen = 10 *SELECT Dost_modCls *DBGOTOP() *n = 1 *DO WHILE .NOT. EOF() * REPLACE Type_Model WITH aModFullNm[n] * DBSKIP(1) * REPLACE Type_Model WITH aModFullNm[n] * mMaxLen = MAX(mMaxLen, LEN(ALLTRIM(aModFullNm[n]))) * n++ * DBSKIP(1) *ENDDO *mMaxLen = mMaxLen * 0.5 mMaxLen = -999999999999 SELECT Dost_modCls DBGOTOP() DO WHILE .NOT. EOF() mMaxLen = MAX(mMaxLen, LEN(ALLTRIM(Type_Model))) DBSKIP(1) ENDDO mMaxLen = mMaxLen * 0.5 CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE DostRasp EXCLUSIVE NEW USE Dost_modCls EXCLUSIVE NEW WNF = 10 *Цвет шрифта соотвествует строкам с максимальным значенем в нужной колонке DCBROWSECOL FIELD Dost_modCls->Type_Model HEADER L("Наименование модели;и частного критерия" ) PARENT oBrowse WIDTH mMaxLen DCBROWSECOL FIELD Dost_modCls->Int_Krit HEADER L("Интегральный критерий" ) PARENT oBrowse WIDTH 15 DCBROWSECOL DATA FieldAnchor( 3, 9,0) HEADER L("Всего;логических;объектов;выборки" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor( 4, 9,0) HEADER L("Число истино-;положительных;решений (TP)" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor( 7, 9,0) HEADER L("Число истино-;отрицательных;решений (TN)" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor( 6, 9,0) HEADER L("Число ложно- ;положительных;решений (FP)" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor( 5, 9,0) HEADER L("Число ложно- ;отрицательных;решений (FN)" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(14, 9,3) HEADER L("Точность;модели" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(15, 9,3) HEADER L("Полнота ;модели" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(16, 9,3) HEADER L("F-мера ;Ван;Ризбергена" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF COLOR {||{nil,aColor[33]}} DCBROWSECOL DATA FieldAnchor(17,10,3) HEADER L("Сумма модулей;уровней сходства;истино-положит.;решений (STP)" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(20,10,3) HEADER L("Сумма модулей;уровней сходства;истино-отрицат.;решений (STN)" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(19,10,3) HEADER L("Сумма модулей;уровней сходства;ложно-положит.;решений (SFP)" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(18,10,3) HEADER L("Сумма модулей;уровней сходства;ложно-отрицат.;решений (SFN)" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(21, 9,3) HEADER L("S-Точность;модели" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(22, 9,3) HEADER L("S-Полнота ;модели" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(23, 9,3) HEADER L("L1-мера ;проф.;Е.В.Луценко" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF COLOR {||{nil,aColor[107]}} DCBROWSECOL DATA FieldAnchor(24, 9,3) HEADER L("Средний модуль;уровней сходства;истино-положит.;решений;(ATP=STP/TP)") PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(27, 9,3) HEADER L("Средний модуль;уровней сходства;истино-отрицат.;решений;(ATN=STN/TN)") PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(26, 9,3) HEADER L("Средний модуль;уровней сходства;ложно-положит.;решений;(AFP=SFP/FP)" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(25, 9,3) HEADER L("Средний модуль;уровней сходства;ложно-отрицат.;решений;(AFN=SFN/FN)" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(28, 9,3) HEADER L("A-Точность;модели;APrecision;= ATP/(ATP+AFP)" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(29, 9,3) HEADER L("A-Полнота ;модели;ARecall;= ATP/(ATP+AFN)" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(30, 9,3) HEADER L("L2-мера ;проф.;Е.В.Луценко" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF COLOR {||{nil,aColor[153]}} DCBROWSECOL DATA FieldAnchor( 8, 9,3) HEADER L("Процент;правильной;идентификации" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor( 9, 9,3) HEADER L("Процент;правильной;не идентификации" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(10, 9,3) HEADER L("Процент;ошибочной ;идентификации" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(11, 9,3) HEADER L("Процент;ошибочной ;не идентификации" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(12, 9,3) HEADER L("Процент;правильных;результатов" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL FIELD Dost_modCls->Date HEADER L("Дата;получения;результата" ) PARENT oBrowse FONT "9.Courier" WIDTH 10 DCBROWSECOL FIELD Dost_modCls->Time HEADER L("Время;получения;результата" ) PARENT oBrowse FONT "9.Courier" WIDTH 8 DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; OPTIONS GetOptions ; MODAL ; TITLE mPar+' '+L('Обобщ.форма по достов.моделей при разн.инт.крит. Текущая модель: "')+UPPER(Ar_Model[M_CurrInf])+'"'; FIT ; CLEAREVENTS ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) ReTURN nil ******************************************************************************************* ****** Кодовый блок для динамического задания шрифта ячейки по ее значению (не работает) STATIC FUNCTION FntBlock(M_MaxVal ) RETURN {|| iif(Dost_mod->P_Avr_T=M_MaxVal,"9.Courier Bold","9.Courier") } ************************************************************************************************** FUNCTION Help4136() aHelp := {} AADD(aHelp, L('Помощь по режимам: 3.4, 4.1.3.6, 4.1.3.7, 4.1.3.8, 4.1.3.10: Виды прогнозов и меры достоверности моделей в системе "Эйдос-Х++". ')) AADD(aHelp, L(' ПОЛОЖИТЕЛЬНЫЙ ПСЕВДОПРОГНОЗ. ')) AADD(aHelp, L('Предположим, модель дает такой прогноз, что выпадет все: и 1, и 2, и 3, и 4, и 5, и 6. Понятно, что из всего этого выпадет лишь что-то одно. В этом случае модель не ')) AADD(aHelp, L('предскажет, что не выпадет, но зато она обязательно предскажет, что выпадет. Однако при этом очень много объектов будет отнесено к классам, к которым они не относятся. ')) AADD(aHelp, L('Тогда вероятность истинно-положительных решений у модели будет 1/6, а вероятность ложно-положительных решений - 5/6. Ясно, что такой прогноз бесполезен, поэтому он ')) AADD(aHelp, L('и назван мной псевдопрогнозом. ')) AADD(aHelp, L(' ОТРИЦАТЕЛЬНЫЙ ПСЕВДОПРОГНОЗ. ')) AADD(aHelp, L('Представим себе, что мы выбрасываем кубик с 6 гранями, и модель предсказывает, что ничего не выпадет, т.е. не выпадет ни 1, ни 2, ни 3, ни 4, ни 5, ни 6, но что-то из ')) AADD(aHelp, L('этого, естественно, обязательно выпадет. Конечно, модель не предсказала, что выпадет, зато она очень хорошо предсказала, что не выпадет. Вероятность истинно-отрицатель-')) AADD(aHelp, L('ных решений у модели будет 5/6, а вероятность ложно-отрицательных решений - 1/6. Такой прогноз гораздо достовернее, чем положительный псевдопрогноз, но тоже бесполезен.')) AADD(aHelp, L(' ИДЕАЛЬНЫЙ ПРОГНОЗ. ')) AADD(aHelp, L(' Если в случае с кубиком мы прогнозируем, что выпадет, например 1, и соответственно прогнозируем, что не выпадет 2, 3, 4, 5, и 6, то это идеальный прогноз, имеющий,')) AADD(aHelp, L('если он осуществляется, 100% достоверность идентификации и не идентификации. Идеальный прогноз, который полностью снимает неопределенность о будущем состоянии объекта ')) AADD(aHelp, L('прогнозирования, на практике удается получить крайне редко и обычно мы имеем дело с реальным прогнозом. ')) AADD(aHelp, L(' РЕАЛЬНЫЙ ПРОГНОЗ. ')) AADD(aHelp, L(' На практике мы чаще всего сталкиваемся именно с этим видом прогноза. Реальный прогноз уменьшает неопределенность о будущем состоянии объекта прогнозирования, но не')) AADD(aHelp, L('полностью, как идеальный прогноз, а оставляет некоторую неопределенность не снятой. Например, для игрального кубика делается такой прогноз: выпадет 1 или 2, и, ')) AADD(aHelp, L('соответственно, не выпадет 3, 4, 5 или 6. Понятно, что полностью на практике такой прогноз не может осуществиться, т.к. варианты выпадения кубика альтернативны, т.е. ')) AADD(aHelp, L('не может выпасть одновременно и 1, и 2. Поэтому у реального прогноза всегда будет определенная ошибка идентификации. Соответственно, если не осуществится один или ')) AADD(aHelp, L('несколько из прогнозируемых вариантов, то возникнет и ошибка не идентификации, т.к. это не прогнозировалось моделью. Теперь представите себе, что у Вас не 1 кубик и ')) AADD(aHelp, L('прогноз его поведения, а тысячи. Тогда можно посчитать средневзвешенные характеристики всех этих видов прогнозов. ')) AADD(aHelp, L(' ')) AADD(aHelp, L(' Таким образом, если просуммировать число верно идентифицированных и не идентифицированных объектов и вычесть число ошибочно идентифицированных и не ')) AADD(aHelp, L('идентифицированных объектов, а затем разделить на число всех объектов то это и будет критерий качества модели (классификатора), учитывающий как ее способность верно ')) AADD(aHelp, L('относить объекты к классам, которым они относятся, так и ее способность верно не относить объекты к тем классам, к которым они не относятся. Этот критерий предложен и ')) AADD(aHelp, L('реализован в системе "Эйдос" проф. Е.В.Луценко в 1994 году. Эта мера достоверности модели предполагает два варианта нормировки: {-1, +1} и {0, 1}: ')) AADD(aHelp, L('La = ( TP + TN - FP - FN ) / ( TP + TN + FP + FN ) (нормировка: {-1,+1}) ')) AADD(aHelp, L('Lb = ( 1 + ( TP + TN - FP - FN ) / ( TP + TN + FP + FN ) ) / 2 (нормировка: { 0, 1}) ')) AADD(aHelp, L(' ')) AADD(aHelp, L('где количество: TP - истинно-положительных решений; TN - истинно-отрицательных решений; FP - ложно-положительных решений; FN - ложно-отрицательных решений; ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Классическая F-мера достоверности моделей Ван Ризбергена (колонка выделена ярко-голубым фоном): ')) AADD(aHelp, L('F-mera = 2*(Precision*Recall)/(Precision+Recall) - достоверность модели ')) AADD(aHelp, L('Precision = TP/(TP+FP) - точность модели; ')) AADD(aHelp, L('Recall = TP/(TP+FN) - полнота модели; ')) AADD(aHelp, L(' ')) AADD(aHelp, L('L1-мера проф.Е.В.Луценко - нечеткое мультиклассовое обобщение классической F-меры с учетом СУММ уровней сходства (колонка выделена ярко-зеленым фоном): ')) AADD(aHelp, L('L1-mera = 2*(SPrecision*SRecall)/(SPrecision+SRecall) ')) AADD(aHelp, L('SPrecision = STP/(STP+SFP) - точность с учетом сумм уровней сходства; ')) AADD(aHelp, L('SRecall = STP/(STP+SFN) - полнота с учетом сумм уровней сходства; ')) AADD(aHelp, L('STP - Сумма модулей сходства истинно-положительных решений; STN - Сумма модулей сходства истинно-отрицательных решений; ')) AADD(aHelp, L('SFP - Сумма модулей сходства ложно-положительных решений; SFN - Сумма модулей сходства ложно-отрицательных решений. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('L2-мера проф.Е.В.Луценко - нечеткое мультиклассовое обобщение классической F-меры с учетом СРЕДНИХ уровней сходства (колонка выделена желтым фоном): ')) AADD(aHelp, L('L2-mera = 2*(APrecision*ARecall)/(APrecision+ARecall) ')) AADD(aHelp, L('APrecision = ATP/(ATP+AFP) - точность с учетом средних уровней сходства; ')) AADD(aHelp, L('ARecall = ATP/(ATP+AFN) - полнота с учетом средних уровней сходства; ')) AADD(aHelp, L('ATP=STP/TP - Среднее модулей сходства истинно-положительных решений; AFN=SFN/FN - Среднее модулей сходства истинно-отрицательных решений; ')) AADD(aHelp, L('AFP=SFP/FP - Среднее модулей сходства ложно-положительных решений; AFN=SFN/FN - Среднее модулей сходства ложно-отрицательных решений. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Строки с максимальными значениями F-меры, L1-меры и L2-меры выделены фоном цвета, соответствующего колонке. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Из графиков частотных распределений истинно-положительных, истинно-отрицательных, ложно-положительных и ложно-отрицательных решений видно, что чем выше модуль уровня ')) AADD(aHelp, L('сходства, тем больше доля истинных решений. Это значит, что модуль уровня сходства является адекватной мерой степени истинности решения и степени уверенности системы ')) AADD(aHelp, L('в этом решении. Поэтому система "Эйдос" имеет адекватный критерий достоверности собственных решений, с помощью которого она может отфильтровать заведомо ложные решения.')) AADD(aHelp, L(' ')) AADD(aHelp, L('Луценко Е.В. Инвариантное относительно объемов данных нечеткое мультиклассовое обобщение F-меры достоверности моделей Ван Ризбергена в АСК-анализе ')) AADD(aHelp, L('и системе "Эйдос" / Е.В. Луценко // Политематический сетевой электронный научный журнал Кубанского государственного аграрного университета (Научный ')) AADD(aHelp, L('журнал КубГАУ) [Электронный ресурс]. - Краснодар: КубГАУ, 2017. - №02(126). С. 1 - 32. - IDA [article ID]: 1261702001. - Режим доступа: ')) AADD(aHelp, L('http://ej.kubagro.ru/2017/02/pdf/01.pdf, 2 у.п.л. ')) mHelpMax = -999;FOR h=1 TO LEN(aHelp);mHelpMax = MAX(mHelpMax, LEN(ALLTRIM(aHelp[h])));NEXT s=1;d=0.75;@0,0 DCGROUP oGroup1 CAPTION L(' ') SIZE mHelpMax-27, 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('Помощь по режимам: 3.4, 4.1.3.#: Виды прогнозов и меры достоверности моделей в системе "Эйдос-Х++"') RETURN NIL ************************************************************************************************** *********************************************************************************************** ******** 4.1.3.7. Обобщ.стат.анализ результатов идент. по моделям и инт.крит. ******** Отображаются результаты обобщенного стат.анализа достоверности идентификации ******** по всем моделям и интегральным критериям из БД: VerModClsIT.dbf *********************************************************************************************** FUNCTION F4_1_3_7() 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.1.3.7()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF IF .NOT. FILE('VerModClsIT.dbf') LB_Warning(L("Необходимо выполнить режим: 3.5 Синтез и верификация моделей")) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW Running(.F.) RETURN NIL ENDIF /* ----- Create ToolBar ----- */ CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE DostRasp EXCLUSIVE NEW USE VerModClsIT EXCLUSIVE NEW ****** Поиск строк с максимальным значением F-меры, L1-меры и L2-меры SELECT VerModClsIT DBGOTOP() M_MaxValF = -9999999999 DO WHILE .NOT. EOF() M_MaxValF = MAX(M_MaxValF, VerModClsIT->F_mera) DBSKIP(1) ENDDO DBGOTOP() M_MaxValL1 = -9999999999 DO WHILE .NOT. EOF() M_MaxValL1 = MAX(M_MaxValL1, VerModClsIT->L1_mera) DBSKIP(1) ENDDO DBGOTOP() M_MaxValL2 = -9999999999 DO WHILE .NOT. EOF() M_MaxValL2 = MAX(M_MaxValL2, VerModClsIT->L2_mera) DBSKIP(1) ENDDO DBGOTOP() /* ----- Create ToolBar ----- */ *** Задать модель ********************************** PUBLIC Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } *** Задать тип графика частотного распределения ***************** mLen1 = LEN(L("Помощь по мерам достоверности")) mLen2 = LEN(L("Помощь по частотным распределениям")) @ 32.5, 0 DCTOOLBAR oToolBar SIZE mLen1, 1.5 DCADDBUTTON CAPTION L('Помощь по мерам достоверности') ; SIZE mLen1-2 ; ACTION {||Help4136(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Помощь по мерам достоверности') @ 32.5, mLen1+3 DCTOOLBAR oToolBar SIZE mLen2, 1.5 DCADDBUTTON CAPTION L('Помощь по частотным распределениям') ; SIZE mLen2-2 ; ACTION {||Help41311(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Помощь по частотным распределениям') @ 32.5, mLen1+mLen2+6 DCTOOLBAR oToolBar SIZE LEN(L("TP,TN,FP,FN"))+LEN(L("(TP-FP), (TN-FN)"))+LEN(L("(T-F)/(T+F)*100")), 1.5 DCADDBUTTON CAPTION L('TP,TN,FP,FN') ; SIZE LEN(L("TP,TN,FP,FN"))-0 ; ACTION {||Graph41311(1,'4.1.3.7.'), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Графики: TP,TN,FP,FN') DCADDBUTTON CAPTION L('(TP-FP), (TN-FN)') ; SIZE LEN(L("(TP-FP), (TN-FN)"))-2 ; ACTION {||Graph41311(2,'4.1.3.7.'), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Графики: (TP-FP), (TN-FN)') DCADDBUTTON CAPTION L('(T-F)/(T+F)*100') ; SIZE LEN(L("(T-F)/(T+F)*100"))-2 ; ACTION {||Graph41311(3,'4.1.3.7.'), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Графики: (TP-FP)/(TP+FP)*100 и (TN-FN)/(TN+FN)*100') *** Задать интервал сглаживания в отдельном окошке, как "Вписать в окно", по умолчанию без сглаживания (1) <===################ @ 32.5, mLen1+mLen2+6+LEN(L("TP,TN,FP,FN"))+LEN(L("(TP-FP), (TN-FN)"))+LEN(L("(T-F)/(T+F)*100"))+1 DCTOOLBAR oToolBar SIZE 30, 1.5 PRIVATE aInput[3] aInput[1] = mWindow aInput[2] = 0 aInput[3] = 0 DCADDBUTTON CAPTION L('Задать интервал сглаживания') ; SIZE LEN(L("Задать интервал сглаживания"))-1 ; ACTION {||SetIntSglag(aInput), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Задать интервал сглаживания') /* ----- Create browse ----- */ 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 PRIVATE bColorBlock:={|| iif(VerModClsIT->F_mera=M_MaxValF .OR. VerModClsIT->L1_mera=M_MaxValL1 .OR. VerModClsIT->L2_mera=M_MaxValL2,{GRA_CLR_RED,nil},iif(VerModClsIT->F_mera=0,{GRA_CLR_WHITE,nil},{GRA_CLR_BLACK,nil})) } // Клиффорд *@ 1, 0 DCBROWSE oBrowse ALIAS 'VerModClsIT' SIZE 217,31 ; * PRESENTATION LC_BrowPres() ; // Только просмотр БД * HEADLINES 8 ; // Кол-во строк в заголовке * FREEZELEFT {1,2} // При горизонтальной прокрутке не прокручивать первые 2 колонки DO CASE CASE M_MaxValF <= M_MaxValL1 .AND. M_MaxValL1 <= M_MaxValL2 @ 1, 0 DCBROWSE oBrowse ALIAS 'VerModClsIT' SIZE 227,31 ; PRESENTATION LC_BrowPres() ; // Только просмотр БД Users HEADLINES 8 ; // Кол-во строк в заголовке FREEZELEFT {1,2} ; // При горизонтальной прокрутке не прокручивать первые 2 колонки COLOR {||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})))} CASE M_MaxValF <= M_MaxValL2 .AND. M_MaxValL2 <= M_MaxValL1 @ 1, 0 DCBROWSE oBrowse ALIAS 'VerModClsIT' SIZE 227,31 ; PRESENTATION LC_BrowPres() ; // Только просмотр БД Users HEADLINES 8 ; // Кол-во строк в заголовке FREEZELEFT {1,2} ; // При горизонтальной прокрутке не прокручивать первые 2 колонки COLOR {||IIF(L1_mera=M_MaxValL1, {nil,aColor[107]},IIF(L2_mera=M_MaxValL2,{nil,aColor[153]},IIF(F_mera=M_MaxValF,{nil,aColor[33]},{nil,GRA_CLR_WHITE})))} CASE M_MaxValL1 <= M_MaxValF .AND. M_MaxValF <= M_MaxValL2 @ 1, 0 DCBROWSE oBrowse ALIAS 'VerModClsIT' SIZE 227,31 ; PRESENTATION LC_BrowPres() ; // Только просмотр БД Users HEADLINES 8 ; // Кол-во строк в заголовке FREEZELEFT {1,2} ; // При горизонтальной прокрутке не прокручивать первые 2 колонки COLOR {||IIF(L2_mera=M_MaxValL2, {nil,aColor[153]},IIF(F_mera =M_MaxValF,{nil,aColor[33]},IIF(L1_mera=M_MaxValL1,{nil,aColor[107]},{nil,GRA_CLR_WHITE})))} CASE M_MaxValL1 <= M_MaxValL2 .AND. M_MaxValL2 <= M_MaxValF @ 1, 0 DCBROWSE oBrowse ALIAS 'VerModClsIT' SIZE 227,31 ; PRESENTATION LC_BrowPres() ; // Только просмотр БД Users HEADLINES 8 ; // Кол-во строк в заголовке FREEZELEFT {1,2} ; // При горизонтальной прокрутке не прокручивать первые 2 колонки COLOR {||IIF(F_mera=M_MaxValF, {nil,aColor[33]},IIF(L2_mera=M_MaxValL2,{nil,aColor[153]},IIF(L1_mera=M_MaxValL1,{nil,aColor[107]},{nil,GRA_CLR_WHITE})))} CASE M_MaxValL2 <= M_MaxValF .AND. M_MaxValF <= M_MaxValL1 @ 1, 0 DCBROWSE oBrowse ALIAS 'VerModClsIT' SIZE 227,31 ; PRESENTATION LC_BrowPres() ; // Только просмотр БД Users HEADLINES 8 ; // Кол-во строк в заголовке FREEZELEFT {1,2} ; // При горизонтальной прокрутке не прокручивать первые 2 колонки COLOR {||IIF(L1_mera=M_MaxValL1, {nil,aColor[107]},IIF(F_mera=M_MaxValF,{nil,aColor[33]},IIF(L2_mera=M_MaxValL2,{nil,aColor[153]},{nil,GRA_CLR_WHITE})))} CASE M_MaxValL2 <= M_MaxValL1 .AND. M_MaxValL1 <= M_MaxValF @ 1, 0 DCBROWSE oBrowse ALIAS 'VerModClsIT' SIZE 227,31 ; PRESENTATION LC_BrowPres() ; // Только просмотр БД Users HEADLINES 8 ; // Кол-во строк в заголовке FREEZELEFT {1,2} ; // При горизонтальной прокрутке не прокручивать первые 2 колонки COLOR {||IIF(F_mera=M_MaxValF, {nil,aColor[33]},IIF(L1_mera=M_MaxValL1,{nil,aColor[107]},IIF(L2_mera =M_MaxValL2,{nil,aColor[153]},{nil,GRA_CLR_WHITE})))} ENDCASE * Структура базы данных N°=74: VerModClsIT.dbf * ============================================================================ * | N | Имя поля | Тип | Ширина | Дес. | Примечание | * ============================================================================ * | 1 | MODINTKRIT | C | 9 | 0 | 1. ModIntKrit Код: ##_####_#, где: ##-числовой номер модели и инт.критерия {1-20}, ####-модель {Abs,Prc1,Prc2,Inf1,Inf2,Inf3,Inf4,Inf5,Inf6,Inf7}, #-инт.крит.: {k,i} * | 2 | NAME_MOD | C | 250 | 0 | 2. Наименование модели и частного критерия * | 3 | INT_KRIT | C | 40 | 0 | 3. Наименование интегрального критерия * | 4 | DIFVALMOD | N | 15 | 7 | 4. DifValMod Достоверность идентификации класса (с учетом всех верно и ошибочно идентифицированных и неидентифицированных логических объектов)) * | 5 | AVRURSX_T | N | 15 | 7 | 5. AvrUrSx_T Средний модуль уровней сходства ВЕРНО идентифицированных и неидентифицированных объектов * | 6 | AVRURSX_F | N | 15 | 7 | 6. AvrUrSx_F Средний модуль уровней сходства ОШИБОЧНО идентифицированных и неидентифицированных объектов * | 7 | DIFAVRURSX | N | 15 | 7 | 7. DifAvrUrSx Разность средних модулей уровней сходства ВЕРНО и ОШИБОЧНО идентифицированных и неидентифицированных объектов * | 8 | N_LOGOBJ | N | 15 | 0 | 8. N_LogObj Количество объектов расп.выборки, фактически относящихся к классу * | 9 | N_T_IDENT | N | 15 | 0 | 9. N_T_Ident Количество верно идентифицированных объектов расп.выборки (TP - истинно-положительное решение) * | 10 | N_F_NIDENT | N | 15 | 0 | 10. N_F_NIdent Количество ошибочно неидентифицированных объектов расп.выборки (FN - ложно-отрицательное решение) * | 11 | N_F_IDENT | N | 15 | 0 | 11. N_F_Ident Количество ошибочно идентифицированных объектов расп.выборки (FP - ложно-положительное решение) * | 12 | N_T_NIDENT | N | 15 | 0 | 12. N_T_NIdent Количество верно неидентифицированных объектов расп.выборки (TN - истинно-отрицательное решение) * | 13 | DVMOD | N | 15 | 7 | 13. M_DVMod = (NT-NF)/(NT+NF)*100 Дифференциальная валидность (достоверность) модели (по классу) (в знаменателе: "всего объектов"). NT = N_T_id+N_T_nid: Количество ВЕРНО идентифицированных и неидентифицированных объектов, NF = N_F_id+N_F_nid: Количество ОШИБОЧНО идентифицированных и неидентифицированных объектов * | 14 | PRECISION | N | 15 | 7 | 14. Precision = TP/(TP+FP) - точность * | 15 | RECALL | N | 15 | 7 | 15. Recall = TP/(TP+FN) - полнота * | 16 | F_MERA | N | 15 | 7 | 16. F-mera = 2*(Precision*Recall)/(Precision+Recall) (мультиклассовый вариант) * | 17 | P_T_IDENT | N | 15 | 7 | 17. P_T_Ident Вероятность верной идентификации объекта с классом с использованием модели * | 18 | P_T_NIDENT | N | 15 | 7 | 18. P_T_NIdent Вероятность верной не идентификации объекта с классом с использованием модели * | 19 | P_F_IDENT | N | 15 | 7 | 19. P_F_Ident Вероятность ошибочной идентификации объекта с классом с использованием модели * | 20 | P_F_NIDENT | N | 15 | 7 | 20. P_F_NIdent Вероятность ошибочной не идентификации объекта с классом с использованием модели * | 21 | P_SLUG_ID | N | 15 | 7 | 21. P_SlUg_Id Вероятность случайного угадывания принадлежности объектов к классам * | 22 | P_SLUG_NID | N | 15 | 7 | 22. P_SlUg_NId Вероятность случайного угадывания непринадлежности объектов к классам * | 23 | EFFMOD_ID | N | 15 | 7 | 23. EffMod_Id Эффективность модели при идентификации: отношение вероятности верной идентификации при использовании модели к вероятности случайного угадывания принадлежности объекта к классу * | 24 | EFFMOD_NID | N | 15 | 7 | 24. EffMod_NId Эффективность модели при неидентификации: отношение вероятности верной неидентификации при использовании модели к вероятности случайного угадывания непринадлежности объекта к классу * | 25 | AVR_EFFMOD | N | 15 | 7 | 25. Avr_EffMod Средняя эффективность модели: (EffMod_Id+EffMod_NId)/2 * | 26 | S_T_IDENT | N | 15 | 7 | 26. Сумма модулей уровней сходства верно идентифицированных объектов расп.выборки (STP - истинно-положительное решение) * | 27 | S_F_NIDENT | N | 15 | 7 | 27. Сумма модулей уровней сходства ошибочно неидентифицированных объектов расп.выборки (SFN - ложно-отрицательное решение) * | 28 | S_F_IDENT | N | 15 | 7 | 28. Сумма модулей уровней сходства ошибочно идентифицированных объектов расп.выборки (SFP - ложно-положительное решение) * | 29 | S_T_NIDENT | N | 15 | 7 | 29. Сумма модулей уровней сходства верно неидентифицированных объектов расп.выборки (STN - истинно-отрицательное решение) * | 30 | SPRECISION | N | 15 | 7 | 30. SPrecision = STP/(STP+SFP) - точность с учетом уровней сходства * | 31 | SRECALL | N | 15 | 7 | 31. SRecall = STP/(STP+SFN) - полнота с учетом уровней сходства * | 32 | L1_MERA | N | 15 | 7 | 32. L1-mera = 2*(SPrecision*SRecall)/(SPrecision+SRecall) (L1-мера проф.Е.В.Луценко - нечеткое мультиклассовое обобщение * | 33 | A_T_IDENT | N | 15 | 7 | 33. Среднее модулей уровней сходства верно идентифицированных объектов расп.выборки (ATP=STP/TP) * | 34 | A_F_NIDENT | N | 15 | 7 | 34. Среднее модулей уровней сходства ошибочно неидентифицированных объектов расп.выборки (AFN=SFN/FN) * | 35 | A_F_IDENT | N | 15 | 7 | 35. Среднее модулей уровней сходства ошибочно идентифицированных объектов расп.выборки (AFP=SFP/FP) * | 36 | A_T_NIDENT | N | 15 | 7 | 36. Среднее модулей уровней сходства верно неидентифицированных объектов расп.выборки (ATN=STN/TN) * | 37 | APRECISION | N | 15 | 7 | 37. APrecision = ATP/(ATP+AFP) - точность с учетом уровней сходства * | 38 | ARECALL | N | 15 | 7 | 38. ARecall = ATP/(ATP+AFN) - полнота с учетом уровней сходства * | 39 | L2_MERA | N | 15 | 7 | 39. L2-mera = 2*(APrecision*ARecall)/(APrecision+ARecall) (L2-мера проф.Е.В.Луценко - нечеткое мультиклассовое обобщение * | 40 | DATE | C | 10 | 0 | 40. Date Дата формирования записи БД * | 41 | TIME | C | 8 | 0 | 41. Time Время формирования записи БД * ============================================================================ * В С Е Г О длина записи: 858 байтов. | * ============================================================================ WNF = 10 // Число разрядов в поле для отображения ************ Управление цветом шрифта в строке в зависимости от значния в нужной колонке *DCBROWSECOL FIELD VerModClsIT->Name_Mod HEADER L("Наименование модели;и частного критерия" ) PARENT oBrowse COLOR bColorBlock WIDTH 31 *DCBROWSECOL FIELD VerModClsIT->Int_Krit HEADER L("Наименование;интегрального критерия" ) PARENT oBrowse COLOR bColorBlock WIDTH 15 *DCBROWSECOL DATA FieldAnchor( 4,9,3) HEADER L("Дифферен-;циальная;досто-;верность;модели;{-1, +1}" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor( 8,9,0) HEADER L("Кол-во;логических;объектов;выборки" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor( 9,9,0) HEADER L("Число истинно-;положительных;решений (TP)" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(12,9,0) HEADER L("Число истинно-;отрицательных;решений (TN)" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(11,9,0) HEADER L("Число ложно- ;положительных;решений (FP)" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(10,9,0) HEADER L("Число ложно- ;отрицательных;решений (FN)" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(14,9,3) HEADER L("Точность;модели" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(15,9,3) HEADER L("Полнота ;модели" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(16,9,3) HEADER L("F-мера ;Ван;Ризбергена" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF COLOR {||{nil,aColor[33]}} *DCBROWSECOL DATA FieldAnchor(26,9,3) HEADER L("Сумма модулей;уровней сходства;истинно-положит.;решений (STP)" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(29,9,3) HEADER L("Сумма модулей;уровней сходства;истинно-отрицат.;решений (STN)" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(28,9,3) HEADER L("Сумма модулей;уровней сходства;ложно-положит.;решений (SFP)" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(27,9,3) HEADER L("Сумма модулей;уровней сходства;ложно-отрицат.;решений (SFN)" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(30,9,3) HEADER L("S-Точность;модели" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(31,9,3) HEADER L("S-Полнота ;модели" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(32,9,3) HEADER L("L1-мера ;проф.;Е.В.Луценко" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF COLOR {||{nil,aColor[107]}} *DCBROWSECOL DATA FieldAnchor(33,9,3) HEADER L("Средний модуль;уровней сходства;истинно-положит.;решений;(ATP=STP/TP)" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(36,9,3) HEADER L("Средний модуль;уровней сходства;истинно-отрицат.;решений;(ATN=STN/TN)" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(35,9,3) HEADER L("Средний модуль;уровней сходства;ложно-положит.;решений;(AFP=SFP/FP)" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(34,9,3) HEADER L("Средний модуль;уровней сходства;ложно-отрицат.;решений;(AFN=SFN/FN)" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(37,9,3) HEADER L("A-Точность;модели;APrecision;= ATP/(ATP+AFP)" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(38,9,3) HEADER L("A-Полнота ;модели;ARecall;= ATP/(ATP+AFN)" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(39,9,3) HEADER L("L2-мера ;проф.;Е.В.Луценко" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF COLOR {||{nil,aColor[153]}} *DCBROWSECOL DATA FieldAnchor( 5,9,3) HEADER L("Средний;модуль;уровня;сходства;ВЕРНО;идентиф.;и неидент.;объектов" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor( 6,9,3) HEADER L("Средний;модуль;уровня;сходства;ОШИБ.;идентиф.;и неидент.;объектов" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor( 7,9,3) HEADER L("Разность;ср.модулей;ур.сход.;ВЕРНО и;ОШИБ.;идентиф.;и неидент.;объектов") PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(17,9,3) HEADER L("Процент ;правильной;идентификации" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(18,9,3) HEADER L("Процент ;правильной;не идентификации" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(19,9,3) HEADER L("Процент ;ошибочной ;идентификации" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(20,9,3) HEADER L("Процент ;ошибочной ;не идентификации" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(21,9,3) HEADER L("Вероятн.;случайн.;угадыв.;принадл.;объектов;к классам" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(22,9,3) HEADER L("Вероятн.;случайн.;угадыв.;непринадл.;объектов;к классам" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(23,9,3) HEADER L("Эффект.;модели;при;идентиф.:;=C13/C17" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(24,9,3) HEADER L("Эффект.;модели;при;неидент.:;=C14/C18" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL DATA FieldAnchor(25,9,3) HEADER L("Средняя;эффект.;модели:;=(C19+;C20)/2" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH WNF *DCBROWSECOL FIELD VerModClsIT->Date HEADER L("Дата;получения;результата" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 10 *DCBROWSECOL FIELD VerModClsIT->Time HEADER L("Время;получения;результата" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 8 *********** Управление фоном строки в зависимости от значения в нужной колонке WNF = 10 // Число разрядов в поле для отображения DCBROWSECOL FIELD VerModClsIT->Name_Mod HEADER L("Наименование модели;и частного критерия" ) PARENT oBrowse WIDTH 31 DCBROWSECOL FIELD VerModClsIT->Int_Krit HEADER L("Наименование;интегрального критерия" ) PARENT oBrowse WIDTH 15 DCBROWSECOL DATA FieldAnchor( 4, 9,3) HEADER L("Дифферен-;циальная;досто-;верность;модели;{-1, +1}" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor( 8, 9,0) HEADER L("Кол-во;логических;объектов;выборки" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor( 9, 9,0) HEADER L("Число истинно-;положительных;решений (TP)" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(12, 9,0) HEADER L("Число истинно-;отрицательных;решений (TN)" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(11, 9,0) HEADER L("Число ложно- ;положительных;решений (FP)" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(10, 9,0) HEADER L("Число ложно- ;отрицательных;решений (FN)" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(14, 9,3) HEADER L("Точность;модели" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(15, 9,3) HEADER L("Полнота ;модели" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(16, 9,3) HEADER L("F-мера ;Ван;Ризбергена" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF COLOR {||{nil,aColor[33]}} DCBROWSECOL DATA FieldAnchor(26,10,3) HEADER L("Сумма модулей;уровней сходства;истинно-положит.;решений (STP)" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(29,10,3) HEADER L("Сумма модулей;уровней сходства;истинно-отрицат.;решений (STN)" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(28,10,3) HEADER L("Сумма модулей;уровней сходства;ложно-положит.;решений (SFP)" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(27,10,3) HEADER L("Сумма модулей;уровней сходства;ложно-отрицат.;решений (SFN)" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(30, 9,3) HEADER L("S-Точность;модели" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(31, 9,3) HEADER L("S-Полнота ;модели" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(32, 9,3) HEADER L("L1-мера ;проф.;Е.В.Луценко" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF COLOR {||{nil,aColor[107]}} DCBROWSECOL DATA FieldAnchor(33, 9,3) HEADER L("Средний модуль;уровней сходства;истинно-положит.;решений;(ATP=STP/TP)" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(36, 9,3) HEADER L("Средний модуль;уровней сходства;истинно-отрицат.;решений;(ATN=STN/TN)" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(35, 9,3) HEADER L("Средний модуль;уровней сходства;ложно-положит.;решений;(AFP=SFP/FP)" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(34, 9,3) HEADER L("Средний модуль;уровней сходства;ложно-отрицат.;решений;(AFN=SFN/FN)" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(37, 9,3) HEADER L("A-Точность;модели;APrecision;= ATP/(ATP+AFP)" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(38, 9,3) HEADER L("A-Полнота ;модели;ARecall;= ATP/(ATP+AFN)" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(39, 9,3) HEADER L("L2-мера ;проф.;Е.В.Луценко" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF COLOR {||{nil,aColor[153]}} DCBROWSECOL DATA FieldAnchor( 5, 9,3) HEADER L("Средний;модуль;уровня;сходства;ВЕРНО;идентиф.;и неидент.;объектов" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor( 6, 9,3) HEADER L("Средний;модуль;уровня;сходства;ОШИБ.;идентиф.;и неидент.;объектов" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor( 7, 9,3) HEADER L("Разность;ср.модулей;ур.сход.;ВЕРНО и;ОШИБ.;идентиф.;и неидент.;объектов") PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(17, 9,3) HEADER L("Процент ;правильной;идентификации" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(18, 9,3) HEADER L("Процент ;правильной;не идентификации" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(19, 9,3) HEADER L("Процент ;ошибочной ;идентификации" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(20, 9,3) HEADER L("Процент ;ошибочной ;не идентификации" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(21, 9,3) HEADER L("Вероятн.;случайн.;угадыв.;принадл.;объектов;к классам" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(22, 9,3) HEADER L("Вероятн.;случайн.;угадыв.;непринадл.;объектов;к классам" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(23, 9,3) HEADER L("Эффект.;модели;при;идентиф.:;=C13/C17" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(24, 9,3) HEADER L("Эффект.;модели;при;неидент.:;=C14/C18" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(25, 9,3) HEADER L("Средняя;эффект.;модели:;=(C19+;C20)/2" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL FIELD VerModClsIT->Date HEADER L("Дата;получения;результата" ) PARENT oBrowse FONT "9.Courier" WIDTH 10 DCBROWSECOL FIELD VerModClsIT->Time HEADER L("Время;получения;результата" ) PARENT oBrowse FONT "9.Courier" WIDTH 8 DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; OPTIONS GetOptions ; MODAL ; TITLE L('4.1.3.7. Обобщ.стат.анализ результатов идент. по моделям и инт.крит. Текущая модель: "')+UPPER(Ar_Model[M_CurrInf])+'"'; FIT ; CLEAREVENTS ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) ReTURN nil ******************************************************************************************* *********************************************************************************************************** ******** 4.1.3.8. Стат.анализ результ. идент. по классам, моделям и инт.крит. ******** Отображаются результаты стат.анализа достоверности идентификации по всем классам, моделям ******** и интегральным критериям из БД: VerModCls.dbf *********************************************************************************************************** FUNCTION F4_1_3_8() LOCAL GetList := {}, GetOptions, oBrowUser, oBrowApp, bApp, bItems Running(.T.) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF ApplChange("4.1.3.8()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF IF .NOT. FILE("VerModClsIT.dbf") LB_Warning(L("Необходимо превдарительно выполнить режим 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("VerModCls.dbf") LB_Warning(L("Необходимо превдарительно выполнить режим 3.5 !!!")) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF dbeSetDefault('DBFNTX') ********* Поиск строк с максимальным значением F-меры, L1-меры и L2-меры CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE VerModClsIT EXCLUSIVE NEW SELECT VerModClsIT DBGOTOP() M_MaxValAllF = -9999999999 DO WHILE .NOT. EOF() M_MaxValAllF = MAX(M_MaxValAllF, VerModClsIT->F_mera) DBSKIP(1) ENDDO DBGOTOP() M_MaxValAllL1 = -9999999999 DO WHILE .NOT. EOF() M_MaxValAllL1 = MAX(M_MaxValAllL1, VerModClsIT->L1_mera) DBSKIP(1) ENDDO DBGOTOP() M_MaxValAllL2 = -9999999999 DO WHILE .NOT. EOF() M_MaxValAllL2 = MAX(M_MaxValAllL2, VerModClsIT->L2_mera) DBSKIP(1) ENDDO DBGOTOP() ************************************************************************ ********* Поиск строк с максимальным значением F-меры, L1-меры и L2-меры CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE VerModCls EXCLUSIVE NEW SELECT VerModCls DBGOTOP() M_MaxValClsF = -9999999999 DO WHILE .NOT. EOF() M_MaxValClsF = MAX(M_MaxValClsF, VerModCls->F_mera) DBSKIP(1) ENDDO DBGOTOP() M_MaxValClsL1 = -9999999999 DO WHILE .NOT. EOF() M_MaxValClsL1 = MAX(M_MaxValClsL1, VerModCls->L1_mera) DBSKIP(1) ENDDO DBGOTOP() M_MaxValClsL2 = -9999999999 DO WHILE .NOT. EOF() M_MaxValClsL2 = MAX(M_MaxValClsL2, VerModCls->L2_mera) DBSKIP(1) ENDDO ************************************************************************ CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE VerModClsIT INDEX ON ModIntKrit TO VerModClsIT CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE VerModCls NEW INDEX ON ModIntKrit TO VerModCls CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE VerModClsIT INDEX VerModClsIT EXCLUSIVE USE VerModCls INDEX VerModCls EXCLUSIVE NEW SET FILTER TO N_LogObj > 0 /* ----- Create ToolBar 2 ----- */ @ 36.5, 1 DCTOOLBAR oToolBar SIZE 200, 1.5 // Строка + 1.5 DCADDBUTTON CAPTION L('Помощь') ; SIZE 4+LEN(L("Помощь")) ; ACTION {||Help4136(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Помощь по режиму 4.1.3.10') *PRIVATE bCBlockAll:={|| iif(VerModClsIT->F_mera=M_MaxValAllF .OR. VerModClsIT->L1_mera=M_MaxValAllL1 .OR. VerModClsIT->L2_mera=M_MaxValAllL2,{GRA_CLR_RED,nil},iif(VerModClsIT->F_mera=0,{GRA_CLR_BLACK,nil},{GRA_CLR_BLACK,nil})) } // Клиффорд *PRIVATE bCBlockCls:={|| iif(VerModCls ->F_mera=M_MaxValClsF .OR. VerModCls ->L1_mera=M_MaxValClsL1 .OR. VerModCls ->L2_mera=M_MaxValClsL2,{GRA_CLR_RED,nil},iif(VerModCls ->F_mera=0,{GRA_CLR_BLACK,nil},{GRA_CLR_BLACK,nil})) } // Клиффорд /* ----- Create browse-1 ----- */ bScale := {|| VerModCls->(DC_SetScope(0,VerModClsIT->ModIntKrit)), ; VerModCls->(DC_SetScope(1,VerModClsIT->ModIntKrit)), ; VerModCls->(DC_DbGoTop()), ; oBrowGrSc:refreshAll() } *@ 1, 0 DCBROWSE oBrowScale ALIAS 'VerModClsIT' SIZE 217,7.5 ; * PRESENTATION LC_BrowPres() ; // Только просмотр БД * HEADLINES 2 ; // Кол-во строк в заголовке * NOSOFTTRACK ; * SCOPE ; * ITEMMARKED {|| Eval(bScale), ; * DC_GetRefresh(GetList,, ; * DCGETREFRESH_TYPE_EXCLUDE,{GETLIST_BROWSE}) } DO CASE CASE M_MaxValAllF <= M_MaxValAllL1 .AND. M_MaxValAllL1 <= M_MaxValAllL2 @ 1, 0 DCBROWSE oBrowScale ALIAS 'VerModClsIT' SIZE 217,7.5 ; PRESENTATION LC_BrowPres() ; // Только просмотр БД Users HEADLINES 2 ; // Кол-во строк в заголовке NOSOFTTRACK ; SCOPE ; COLOR {||IIF(VerModClsIT->L2_mera=M_MaxValAllL2, {nil,aColor[153]},IIF(VerModClsIT->L1_mera=M_MaxValAllL1,{nil,aColor[107]},IIF(VerModClsIT->F_mera=M_MaxValAllF,{nil,aColor[33]},{nil,GRA_CLR_WHITE})))}; ITEMMARKED {|| Eval(bScale), DC_GetRefresh(GetList,, DCGETREFRESH_TYPE_EXCLUDE,{GETLIST_BROWSE}) } CASE M_MaxValAllF <= M_MaxValAllL2 .AND. M_MaxValAllL2 <= M_MaxValAllL1 @ 1, 0 DCBROWSE oBrowScale ALIAS 'VerModClsIT' SIZE 217,7.5 ; PRESENTATION LC_BrowPres() ; // Только просмотр БД Users HEADLINES 2 ; // Кол-во строк в заголовке NOSOFTTRACK ; SCOPE ; COLOR {||IIF(VerModClsIT->L2_mera=M_MaxValAllL2, {nil,aColor[153]},IIF(VerModClsIT->L1_mera=M_MaxValAllL1,{nil,aColor[107]},IIF(VerModClsIT->F_mera=M_MaxValAllF,{nil,aColor[33]},{nil,GRA_CLR_WHITE})))}; ITEMMARKED {|| Eval(bScale), DC_GetRefresh(GetList,, DCGETREFRESH_TYPE_EXCLUDE,{GETLIST_BROWSE}) } CASE M_MaxValAllL1 <= M_MaxValAllF .AND. M_MaxValAllF <= M_MaxValAllL2 @ 1, 0 DCBROWSE oBrowScale ALIAS 'VerModClsIT' SIZE 217,7.5 ; PRESENTATION LC_BrowPres() ; // Только просмотр БД Users HEADLINES 2 ; // Кол-во строк в заголовке NOSOFTTRACK ; SCOPE ; COLOR {||IIF(VerModClsIT->L2_mera=M_MaxValAllL2, {nil,aColor[153]},IIF(VerModClsIT->L1_mera=M_MaxValAllL1,{nil,aColor[107]},IIF(VerModClsIT->F_mera=M_MaxValAllF,{nil,aColor[33]},{nil,GRA_CLR_WHITE})))}; ITEMMARKED {|| Eval(bScale), DC_GetRefresh(GetList,, DCGETREFRESH_TYPE_EXCLUDE,{GETLIST_BROWSE}) } CASE M_MaxValAllL1 <= M_MaxValAllL2 .AND. M_MaxValAllL2 <= M_MaxValAllF @ 1, 0 DCBROWSE oBrowScale ALIAS 'VerModClsIT' SIZE 217,7.5 ; PRESENTATION LC_BrowPres() ; // Только просмотр БД Users HEADLINES 2 ; // Кол-во строк в заголовке NOSOFTTRACK ; SCOPE ; COLOR {||IIF(VerModClsIT->L2_mera=M_MaxValAllL2, {nil,aColor[153]},IIF(VerModClsIT->L1_mera=M_MaxValAllL1,{nil,aColor[107]},IIF(VerModClsIT->F_mera=M_MaxValAllF,{nil,aColor[33]},{nil,GRA_CLR_WHITE})))}; ITEMMARKED {|| Eval(bScale), DC_GetRefresh(GetList,, DCGETREFRESH_TYPE_EXCLUDE,{GETLIST_BROWSE}) } CASE M_MaxValAllL2 <= M_MaxValAllF .AND. M_MaxValAllF <= M_MaxValAllL1 @ 1, 0 DCBROWSE oBrowScale ALIAS 'VerModClsIT' SIZE 217,7.5 ; PRESENTATION LC_BrowPres() ; // Только просмотр БД Users HEADLINES 2 ; // Кол-во строк в заголовке NOSOFTTRACK ; SCOPE ; COLOR {||IIF(VerModClsIT->L2_mera=M_MaxValAllL2, {nil,aColor[153]},IIF(VerModClsIT->L1_mera=M_MaxValAllL1,{nil,aColor[107]},IIF(VerModClsIT->F_mera=M_MaxValAllF,{nil,aColor[33]},{nil,GRA_CLR_WHITE})))}; ITEMMARKED {|| Eval(bScale), DC_GetRefresh(GetList,, DCGETREFRESH_TYPE_EXCLUDE,{GETLIST_BROWSE}) } CASE M_MaxValAllL2 <= M_MaxValAllL1 .AND. M_MaxValAllL1 <= M_MaxValAllF @ 1, 0 DCBROWSE oBrowScale ALIAS 'VerModClsIT' SIZE 217,7.5 ; PRESENTATION LC_BrowPres() ; // Только просмотр БД Users HEADLINES 2 ; // Кол-во строк в заголовке NOSOFTTRACK ; SCOPE ; COLOR {||IIF(VerModClsIT->L2_mera=M_MaxValAllL2, {nil,aColor[153]},IIF(VerModClsIT->L1_mera=M_MaxValAllL1,{nil,aColor[107]},IIF(VerModClsIT->F_mera=M_MaxValAllF,{nil,aColor[33]},{nil,GRA_CLR_WHITE})))}; ITEMMARKED {|| Eval(bScale), DC_GetRefresh(GetList,, DCGETREFRESH_TYPE_EXCLUDE,{GETLIST_BROWSE}) } ENDCASE WNF = 9 // Ширина числового поля DCSETPARENT oBrowScale * Строка заданного цвета *DCBROWSECOL FIELD VerModClsIT->Name_Mod HEADER L("Наименование модели;и частного критерия") PARENT oBrowScale FONT "9.Courier" COLOR bCBlockAll WIDTH 75 *DCBROWSECOL FIELD VerModClsIT->Int_Krit HEADER L("Наименование;интегрального критерия" ) PARENT oBrowScale FONT "9.Courier" COLOR bCBlockAll WIDTH 20 *DCBROWSECOL DATA FieldAnchorA(14,"VerModClsIT",9,3) HEADER L("Точность;модели" ) PARENT oBrowScale FONT "9.Courier" COLOR bCBlockAll WIDTH 10 *DCBROWSECOL DATA FieldAnchorA(15,"VerModClsIT",9,3) HEADER L("Полнота;модели" ) PARENT oBrowScale FONT "9.Courier" COLOR bCBlockAll WIDTH 10 *DCBROWSECOL DATA FieldAnchorA(16,"VerModClsIT",9,3) HEADER L("F-мера;Ван Ризбергена" ) PARENT oBrowScale FONT "9.Courier" COLOR bCBlockAll WIDTH 15 COLOR {||{nil,aColor[33]}} *DCBROWSECOL DATA FieldAnchorA(30,"VerModClsIT",9,3) HEADER L("S-Точность;модели" ) PARENT oBrowScale FONT "10.Courier Bold" COLOR bCBlockAll WIDTH 10 *DCBROWSECOL DATA FieldAnchorA(31,"VerModClsIT",9,3) HEADER L("S-Полнота;модели" ) PARENT oBrowScale FONT "10.Courier Bold" COLOR bCBlockAll WIDTH 10 *DCBROWSECOL DATA FieldAnchorA(32,"VerModClsIT",9,3) HEADER L("L1-мера;проф.Е.В.Луценко" ) PARENT oBrowScale FONT "10.Courier Bold" COLOR bCBlockAll WIDTH 15 COLOR {||{nil,aColor[107]}} *DCBROWSECOL DATA FieldAnchorA(37,"VerModClsIT",9,3) HEADER L("A-Точность;модели" ) PARENT oBrowScale FONT "10.Courier Bold" COLOR bCBlockAll WIDTH 10 *DCBROWSECOL DATA FieldAnchorA(38,"VerModClsIT",9,3) HEADER L("A-Полнота;модели" ) PARENT oBrowScale FONT "10.Courier Bold" COLOR bCBlockAll WIDTH 10 *DCBROWSECOL DATA FieldAnchorA(39,"VerModClsIT",9,3) HEADER L("L2-мера;проф.Е.В.Луценко" ) PARENT oBrowScale FONT "10.Courier Bold" COLOR bCBlockAll WIDTH 15 COLOR {||{nil,aColor[153]}} * Строка заданным фоном DCBROWSECOL FIELD VerModClsIT->Name_Mod HEADER L("Наименование модели;и частного критерия") PARENT oBrowScale FONT "9.Courier" WIDTH 75 DCBROWSECOL FIELD VerModClsIT->Int_Krit HEADER L("Наименование;интегрального критерия" ) PARENT oBrowScale FONT "9.Courier" WIDTH 20 DCBROWSECOL DATA FieldAnchorA(14,"VerModClsIT",9,3) HEADER L("Точность;модели" ) PARENT oBrowScale FONT "9.Courier" WIDTH 10 DCBROWSECOL DATA FieldAnchorA(15,"VerModClsIT",9,3) HEADER L("Полнота;модели" ) PARENT oBrowScale FONT "9.Courier" WIDTH 10 DCBROWSECOL DATA FieldAnchorA(16,"VerModClsIT",9,3) HEADER L("F-мера;Ван Ризбергена" ) PARENT oBrowScale FONT "9.Courier" WIDTH 15 COLOR {||{nil,aColor[33]}} DCBROWSECOL DATA FieldAnchorA(30,"VerModClsIT",9,3) HEADER L("S-Точность;модели" ) PARENT oBrowScale FONT "9.Courier" WIDTH 10 DCBROWSECOL DATA FieldAnchorA(31,"VerModClsIT",9,3) HEADER L("S-Полнота;модели" ) PARENT oBrowScale FONT "9.Courier" WIDTH 10 DCBROWSECOL DATA FieldAnchorA(32,"VerModClsIT",9,3) HEADER L("L1-мера;проф.Е.В.Луценко" ) PARENT oBrowScale FONT "9.Courier" WIDTH 15 COLOR {||{nil,aColor[107]}} DCBROWSECOL DATA FieldAnchorA(37,"VerModClsIT",9,3) HEADER L("A-Точность;модели" ) PARENT oBrowScale FONT "9.Courier" WIDTH 10 DCBROWSECOL DATA FieldAnchorA(38,"VerModClsIT",9,3) HEADER L("A-Полнота;модели" ) PARENT oBrowScale FONT "9.Courier" WIDTH 10 DCBROWSECOL DATA FieldAnchorA(39,"VerModClsIT",9,3) HEADER L("L2-мера;проф.Е.В.Луценко" ) PARENT oBrowScale FONT "9.Courier" WIDTH 15 COLOR {||{nil,aColor[153]}} /* ----- Create browse-2 ----- */ DCSETPARENT TO *@9, 0 DCBROWSE oBrowGrSc ALIAS 'VerModCls' SIZE 217,27 ; * PRESENTATION LC_BrowPres() ; // Только просмотр БД * HEADLINES 8 ; // Кол-во строк в заголовке * NOSOFTTRACK ; * SCOPE ; * ITEMMARKED bItems DO CASE CASE M_MaxValClsF <= M_MaxValClsL1 .AND. M_MaxValClsL1 <= M_MaxValClsL2 @ 9, 0 DCBROWSE oBrowGrSc ALIAS 'VerModCls' SIZE 217,27 ; PRESENTATION LC_BrowPres() ; // Только просмотр БД Users HEADLINES 8 ; // Кол-во строк в заголовке FREEZELEFT {1,2} ; // При горизонтальной прокрутке не прокручивать первые 2 колонки NOSOFTTRACK ; SCOPE ; ITEMMARKED bItems; COLOR {||IIF(L2_mera=M_MaxValClsL2, {nil,aColor[153]},IIF(L1_mera=M_MaxValClsL1,{nil,aColor[107]},IIF(F_mera=M_MaxValClsF,{nil,aColor[33]},{nil,GRA_CLR_WHITE})))} CASE M_MaxValClsF <= M_MaxValClsL2 .AND. M_MaxValClsL2 <= M_MaxValClsL1 @ 9, 0 DCBROWSE oBrowGrSc ALIAS 'VerModCls' SIZE 217,27 ; PRESENTATION LC_BrowPres() ; // Только просмотр БД Users HEADLINES 8 ; // Кол-во строк в заголовке FREEZELEFT {1,2} ; // При горизонтальной прокрутке не прокручивать первые 2 колонки NOSOFTTRACK ; SCOPE ; ITEMMARKED bItems; COLOR {||IIF(L1_mera=M_MaxValClsL1, {nil,aColor[107]},IIF(L2_mera=M_MaxValClsL2,{nil,aColor[153]},IIF(F_mera=M_MaxValClsF,{nil,aColor[33]},{nil,GRA_CLR_WHITE})))} CASE M_MaxValClsL1 <= M_MaxValClsF .AND. M_MaxValClsF <= M_MaxValClsL2 @ 9, 0 DCBROWSE oBrowGrSc ALIAS 'VerModCls' SIZE 217,27 ; PRESENTATION LC_BrowPres() ; // Только просмотр БД Users HEADLINES 8 ; // Кол-во строк в заголовке FREEZELEFT {1,2} ; // При горизонтальной прокрутке не прокручивать первые 2 колонки NOSOFTTRACK ; SCOPE ; ITEMMARKED bItems; COLOR {||IIF(L2_mera=M_MaxValClsL2, {nil,aColor[153]},IIF(F_mera =M_MaxValClsF,{nil,aColor[33]},IIF(L1_mera=M_MaxValClsL1,{nil,aColor[107]},{nil,GRA_CLR_WHITE})))} CASE M_MaxValClsL1 <= M_MaxValClsL2 .AND. M_MaxValClsL2 <= M_MaxValClsF @ 9, 0 DCBROWSE oBrowGrSc ALIAS 'VerModCls' SIZE 217,27 ; PRESENTATION LC_BrowPres() ; // Только просмотр БД Users HEADLINES 8 ; // Кол-во строк в заголовке FREEZELEFT {1,2} ; // При горизонтальной прокрутке не прокручивать первые 2 колонки NOSOFTTRACK ; SCOPE ; ITEMMARKED bItems; COLOR {||IIF(F_mera=M_MaxValClsF, {nil,aColor[33]},IIF(L2_mera=M_MaxValClsL2,{nil,aColor[153]},IIF(L1_mera=M_MaxValClsL1,{nil,aColor[107]},{nil,GRA_CLR_WHITE})))} CASE M_MaxValClsL2 <= M_MaxValClsF .AND. M_MaxValClsF <= M_MaxValClsL1 @ 9, 0 DCBROWSE oBrowGrSc ALIAS 'VerModCls' SIZE 217,27 ; PRESENTATION LC_BrowPres() ; // Только просмотр БД Users HEADLINES 8 ; // Кол-во строк в заголовке FREEZELEFT {1,2} ; // При горизонтальной прокрутке не прокручивать первые 2 колонки NOSOFTTRACK ; SCOPE ; ITEMMARKED bItems; COLOR {||IIF(L1_mera=M_MaxValClsL1, {nil,aColor[107]},IIF(F_mera=M_MaxValClsF,{nil,aColor[33]},IIF(L2_mera=M_MaxValClsL2,{nil,aColor[153]},{nil,GRA_CLR_WHITE})))} CASE M_MaxValClsL2 <= M_MaxValClsL1 .AND. M_MaxValClsL1 <= M_MaxValClsF @ 9, 0 DCBROWSE oBrowGrSc ALIAS 'VerModCls' SIZE 217,27 ; PRESENTATION LC_BrowPres() ; // Только просмотр БД Users HEADLINES 8 ; // Кол-во строк в заголовке FREEZELEFT {1,2} ; // При горизонтальной прокрутке не прокручивать первые 2 колонки NOSOFTTRACK ; SCOPE ; ITEMMARKED bItems; COLOR {||IIF(F_mera=M_MaxValClsF, {nil,aColor[33]},IIF(L1_mera=M_MaxValClsL1,{nil,aColor[107]},IIF(L2_mera =M_MaxValClsL2,{nil,aColor[153]},{nil,GRA_CLR_WHITE})))} ENDCASE DCSETPARENT oBrowGrSc WNF = 9 * Строка заданного цвета *DCBROWSECOL DATA FieldAnchor( 2,6,0) HEADER L("Код;класса" ) PARENT oBrowGrSc FONT "9.Courier" COLOR bCBlockCls WIDTH 6 *DCBROWSECOL FIELD VerModCls->Name_cls HEADER L("Наименование;класса" ) PARENT oBrowGrSc FONT "9.Courier" COLOR bCBlockCls WIDTH 25 *DCBROWSECOL DATA FieldAnchor( 4,9,3) HEADER L("Дифферен-;циальная;досто-;верность;модели;{-1, +1}" ) PARENT oBrowGrSc FONT "9.Courier" COLOR bCBlockCls WIDTH WNF *DCBROWSECOL DATA FieldAnchor( 8,9,0) HEADER L("Кол-во;логических;объектов;выборки" ) PARENT oBrowGrSc FONT "9.Courier" COLOR bCBlockCls WIDTH WNF *DCBROWSECOL DATA FieldAnchor( 9,9,0) HEADER L("Число истинно-;положительных;решений (TP)" ) PARENT oBrowGrSc FONT "10.Courier" COLOR bCBlockCls WIDTH WNF *DCBROWSECOL DATA FieldAnchor(12,9,0) HEADER L("Число истинно-;отрицательных;решений (TN)" ) PARENT oBrowGrSc FONT "10.Courier" COLOR bCBlockCls WIDTH WNF *DCBROWSECOL DATA FieldAnchor(11,9,0) HEADER L("Число ложно- ;положительных;решений (FP)" ) PARENT oBrowGrSc FONT "10.Courier" COLOR bCBlockCls WIDTH WNF *DCBROWSECOL DATA FieldAnchor(10,9,0) HEADER L("Число ложно- ;отрицательных;решений (FN)" ) PARENT oBrowGrSc FONT "10.Courier" COLOR bCBlockCls WIDTH WNF *DCBROWSECOL DATA FieldAnchor(14,9,3) HEADER L("Точность;модели" ) PARENT oBrowGrSc FONT "10.Courier" COLOR bCBlockCls WIDTH WNF *DCBROWSECOL DATA FieldAnchor(15,9,3) HEADER L("Полнота ;модели" ) PARENT oBrowGrSc FONT "10.Courier" COLOR bCBlockCls WIDTH WNF *DCBROWSECOL DATA FieldAnchor(16,9,3) HEADER L("F-мера ;Ван;Ризбергена" ) PARENT oBrowGrSc FONT "10.Courier" COLOR bCBlockCls WIDTH WNF COLOR {||{nil,aColor[33]}} *DCBROWSECOL DATA FieldAnchor(26,9,3) HEADER L("Сумма модулей;уровней сходства;истинно-положит.;решений (STP)" ) PARENT oBrowGrSc FONT "10.Courier Bold" COLOR bCBlockCls WIDTH WNF *DCBROWSECOL DATA FieldAnchor(29,9,3) HEADER L("Сумма модулей;уровней сходства;истинно-отрицат.;решений (STN)" ) PARENT oBrowGrSc FONT "10.Courier Bold" COLOR bCBlockCls WIDTH WNF *DCBROWSECOL DATA FieldAnchor(28,9,3) HEADER L("Сумма модулей;уровней сходства;ложно-положит.;решений (SFP)" ) PARENT oBrowGrSc FONT "10.Courier Bold" COLOR bCBlockCls WIDTH WNF *DCBROWSECOL DATA FieldAnchor(27,9,3) HEADER L("Сумма модулей;уровней сходства;ложно-отрицат.;решений (SFN)" ) PARENT oBrowGrSc FONT "10.Courier Bold" COLOR bCBlockCls WIDTH WNF *DCBROWSECOL DATA FieldAnchor(30,9,3) HEADER L("S-Точность;модели" ) PARENT oBrowGrSc FONT "10.Courier Bold" COLOR bCBlockCls WIDTH WNF *DCBROWSECOL DATA FieldAnchor(31,9,3) HEADER L("S-Полнота ;модели" ) PARENT oBrowGrSc FONT "10.Courier Bold" COLOR bCBlockCls WIDTH WNF *DCBROWSECOL DATA FieldAnchor(32,9,3) HEADER L("L1-мера ;проф.;Е.В.Луценко" ) PARENT oBrowGrSc FONT "10.Courier Bold" COLOR bCBlockCls WIDTH WNF COLOR {||{nil,aColor[107]}} *DCBROWSECOL DATA FieldAnchor(33,9,3) HEADER L("Средний модуль;уровней сходства;истинно-положит.;решений;(ATP=STP/TP)" ) PARENT oBrowGrSc FONT "10.Courier Bold" COLOR bCBlockCls WIDTH WNF *DCBROWSECOL DATA FieldAnchor(36,9,3) HEADER L("Средний модуль;уровней сходства;истинно-отрицат.;решений;(ATN=STN/TN)" ) PARENT oBrowGrSc FONT "10.Courier Bold" COLOR bCBlockCls WIDTH WNF *DCBROWSECOL DATA FieldAnchor(35,9,3) HEADER L("Средний модуль;уровней сходства;ложно-положит.;решений;(AFP=SFP/FP)" ) PARENT oBrowGrSc FONT "10.Courier Bold" COLOR bCBlockCls WIDTH WNF *DCBROWSECOL DATA FieldAnchor(34,9,3) HEADER L("Средний модуль;уровней сходства;ложно-отрицат.;решений;(AFN=SFN/FN)" ) PARENT oBrowGrSc FONT "10.Courier Bold" COLOR bCBlockCls WIDTH WNF *DCBROWSECOL DATA FieldAnchor(37,9,3) HEADER L("A-Точность;модели;APrecision;= ATP/(ATP+AFP)" ) PARENT oBrowGrSc FONT "10.Courier Bold" COLOR bCBlockCls WIDTH WNF *DCBROWSECOL DATA FieldAnchor(38,9,3) HEADER L("A-Полнота ;модели;ARecall;= ATP/(ATP+AFN)" ) PARENT oBrowGrSc FONT "10.Courier Bold" COLOR bCBlockCls WIDTH WNF *DCBROWSECOL DATA FieldAnchor(39,9,3) HEADER L("L2-мера ;проф.;Е.В.Луценко" ) PARENT oBrowGrSc FONT "10.Courier Bold" COLOR bCBlockCls WIDTH WNF COLOR {||{nil,aColor[153]}} *DCBROWSECOL DATA FieldAnchor( 5,9,3) HEADER L("Средний;модуль;уровня;сходства;ВЕРНО;идентиф.;и неидент.;объектов" ) PARENT oBrowGrSc FONT "9.Courier" COLOR bCBlockCls WIDTH WNF *DCBROWSECOL DATA FieldAnchor( 6,9,3) HEADER L("Средний;модуль;уровня;сходства;ОШИБ.;идентиф.;и неидент.;объектов" ) PARENT oBrowGrSc FONT "9.Courier" COLOR bCBlockCls WIDTH WNF *DCBROWSECOL DATA FieldAnchor( 7,9,3) HEADER L("Разность;ср.модулей;ур.сход.;ВЕРНО и;ОШИБ.;идентиф.;и неидент.;объектов") PARENT oBrowGrSc FONT "9.Courier" COLOR bCBlockCls WIDTH WNF *DCBROWSECOL DATA FieldAnchor(17,9,3) HEADER L("Процент ;правильной;идентификации" ) PARENT oBrowGrSc FONT "9.Courier" COLOR bCBlockCls WIDTH WNF *DCBROWSECOL DATA FieldAnchor(18,9,3) HEADER L("Процент ;правильной;не идентификации" ) PARENT oBrowGrSc FONT "9.Courier" COLOR bCBlockCls WIDTH WNF *DCBROWSECOL DATA FieldAnchor(19,9,3) HEADER L("Процент ;ошибочной ;идентификации" ) PARENT oBrowGrSc FONT "9.Courier" COLOR bCBlockCls WIDTH WNF *DCBROWSECOL DATA FieldAnchor(20,9,3) HEADER L("Процент ;ошибочной ;не идентификации" ) PARENT oBrowGrSc FONT "9.Courier" COLOR bCBlockCls WIDTH WNF *DCBROWSECOL DATA FieldAnchor(21,9,3) HEADER L("Вероятн.;случайн.;угадыв.;принадл.;объектов;к классам" ) PARENT oBrowGrSc FONT "9.Courier" COLOR bCBlockCls WIDTH WNF *DCBROWSECOL DATA FieldAnchor(22,9,3) HEADER L("Вероятн.;случайн.;угадыв.;непринадл.;объектов;к классам" ) PARENT oBrowGrSc FONT "9.Courier" COLOR bCBlockCls WIDTH WNF *DCBROWSECOL DATA FieldAnchor(23,9,3) HEADER L("Эффект.;модели;при;идентиф.:;=C13/C17" ) PARENT oBrowGrSc FONT "9.Courier" COLOR bCBlockCls WIDTH WNF *DCBROWSECOL DATA FieldAnchor(24,9,3) HEADER L("Эффект.;модели;при;неидент.:;=C14/C18" ) PARENT oBrowGrSc FONT "9.Courier" COLOR bCBlockCls WIDTH WNF *DCBROWSECOL DATA FieldAnchor(25,9,3) HEADER L("Средняя;эффект.;модели:;=(C19+;C20)/2" ) PARENT oBrowGrSc FONT "9.Courier" COLOR bCBlockCls WIDTH WNF *DCBROWSECOL FIELD VerModCls->Date HEADER L("Дата;получения;результата" ) PARENT oBrowGrSc FONT "9.Courier" COLOR bCBlockCls WIDTH 10 *DCBROWSECOL FIELD VerModCls->Time HEADER L("Время;получения;результата" ) PARENT oBrowGrSc FONT "9.Courier" COLOR bCBlockCls WIDTH 8 * Строка заданным фоном DCBROWSECOL DATA FieldAnchor( 2,6,0) HEADER L("Код;класса" ) PARENT oBrowGrSc FONT "9.Courier" WIDTH 6 DCBROWSECOL FIELD VerModCls->Name_cls HEADER L("Наименование;класса" ) PARENT oBrowGrSc FONT "9.Courier" WIDTH 25 DCBROWSECOL DATA FieldAnchor( 4,9,3) HEADER L("Дифферен-;циальная;досто-;верность;модели;{-1, +1}" ) PARENT oBrowGrSc FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor( 8,9,0) HEADER L("Кол-во;логических;объектов;выборки" ) PARENT oBrowGrSc FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor( 9,9,0) HEADER L("Число истинно-;положительных;решений (TP)" ) PARENT oBrowGrSc FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(12,9,0) HEADER L("Число истинно-;отрицательных;решений (TN)" ) PARENT oBrowGrSc FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(11,9,0) HEADER L("Число ложно- ;положительных;решений (FP)" ) PARENT oBrowGrSc FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(10,9,0) HEADER L("Число ложно- ;отрицательных;решений (FN)" ) PARENT oBrowGrSc FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(14,9,3) HEADER L("Точность;модели" ) PARENT oBrowGrSc FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(15,9,3) HEADER L("Полнота ;модели" ) PARENT oBrowGrSc FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(16,9,3) HEADER L("F-мера ;Ван;Ризбергена" ) PARENT oBrowGrSc FONT "9.Courier" WIDTH WNF COLOR {||{nil,aColor[33]}} DCBROWSECOL DATA FieldAnchor(26,9,3) HEADER L("Сумма модулей;уровней сходства;истинно-положит.;решений (STP)" ) PARENT oBrowGrSc FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(29,9,3) HEADER L("Сумма модулей;уровней сходства;истинно-отрицат.;решений (STN)" ) PARENT oBrowGrSc FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(28,9,3) HEADER L("Сумма модулей;уровней сходства;ложно-положит.;решений (SFP)" ) PARENT oBrowGrSc FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(27,9,3) HEADER L("Сумма модулей;уровней сходства;ложно-отрицат.;решений (SFN)" ) PARENT oBrowGrSc FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(30,9,3) HEADER L("S-Точность;модели" ) PARENT oBrowGrSc FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(31,9,3) HEADER L("S-Полнота ;модели" ) PARENT oBrowGrSc FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(32,9,3) HEADER L("L1-мера ;проф.;Е.В.Луценко" ) PARENT oBrowGrSc FONT "9.Courier" WIDTH WNF COLOR {||{nil,aColor[107]}} DCBROWSECOL DATA FieldAnchor(33,9,3) HEADER L("Средний модуль;уровней сходства;истинно-положит.;решений;(ATP=STP/TP)" ) PARENT oBrowGrSc FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(36,9,3) HEADER L("Средний модуль;уровней сходства;истинно-отрицат.;решений;(ATN=STN/TN)" ) PARENT oBrowGrSc FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(35,9,3) HEADER L("Средний модуль;уровней сходства;ложно-положит.;решений;(AFP=SFP/FP)" ) PARENT oBrowGrSc FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(34,9,3) HEADER L("Средний модуль;уровней сходства;ложно-отрицат.;решений;(AFN=SFN/FN)" ) PARENT oBrowGrSc FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(37,9,3) HEADER L("A-Точность;модели;APrecision;= ATP/(ATP+AFP)" ) PARENT oBrowGrSc FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(38,9,3) HEADER L("A-Полнота ;модели;ARecall;= ATP/(ATP+AFN)" ) PARENT oBrowGrSc FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(39,9,3) HEADER L("L2-мера ;проф.;Е.В.Луценко" ) PARENT oBrowGrSc FONT "9.Courier" WIDTH WNF COLOR {||{nil,aColor[153]}} DCBROWSECOL DATA FieldAnchor( 5,9,3) HEADER L("Средний;модуль;уровня;сходства;ВЕРНО;идентиф.;и неидент.;объектов" ) PARENT oBrowGrSc FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor( 6,9,3) HEADER L("Средний;модуль;уровня;сходства;ОШИБ.;идентиф.;и неидент.;объектов" ) PARENT oBrowGrSc FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor( 7,9,3) HEADER L("Разность;ср.модулей;ур.сход.;ВЕРНО и;ОШИБ.;идентиф.;и неидент.;объектов") PARENT oBrowGrSc FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(17,9,3) HEADER L("Процент ;правильной;идентификации" ) PARENT oBrowGrSc FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(18,9,3) HEADER L("Процент ;правильной;не идентификации" ) PARENT oBrowGrSc FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(19,9,3) HEADER L("Процент ;ошибочной ;идентификации" ) PARENT oBrowGrSc FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(20,9,3) HEADER L("Процент ;ошибочной ;не идентификации" ) PARENT oBrowGrSc FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(21,9,3) HEADER L("Вероятн.;случайн.;угадыв.;принадл.;объектов;к классам" ) PARENT oBrowGrSc FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(22,9,3) HEADER L("Вероятн.;случайн.;угадыв.;непринадл.;объектов;к классам" ) PARENT oBrowGrSc FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(23,9,3) HEADER L("Эффект.;модели;при;идентиф.:;=C13/C17" ) PARENT oBrowGrSc FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(24,9,3) HEADER L("Эффект.;модели;при;неидент.:;=C14/C18" ) PARENT oBrowGrSc FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(25,9,3) HEADER L("Средняя;эффект.;модели:;=(C19+;C20)/2" ) PARENT oBrowGrSc FONT "9.Courier" WIDTH WNF DCBROWSECOL FIELD VerModCls->Date HEADER L("Дата;получения;результата" ) PARENT oBrowGrSc FONT "9.Courier" WIDTH 10 DCBROWSECOL FIELD VerModCls->Time HEADER L("Время;получения;результата" ) PARENT oBrowGrSc FONT "9.Courier" WIDTH 8 DCGETOPTIONS SAYFONT '10.Helv Bold' TABSTOP AUTORESIZE cTitle = L('4.1.3.8. Стат.анализ результатов идентификации по классам, моделям и инт.критериям. Текущая модель: "')+UPPER(Ar_Model[M_CurrInf])+'"' DCREAD GUI ; FIT ; OPTIONS GetOptions ; MODAL ; TITLE cTitle ; EVAL {|o|SetAppFocus(oBrowScale:GetColumn(1))} ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ****** END OF EXAMPLE *********************** ************************************************************************************************** FUNCTION Help41311() aHelp := {} AADD(aHelp, L(' Режим: 4.1.3.11. РАСЧЕТ И ГРАФИЧЕСКАЯ ВИЗУАЛИЗАЦИЯ ЧАСТОТНЫХ РАСПРЕДЕЛЕНИЙ УРОВНЕЙ СХОДСТВА: ')) AADD(aHelp, L(' ')) AADD(aHelp, L('По нажатию кнопок: [TP,TN,FP,FN], [(TP-FP),(TN-FN)], [(T-F)/(T+F)*100] отображаются графики частотных распределений для модели и интегрального критерия той строки, на')) AADD(aHelp, L('которой в экранной форме 3.4 стоит курсор. По клику на кнопке: [(T-F)/(T+F)*100] выводятся графики частотных распределений: (TP-FP)/(TP+FP)*100 и (TN-FN)/(TN+FN)*100.')) AADD(aHelp, L('где: ')) AADD(aHelp, L('TP-True-Positive; TN-True-Negative; FP-False Positive; FN-False-Negative, количество истинных и ложных положительных и отрицательных решений. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Луценко Е.В. Инвариантное относительно объемов данных нечеткое мультиклассовое обобщение F-меры достоверности моделей Ван Ризбергена в АСК-анализе и системе "Эйдос" ')) AADD(aHelp, L('/ Е.В. Луценко // Политематический сетевой электронный научный журнал Кубанского государственного аграрного университета (Научный журнал КубГАУ) [Электронный ресурс].')) AADD(aHelp, L('- Краснодар: КубГАУ, 2017. - №02(126). С. 1 - 32. -IDA [article ID]: 1261702001. -Режим доступа: http://ej.kubagro.ru/2017/02/pdf/01.pdf, 2 у.п.л. ')) 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 s=s+1.5*d @s,0 DCGROUP oGroup2 CAPTION L('Примерные графики TP,TN,FP,FN, а также F-меры и критериев L1, L2 при увеличении объема выборки:') SIZE mHelpMax-20, 16.2 **** Если файл существует изображения и его контрольная сумма совпадает, то он отображается cFile = Disk_dir+"\TP_TN_FP_FN_F_L1_L2-1000.jpg" IF FILE(cFile) IF FILECHECK(cFile) = 16503596 @20,8.5 DCSTATIC TYPE XBPSTATIC_TYPE_BITMAP CAPTION cFile SIZE 1000,293 PIXEL PARENT oGroup2 ELSE aMess := {} AADD(aMess, L('Графический файл: "#" поврежден и не может быть отображен!')) AADD(aMess, L('Контрольная сумма (CRC): "$" ')) aMess[1] = STRTRAN(aMess[1], "#", cFile) aMess[2] = STRTRAN(aMess[2], "$", ALLTRIM(STR(FILECHECK(cFile),19))) // Отображение контрольной суммы файлы LB_Warning(aMess) ENDIF ENDIF DCREAD GUI TO lExit FIT MODAL TITLE L('Помощь по режиму 3.4. (C) Система "ЭЙДОС-X++"') RETURN NIL ************************************************************************************************** *********************************************************************************************** ******** 4.1.3.11.Распределения уровн.сходства при разных моделях и инт.критериях ******** Отображаются частотные распределения уровней сходства верно и ошибочно ******** идентифицированных и неидентифицированных объектов при разных моделях ******** и интегральных критериях из БД: DostRasp.dbf *********************************************************************************************** *FUNCTION F4_1_3_11old(mNumModel) *LOCAL GetList := {}, aPres, oBrowse, oToolBar, bItems, aColors, bColor, GetOptions *Running(.T.) *IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации * LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) * Running(.F.) * RETURN NIL *ENDIF *IF ApplChange("4.1.3.11()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения * ************************************************************** * ***** БД, открытые перед запуском главного меню * ***** Восстанавливать их после выхода из функций главного меню * ************************************************************** * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы * USE PathGrAp EXCLUSIVE NEW * USE Appls EXCLUSIVE NEW * USE Users EXCLUSIVE NEW * ************************************************************** * Running(.F.) * RETURN NIL *ENDIF *IF .NOT. FILE("DostRasp.dbf") * LB_Warning(L('Отсутствует БД "DostRasp.dbf". Необходимо выполнить режим 3.5 !!!')) * ************************************************************** * ***** БД, открытые перед запуском главного меню * ***** Восстанавливать их после выхода из функций главного меню * ************************************************************** * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы * USE PathGrAp EXCLUSIVE NEW * USE Appls EXCLUSIVE NEW * USE Users EXCLUSIVE NEW * ************************************************************** * Running(.F.) * RETURN NIL *ENDIF *oScrn := DC_WaitOn( L('Расчет част.распр.уровней сходства истинно- и ложно- положит.и отрицат.решений' ),,,,,,,,,,,.F.) *M_CurrInf = mNumModel // Текущая модель /* ----- Create ToolBar ----- */ *@ 28.5, 1 DCTOOLBAR oToolBar SIZE 151, 1.5 *DCADDBUTTON CAPTION L('Помощь по графикам') ; * SIZE LEN(L("Помощь по графикам"))+2 ; * ACTION {||Help41311(), DC_GetRefresh(GetList)} ; * PARENT oToolBar ; * TOOLTIP L('Помощь') *DCADDBUTTON CAPTION L('TP,TN,FP,FN, резонанс') ; * SIZE LEN(L("TP,TN,FP,FN, резонанс"))-0 ; * ACTION {||Graph41311(1), DC_GetRefresh(GetList)} ; * PARENT oToolBar ; * TOOLTIP L('Графики: TP,TN,FP,FN, интегральный критерий - резонанс знаний') *DCADDBUTTON CAPTION L('TP,TN,FP,FN, сумма') ; * SIZE LEN(L("TP,TN,FP,FN, сумма"))+2 ; * ACTION {||Graph41311(2), DC_GetRefresh(GetList)} ; * PARENT oToolBar ; * TOOLTIP L('Графики: TP,TN,FP,FN, интегральный критерий - сумма знаний') *DCADDBUTTON CAPTION L('(TP-FP), (TN-FN), резонанс') ; * SIZE LEN(L("(TP-FP), (TN-FN), резонанс"))-2 ; * ACTION {||Graph41311(3), DC_GetRefresh(GetList)} ; * PARENT oToolBar ; * TOOLTIP L('Графики: (TP-FP), (TN-FN), интегральный критерий - резонанс знаний') *DCADDBUTTON CAPTION L('(TP-FP), (TN-FN), сумма') ; * SIZE LEN(L("(TP-FP), (TN-FN), сумма"))-1 ; * ACTION {||Graph41311(4), DC_GetRefresh(GetList)} ; * PARENT oToolBar ; * TOOLTIP L('Графики: (TP-FP), (TN-FN), интегральный критерий - сумма знаний') *DCADDBUTTON CAPTION L('(T-F)/(T+F)*100, резонанс') ; * SIZE LEN(L("(T-F)/(T+F)*100, резонанс"))-2 ; * ACTION {||Graph41311(5), DC_GetRefresh(GetList)} ; * PARENT oToolBar ; * TOOLTIP L('Графики: (TP-FP)/(TP+FP)*100 и (TN-FN)/(TN+FN)*100, интегральный критерий - резонанс знаний') *DCADDBUTTON CAPTION L('(T-F)/(T+F)*100, сумма') ; * SIZE LEN(L("(T-F)/(T+F)*100, сумма"))-1 ; * ACTION {||Graph41311(6), DC_GetRefresh(GetList)} ; * PARENT oToolBar ; * TOOLTIP L('Графики: (TP-FP)/(TP+FP)*100 и (TN-FN)/(TN+FN)*100, интегральный критерий - сумма знаний') /* ----- Create browse ----- */ *CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций *USE DostRasp EXCLUSIVE NEW *SELECT DostRasp *DBGOTOP() *IF RECCOUNT() = 0 * DC_Impl(oScrn) * LB_Warning(L('БД "DostRasp.dbf" пуста. Необходимо выполнить режим 3.5 !!!')) * ************************************************************** * ***** БД, открытые перед запуском главного меню * ***** Восстанавливать их после выхода из функций главного меню * ************************************************************** * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы * USE PathGrAp EXCLUSIVE NEW * USE Appls EXCLUSIVE NEW * USE Users EXCLUSIVE NEW * ************************************************************** * Running(.F.) * RETURN NIL *ENDIF *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 ******* Формирование наименований колонок и ширины полей *PRIVATE aHeadName[FCOUNT()], aWidth[FCOUNT()] *AFILL(aWidth, 4) *aHeadName[1] = "Наименование частного и интегрального критерия" *aWidth[1] = LEN(ALLTRIM(aHeadName[1])) *mFN = -100 *FOR j=2 TO FCOUNT() * aHeadName[j] = ALLTRIM(STR(mFN++)) *NEXT *SELECT DostRasp *DBGOTOP() *DO WHILE .NOT. EOF() * FOR j=2 TO FCOUNT() * aWidth[j] = MAX(aWidth[j], LEN(ALLTRIM(STR(FIELDGET(j))))) * aWidth[j] = MAX(aWidth[j], LEN(aHeadName[j])) * NEXT * DBSKIP(1) *ENDDO *DBGOTOP() *DC_Impl(oScrn) *PRIVATE bColorBlock:={|| iif(AT("ЧАСТНЫЙ КРИТЕРИЙ", Name)>0,{GRA_CLR_RED,nil},iif(AT("ЧАСТНЫЙ КРИТЕРИЙ", Name)=0,{GRA_CLR_BLACK,nil},{GRA_CLR_BLACK,nil})) } // Клиффорд *DCSETPARENT TO *@ 1, 0 DCBROWSE oBrowse ALIAS 'DostRasp' SIZE 152,27 ; * PRESENTATION LC_BrowPres() ; // Только просмотр БД * HEADLINES 1 ; // Кол-во строк в заголовке (перенос строки - ";") * FREEZELEFT {1,1} // При горизонтальной прокрутке не прокручивать первую колонку *DCSETPARENT oBrowse *DCBROWSECOL FIELD DostRasp->Name HEADER aHeadName[1] PARENT oBrowse COLOR bColorBlock WIDTH aWidth[1] *FOR j=2 TO FCOUNT() ** DCBROWSECOL DATA FieldAnchor(j,4,0) HEADER aHeadName[j] PARENT oBrowse COLOR bColorBlock FONT "9.Courier" WIDTH aWidth[j] * DCBROWSECOL DATA FieldAnchor(j,aWidth[j],0) HEADER aHeadName[j] PARENT oBrowse COLOR {|| IIF(N1=-100, {nil,aColor[153]}, {nil,GRA_CLR_WHITE})} FONT "9.Courier" WIDTH aWidth[j] *NEXT *DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE *DCREAD GUI ; * OPTIONS GetOptions ; * MODAL ; * TITLE L('4.1.3.11. Част.распр.уровн.сход.TP,TN,FP,FN решений при разных моделях и инт.критериях. Текущая модель: "')+UPPER(Ar_Model[M_CurrInf])+'"'; * FIT ; * CLEAREVENTS * ************************************************************** * ***** БД, открытые перед запуском главного меню * ***** Восстанавливать их после выхода из функций главного меню * ************************************************************** * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы * USE PathGrAp EXCLUSIVE NEW * USE Appls EXCLUSIVE NEW * USE Users EXCLUSIVE NEW * ************************************************************** *Running(.F.) *ReTURN nil *************************************************************************************************** *************************************************************************************************** ******** Отображение графиков частотных распределений ******** Графики истинно- и ложно- положительных и отрицательных решений XSample_23() xdemo.exe *************************************************************************************************** FUNCTION Graph41311(mTypeChart, mRegim) LOCAL GetList := {}, oStatic * StrFile(ALLTRIM(STR(mNumMod)), '_NumMod.txt') mNumMod = VAL(FileStr('_NumMod.txt')) * DC_ASave(mNumMod , "_NumMod.arx") mNumMod = DC_ARestore("_NumMod.arx") StrFile(STR(mTypeChart), '_41311.txt') // Запись текстового файла с параметром mTypeChart * mTypeChart = VAL(FileStr('_41311.txt')) // Загрузка параметра mPar из текстового файла 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 ') } oScrn := DC_WaitOn( L('Расчет част.распр.уровней сходства истинно- и ложно- положительных и отрицательных решений' ),,,,,,,,,,,.F.) PUBLIC mRecno4136 := RECNO() // № строки в 4.1.3.6 на основе которой определяется модель и инт.критерий * MsgBox(STR(mRecno4136)) DO CASE CASE mRegim = '4.1.3.6.' .OR. mRegim = '3.4.' SELECT Dost_modCls PUBLIC M_Name := ALLTRIM(SUBSTR(Type_model, 1,7)) // Наименование модели CASE mRegim = '4.1.3.7.' SELECT VerModClsIT PUBLIC M_Name := ALLTRIM(SUBSTR(Name_mod, 1,7)) // Наименование модели ENDCASE ****** Массив ссылок со строк БД Dost_modCls.dbf (отображается в режиме 4.1.3.6) на строки БД DostRasp.dbf (4.1.3.11) aLinks := {} // mRecno4136 AADD(aLinks, 2) // * 1 1. ABS - частный критерий: количество встреч сочетаний: "класс-признак" у объектов обуч.выборки Корреляция абс.частот с обр.объекта AADD(aLinks, 10) // 2 1. ABS - частный критерий: количество встреч сочетаний: "класс-признак" у объектов обуч.выборки Сумма абс.частот по признакам объекта AADD(aLinks, 19) // * 3 2. PRC1 - частный критерий: усл. вероятность i-го признака среди признаков объектов j-го класса Корреляция усл.отн.частот с обр.объекта AADD(aLinks, 27) // 4 2. PRC1 - частный критерий: усл. вероятность i-го признака среди признаков объектов j-го класса Сумма усл.отн.частот по признакам объект AADD(aLinks, 36) // * 5 3. PRC2 - частный критерий: условная вероятность i-го признака у объектов j-го класса Корреляция усл.отн.частот с обр.объекта AADD(aLinks, 44) // 6 3. PRC2 - частный критерий: условная вероятность i-го признака у объектов j-го класса Сумма усл.отн.частот по признакам объект AADD(aLinks, 53) // * 7 4. INF1 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC1 Семантический резонанс знаний AADD(aLinks, 61) // 8 4. INF1 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC1 Сумма знаний AADD(aLinks, 70) // * 9 5. INF2 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC2 Семантический резонанс знаний AADD(aLinks, 78) // 10 5. INF2 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC2 Сумма знаний AADD(aLinks, 87) // * 11 6. INF3 - частный критерий: Xи-квадрат, разности между фактическими и ожидаемыми абс.частотами Семантический резонанс знаний AADD(aLinks, 95) // 12 6. INF3 - частный критерий: Xи-квадрат, разности между фактическими и ожидаемыми абс.частотами Сумма знаний AADD(aLinks, 104) // * 13 7. INF4 - частный критерий: ROI (Return On Investment); вероятности из PRC1 Семантический резонанс знаний AADD(aLinks, 112) // 14 7. INF4 - частный критерий: ROI (Return On Investment); вероятности из PRC1 Сумма знаний AADD(aLinks, 121) // * 15 8. INF5 - частный критерий: ROI (Return On Investment); вероятности из PRC2 Семантический резонанс знаний AADD(aLinks, 129) // 16 8. INF5 - частный критерий: ROI (Return On Investment); вероятности из PRC2 Сумма знаний AADD(aLinks, 138) // * 17 9. INF6 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC1 Семантический резонанс знаний AADD(aLinks, 146) // 18 9. INF6 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC1 Сумма знаний AADD(aLinks, 155) // * 19 10.INF7 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC2 Семантический резонанс знаний AADD(aLinks, 163) // 20 10.INF7 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC2 Сумма знаний ******* Занести исходные массивы из базы данных DostRasp.dbf **************************** mPar = mTypeChart * 2 - IF(mRecno4136=2*INT(mRecno4136/2),0,1) StrFile(STR(mPar), '_41311.txt') // Запись текстового файла с параметром mMaxLenCls * mPar = VAL(FileStr('_41311.txt')) // Загрузка параметра mMaxLenCls из текстового файла * MsgBox(STR(mPar)) * mTypeChart mPar * 1 1. TP,TN,FP,FN, интегральный критерий - резонанс знаний; * 1 2. TP,TN,FP,FN, интегральный критерий - сумма знаний; * 2 3. (TP-FP), (TN-FN), интегральный критерий - резонанс знаний; * 2 4. (TP-FP), (TN-FN), интегральный критерий - сумма знаний; * 3 5. (TP-FP)/(TP+FP)*100 и (TN-FN)/(TN+FN)*100, интегральный критерий - резонанс знаний; * 3 6. (TP-FP)/(TP+FP)*100 и (TN-FN)/(TN+FN)*100, интегральный критерий - сумма знаний; SELECT DostRasp // БД, отображаемая в режиме 4.1.3.11 DBGOTO(aLinks[mRecno4136]+4) // Переход на строку БД DostRasp.dbf (4.1.3.11) PRIVATE aData_TP[101] // Массив частот ур.сходства истинно-положительных решений (TP) PRIVATE aData_TN[101] // Массив частот ур.сходства истинно-отрицательных решений (TN) PRIVATE aData_FP[101] // Массив частот ур.сходства ложно-положительных решений (FP) PRIVATE aData_FN[101] // Массив частот ур.сходства ложно-отрицательных решений (FN) *** Ноль (0 = F102) есть во всех массивах: и в массивах отрицательных, и в массивах положительных решений FOR j=102 TO 202 aData_TP[j-101] = FIELDGET(j) NEXT DBSKIP(1) FOR j= 2 TO 102 aData_TN[j- 1] = FIELDGET(j) NEXT DBSKIP(1) FOR j=102 TO 202 aData_FP[j-101] = FIELDGET(j) NEXT DBSKIP(1) FOR j= 2 TO 102 aData_FN[j- 1] = FIELDGET(j) NEXT DC_Impl(oScrn) *@ 2,1 DCSTATIC TYPE XBPSTATIC_TYPE_RECESSEDBOX SIZE 131,27 ; // Размер окна для отображения графика <<<#################### * OBJECT oStatic; * EVAL {|| _PresSpace(oStatic, aData_TP, aData_TN, aData_FP, aData_FN) } 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 ) 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 ) *######################################################################################################################### LinChart( oPS, aData_TP, aData_TN, aData_FP, aData_FN ) // Графическая функция <<<===########################### *######################################################################################################################### *My image original, my image scaled ****** Запись полноразмерного графического файла в папку: M_PathAppl+"\SemNetCls2d\" * DC_Impl(oScr) IF FILEDATE("FreqDistr",16) = CTOD("//") DIRMAKE("FreqDistr") aMess := {} AADD(aMess, L('В папке текущего приложения: "'+UPPER(ALLTRIM(M_PathAppl))+'"')) AADD(aMess, L('не было директории "FreqDistr" для частотных распределений')) AADD(aMess, L('истинных и ложных положительных и отрицательных решений и она была создана!')) AADD(aMess, L('В эту папку записываются исходные изображения высокого качества (без масштабирования)')) LB_Warning(aMess, mRegim+' '+L('Обобщ.форма по достов.моделей при разн.инт.крит.')) ENDIF DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения * DC_ASave(mNumMod , "_NumMod.arx") mNumMod = DC_ARestore("_NumMod.arx") DIRCHANGE(M_PathAppl+"\FreqDistr\") // Перейти в папку SemNetAtr2d cFileName = "FreqDistr"+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) // Перейти в папку текущего приложения ********** Восстановление среды режима 4.1.3.6 ********* CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE DostRasp EXCLUSIVE NEW DO CASE CASE mRegim = '4.1.3.6.' .OR. mRegim = '3.4.' USE Dost_modCls EXCLUSIVE NEW SELECT Dost_modCls CASE mRegim = '4.1.3.7.' USE VerModClsIT EXCLUSIVE NEW SELECT VerModClsIT ENDCASE DBGOTO(mRecno4136) RETURN NIL ************************************************* STATIC FUNCTION _PresSpace( oStatic, aData_TP, aData_TN, aData_FP, aData_FN) LOCAL oPS, oDevice PRIVATE LY := 20 // Зона под областью графика для легенды PRIVATE X0 := 20, Y0 := 20 // Начало координат по осям X и Y PRIVATE W_Wind := 920 - X0 // Ширина окна PRIVATE H_Wind := 530 - Y0 - LY // Высота окна 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, W_Wind, H_Wind } ) //Define :paint code block oStatic:paint := {|mp1,mp2,obj| mp1 := LinChart( oPS, aData_TP, aData_TN, aData_FP, aData_FN ) } RETURN nil ********************************************************************* STATIC FUNCTION LinChart(oPS, aData_TP, aData_TN, aData_FP, aData_FN) * StrFile(STR(mPar), '_41311.txt') // Запись текстового файла с параметром mMaxLenCls mPar = VAL(FileStr('_41311.txt')) // Загрузка параметра mMaxLenCls из текстового файла PRIVATE LY := 30 // Зона под областью графика для легенды PRIVATE X0 := 30, Y0 := 30 // Начало координат по осям X и Y PRIVATE W_Wind := X_MaxW-2*X0 // Ширина окна PRIVATE H_Wind := Y_MaxW-Y0-LY-70 // Высота окна PRIVATE aXName := {} // Массив надписей по оси X PRIVATE aYName := {} // Массив надписей по оси Y PRIVATE NX := 20, NY := 10 // Кол-во меток по осям X и Y FOR j=-100 TO +100 AADD(aXName, ALLTRIM(STR(j,19))) NEXT *********************************** ******* Ветвление по типам графиков *********************************** DO CASE CASE mPar=1 .OR. mPar=2 // 1,2. TP,TN,FP,FN // ############################################################ CASE mPar=3 .OR. mPar=4 // 3,4. (TP-FP), (TN-FN) // ############################################################ CASE mPar=5 .OR. mPar=6 // 5,6. (TP-FP)/(TP+FP)*100, (TN-FN)/(TN+FN)*100 // ############################################################ ENDCASE IF mWindow > 1 ******* Расчет сглаженных кривых ************* (http://habr.com/post/134375/) // Сглаженные массивы PRIVATE aAvrTP[101] // Длина исходного массива: уровни сходства от 0% до +100% PRIVATE aAvrTN[101] // Длина исходного массива: уровни сходства от 0% до -100% PRIVATE aAvrFP[101] // Длина исходного массива: уровни сходства от 0% до +100% PRIVATE aAvrFN[101] // Длина исходного массива: уровни сходства от 0% до -100% PRIVATE aAvrTNFP[202] PRIVATE aAvrFNTP[202] ******* Формирование объединенных массивов исходных данных ********************** PRIVATE aData_TNFP[201] PRIVATE aData_FNTP[201] FOR j= 1 TO 101 aData_TNFP[j] = aData_TN[j] NEXT FOR j=101 TO 201 aData_TNFP[j] = aData_FP[j-100] NEXT FOR j= 1 TO 101 aData_FNTP[j] = aData_FN[j] NEXT FOR j=101 TO 201 aData_FNTP[j] = aData_TP[j-100] NEXT ******* Расчет сглаженной кривой aAvrTP ************* (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 // первый элемент берем из исходного массива как есть aAvrTNFP[1] = aData_TNFP[1] aAvrFNTP[1] = aData_FNTP[1] hw = (mWindow-1)/2 // Размах окна влево и вправо от текущей позиции n = 201 FOR i=2 TO n // Организовываем цикл по числу элементов mSumTNFP = 0 mSumFNTP = 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) // организуем цикл от начала до конца окна mSumTNFP = mSumTNFP + aData_TNFP[j] // <===######################## mSumFNTP = mSumFNTP + aData_FNTP[j] NEXT aAvrTNFP[i] = mSumTNFP / z aAvrFNTP[i] = mSumFNTP / z NEXT ***** Добавить в БД DostRasp.dbf две записи с данными сглаженных частотных распределений aAvrTNFP и aAvrFNTP DELETE FOR RECNO() > 170 PACK APPEND BLANK REPLACE Name WITH L('Сглаженное (w=')+')'+ALLTRIM(STR(mWindow))+' '+L('частотное распределение aAvrTNFP:') FOR j=1 TO 201 FIELDPUT(j+1, aAvrTNFP[j]) NEXT APPEND BLANK REPLACE Name WITH L('Сглаженное (w=')+')'+ALLTRIM(STR(mWindow))+' '+L('частотное распределение aAvrFNTP:') FOR j=1 TO 201 FIELDPUT(j+1, aAvrFNTP[j]) NEXT ***** Или рисовать прямо aAvrTNFP и aAvrFNTP с заменой цвета при переходе через 0 FOR j= 1 TO 101 aAvrTN[j ] = aAvrTNFP[j] NEXT FOR j=101 TO 201 aAvrFP[j-100] = aAvrTNFP[j] NEXT FOR j= 1 TO 101 aAvrFN[j ] = aAvrFNTP[j] NEXT FOR j=101 TO 201 aAvrTP[j-100] = aAvrFNTP[j] NEXT ENDIF // Здесь найти имена наименований по оси X и сформировать два массива: для верно и ошибочно идентифицированных // Макс.- Мин. искать для обоих массивов общие MIN_aData := +99999999 MAX_aData := -99999999 *********************************** ******* Ветвление по типам графиков *********************************** DO CASE CASE mPar=1 .OR. mPar=2 // 1,2. TP,TN,FP,FN // ############################################################ FOR j=1 TO 101 MIN_aData = MIN(MIN_aData, aData_TP[j]) MIN_aData = MIN(MIN_aData, aData_TN[j]) MIN_aData = MIN(MIN_aData, aData_FP[j]) MIN_aData = MIN(MIN_aData, aData_FN[j]) MAX_aData = MAX(MAX_aData, aData_TP[j]) MAX_aData = MAX(MAX_aData, aData_TN[j]) MAX_aData = MAX(MAX_aData, aData_FP[j]) MAX_aData = MAX(MAX_aData, aData_FN[j]) MIN_aData = MIN(MIN_aData, aAvrTP[j]) MIN_aData = MIN(MIN_aData, aAvrTN[j]) MIN_aData = MIN(MIN_aData, aAvrFP[j]) MIN_aData = MIN(MIN_aData, aAvrFN[j]) MAX_aData = MAX(MAX_aData, aAvrTP[j]) MAX_aData = MAX(MAX_aData, aAvrTN[j]) MAX_aData = MAX(MAX_aData, aAvrFP[j]) MAX_aData = MAX(MAX_aData, aAvrFN[j]) NEXT CASE mPar=3 .OR. mPar=4 // 3,4. (TP-FP), (TN-FN) // ############################################################ FOR j=1 TO 101 MIN_aData = MIN(MIN_aData, aData_TP[j]-aData_FP[j]) MIN_aData = MIN(MIN_aData, aData_TN[j]-aData_FN[j]) MAX_aData = MAX(MAX_aData, aData_TP[j]-aData_FP[j]) MAX_aData = MAX(MAX_aData, aData_TN[j]-aData_FN[j]) MIN_aData = MIN(MIN_aData, aAvrTP[j]-aAvrFP[j]) MIN_aData = MIN(MIN_aData, aAvrTN[j]-aAvrFN[j]) MAX_aData = MAX(MAX_aData, aAvrTP[j]-aAvrFP[j]) MAX_aData = MAX(MAX_aData, aAvrTN[j]-aAvrFN[j]) NEXT CASE mPar=5 .OR. mPar=6 // 5,6. (TP-FP)/(TP+FP)*100, (TN-FN)/(TN+FN)*100 // ############################################################ FOR j=1 TO 101 MIN_aData = MIN(MIN_aData, (aData_TP[j]-aData_FP[j])/(aData_TP[j]+aData_FP[j])*100) MIN_aData = MIN(MIN_aData, (aData_TN[j]-aData_FN[j])/(aData_TN[j]+aData_FN[j])*100) MAX_aData = MAX(MAX_aData, (aData_TP[j]-aData_FP[j])/(aData_TP[j]+aData_FP[j])*100) MAX_aData = MAX(MAX_aData, (aData_TN[j]-aData_FN[j])/(aData_TN[j]+aData_FN[j])*100) MIN_aData = MIN(MIN_aData, (aAvrTP[j]-aAvrFP[j])/(aAvrTP[j]+aAvrFP[j])*100) MIN_aData = MIN(MIN_aData, (aAvrTN[j]-aAvrFN[j])/(aAvrTN[j]+aAvrFN[j])*100) MAX_aData = MAX(MAX_aData, (aAvrTP[j]-aAvrFP[j])/(aAvrTP[j]+aAvrFP[j])*100) MAX_aData = MAX(MAX_aData, (aAvrTN[j]-aAvrFN[j])/(aAvrTN[j]+aAvrFN[j])*100) NEXT ENDCASE * DC_DebugQout( aData_TP ) * DC_DebugQout( aData_TN ) * DC_DebugQout( aData_FP ) * DC_DebugQout( aData_FN ) KX = W_Wind/201 // Коэфф.сжатия по оси X (100 для N, 100 для P, и + 0) KY = H_Wind/(MAX_aData-MIN_aData) // Коэфф.сжатия по оси Y. Сюда надо сверху еще впихнуть название диаграммы ***** Стиль шрифта ******************************* oFont := XbpFont():new():create("10.Arial") 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 ) // Установить символьные атрибуты ***** Закрасить фон прямоугольника *************** GraSetColor( oPS, aColor[98] , aColor[98] ) GraBox( oPS, { X0, Y0+LY }, { X0+W_Wind, Y0+LY+H_Wind }, GRA_FILL) GraSetColor( oPS, aColor[222] , aColor[222] ) *** Закрасить области между метками на оси X ***** GraSetColor( oPS, aColor[99] , aColor[99] ) Yx = Y0 + LY + (0-MIN_aData)*KY DX = 10 // Кол-во значений j, через которое ставить метку FOR j=-100 TO +100-DX STEP 2*DX x = j+100 GraBox( oPS, { X0 + x*KX, Y0+LY }, { X0 + (x+DX)*KX, Y0+LY+H_Wind } , GRA_FILL ) NEXT GraSetColor( oPS, aColor[222] , aColor[222] ) // Стиль линии сетки aAttr := ARRAY( GRA_AL_COUNT ) aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DOT aAttr [ GRA_AL_COLOR ] := GRA_CLR_PALEGRAY GraSetAttrLine( oPS, aAttr ) // Горизонтальная ось X Yx = Y0 + LY + (0-MIN_aData)*KY DX = 10 // Кол-во значений j, через которое ставить метку FOR j=-100 TO +100 x = j+100 X1 = X0 + x*KX // IF x=DX*INT(x/DX) // Если j делится на цело на DX, тогда рисовать надпись и сетку GraLine( oPS, {X1, Y0+LY }, {X1, Y0+LY+H_Wind} ) // Вертикальная сетка GraStringAt( oPS, { X1, Yx-14 }, ALLTRIM(STR(j,19))) ENDIF NEXT // Вертикальная ось Y // Надписи на вертикальной оси DY = (MAX_aData-MIN_aData)/NY // Диапазон значений j, через которое ставить метку FOR j = MIN_aData TO MAX_aData STEP DY X1 = X0+W_Wind/2 Y1 = Y0+LY + (j-MIN_aData)*KY MN = ALLTRIM(STR(j,19,1)) GraLine( oPS, {X0, Y1 }, {X0+W_Wind, Y1} ) // Горизонтальная сетка GraStringAt( oPS, { X1-7*LEN(MN)-5, Y1 }, MN ) NEXT j = MAX_aData X1 = X0+W_Wind/2 Y1 = Y0+LY + (j-MIN_aData)*KY MN = ALLTRIM(STR(j,19,1)) GraLine( oPS, {X0, Y1 }, {X0+W_Wind, Y1} ) // Горизонтальная сетка GraStringAt( oPS, { X1-7*LEN(MN)-5, Y1 }, MN ) // Рисование линий (стиль - сплошная толстая линия), ******** Задание цветов линий TP_color = 190 TN_color = 192 FP_color = 14 FN_color = 12 d1 = 6 // смещение нижней надписи d2 = 19 // смещение верхней надписи * aAttr [ GRA_AL_COLOR ] := aColor[TP_color] * aAttr [ GRA_AL_COLOR ] := aColor[TN_color] * aAttr [ GRA_AL_COLOR ] := aColor[FP_color] * aAttr [ GRA_AL_COLOR ] := aColor[FN_color] *********************************** ******* Ветвление по типам графиков *********************************** oFont := XbpFont():new():create("12.Arial") GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты DO CASE CASE mPar=1 .OR. mPar=2 // 1,2. TP,TN,FP,FN // ############################################################ *** Исходное частотное распределение уровней сходства TP-решений oFont := XbpFont():new():create("10.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 ) // Установить символьные атрибуты // Стиль линии aAttr := ARRAY( GRA_AL_COUNT ) aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии aAttr [ GRA_AL_COLOR ] := aColor[TP_color] aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_SOLID GraSetAttrLine( oPS, aAttr ) GraLine( oPS, {X0+500, Y0-6}, {X0+570, Y0-6 } ) GraStringAt( oPS, { X0+ 580, Y0-d1 }, L('Част.распр.ур.сх.истинно-положительных решений: (TP)' )) aAttr [ GRA_AL_WIDTH ] := IF(mWindow>1,1,3) // Задать толщину линии GraSetAttrLine( oPS, aAttr ) FOR j = 2 TO 101 X1 = X0 + W_Wind/2 + (j-2)*KX - 4 Y1 = Y0+LY + (aData_TP[j-1]-MIN_aData)*KY X2 = X0 + W_Wind/2 + (j-1)*KX - 4 Y2 = Y0+LY + (aData_TP[j]-MIN_aData)*KY GraLine( oPS, {X1, Y1}, {X2, Y2} ) NEXT ** Сглаженное частотное распределение уровней сходства TP-решений IF mWindow > 1 aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии GraSetAttrLine( oPS, aAttr ) FOR j = 2 TO 101 X1 = X0 + W_Wind/2 + (j-2)*KX - 4 Y1 = Y0+LY + (aAvrTP[j-1]-MIN_aData)*KY X2 = X0 + W_Wind/2 + (j-1)*KX - 4 Y2 = Y0+LY + (aAvrTP[j]-MIN_aData)*KY GraLine( oPS, {X1, Y1}, {X2, Y2} ) NEXT ENDIF *** Исходное частотное распределение уровней сходства TN-решений aAttr := ARRAY( GRA_AL_COUNT ) aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии aAttr [ GRA_AL_COLOR ] := aColor[TN_color] aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_SOLID GraSetAttrLine( oPS, aAttr ) GraLine( oPS, {X0+500, Y0-19}, {X0+570, Y0-19 } ) GraStringAt( oPS, { X0+ 580, Y0-d2 }, L("Част.распр.ур.сх.истинно-отрицательных решений: (TN)" )) aAttr [ GRA_AL_WIDTH ] := IF(mWindow>1,1,3) // Задать толщину линии GraSetAttrLine( oPS, aAttr ) FOR j = 2 TO 101 X1 = X0 + (j-2)*KX - 1 Y1 = Y0+LY + (aData_TN[j-1]-MIN_aData)*KY X2 = X0 + (j-1)*KX - 1 Y2 = Y0+LY + (aData_TN[j]-MIN_aData)*KY GraLine( oPS, {X1, Y1}, {X2, Y2} ) NEXT ** Сглаженное частотное распределение уровней сходства TN-решений IF mWindow > 1 aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии GraSetAttrLine( oPS, aAttr ) FOR j = 2 TO 101 X1 = X0 + (j-2)*KX - 1 Y1 = Y0+LY + (aAvrTN[j-1]-MIN_aData)*KY X2 = X0 + (j-1)*KX - 1 Y2 = Y0+LY + (aAvrTN[j]-MIN_aData)*KY GraLine( oPS, {X1, Y1}, {X2, Y2} ) NEXT ENDIF *** Исходное частотное распределение уровней сходства FP-решений // Стиль линии aAttr := ARRAY( GRA_AL_COUNT ) aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии aAttr [ GRA_AL_COLOR ] := aColor[FP_color] aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_SOLID GraSetAttrLine( oPS, aAttr ) GraLine( oPS, {X0, Y0-6}, {X0+70, Y0-6 } ) GraStringAt( oPS, { X0+80, Y0-d1 }, L("Част.распр.ур.сх.ложно-положительных решений: (FP)" )) aAttr [ GRA_AL_WIDTH ] := IF(mWindow>1,1,3) // Задать толщину линии GraSetAttrLine( oPS, aAttr ) FOR j = 2 TO 101 X1 = X0 + W_Wind/2 + (j-2)*KX - 4 Y1 = Y0+LY + (aData_FP[j-1]-MIN_aData)*KY X2 = X0 + W_Wind/2 + (j-1)*KX - 4 Y2 = Y0+LY + (aData_FP[j]-MIN_aData)*KY GraLine( oPS, {X1, Y1}, {X2, Y2} ) NEXT *** Сглаженное частотное распределение уровней сходства FP-решений IF mWindow > 1 aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии GraSetAttrLine( oPS, aAttr ) FOR j = 2 TO 101 X1 = X0 + W_Wind/2 + (j-2)*KX - 4 Y1 = Y0+LY + (aAvrFP[j-1]-MIN_aData)*KY X2 = X0 + W_Wind/2 + (j-1)*KX - 4 Y2 = Y0+LY + (aAvrFP[j]-MIN_aData)*KY GraLine( oPS, {X1, Y1}, {X2, Y2} ) NEXT ENDIF *** Исходное частотное распределение уровней сходства FN-решений // Стиль линии aAttr := ARRAY( GRA_AL_COUNT ) aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии aAttr [ GRA_AL_COLOR ] := aColor[FN_color] aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_SOLID GraSetAttrLine( oPS, aAttr ) GraLine( oPS, {X0, Y0-19}, {X0+70, Y0-19 } ) GraStringAt( oPS, { X0+80, Y0-d2 }, L("Част.распр.ур.сх.ложно-отрицательных решений: (FN)" )) aAttr [ GRA_AL_WIDTH ] := IF(mWindow>1,1,3) // Задать толщину линии GraSetAttrLine( oPS, aAttr ) FOR j = 2 TO 101 X1 = X0 + (j-2)*KX - 1 Y1 = Y0+LY + (aData_FN[j-1]-MIN_aData)*KY X2 = X0 + (j-1)*KX - 1 Y2 = Y0+LY + (aData_FN[j]-MIN_aData)*KY GraLine( oPS, {X1, Y1}, {X2, Y2} ) NEXT *** Сглаженное частотное распределение уровней сходства FN-решений IF mWindow > 1 aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии GraSetAttrLine( oPS, aAttr ) FOR j = 2 TO 101 X1 = X0 + (j-2)*KX - 1 Y1 = Y0+LY + (aAvrFN[j-1]-MIN_aData)*KY X2 = X0 + (j-1)*KX - 1 Y2 = Y0+LY + (aAvrFN[j]-MIN_aData)*KY GraLine( oPS, {X1, Y1}, {X2, Y2} ) NEXT // Поиск максимумов частотных распределений по сглаженным кривым, рисование линий максимумов, вычисление их расхождения и вывод надписи об этом <===############# mMaxY_TNFP = -9999 mMaxY_FNTP = -9999 mMaxX_TNFP = -9999 mMaxX_FNTP = -9999 FOR j=1 TO 201 IF aAvrTNFP[j] > mMaxY_TNFP mMaxY_TNFP = aAvrTNFP[j] mMaxX_TNFP = j ENDIF IF aAvrFNTP[j] > mMaxY_FNTP mMaxY_FNTP = aAvrFNTP[j] mMaxX_FNTP = j ENDIF NEXT cMaxX_TNFP = mMaxX_TNFP // Для рисования разности ур.сходства максимумов cMaxX_FNTP = mMaxX_FNTP mMaxX_TNFP = X0 + mMaxX_TNFP * KX - 10 // -10 <===####### ???????? mMaxX_FNTP = X0 + mMaxX_FNTP * KX - 10 mMaxY_TNFP = Y0 + LY + mMaxY_TNFP * KY mMaxY_FNTP = Y0 + LY + mMaxY_FNTP * KY Yx = Y0 + LY + (0-MIN_aData) * KY aAttr := ARRAY( GRA_AL_COUNT ) aAttr [ GRA_AL_WIDTH ] := GRA_LINEWIDTH_THICK aAttr [ GRA_AL_COLOR ] := aColor[109] aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DOT aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии GraSetAttrLine( oPS, aAttr ) GraLine( oPS, {mMaxX_TNFP, Yx}, {mMaxX_TNFP, mMaxY_TNFP} ) GraLine( oPS, {mMaxX_FNTP, Yx}, {mMaxX_FNTP, mMaxY_FNTP} ) ***** Корреляция частотных распределений TNFP, FNTP ******************************** ***** Расчет среднего и дисперсии сглаженных массивов aAvrTNFP и aAvrFNTP mSumTNFP = 0 mSumFNTP = 0 FOR j=1 TO 201 mSumTNFP = mSumTNFP + aAvrTNFP[j] mSumFNTP = mSumFNTP + aAvrFNTP[j] NEXT mSrTNFP = mSumTNFP/201 mSrFNTP = mSumFNTP/201 mDiTNFP = 0 mDiFNTP = 0 FOR j=1 TO 201 mDiTNFP = mDiTNFP + ( mSrTNFP - aAvrTNFP[j]) ^ 2 mDiFNTP = mDiFNTP + ( mSrFNTP - aAvrFNTP[j]) ^ 2 NEXT mDiTNFP = SQRT( mDiTNFP / (201 - 1)) mDiFNTP = SQRT( mDiFNTP / (201 - 1)) mKov = 0 FOR j=1 TO 201 mKov = mKov + (aAvrTNFP[j] - mSrTNFP) * (aAvrFNTP[j] - mSrFNTP) NEXT mKov = 100 * mKov / 201 mKorr = mKov / (mDiTNFP * mDiFNTP ) GraStringAt( oPS, { X0+1035 , Y0-d1 }, L('Корреляция частотных распределений TNFP, FNTP:') +' ' +ALLTRIM(STR(mKorr,7,1))+' %') GraStringAt( oPS, { X0+1035 , Y0-d2 }, L('Разн.мод.уровн.сход. MAX част.распр.TNFP, FNTP:')+' '+ALLTRIM(STR(ABS(cMaxX_FNTP)-ABS(cMaxX_TNFP),7,1))+' %') oFont := XbpFont():new():create("8.Arial Bold") GraSetFont(oPS , oFont) // установить шрифт aAttrF := ARRAY( GRA_AS_COUNT ) aAttrF [ GRA_AS_COLOR ] := aColor[109] aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода aAttrF [ GRA_AS_VERTALIGN ] := GRA_VALIGN_HALF // Выравнивание символов по вертикали по средней линии относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraStringAt( oPS, { mMaxX_TNFP, Yx-25 }, ALLTRIM(STR(ROUND(cMaxX_TNFP-100,0)))) GraStringAt( oPS, { mMaxX_FNTP, Yx-25 }, ALLTRIM(STR(ROUND(cMaxX_FNTP-100,0)))) ENDIF CASE mPar=3 .OR. mPar=4 // 3,4. (TP-FP), (TN-FN) // ############################################################ oFont := XbpFont():new():create("10.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 ) // Установить символьные атрибуты // Стиль линии aAttr := ARRAY( GRA_AL_COUNT ) aAttr [ GRA_AL_WIDTH ] := GRA_LINEWIDTH_THICK aAttr [ GRA_AL_COLOR ] := aColor[TP_color] aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_SOLID aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии GraSetAttrLine( oPS, aAttr ) GraLine( oPS, {X0, Y0-6}, {X0+70, Y0-6 } ) GraStringAt( oPS, { X0+80, Y0-d1 }, L('Разность количества истинных и ложных положительных решений (TP-FP) при разных уровнях сходства' )) aAttr [ GRA_AL_WIDTH ] := IF(mWindow>1,1,3) // Задать толщину линии GraSetAttrLine( oPS, aAttr ) FOR j = 2 TO LEN(aData_TP) X1 = X0 + W_Wind/2 + (j-2)*KX - 4 Y1 = Y0 + LY + ((aData_TP[j-1]-aData_FP[j-1])-MIN_aData)*KY X2 = X0 + W_Wind/2 + (j-1)*KX - 4 Y2 = Y0 + LY + ((aData_TP[j ]-aData_FP[j ])-MIN_aData)*KY GraLine( oPS, {X1, Y1}, {X2, Y2} ) NEXT IF mWindow > 1 aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии GraSetAttrLine( oPS, aAttr ) FOR j = 2 TO LEN(aData_TP) X1 = X0 + W_Wind/2 + (j-2)*KX - 4 Y1 = Y0 + LY + ((aAvrTP[j-1]-aAvrFP[j-1])-MIN_aData)*KY X2 = X0 + W_Wind/2 + (j-1)*KX - 4 Y2 = Y0 + LY + ((aAvrTP[j ]-aAvrFP[j ])-MIN_aData)*KY GraLine( oPS, {X1, Y1}, {X2, Y2} ) NEXT ENDIF aAttr := ARRAY( GRA_AL_COUNT ) aAttr [ GRA_AL_WIDTH ] := GRA_LINEWIDTH_THICK aAttr [ GRA_AL_COLOR ] := aColor[FN_color] aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_SOLID aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии GraSetAttrLine( oPS, aAttr ) GraLine( oPS, {X0, Y0-19}, {X0+70, Y0-19 } ) GraStringAt( oPS, { X0+80, Y0-d2 }, L('Разность количества истинных и ложных отрицательных решений (TN-FN) при разных уровнях сходства' )) aAttr [ GRA_AL_WIDTH ] := IF(mWindow>1,1,3) // Задать толщину линии GraSetAttrLine( oPS, aAttr ) FOR j = 2 TO LEN(aData_TN) X1 = X0 + (j-2)*KX - 1 Y1 = Y0+LY + ((aData_TN[j-1]-aData_FN[j-1])-MIN_aData)*KY X2 = X0 + (j-1)*KX - 1 Y2 = Y0+LY + ((aData_TN[j ]-aData_FN[j ])-MIN_aData)*KY GraLine( oPS, {X1, Y1}, {X2, Y2} ) NEXT IF mWindow > 1 aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии GraSetAttrLine( oPS, aAttr ) FOR j = 2 TO LEN(aData_TN) X1 = X0 + (j-2)*KX - 1 Y1 = Y0+LY + ((aAvrTN[j-1]-aAvrFN[j-1])-MIN_aData)*KY X2 = X0 + (j-1)*KX - 1 Y2 = Y0+LY + ((aAvrTN[j ]-aAvrFN[j ])-MIN_aData)*KY GraLine( oPS, {X1, Y1}, {X2, Y2} ) NEXT ENDIF CASE mPar=5 .OR. mPar=6 // 5,6. (TP-FP)/(TP+FP)*100, (TN-FN)/(TN+FN)*100 // ############################################################ oFont := XbpFont():new():create("10.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 ) // Установить символьные атрибуты // Стиль линии aAttr := ARRAY( GRA_AL_COUNT ) aAttr [ GRA_AL_WIDTH ] := GRA_LINEWIDTH_THICK aAttr [ GRA_AL_COLOR ] := aColor[TP_color] aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_SOLID aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии GraSetAttrLine( oPS, aAttr ) GraLine( oPS, {X0, Y0-6}, {X0+70, Y0-6 } ) GraStringAt( oPS, { X0+80, Y0-d1 }, L('Разность количества положительных истинных и ложных решений в % от их суммарного количества при разных уровнях сходства: (TP-FP)/(TP+FP)*100' )) aAttr [ GRA_AL_WIDTH ] := IF(mWindow>1,1,3) // Задать толщину линии GraSetAttrLine( oPS, aAttr ) FOR j = 2 TO LEN(aData_TP) X1 = X0 + W_Wind/2 + (j-2)*KX - 4 Y1 = Y0 + LY + ((aData_TP[j-1]-aData_FP[j-1])/(aData_TP[j-1]+aData_FP[j-1])*100-MIN_aData)*KY X2 = X0 + W_Wind/2 + (j-1)*KX - 4 Y2 = Y0 + LY + ((aData_TP[j ]-aData_FP[j ])/(aData_TP[j ]+aData_FP[j ])*100-MIN_aData)*KY GraLine( oPS, {X1, Y1}, {X2, Y2} ) NEXT IF mWindow > 1 aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии GraSetAttrLine( oPS, aAttr ) FOR j = 2 TO LEN(aData_TP) X1 = X0 + W_Wind/2 + (j-2)*KX - 4 Y1 = Y0 + LY + ((aAvrTP[j-1]-aAvrFP[j-1])/(aAvrTP[j-1]+aAvrFP[j-1])*100-MIN_aData)*KY X2 = X0 + W_Wind/2 + (j-1)*KX - 4 Y2 = Y0 + LY + ((aAvrTP[j ]-aAvrFP[j ])/(aAvrTP[j ]+aAvrFP[j ])*100-MIN_aData)*KY GraLine( oPS, {X1, Y1}, {X2, Y2} ) NEXT ENDIF aAttr := ARRAY( GRA_AL_COUNT ) aAttr [ GRA_AL_WIDTH ] := GRA_LINEWIDTH_THICK aAttr [ GRA_AL_COLOR ] := aColor[FN_color] aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_SOLID aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии GraSetAttrLine( oPS, aAttr ) GraLine( oPS, {X0, Y0-19}, {X0+70, Y0-19 } ) GraStringAt( oPS, { X0+80, Y0-d2 }, L('Разность количества отрицательных истинных и ложных решений в % от их суммарного количества при разных уровнях сходства: (TN-FN)/(TN+FN)*100' )) aAttr [ GRA_AL_WIDTH ] := IF(mWindow>1,1,3) // Задать толщину линии GraSetAttrLine( oPS, aAttr ) FOR j = 2 TO LEN(aData_TN) X1 = X0 + (j-2)*KX - 1 Y1 = Y0+LY + ((aData_TN[j-1]-aData_FN[j-1])/(aData_TN[j-1]+aData_FN[j-1])*100-MIN_aData)*KY X2 = X0 + (j-1)*KX - 1 Y2 = Y0+LY + ((aData_TN[j ]-aData_FN[j ])/(aData_TN[j ]+aData_FN[j ])*100-MIN_aData)*KY GraLine( oPS, {X1, Y1}, {X2, Y2} ) NEXT IF mWindow > 1 aAttr [ GRA_AL_WIDTH ] := 3 // Задать толщину линии GraSetAttrLine( oPS, aAttr ) FOR j = 2 TO LEN(aData_TN) X1 = X0 + (j-2)*KX - 1 Y1 = Y0+LY + ((aAvrTN[j-1]-aAvrFN[j-1])/(aAvrTN[j-1]+aAvrFN[j-1])*100-MIN_aData)*KY X2 = X0 + (j-1)*KX - 1 Y2 = Y0+LY + ((aAvrTN[j ]-aAvrFN[j ])/(aAvrTN[j ]+aAvrFN[j ])*100-MIN_aData)*KY GraLine( oPS, {X1, Y1}, {X2, Y2} ) NEXT ENDIF ENDCASE oFont := XbpFont():new():create("10.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, { X0+1475, Y0-d1 }, L('Форма создана:')+' '+DTOC(DATE())+"-"+TIME()) IF mWindow > 1 GraStringAt( oPS, { X0+1475, Y0-d2 }, L('Интервал сглаживания =')+' '+ALLTRIM(STR(mWindow))) ELSE GraStringAt( oPS, { X0+1475, Y0-d2 }, L('Без сглаживания')) ENDIF // Начертить РАМКУ области построения графика aAttr := Array( GRA_AL_COUNT ) // атрибуты линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_SOLID * aAttr [ GRA_AL_COLOR ] := GRA_CLR_RED aAttr [ GRA_AL_COLOR ] := GRA_CLR_BLACK aAttr [ GRA_AL_WIDTH ] := 2 // Задать толщину линии GraSetAttrLine( oPS, aAttr ) GraBox( oPS, {X0-1, Y0+LY-1}, {X0+W_Wind+1, Y0+LY+H_Wind+1} ) aAttrF [ GRA_AS_HORIZALIGN ] := GRA_HALIGN_CENTER // Выравнивание символов по горизонтали по центру относительно точки начала вывода GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты // Стиль линии рамки aAttr := ARRAY( GRA_AL_COUNT ) aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_SOLID aAttr [ GRA_AL_WIDTH ] := GRA_LINEWIDTH_NORMAL aAttr [ GRA_AL_COLOR ] := GRA_CLR_BLACK aAttr [ GRA_AL_WIDTH ] := 2 // Задать толщину линии GraSetAttrLine( oPS, aAttr ) ** GraLine( oPS, {X0, Y0+LY-1 }, {X0, Y0+LY+H_Wind} ) // Левая вертикальная граница рамки ** GraLine( oPS, {X0+W_Wind, Y0+LY }, {X0+W_Wind, Y0+LY+H_Wind} ) // Правая вертикальная граница рамки * j = MIN_aData * Y1 = Y0+LY + (j-MIN_aData)*KY - 1 ** GraLine( oPS, {X0, Y1 }, {X0+W_Wind, Y1} ) // Нижняя горизонтальная граница рамки * j = MAX_aData * Y1 = Y0+LY + (j-MIN_aData)*KY + 1 ** GraLine( oPS, {X0, Y1 }, {X0+W_Wind, Y1} ) // Верхняя горизонтальная граница рамки. Сюда надо сверху еще впихнуть название диаграммы // Ось X начертить на 0-м уровне Yx = Y0 + LY + (0-MIN_aData)*KY GraLine( oPS, {X0, Yx}, {X0+W_Wind, Yx} ) // Ось X // Ось Y начертить на 0-м уровне X1 = X0 + 100*KX GraLine( oPS, {X1, Y0+LY }, {X1, Y0+LY+H_Wind } ) // Ось Y // Надписи на вертикальной оси Y DY = (MAX_aData-MIN_aData)/NY // Диапазон значений j, через которое ставить метку FOR j = MIN_aData TO MAX_aData STEP DY X1 = X0+W_Wind/2 Y1 = Y0+LY + (j-MIN_aData)*KY MN = ALLTRIM(STR(j,19,1)) GraStringAt( oPS, { X1-7*LEN(MN)-5, Y1 }, MN ) NEXT j = MAX_aData X1 = X0+W_Wind/2 Y1 = Y0+LY + (j-MIN_aData)*KY MN = ALLTRIM(STR(j,19,1)) GraLine( oPS, {X0, Y1 }, {X0+W_Wind, Y1} ) // Горизонтальная сетка GraStringAt( oPS, { X1-7*LEN(MN)-5, Y1 }, MN ) *********************************************************** ******* Наименование диаграммы. Ветвление по типам графиков *********************************************************** DO CASE CASE mPar=1 // 1,2. TP,TN,FP,FN // ############################################################ mTitle = L('Число TP,TN,FP,FN решений в модели:')+' '+SUBSTR(M_Name,1,7)+L(', интегральный критерий - резонанс знаний') CASE mPar=2 // 1,2. TP,TN,FP,FN // ############################################################ mTitle = L('Число TP,TN,FP,FN решений в модели:')+' '+SUBSTR(M_Name,1,7)+L(', интегральный критерий - сумма знаний') CASE mPar=3 // 3,4. (TP-FP), (TN-FN) // ############################################################ mTitle = L('Число (TP-FP),(TN-FN) решений в модели:')+' '+SUBSTR(M_Name,1,7)+L(', интегральный критерий - резонанс знаний') CASE mPar=4 // 3,4. (TP-FP), (TN-FN) // ############################################################ mTitle = L('Число (TP-FP),(TN-FN) решений в модели:')+' '+SUBSTR(M_Name,1,7)+L(', интегральный критерий - сумма знаний') CASE mPar=5 // 5,6. (TP-FP)/(TP+FP)*100, (TN-FN)/(TN+FN)*100 // ############################################################ mTitle = L('Число (TP-FP)/(TP+FP)*100, (TN-FN)/(TN+FN)*100 решений в модели:')+' '+SUBSTR(M_Name,1,7)+L(', интегральный критерий - резонанс знаний') CASE mPar=6 // 5,6. (TP-FP)/(TP+FP)*100, (TN-FN)/(TN+FN)*100 // ############################################################ mTitle = L('Число (TP-FP)/(TP+FP)*100, (TN-FN)/(TN+FN)*100 решений в модели:')+' '+SUBSTR(M_Name,1,7)+L(', интегральный критерий - сумма знаний') ENDCASE 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, { W_Wind/2, Y_MaxW - 20 }, 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 ) // Установить символьные атрибуты IF LEN(ALLTRIM(M_NameAppl)) < 70 GraStringAt( oPS, { W_Wind/2, Y_MaxW - 50 }, "Приложение: "+'"'+ALLTRIM(M_NameAppl)+'."' ) ELSE GraStringAt( oPS, { W_Wind/2, Y_MaxW - 50 }, '"'+ALLTRIM(M_NameAppl)+'"' ) ENDIF RETURN NIL *********************************************************************************************************** *********************************************************************************************************** ******** 4.1.3.10.Достоверность идент. классов при разных моделях и инт.крит. ******** Отображается достоверность идентификации объектов по классам при разных моделях ******** (т.е. разных частных критериях) и при разных интегральных критериях из БД: Dost_clsF.dbf *********************************************************************************************************** FUNCTION F4_1_3_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.1.3.10()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Dost_clsF EXCLUSIVE NEW SELECT Dost_clsF SET FILTER TO Dost_clsF->Max_dost > 0 DBGOTOP() M_MaxDost = -9999999999 M_MaxLCls = -9999999999 DO WHILE .NOT. EOF() M_MaxDost = MAX(M_MaxDost, Dost_clsF->Max_dost) M_MaxLCls = MAX(M_MaxLCls, LEN(ALLTRIM(Dost_clsF->Name_cls))) DBSKIP(1) ENDDO DBGOTOP() /* ----- Create ToolBar ----- */ @ 32.5, 1 DCTOOLBAR oToolBar SIZE 231, 1.5 // Строка + 1.5 DCADDBUTTON CAPTION L('Помощь') ; SIZE 4+LEN(L("Помощь")) ; ACTION {||Help4136(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Помощь по режиму 4.1.3.10') DCADDBUTTON CAPTION L('Сортировка по убыванию F-меры') ; SIZE 4+LEN(L("Сортировка по убыванию F-меры")) ; ACTION {||Sort41310F(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Помощь по режиму 4.1.3.9') DCADDBUTTON CAPTION L('Сортировка по коду объекта') ; SIZE 4+LEN(L("Сортировка по коду объекта")) ; ACTION {||Sort41310K(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Помощь по режиму 4.1.3.9') /* ----- Create browse ----- */ 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 PRIVATE bColorBlock:={|| iif(Dost_clsF->Max_Dost=M_MaxDost,{GRA_CLR_RED,nil},iif(Dost_clsF->Max_Dost=0,{GRA_CLR_WHITE,nil},{GRA_CLR_BLACK,nil})) } // Клиффорд *PRIVATE bColorBlock:={|| iif(Dost_clsF->Max_Dost=M_MaxDost,{GRA_CLR_RED,nil},iif(Dost_clsF->Max_Dost=0,{GRA_CLR_BLACK,nil},{GRA_CLR_WHITE,nil})) } // Клиффорд @ 1, 0 DCBROWSE oBrowse ALIAS 'Dost_clsF' SIZE 231,31 ; PRESENTATION LC_BrowPres() ; // Только просмотр БД Users HEADLINES 6 ; // Кол-во строк в заголовке * FREEZELEFT {1,5} ; // При горизонтальной прокрутке не прокручивать первые 5 колонок DCBROWSECOL DATA FldAnchINT(1) HEADER L("Код;класса" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 9 DCBROWSECOL FIELD Dost_clsF->Name_cls HEADER L("Наименование;класса" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH M_MaxLCls+1 DCBROWSECOL DATA FieldAnchor(3,9,3) HEADER L("MAX;досто-;верность" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 9 DCBROWSECOL FIELD Dost_clsF->Mod_MaxD HEADER L("Модель;с MAX;досто-;верностью" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 15 DCBROWSECOL FIELD Dost_clsF->IKR_MaxD HEADER L("Интегр.;критерий;с MAX;досто-;верностью" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 15 DCBROWSECOL DATA FieldAnchor( 6,9,3) HEADER L("Модель:;ABS, ;интегр.;критер.:;РЕЗОНАНС;ЗНАНИЙ") PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 9 DCBROWSECOL DATA FieldAnchor( 7,9,3) HEADER L("Модель:;PRC1,;интегр.;критер.:;РЕЗОНАНС;ЗНАНИЙ") PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 9 DCBROWSECOL DATA FieldAnchor( 8,9,3) HEADER L("Модель:;PRC2,;интегр.;критер.:;РЕЗОНАНС;ЗНАНИЙ") PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 9 DCBROWSECOL DATA FieldAnchor( 9,9,3) HEADER L("Модель:;INF1,;интегр.;критер.:;РЕЗОНАНС;ЗНАНИЙ") PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 9 DCBROWSECOL DATA FieldAnchor(10,9,3) HEADER L("Модель:;INF2,;интегр.;критер.:;РЕЗОНАНС;ЗНАНИЙ") PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 9 DCBROWSECOL DATA FieldAnchor(11,9,3) HEADER L("Модель:;INF3,;интегр.;критер.:;РЕЗОНАНС;ЗНАНИЙ") PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 9 DCBROWSECOL DATA FieldAnchor(12,9,3) HEADER L("Модель:;INF4,;интегр.;критер.:;РЕЗОНАНС;ЗНАНИЙ") PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 9 DCBROWSECOL DATA FieldAnchor(13,9,3) HEADER L("Модель:;INF5,;интегр.;критер.:;РЕЗОНАНС;ЗНАНИЙ") PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 9 DCBROWSECOL DATA FieldAnchor(14,9,3) HEADER L("Модель:;INF6,;интегр.;критер.:;РЕЗОНАНС;ЗНАНИЙ") PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 9 DCBROWSECOL DATA FieldAnchor(15,9,3) HEADER L("Модель:;INF7,;интегр.;критер.:;РЕЗОНАНС;ЗНАНИЙ") PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 9 DCBROWSECOL DATA FieldAnchor(16,9,3) HEADER L("Модель:;ABS, ;интегр.;критер.:;СУММА;ЗНАНИЙ" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 9 DCBROWSECOL DATA FieldAnchor(17,9,3) HEADER L("Модель:;PRC1,;интегр.;критер.:;СУММА;ЗНАНИЙ" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 9 DCBROWSECOL DATA FieldAnchor(18,9,3) HEADER L("Модель:;PRC2,;интегр.;критер.:;СУММА;ЗНАНИЙ" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 9 DCBROWSECOL DATA FieldAnchor(19,9,3) HEADER L("Модель:;INF1,;интегр.;критер.:;СУММА;ЗНАНИЙ" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 9 DCBROWSECOL DATA FieldAnchor(20,9,3) HEADER L("Модель:;INF2,;интегр.;критер.:;СУММА;ЗНАНИЙ" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 9 DCBROWSECOL DATA FieldAnchor(21,9,3) HEADER L("Модель:;INF3,;интегр.;критер.:;СУММА;ЗНАНИЙ" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 9 DCBROWSECOL DATA FieldAnchor(22,9,3) HEADER L("Модель:;INF4,;интегр.;критер.:;СУММА;ЗНАНИЙ" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 9 DCBROWSECOL DATA FieldAnchor(23,9,3) HEADER L("Модель:;INF5,;интегр.;критер.:;СУММА;ЗНАНИЙ" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 9 DCBROWSECOL DATA FieldAnchor(24,9,3) HEADER L("Модель:;INF6,;интегр.;критер.:;СУММА;ЗНАНИЙ" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 9 DCBROWSECOL DATA FieldAnchor(25,9,3) HEADER L("Модель:;INF7,;интегр.;критер.:;СУММА;ЗНАНИЙ" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 9 DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; OPTIONS GetOptions ; MODAL ; TITLE L('4.1.3.10. F-мера (качество) идентификации классов при разных моделях и интегральных критериях. Текущая модель: "')+UPPER(Ar_Model[M_CurrInf])+'"'; FIT ; CLEAREVENTS ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) ReTURN nil *********************************************************************************************************** ******** Сортировка классов по убыванию F-меры FUNCTION Sort41310F() INDEX ON STR(9999999.9999999-Dost_clsF->Max_dost,19,7) TO Dost_Fcls ReTURN nil ******** Сортировка классов по возрастанию кода классов FUNCTION Sort41310K() INDEX ON STR(kod_cls,15) TO Dost_Kcls ReTURN nil *********************************************************************************************************** ******** 4.1.3.9.Достоверность идент. объектов при разных моделях и инт.крит. ******** Отображается достоверность идентификации объектов по классам при разных моделях ******** (т.е. разных частных критериях) и при разных интегральных критериях из БД: Dost_objF.dbf *********************************************************************************************************** FUNCTION F4_1_3_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.1.3.9()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций IF FILE("Inp_data.DBF") CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Inp_data EXCLUSIVE NEW COPY STRUCTURE TO Inp_data_del.dbf CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Inp_data EXCLUSIVE NEW;N_Obj = RECCOUNT() // Кол-во объектов обучающей выборки USE Inp_data_del EXCLUSIVE NEW // База данных для удаленных объектов ENDIF USE Dost_objF EXCLUSIVE NEW SELECT Dost_objF DBGOTOP() M_MaxDost = -9999999999 DO WHILE .NOT. EOF() M_MaxDost = MAX(M_MaxDost, Dost_objF->Max_dost) DBSKIP(1) ENDDO DBGOTOP() /* ----- Create ToolBar ----- */ @ 32.5, 1 DCTOOLBAR oToolBar SIZE 231, 1.5 // Строка + 1.5 DCADDBUTTON CAPTION L('Помощь') ; SIZE 4+LEN(L("Помощь")) ; ACTION {||Help4136(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Помощь по режиму 4.1.3.9') DCADDBUTTON CAPTION L('Сортировка по убыванию F-меры') ; SIZE 4+LEN(L("Сортировка по убыванию F-меры")) ; ACTION {||Sort4139F(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Помощь по режиму 4.1.3.9') DCADDBUTTON CAPTION L('Сортировка по коду объекта') ; SIZE 4+LEN(L("Сортировка по коду объекта")) ; ACTION {||Sort4139K(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Помощь по режиму 4.1.3.9') IF FILE("Inp_data.DBF") DCADDBUTTON CAPTION L('Удалить объекты с F-меройMax_Dost=M_MaxDost,{GRA_CLR_RED,nil},iif(Dost_objF->Max_Dost=0,{GRA_CLR_WHITE,nil},{GRA_CLR_BLACK,nil})) } // Клиффорд @ 1, 0 DCBROWSE oBrowse ALIAS 'Dost_objF' SIZE 231,31 ; PRESENTATION LC_BrowPres() ; // Только просмотр БД Users HEADLINES 6 ; // Кол-во строк в заголовке DCBROWSECOL DATA FldAnchINT(1) HEADER L("Код;класса" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 9 DCBROWSECOL FIELD Dost_objF->Name_obj HEADER L("Наименование объекта;распознаваемой выборки" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 40 DCBROWSECOL DATA FieldAnchor(3,9,3) HEADER L("MAX;досто-;верность" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 10 DCBROWSECOL FIELD Dost_objF->Mod_MaxD HEADER L("Модель;с MAX;досто-;верностью" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 10 DCBROWSECOL FIELD Dost_objF->IKR_MaxD HEADER L("Интегр.;критерий;с MAX;досто-;верностью" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 10 DCBROWSECOL DATA FieldAnchor( 6,9,3) HEADER L("Модель:;ABS, ;интегр.;критер.:;РЕЗОНАНС;ЗНАНИЙ") PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 9 DCBROWSECOL DATA FieldAnchor( 7,9,3) HEADER L("Модель:;PRC1,;интегр.;критер.:;РЕЗОНАНС;ЗНАНИЙ") PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 9 DCBROWSECOL DATA FieldAnchor( 8,9,3) HEADER L("Модель:;PRC2,;интегр.;критер.:;РЕЗОНАНС;ЗНАНИЙ") PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 9 DCBROWSECOL DATA FieldAnchor( 9,9,3) HEADER L("Модель:;INF1,;интегр.;критер.:;РЕЗОНАНС;ЗНАНИЙ") PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 9 DCBROWSECOL DATA FieldAnchor(10,9,3) HEADER L("Модель:;INF2,;интегр.;критер.:;РЕЗОНАНС;ЗНАНИЙ") PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 9 DCBROWSECOL DATA FieldAnchor(11,9,3) HEADER L("Модель:;INF3,;интегр.;критер.:;РЕЗОНАНС;ЗНАНИЙ") PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 9 DCBROWSECOL DATA FieldAnchor(12,9,3) HEADER L("Модель:;INF4,;интегр.;критер.:;РЕЗОНАНС;ЗНАНИЙ") PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 9 DCBROWSECOL DATA FieldAnchor(13,9,3) HEADER L("Модель:;INF5,;интегр.;критер.:;РЕЗОНАНС;ЗНАНИЙ") PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 9 DCBROWSECOL DATA FieldAnchor(14,9,3) HEADER L("Модель:;INF6,;интегр.;критер.:;РЕЗОНАНС;ЗНАНИЙ") PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 9 DCBROWSECOL DATA FieldAnchor(15,9,3) HEADER L("Модель:;INF7,;интегр.;критер.:;РЕЗОНАНС;ЗНАНИЙ") PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 9 DCBROWSECOL DATA FieldAnchor(16,9,3) HEADER L("Модель:;ABS, ;интегр.;критер.:;СУММА;ЗНАНИЙ" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 9 DCBROWSECOL DATA FieldAnchor(17,9,3) HEADER L("Модель:;PRC1,;интегр.;критер.:;СУММА;ЗНАНИЙ" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 9 DCBROWSECOL DATA FieldAnchor(18,9,3) HEADER L("Модель:;PRC2,;интегр.;критер.:;СУММА;ЗНАНИЙ" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 9 DCBROWSECOL DATA FieldAnchor(19,9,3) HEADER L("Модель:;INF1,;интегр.;критер.:;СУММА;ЗНАНИЙ" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 9 DCBROWSECOL DATA FieldAnchor(20,9,3) HEADER L("Модель:;INF2,;интегр.;критер.:;СУММА;ЗНАНИЙ" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 9 DCBROWSECOL DATA FieldAnchor(21,9,3) HEADER L("Модель:;INF3,;интегр.;критер.:;СУММА;ЗНАНИЙ" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 9 DCBROWSECOL DATA FieldAnchor(22,9,3) HEADER L("Модель:;INF4,;интегр.;критер.:;СУММА;ЗНАНИЙ" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 9 DCBROWSECOL DATA FieldAnchor(23,9,3) HEADER L("Модель:;INF5,;интегр.;критер.:;СУММА;ЗНАНИЙ" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 9 DCBROWSECOL DATA FieldAnchor(24,9,3) HEADER L("Модель:;INF6,;интегр.;критер.:;СУММА;ЗНАНИЙ" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 9 DCBROWSECOL DATA FieldAnchor(25,9,3) HEADER L("Модель:;INF7,;интегр.;критер.:;СУММА;ЗНАНИЙ" ) PARENT oBrowse FONT "9.Courier" COLOR bColorBlock WIDTH 9 DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; OPTIONS GetOptions ; MODAL ; TITLE L('4.1.3.9. F-мера (качество) идентификации объектов при разных моделях и интегральных критериях. Текущая модель: "')+UPPER(Ar_Model[M_CurrInf])+'"'; FIT ; CLEAREVENTS ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) ReTURN nil ********************************************************************************************************** ******** Сортировка объектов по убыванию F-меры FUNCTION Sort4139F() INDEX ON STR(9999999.9999999-Max_dost,19,7) TO Dost_Fobj ReTURN nil ******** Сортировка объектов по возрастанию кода объекта FUNCTION Sort4139K() INDEX ON STR(kod_obj,15) TO Dost_Kobj ReTURN nil ************************************************** ******** Удалить из обучающей выборки все объекты, ******** у которых F-мера минимальна ************************************************** FUNCTION Sort4139D() SET ORDER TO DBGOBOTTOM() mFmeraMin = Max_dost ********************************************************************************************* @0,0 DCGROUP oGroup1 CAPTION L('Задайте минимальное допустимое значение F-меры:') SIZE 47.0, 2.5 @1,2 DCSAY L("F-мера:") GET mFmeraMin PICTURE "#.#######" PARENT oGroup1 DCREAD GUI; TO lExit ; FIT; ADDBUTTONS; MODAL; TITLE L("Режим 4.1.3.9.") IF lExit ** Button Ok ELSE ADS_SERVER_QUIT() QUIT ENDIF ********************************************************************************************* ***** Сформировать массив кодов удаляемых объектов INDEX ON STR(9999999.9999999-Max_dost,19,7) TO Dost_Fobj aDel := {} DBGOTOP() DO WHILE .NOT. EOF() IF Max_dost < mFmeraMin AADD(aDel, Kod_obj) ENDIF DBSKIP(1) ENDDO ****** Переписать все данные по уаляемым объектам из Inp_data в Inp_data_del ****** и пометить удаляемые записи FOR j=1 TO LEN(aDel) SELECT Inp_data DBGOTO(aDel[j]) ar := {} FOR i=1 TO FCOUNT() AADD(ar, FIELDGET(i)) NEXT DELETE SELECT Inp_data_del APPEND BLANK FOR i=1 TO LEN(ar) FIELDPUT(i, ar[i]) NEXT NEXT SELECT Inp_data PACK // Удаление SELECT Dost_objF SET ORDER TO FOR j=1 TO LEN(aDel) DELETE FOR Kod_obj = aDel[j] NEXT PACK CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций Name_SS = M_PathAppl+"\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) ***** Восстановление среды CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Inp_data EXCLUSIVE NEW;N_Obj = RECCOUNT() // Кол-во объектов обучающей выборки USE Inp_data_del EXCLUSIVE NEW // База данных для удаленных объектов USE Dost_objF EXCLUSIVE NEW SELECT Dost_objF DBGOTOP() **** Автоматическое формирование параметров для режима 2.3.2.2. IF .NOT. FILE("_2_3_2_2.arx") LB_Warning(L("Не был выполнен режим 2.3.2.2."), L("Режим 4.1.3.9." )) ELSE aSoftInt = DC_ARestore(M_PathAppl+"\_2_3_2_2.arx") 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 aMess := {} AADD(aMess, L('Из обучающей выборки: ')+Disk_dir+L('\AID_DATA\Inp_data\Inp_data.dbf удалено')+' '+ALLTRIM(STR(LEN(aDel)))+' '+L('объектов,')) AADD(aMess, L('у которых при идентификации в лучшей модели F-мера оказалась меньше, чем:')+' '+ALLTRIM(STR(mFmeraMin,15,7))+'.') AADD(aMess, L('Вся информация об удаленных объектах находится в файле:')+' '+M_PathAppl+'\Inp_data_del.dbf.') AADD(aMess, L(' ')) AADD(aMess, L('Теперь необходимо запустить режим 2.3.2.2 с параметрами по умолчанию,')) AADD(aMess, L('(с загрузкой исходных данных из Inp_data.dbf), а затем выполнить режим 3.5.')) AADD(aMess, L(' ')) AADD(aMess, L('Эту процедуру удаления ниболее плохо распознаваемых объектов можно повторять.')) LB_Warning(aMess, L("Режим 4.1.3.9." )) ReTURN nil ********************************************************************************************************** ******** 5.14. Пояснения по частн.и инт.критериям и лаб.работам ********************************************************************************************************** FUNCTION F5_14() LOCAL GetList[0], lOk Running(.T.) DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы @0, 0 DCGROUP oGroup1 CAPTION L('Пояснения по смыслу частных и интегральных критериев') SIZE 100.5, 2.6 p=3 @ 1, P DCPUSHBUTTON ; CAPTION L('Частные критерии моделей знаний') ; SIZE LEN(L('Частные критерии моделей знаний'))+4, 1 ; PARENT oGroup1 ; ACTION {||Help33()} p=p+LEN(L('Частные критерии моделей знаний'))+8 @ 1, p DCPUSHBUTTON ; CAPTION L('Интегральные критерии') ; PARENT oGroup1 ; SIZE LEN(L('Интегральные критерии'))+4, 1 ; ACTION {||Help4131c()} p=p+LEN(L('Интегральные критерии'))+8 @ 1, p DCPUSHBUTTON ; CAPTION L('ЧатБот "Эйдос"') ; SIZE LEN(L('ЧатБот "Эйдос"'))+4, 1 ; PARENT oGroup1 ; ACTION {||LC_RunUrl("https://ora.ai/eugene-lutsenko/aidos")} @3, 0 DCGROUP oGroup2 CAPTION L('Описания лабораторных работ') SIZE 100.5, 32.3 D1=0.9 // Межстрочный интервал D2=0.8 // Высота кнопок D3=28 // Позиция текста после кнопок s=1.15 @s, 02 DCSAY L('1. Лаб.работы, устанавливаемые путем КОПИРОВАНИЯ готовых баз данных учебного приложения:') PARENT oGroup2 FONT '9.Arial Bold' s=s+D1 @s, D3 DCSAY L('Лаб.раб.№ 1.01: Прогноз пунктов назначения ж/д составов ') PARENT oGroup2;s=s+D1 @s, D3 DCSAY L('Лаб.раб.№ 1.02: Прогноз учебных достижений студентов на основе их имиджа ') PARENT oGroup2;s=s+D1 @s, D3 DCSAY L('Лаб.раб.№ 1.03: Прогноз учебных достижений студентов на основе их почерка ') PARENT oGroup2;s=s+D1 @s, D3 DCSAY L('Лаб.раб.№ 1.04: Прогноз учебн.дост.студ. на основе их социального статуса ') PARENT oGroup2;s=s+D1 @s, D3 DCSAY L('Лаб.раб.№ 1.05: Идентификация трехмерных тел по их проекциям ') PARENT oGroup2;s=s+D1 @s, D3 DCSAY L('Лаб.раб.№ 1.06: Идентификация правильных тел Платона по их признакам ') PARENT oGroup2;s=s+D1 @s, D3 DCSAY L('Лаб.раб.№ 1.07: Идентификация символов по их признакам ') PARENT oGroup2;s=s+D1 @s, D3 DCSAY L('Лаб.раб.№ 1.08: Прогнозирование и принятие решений в растениеводстве ') PARENT oGroup2;s=s+D1 @s, D3 DCSAY L('Лаб.раб.№ 1.09: Идентификация респондентов по астрономическим данным ') PARENT oGroup2;s=s+D1 @s, D3 DCSAY L('Лаб.раб.№ 1.10: Идентификация места по признакам (на примере остановок транспорта) ') PARENT oGroup2;s=s+D1 s=s+0.5*D1 @s, 02 DCSAY L('2. Лаб.работы, устанавливаемые путем РАСЧЕТА исходных баз данных учебного приложения:') PARENT oGroup2 FONT '9.Arial Bold' s=s+D1 @s, D3 DCSAY L('Лаб.раб.№ 2.01: Исследование RND-модели, аналогичной текущей ') PARENT oGroup2;s=s+D1 @s, D3 DCSAY L('Лаб.раб.№ 2.02: Исследование свойств нат.чисел при разл.объемах выборки ') PARENT oGroup2;s=s+D1 @s, D3 DCSAY L('Лаб.раб.№ 2.03: Исследование детерминации свойств системы ее структурой ') PARENT oGroup2;s=s+D1 @s, D3 DCSAY L('Лаб.раб.№ 2.04: Исследование зашумленных когнитивных функций ') PARENT oGroup2;s=s+D1 @s, D3 DCSAY L('Лаб.раб.№ 2.05: Исследование нормального распределения ') PARENT oGroup2;s=s+D1 @s, D3 DCSAY L('Лаб.раб.№ 2.06: АСК-анализ изображений (на примере символов) ') PARENT oGroup2;s=s+D1 @s, D3 DCSAY L('Лаб.раб.№ 2.07: Оценка стоимости квартир по параметрам квартиры, дома и района ') PARENT oGroup2;s=s+D1 @s, D3 DCSAY L('Лаб.раб.№ 2.08: АСК-анализ числовых и символьных рядов, в т.ч. псевдослучаных чисел ') PARENT oGroup2;s=s+D1 @s, D3 DCSAY L('Лаб.раб.№ 2.09: Исследование RND-модели при различных объемах выборки ') PARENT oGroup2;s=s+D1 @s, D3 DCSAY L('Лаб.раб.№ 2.10: в процессе разработки ') PARENT oGroup2;s=s+D1 s=s+0.5*D1 @s, 02 DCSAY L('3. Лаб.работы, устанавливаемые путем ВВОДА из внешних баз данных с помощью программного интерфейса:') PARENT oGroup2 FONT '9.Arial Bold' s=s+D1 @s, D3 DCSAY L('Лаб.раб.№ 3.01: Идентификация слов по входящим в них буквам ') PARENT oGroup2;s=s+D1 @s, D3 DCSAY L('Лаб.раб.№ 3.02: Атрибуция анонимных и псевдонимных текстов ') PARENT oGroup2;s=s+D1 @s, D3 DCSAY L('Лаб.раб.№ 3.03: Идентификация предметов по их признакам ') PARENT oGroup2;s=s+D1 @s, D3 DCSAY L('Лаб.раб.№ 3.04: Оценка автомобилей с пробегом по их характеристикам ') PARENT oGroup2;s=s+D1 @s, D3 DCSAY L('Лаб.раб.№ 3.05: Оценка стоимости квартир по параметрам квартиры, дома и района ') PARENT oGroup2;s=s+D1 @s, D3 DCSAY L('Лаб.раб.№ 3.06: Прогнозирование и принятие решений в зерновом производстве ') PARENT oGroup2;s=s+D1 @s, D3 DCSAY L('Лаб.раб.№ 3.07: Принятие решений по конфигурированию системы безопасности MS Windows ') PARENT oGroup2;s=s+D1 @s, D3 DCSAY L('Лаб.раб.№ 3.08: Управление номенклатурой и объемами реализации продукции (бенчмаркинг)') PARENT oGroup2;s=s+D1 @s, D3 DCSAY L('Лаб.раб.№ 3.09: Автоматизированный SWOT-анализ и реинжиниринг бизнес процессов ') PARENT oGroup2;s=s+D1 @s, D3 DCSAY L('Лаб.раб.№ 3.10: Прогноз рисков ДТП и страховых выплат в системе ОСАГО (андеррайтинг) ') PARENT oGroup2;s=s+D1 // ЛР, устанавливаемые путем копирования БД *************************************************** s=1 s=s+D1 @s, 2 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 1.01') SIZE 22, D2 ACTION {||LC_RunUrl("http://lc.kubagro.ru/aidos/aidos06_lab/lab_01.htm")} PARENT oGroup2;s=s+D1 @s, 2 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 1.02') SIZE 22, D2 ACTION {||LC_RunUrl("http://lc.kubagro.ru/aidos/aidos06_lab/lab_02.htm")} PARENT oGroup2;s=s+D1 @s, 2 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 1.03') SIZE 22, D2 ACTION {||LC_RunUrl("http://lc.kubagro.ru/aidos/aidos06_lab/lab_03.htm")} PARENT oGroup2;s=s+D1 @s, 2 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 1.04') SIZE 22, D2 ACTION {||LC_RunUrl("http://lc.kubagro.ru/aidos/aidos06_lab/lab_04.htm")} PARENT oGroup2;s=s+D1 @s, 2 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 1.05') SIZE 22, D2 ACTION {||LC_RunUrl("http://lc.kubagro.ru/aidos/aidos06_lab/lab_08.htm")} PARENT oGroup2;s=s+D1 @s, 2 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 1.06') SIZE 22, D2 ACTION {||LC_RunUrl("http://lc.kubagro.ru/aidos/index.htm")} PARENT oGroup2;s=s+D1 @s, 2 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 1.07') SIZE 22, D2 ACTION {||TheoryLW1_07()} PARENT oGroup2;s=s+D1 @s, 2 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 1.08') SIZE 22, D2 ACTION {||TheoryLW1_08()} PARENT oGroup2;s=s+D1 @s, 2 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 1.09') SIZE 22, D2 ACTION {||TheoryLW1_09()} PARENT oGroup2;s=s+D1 @s, 2 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 1.10') SIZE 22, D2 ACTION {||Razrab() } PARENT oGroup2;s=s+D1 // ЛР, устанавливаемые путем расчета БД ******************************************************* s=s+0.5*D1 s=s+D1 @s, 2 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 2.01') SIZE 22, D2 ACTION {||LC_RunUrl("http://lc.kubagro.ru/aidos/aidos06_lab/lab_10.htm")} PARENT oGroup2;s=s+D1 @s, 2 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 2.02') SIZE 22, D2 ACTION {||TheoryLW2_02()} PARENT oGroup2;s=s+D1 @s, 2 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 2.03') SIZE 22, D2 ACTION {||TheoryLW2_03()} PARENT oGroup2;s=s+D1 @s, 2 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 2.04') SIZE 22, D2 ACTION {||TheoryLW2_04()} PARENT oGroup2;s=s+D1 @s, 2 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 2.05') SIZE 22, D2 ACTION {||Razrab() } PARENT oGroup2;s=s+D1 @s, 2 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 2.06') SIZE 22, D2 ACTION {||HelpASCAimages()} PARENT oGroup2;s=s+D1 @s, 2 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 2.07') SIZE 22, D2 ACTION {||Razrab() } PARENT oGroup2;s=s+D1 @s, 2 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 2.08') SIZE 22, D2 ACTION {||LC_RunUrl("http://ej.kubagro.ru/2014/05/pdf/22.pdf")} PARENT oGroup2;s=s+D1 @s, 2 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 2.09') SIZE 22, D2 ACTION {||LC_RunUrl("http://lc.kubagro.ru/aidos/aidos06_lab/lab_10.htm")} PARENT oGroup2;s=s+D1 @s, 2 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 2.10') SIZE 22, D2 ACTION {||Razrab() } PARENT oGroup2;s=s+D1 // ЛР, устанавливаемые путем импорта данных из внешних БД ************************************* s=s+0.5*D1 s=s+D1 @s, 2 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 3.01') SIZE 22, D2 ACTION {||LC_RunUrl("http://ej.kubagro.ru/2004/02/pdf/12.pdf")} PARENT oGroup2;s=s+D1 @s, 2 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 3.02') SIZE 22, D2 ACTION {||LC_RunUrl("http://lc.kubagro.ru/aidos/Works_on_ASK-analysis_of_texts.htm")} PARENT oGroup2;s=s+D1 @s, 2 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 3.03') SIZE 22, D2 ACTION {||Razrab()} PARENT oGroup2;s=s+D1 @s, 2 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 3.04') SIZE 22, D2 ACTION {||LC_RunUrl("http://ej.kubagro.ru/2013/10/pdf/36.pdf")} PARENT oGroup2;s=s+D1 @s, 2 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 3.05') SIZE 22, D2 ACTION {||Razrab()} PARENT oGroup2;s=s+D1 @s, 2 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 3.06') SIZE 22, D2 ACTION {||LC_RunUrl("http://ej.kubagro.ru/2010/05/pdf/07.pdf")} PARENT oGroup2;s=s+D1 @s, 2 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 3.07') SIZE 22, D2 ACTION {||LC_RunUrl("http://ej.kubagro.ru/2010/05/pdf/06.pdf")} PARENT oGroup2;s=s+D1 @s, 2 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 3.08') SIZE 22, D2 ACTION {||LC_RunUrl("http://ej.kubagro.ru/2010/05/pdf/08.pdf")} PARENT oGroup2;s=s+D1 @s, 2 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 3.09') SIZE 22, D2 ACTION {||TheoryLW3_09()} PARENT oGroup2;s=s+D1 @s, 2 DCPUSHBUTTON CAPTION L('Теория по Лаб.раб.№ 3.10') SIZE 22, D2 ACTION {||LC_RunUrl("http://ej.kubagro.ru/2007/05/pdf/08.pdf")} PARENT oGroup2;s=s+D1 *######################################################################################################################################################## *######################################################################################################################################################## DCREAD GUI ; FIT ; MODAL ; TITLE L('5.14. Пояснения по частным и интегральным критериям и лаб.работам') Running(.F.) ReTURN nil ********************************************************************************************************** ******** Окно с ссылкой на статьи с теорией по Лаб.раб.№03 FUNCTION TheoryLW03() DCSETFONT TO '9.Helv' @ 1,1 DCSAY L('Луценко Е.В. Прогнозирование учебных достижений студентов на основе особенностей их почерка с применением ') SAYSIZE 0 @ 2,1 DCSAY L('системно-когнитивного анализа / Е.В. Луценко // Политематический сетевой электронный научный журнал Кубан-') SAYSIZE 0 @ 3,1 DCSAY L('ского государственного аграрного университета (Научный журнал КубГАУ) [Электронный ресурс]. - Краснодар: ') SAYSIZE 0 @ 4,1 DCSAY L('КубГАУ, 2006. -№04(20). С.309 - 327. - Шифр Информрегистра: 0420600012\0083. 1,188 у.п.л. - Режим доступа:') SAYSIZE 0 @ 5,1 DCSAY L('http://ej.kubagro.ru/2006/04/pdf/27.pdf') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://ej.kubagro.ru/2006/04/pdf/27.pdf', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} @ 7,1 DCSAY L('Луценко Е.В. Лабораторный практикум по интеллектуальным информационным системам: Учебное пособие для ') SAYSIZE 0 @ 8,1 DCSAY L('студентов специальности "Прикладная информатика (по областям)" и другим экономическим специальностям.') SAYSIZE 0 @ 9,1 DCSAY L('2-е изд., перераб. и доп. - Краснодар: КубГАУ, 2006. - 318с. [Электронный ресурс]. - Режим доступа: ') SAYSIZE 0 @10,1 DCSAY L('http://lc.kubagro.ru/aidos/aidos06_lab/lab_03.htm') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://lc.kubagro.ru/aidos/aidos06_lab/lab_03.htm', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} DCREAD GUI FIT MODAL TITLE L('5.14. Информация о статье и учебном пособии с теорией по Лаб.раб.№ 03') RETURN NIL ******** Окно с ссылкой на статьи с теорией по Лаб.раб.№07 FUNCTION TheoryLW1_07() s=1 d=0.8 DCSETFONT TO '9.Helv Bold' @ s,1 DCSAY L('Нейросетевая интерпретация модели знаний системы "Эйдос")') SAYSIZE 0;s=s+1.5*d DCSETFONT TO '9.Helv' @ 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('КубГАУ, 2003. - №01(001). С. 79 - 91. - IDA [article ID]: 0010301011. - Режим доступа: ') SAYSIZE 0;s=s+d @ s,1 DCSAY L('http://ej.kubagro.ru/2003/01/pdf/11.pdf') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://ej.kubagro.ru/2003/01/pdf/11.pdf', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} ;s=s+2*d DCSETFONT TO '9.Helv Bold' @ s,1 DCSAY L('1-й слой нейронной сети: "писели - элементы символов (или символы)"') SAYSIZE 0;s=s+1.5*d DCSETFONT TO '9.Helv' @ s,1 DCSAY L('Луценко Е.В. Системно-когнитивный подход к синтезу эффективного алфавита / Е.В. Луценко // ') SAYSIZE 0;s=s+d @ s,1 DCSAY L('Политематический сетевой электронный научный журнал Кубанского государственного аграрного ') SAYSIZE 0;s=s+d @ s,1 DCSAY L('университета (Научный журнал КубГАУ) [Электронный ресурс].-Краснодар:КубГАУ,2009.-№07(51).С. ') SAYSIZE 0;s=s+d @ s,1 DCSAY L('109 - 129. 1,312 у.п.л., - Шифр Информрегистра: 0420900012\0067. - Режим доступа: ') SAYSIZE 0;s=s+d @ s,1 DCSAY L('http://ej.kubagro.ru/2009/07/pdf/05.pdf') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://ej.kubagro.ru/2009/07/pdf/05.pdf', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} ;s=s+2*d DCSETFONT TO '9.Helv Bold' @ s,1 DCSAY L('2-й слой нейронной сети: "элементы символов - символы"') SAYSIZE 0;s=s+1.5*d DCSETFONT TO '9.Helv' @ s,1 DCSAY L('Луценко Е.В. Cистемно-когнитивный анализ изображений (обобщение, абстрагирование, классификация ') 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('КубГАУ, 2009. - №02(46). С. 146 - 164. - Шифр Информрегистра: 0420900012\0017. - Режим доступа: ') SAYSIZE 0;s=s+d @ s,1 DCSAY L('http://ej.kubagro.ru/2009/02/pdf/10.pdf') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://ej.kubagro.ru/2009/02/pdf/10.pdf', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} ;s=s+2*d DCREAD GUI FIT MODAL TITLE L('5.14. Информация о статьях с теорией по Лаб.раб.№ 07') RETURN NIL ******** Окно с ссылкой на статью с теорией по Лаб.раб.№08 FUNCTION TheoryLW1_08() DCSETFONT TO '9.Helv' @ 1,1 DCSAY L('Луценко Е.В., Лойко В.И., Семантические информационные модели управления агропромышленным комплексом.') SAYSIZE 0 @ 2,1 DCSAY L('Монография (научное издание). -Краснодар: КубГАУ. 2005. - 480 с.[Электронный ресурс].- Режим доступа:') SAYSIZE 0 @ 3,1 DCSAY L('http://lc.kubagro.ru/aidos/aidos05/4.1.htm') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://lc.kubagro.ru/aidos/aidos05/4.1.htm', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} @ 5,1 DCSAY L('Луценко Е. В., Лойко В.И., Великанова Л.О. Прогнозирование и принятие решений в растениеводстве с применением' ) SAYSIZE 0 @ 6,1 DCSAY L('технологий искусственного интеллекта: Монография (научное издание).-Краснодар:[Электронный ресурс].-Режим доступа:') SAYSIZE 0 @ 7,1 DCSAY L('http://lc.kubagro.ru/aidos/aidos08_LLV/index.htm') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://lc.kubagro.ru/aidos/aidos08_LLV/index.htm', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} DCREAD GUI FIT MODAL TITLE L('5.14. Информация о статье с теорией по Лаб.раб.№ 08') RETURN NIL ******** Окно с ссылкой на статью с теорией по Лаб.раб.№09 FUNCTION TheoryLW1_09() DCSETFONT TO '9.Helv' @ 1,1 DCSAY L('Трунев А.П., Луценко Е.В. Автоматизированный системно-когнитивный анализ влияния факторов космической' ) SAYSIZE 0 @ 2,1 DCSAY L('среды на ноосферу, магнитосферу и литосферу Земли: Под науч. ред. д.т.н., проф. В.И.Лойко. Монография (научное') SAYSIZE 0 @ 3,1 DCSAY L('издание). - Краснодар, КубГАУ. 2012. - 480 с. [Электронный ресурс]. - Режим доступа:' ) SAYSIZE 0 @ 4,1 DCSAY L('http://lc.kubagro.ru/aidos/aidos12_TL2/3.htm') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://lc.kubagro.ru/aidos/aidos12_TL2/3.htm', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} DCREAD GUI FIT MODAL TITLE L('5.14. Информация о статье с теорией по Лаб.раб.№ 09') RETURN NIL ******** Окно с ссылкой на статью с теорией по Лаб.раб.№12 FUNCTION TheoryLW2_03() DCSETFONT TO '9.Helv' @ 1,1 DCSAY L('Луценко Е.В. Исследование влияния подсистем различных уровней иерархии на эмерд- ' ) SAYSIZE 0 @ 2,1 DCSAY L('жентные свойства системы в целом с применением АСК-анализа и интеллектуальной ' ) SAYSIZE 0 @ 3,1 DCSAY L('системы "Эйдос" (микроструктура системы как фактор управления ее макросвойства ' ) SAYSIZE 0 @ 4,1 DCSAY L('ми) / Е.В. Луценко // Политематический сетевой электронный научный журнал Кубан- ' ) SAYSIZE 0 @ 5,1 DCSAY L('ского государственного аграрного университета (Научный журнал КубГАУ) [Электрон- ' ) SAYSIZE 0 @ 6,1 DCSAY L('ный ресурс]. -Краснодар: КубГАУ,2012.-№01(75).С.638-680.,2.688у.п.л.-Режим доступа:') SAYSIZE 0 @ 7,1 DCSAY L('http://ej.kubagro.ru/2012/01/pdf/52.pdf') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://ej.kubagro.ru/2012/01/pdf/52.pdf', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} DCREAD GUI FIT MODAL TITLE L('5.14. Информация о статье с теорией по Лаб.раб.№ 12') RETURN NIL ******** Окно с ссылкой на статью с теорией по Лаб.раб.№13 по когн.функциям взять за основу окно режима 4.5 FUNCTION TheoryLW2_04() DCSETFONT TO '9.Helv' @ 0.0,0 DCGROUP oGroup1 CAPTION L('Что такое когнитивная функция:') SIZE 90,20.0 @ 20.5,0 DCGROUP oGroup2 CAPTION L('Задайте нужный режим:' ) SIZE 90, 4.2 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,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;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;s=s+0.8 @s,1 DCSAY L('дарственного аграрного университета (Научный журнал КубГАУ) [Электронный ресурс]. - Краснодар: КубГАУ, 2011. -') PARENT oGroup1;s=s+0.8 @s,1 DCSAY L('№03(67). С. 240 - 282. - Шифр Информрегистра: 0421100012\0077. , 2,688 у.п.л. - Режим доступа: ') PARENT oGroup1;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.)} // .T. - внешняя программа запускается, а главная исполняется дальше, .F. - главная ждет окончания внешней программы @1.0, 1 DCPUSHBUTTON CAPTION L('Литератур.ссылки на статьи по когнитивным функциям' ) SIZE 43, 1.1 PARENT oGroup2 ACTION {||Publ_CognFun()} @1.0, 45 DCPUSHBUTTON CAPTION L('Скачать подборку публикаций по когнитивным функциям') SIZE 44, 1.1 PARENT oGroup2 ACTION {||LC_RunUrl("http://lc.kubagro.ru/Install_Aidos-X/PublCognFun.rar")} @2.5, 45 DCPUSHBUTTON CAPTION L('Скачать подборку публикаций по управлению знаниями') SIZE 44, 1.1 PARENT oGroup2 ACTION {||LC_RunUrl("http://lc.kubagro.ru/Install_Aidos-X/PublUprZn.rar")} DCREAD GUI FIT MODAL TITLE L('5.14. Информация о статьях с теорией по Лаб.раб.№ 13') RETURN NIL ******** Окно со ссылкой на статьи с теорией по Лаб.раб.№ 2.02 (22) FUNCTION TheoryLW2_02() DCSETFONT TO '9.Helv' @ 1,1 DCSAY L('Луценко Е.В. Применение теории информации и АСК-анализа для экспериментальных исследований в теории ') SAYSIZE 0 @ 2,1 DCSAY L('чисел / Е.В. Луценко // Политематический сетевой электронный научный журнал Кубанского государствен- ') SAYSIZE 0 @ 3,1 DCSAY L('ного аграрного университета (Научный журнал КубГАУ) [Электронный ресурс]. - Краснодар: КубГАУ, 2014. ') SAYSIZE 0 @ 4,1 DCSAY L('- №03(097). С.676-717. - IDA [article ID]: 0971403048. - Режим доступа: ') SAYSIZE 0 @ 5,1 DCSAY L('http://ej.kubagro.ru/2014/03/pdf/48.pdf') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://ej.kubagro.ru/2014/03/pdf/48.pdf', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} @ 7,1 DCSAY L('Луценко Е.В. Лабораторный практикум по интеллектуальным информационным системам: Учебное пособие для ') SAYSIZE 0 @ 8,1 DCSAY L('студентов специальности "Прикладная информатика (по областям)" и другим экономическим специальностям.') SAYSIZE 0 @ 9,1 DCSAY L('2-е изд., перераб. и доп. - Краснодар: КубГАУ, 2006. - 318с. [Электронный ресурс]. - Режим доступа: ') SAYSIZE 0 @10,1 DCSAY L('http://lc.kubagro.ru/aidos/aidos06_lab/lab_07.htm') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://lc.kubagro.ru/aidos/aidos06_lab/lab_07.htm', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} DCREAD GUI FIT MODAL TITLE L('5.14. Информация о статьях с теорией по Лаб.раб.№ 2.02') RETURN NIL ******** Окно со ссылкой на статьи с теорией по Лаб.раб.№ 3.02 FUNCTION TheoryLW3_02() DCSETFONT TO '9.Helv' s=1 D=0.8 h=36 @ s, 1 DCSAY L('АСК-анализ текстов позволяет:') FONT '10.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('- сравнивать обобщенные лингвистические образы классов друг с другом и создавать их кластеры и конструкты;' ) 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('Кубанского государственного аграрного университета (Научный журнал КубГАУ) [Электронный ресурс]. - Краснодар: КубГАУ, 2003. - №02(002). С. 146 - 164.' ) SAYSIZE 0;s=s+D @ s, 1 DCSAY L('- IDA [article ID]: 0020302013. - Режим доступа:' ) SAYSIZE 0 @ s, h DCSAY L('http://ej.kubagro.ru/2003/02/pdf/13.pdf') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://ej.kubagro.ru/2003/02/pdf/13.pdf', 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('Кубанского государственного аграрного университета (Научный журнал КубГАУ) [Электронный ресурс]. - Краснодар: КубГАУ, 2004. - №03(005). С. 44 - 43.' ) SAYSIZE 0;s=s+D @ s, 1 DCSAY L('- IDA [article ID]: 0050403003. - Режим доступа: ') SAYSIZE 0 @ s, h DCSAY L('http://ej.kubagro.ru/2004/03/pdf/03.pdf') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://ej.kubagro.ru/2004/03/pdf/03.pdf', 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('Кубанского государственного аграрного университета (Научный журнал КубГАУ) [Электронный ресурс]. - Краснодар: КубГАУ, 2014. - №06(100). С. 109 - 145. - IDA' ) SAYSIZE 0;s=s+D @ s, 1 DCSAY L('[article ID]: 1001406007. - Режим доступа:') SAYSIZE 0 @ s, h DCSAY L('http://ej.kubagro.ru/2014/06/pdf/07.pdf') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://ej.kubagro.ru/2014/06/pdf/07.pdf', 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('стандартным, нестандартным и некорректным библиографическим описаниям / Е.В. Луценко // Политематический сетевой электронный научный журнал Кубанского' ) SAYSIZE 0;s=s+D @ s, 1 DCSAY L('государственного аграрного университета (Научный журнал КубГАУ) [Электронный ресурс]. - Краснодар: КубГАУ, 2014. - №09(103). С. 498 - 544. - IDA [article ID]:' ) SAYSIZE 0;s=s+D @ s, 1 DCSAY L('1031409032. - Режим доступа:') SAYSIZE 0 @ s, h DCSAY L('http://ej.kubagro.ru/2014/09/pdf/32.pdf') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://ej.kubagro.ru/2014/09/pdf/32.pdf', 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('"Эйдос" (на примере Российского индекса научного цитирования - РИНЦ) / Е.В.Луценко, В.А.Глухов// Политематический сетевой электронный научный журнал Кубанского') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('государственного аграрного университета (Научный журнал КубГАУ) [Электронный ресурс]. - Краснодар: КубГАУ, 2017. - №01(125). С. 1 - 65. - IDA [article ID]:' ) SAYSIZE 0;s=s+D @ s, 1 DCSAY L('1251701001. - Режим доступа:') SAYSIZE 0 @ s, h DCSAY L('http://ej.kubagro.ru/2017/01/pdf/01.pdf') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://ej.kubagro.ru/2017/01/pdf/01.pdf', 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('автоматическая классификация текстов по направлениям науки / Е.В. Луценко // Политематический сетевой электронный научный журнал Кубанского государственного' ) SAYSIZE 0;s=s+D @ s, 1 DCSAY L('аграрного университета (Научный журнал КубГАУ) [Электронный ресурс]. - Краснодар: КубГАУ, 2018. - №10(144). С. 44 - 102. - IDA [article ID]: 1441810033.' ) SAYSIZE 0;s=s+D @ s, 1 DCSAY L('- Режим доступа:') SAYSIZE 0 @ s, h DCSAY L('http://ej.kubagro.ru/2018/10/pdf/33.pdf') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://ej.kubagro.ru/2018/10/pdf/33.pdf', 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('и интеллектуальной системы "Эйдос" (на примере Научного журнала КубГАУ и его научных специальностей: механизации, агрономии и ветеринарии) / Е.В. Луценко,' ) SAYSIZE 0;s=s+D @ s, 1 DCSAY L('Н.В.Андрафанова, Н.В.Потапова // Политематический сетевой электронный научный журнал Кубанского государственного аграрного университета (Научный журнал КубГАУ)') SAYSIZE 0;s=s+D @ s, 1 DCSAY L('[Электронный ресурс]. - Краснодар: КубГАУ, 2019. - №01(145). С. 31 - 102. - IDA [article ID]: 1451901033.' ) SAYSIZE 0;s=s+D @ s, 1 DCSAY L('- Режим доступа:') SAYSIZE 0 @ s, h DCSAY L('http://ej.kubagro.ru/2019/01/pdf/33.pdf') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://ej.kubagro.ru/2019/01/pdf/33.pdf', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} ;s=s+D s=s+D @ s, 1 DCSAY L('Ссылки на работы проф.Е.В.Луценко по АСК-анализу текстов. - Режим доступа:' ) SAYSIZE 0;s=s+D @ s, h DCSAY L('http://lc.kubagro.ru/aidos/Works_on_ASK-analysis_of_texts.htm') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://lc.kubagro.ru/aidos/Works_on_ASK-analysis_of_texts.htm', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} ;s=s+D DCREAD GUI FIT MODAL TITLE L('5.14. Информация о статьях с теорией по Лаб.раб.№ 3.02') RETURN NIL ******** Окно со ссылкой на статьи с теорией по Лаб.раб.№ 3.09 (29) FUNCTION TheoryLW3_09() DCSETFONT TO '9.Helv' s=1 D=0.8 @ s,1 DCSAY L('Луценко Е.В. Синтез системно-когнитивной модели природно-экономической системы и ее использование ') SAYSIZE 0;s=s+D @ s,1 DCSAY L('для прогнозирования и управления в зерновом производстве (Часть 1 - постановка задачи) ') 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('КубГАУ, 2013. - №05(089). С. 1288 - 1300. - IDA [article ID]: 0891305089. - Режим доступа: ') SAYSIZE 0;s=s+D @ s,1 DCSAY L('http://ej.kubagro.ru/2013/05/pdf/89.pdf') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://ej.kubagro.ru/2013/05/pdf/89.pdf', 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('прогнозирования и управления в зерновом производстве (Часть 2 - преобразование эмпирических данных в ') 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('- Краснодар: КубГАУ, 2013. - №05(089). С. 1301 - 1319. - IDA [article ID]: 0891305090. - Режим доступа:') SAYSIZE 0;s=s+D @ s,1 DCSAY L('http://ej.kubagro.ru/2013/05/pdf/90.pdf') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://ej.kubagro.ru/2013/05/pdf/90.pdf', 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('для прогнозирования и управления в зерновом производстве (Часть 3 - прогнозирование и принятие решений)') 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('КубГАУ, 2013. - №06(090). С. 863 - 872. - IDA [article ID]: 0901306059. - Режим доступа: ') SAYSIZE 0;s=s+D @ s,1 DCSAY L('http://ej.kubagro.ru/2013/06/pdf/59.pdf') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://ej.kubagro.ru/2013/06/pdf/59.pdf', 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('для прогнозирования и управления в зерновом производстве (Часть 4 - исследование объекта моделирования ') 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('ресурс]. - Краснодар: КубГАУ, 2013. - №06(090). С. 873 - 893. - IDA [article ID]: 0901306060. - Режим доступа:') SAYSIZE 0;s=s+D @ s,1 DCSAY L('http://ej.kubagro.ru/2013/06/pdf/60.pdf') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://ej.kubagro.ru/2013/06/pdf/60.pdf', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} ;s=s+D s=s+D @ s,1 DCSAY L('Луценко Е.В. Количественный автоматизированный SWOT- и PEST-анализ средствами АСК-анализа и интеллектуальной ') SAYSIZE 0;s=s+D @ s,1 DCSAY L('системы <Эйдос-Х++> / Е.В. Луценко // Политематический сетевой электронный научный журнал Кубанского государс-') SAYSIZE 0;s=s+D @ s,1 DCSAY L('твенного аграрного университета (Научный журнал КубГАУ) [Электронный ресурс]. - Краснодар: КубГАУ, 2014. - ') SAYSIZE 0;s=s+D @ s,1 DCSAY L('№07(101). С. 1368 - 1410. - IDA [article ID]: 1011407090. - Режим доступа: ') SAYSIZE 0;s=s+D @ s,1 DCSAY L('http://ej.kubagro.ru/2014/07/pdf/90.pdf') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolH)andler ' + ; 'http://ej.kubagro.ru/2014/07/pdf/90.pdf', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} ;s=s+D DCREAD GUI FIT MODAL TITLE L('5.14. Информация о статьях с теорией по Лаб.раб.№ 3.09') RETURN NIL ************************************************************************************************ ******** Возврат значения поля для формирования индексного массива: ******** INDEX ON CalculateValue(ff) TO Mrk_funi ************************************************************************************************ FUNCTION CalculateValue(ff) local nValue := FIELDGET(ff) mKey = '' IF FIELDDECI(ff) = 0 // Целые (целых в Inp_data нет никогда) mKey = STR(99999999999-nValue,195) ELSE mKey = STR(99999999999.9999999-nValue,19,7) ENDIF RETURN(mKey) ****************************************************************************************************************** ******** Сформировать в БД Class_Sc информацию по числу классов и начальным и конечным кодам классов в класс.шкале ****************************************************************************************************************** FUNCTION ClSc_Ngr() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Class = RECCOUNT() USE Class_Sc EXCLUSIVE NEW IF N_Class = 0 LB_Warning(L("База классов пуста!"), L('2.3.2.2. Универсальный программный интерфейс импорта данных в систему "ЭЙДОС-X++"')) Running(.F.) RETURN(.F.) ENDIF ****** Определение начальной и конечной записей для каждой классификационной шкалы ****** ЕСЛИ В СТОЛБЦЕ НЕТ РАЗЛИЧИЯ ГРАДАЦИЙ, ТО ИГНОРИРОВАТЬ ЕГО ################# SELECT Classes DBGOTOP() mMinKodCls = Kod_cls mMinKodClSc = Kod_ClSc DBGOBOTTOM() mMaxKodCls = Kod_cls mMaxKodClSc = Kod_ClSc PRIVATE aKodClsMin[mMaxKodClSc] PRIVATE aKodClsMax[mMaxKodClSc] DBGOTOP() mKodClSc = Kod_ClSc aKodClsMin[mKodClSc] = Kod_cls DO WHILE .NOT. EOF() IF mKodClSc = Kod_ClSc aKodClsMax[mKodClSc] = Kod_cls ELSE mKodClSc = Kod_ClSc aKodClsMin[mKodClSc] = Kod_cls aKodClsMax[mKodClSc] = Kod_cls ENDIF DBSKIP(1) ENDDO aKodClsMax[mMaxKodClSc] = mMaxKodCls aMessCls := {} AADD(aMessCls, 'В следующих классификационных шкалах были удалены некоторые (может быть и все) градации:') mFlagErrCls = .F. DO WHILE .NOT. EOF() mKodClSc = Kod_ClSc mNameClSc = Name_ClSc IF LEN(aKodClsMin) <= mKodClSc .AND. LEN(aKodClsMax) <= mKodClSc REPLACE N_GrClSc WITH aKodClsMax[mKodClSc] - aKodClsMin[mKodClSc] + 1 REPLACE KodGr_Min WITH aKodClsMin[mKodClSc] REPLACE KodGr_Max WITH aKodClsMax[mKodClSc] ELSE AADD(aMessCls, STR(mKodClSc,15)+' '+ALLTRIM(mNameClSc)) mFlagErrCls = .T. ENDIF DBSKIP(1) ENDDO *IF mFlagErrCls * AADD(aMessCls, L('Возможно имеет смысл изменить параметры ввода данных в режиме 2.3.2.2.')) * LB_Warning(aMessCls, L('2.3.2.2. Универсальный программный интерфейс импорта данных в систему "ЭЙДОС-X++"')) *ENDIF RETURN(.T.) ******** Сформировать в БД Opis_Sc информацию по числу признаков и начальным и конечным кодам признаков в опис.шкале FUNCTION OpSc_Ngr() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Attributes EXCLUSIVE NEW;N_Attr = RECCOUNT() USE Opis_Sc EXCLUSIVE NEW IF N_Attr = 0 LB_Warning(L("База признаков пуста!"), L('2.3.2.2. Универсальный программный интерфейс импорта данных в систему "ЭЙДОС-X++"')) Running(.F.) RETURN(.F.) ENDIF ****** Определение начальной и конечной записей для каждой описательной шкалы ****** ЕСЛИ В СТОЛБЦЕ НЕТ РАЗЛИЧИЯ ГРАДАЦИЙ, ТО ИГНОРИРОВАТЬ ЕГО ############ ****** SET FILTER ? SELECT Attributes DBGOTOP() mMinKodAtr = Kod_atr mMinKodOpSc = Kod_OpSc DBGOBOTTOM() mMaxKodAtr = Kod_atr mMaxKodOpSc = Kod_OpSc PRIVATE aKodAtrMin[mMaxKodOpSc] PRIVATE aKodAtrMax[mMaxKodOpSc] DBGOTOP() mKodOpSc = Kod_OpSc aKodAtrMin[mKodOpSc] = Kod_atr DO WHILE .NOT. EOF() IF mKodOpSc = Kod_OpSc aKodAtrMax[mKodOpSc] = Kod_atr ELSE mKodOpSc = Kod_OpSc aKodAtrMin[mKodOpSc] = Kod_atr aKodAtrMax[mKodOpSc] = Kod_atr ENDIF DBSKIP(1) ENDDO aKodAtrMax[mMaxKodOpSc] = mMaxKodAtr SELECT Opis_Sc DBGOTOP() *DC_DebugQout( aKodAtrMin ) *DC_DebugQout( aKodAtrMax ) aMessAtr := {} AADD(aMessAtr, 'В следующих описательных шкалах были удалены некоторые (может быть и все) градации:') mFlagErrAtr = .F. DO WHILE .NOT. EOF() mKodOpSc = Kod_OpSc mNameOpSc = Name_OpSc IF LEN(aKodAtrMin) <= mKodOpSc .AND. LEN(aKodAtrMax) <= mKodOpSc REPLACE N_GrOpSc WITH aKodAtrMax[mKodOpSc] - aKodAtrMin[mKodOpSc] + 1 REPLACE KodGr_Min WITH aKodAtrMin[mKodOpSc] REPLACE KodGr_Max WITH aKodAtrMax[mKodOpSc] ELSE AADD(aMessAtr, STR(mKodOpSc,15)+' '+ALLTRIM(mNameOpSc)) mFlagErrAtr = .T. ENDIF DBSKIP(1) ENDDO *IF mFlagErrAtr * AADD(aMessAtr, 'Возможно имеет смысл изменить параметры ввода данных в режиме 2.3.2.2.') * LB_Warning(aMessAtr, '2.3.2.2. Универсальный программный интерфейс импорта данных в систему "ЭЙДОС-X++"') *ENDIF Running(.F.) RETURN(.T.) ******************************************************************* ******** Возврат символа, соответствующего градации (для сценариев) ******************************************************************* FUNCTION SimbolGr(N_Urovney, gr) // 48-57: коды цифр: 0-9 // 65-90: коды заглавных символов латинского алфавита: A-Z // Первые 16 символов как в 16-ричной системе счисления N_Urovney = IF(N_Urovney<=36, N_Urovney, 36) // Ограничение глубины-горизонта aSimb := {} FOR j=1 TO N_Urovney IF j <= 10 AADD(aSimb, CHR(j+47)) // j от 1 до 10 ELSE AADD(aSimb, CHR(j+54)) // j от 11 до 36 ENDIF NEXT *DC_DebugQout( {N_Urovney, aSimb } ) RETURN(aSimb[gr]) ************************************************************************************* * Обращение к LC_Excel2WorkArea() не в системе Эйдос, а как к отдельной программе ************************************************************************************* *FUNCTION Main() *PARAMETERS cExcelFile *SET COLLATION TO SYSTEM // Руссификация *SET COLLATION TO ASCII // Руссификация *DC_IconDefault(1000) *IF EMPTY(cExcelFile) * LB_Warning(L('Задайте в качестве параметра имя конвертируемого Excel-файла с расширением: "XLS-DBF FileName.xlsx"') * RETURN NIL *ENDIF *CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций *cExcelFile = DC_CurPath() + '\' + cExcelFile *LC_Excel2WorkArea( cExcelFile ) *RETURN nil ************************************************************************************* ****************************************************************************************************************************************** ******** Загрузка Excel-листа в DBF-таблицу по частям ****************************************************************************************************************************************** ****************************************************************************************************************************************** ******** XLS => DBF. Для работы с включенным ADS создать и записать на диск массив наименований полей файла исходных данных _FieldName.arx ****************************************************************************************************************************************** FUNCTION LC_Excel2WorkArea_new( cExcelFile, mPathAppl ) *DIRCHANGE( mPathAppl ) // Перейти в папку текущего приложения // Это только в системе Эйдос *cDBaseFile = SUBSTR(cExcelFile, 1, AT('.',cExcelFile)-1) + '.dbf' // Это только в системе Эйдос cExcelFile = DC_CurPath() + '\' + ALLTRIM(cExcelFile) // Это только в системе Эйдос *cExcelFile = ALLTRIM(cExcelFile) // Это только в системе Эйдос * Запуск функции, аналогичной LC_Excel2WorkArea, но реализованной на Питоне <<<===############################ mPos = RAT('\',cExcelFile) StrFile(SUBSTR(cExcelFile,mPos+1,LEN(cExcelFile)-mPos), 'LC_Excel2WorkArea.txt') LC_RunShell("__AIDOS-PY.exe", 717400306, "LC_Excel2WorkArea") // Мой вариант на Питоне в системе __AIDOS-PY.exe CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций 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) COPY FILE (Name_DD) TO (Name_SS) Name_SS = Disk_dir+"\_2_3_2_2.arx" Name_DD = Disk_dir+"\AID_DATA\Inp_data\_2_3_2_2.arx" COPY FILE (Name_SS) TO (Name_DD) Running(.F.) RETURN .T. ******************************************************************************************************************************************** ******** XLSX=>DBF конвертор на xBase++, использущий MS Excel, но в случае, если он не той версии или не установлен, то реализованный Питоне ******************************************************************************************************************************************** FUNCTION LC_Excel2WorkArea( cExcelFile, mPathAppl ) LOCAL lStatus := .f., oExcel, cPath, oSheet, oBook, aValues, i, j, ; aStru, xValue LOCAL oProgressm, oDialogm, lOk DIRCHANGE( mPathAppl ) // Перейти в папку текущего приложения // Это только в системе Эйдос cDBaseFile = SUBSTR(cExcelFile, 1, AT('.',cExcelFile)-1) + '.dbf' // Это только в системе Эйдос cExcelFile = DC_CurPath() + '\' + ALLTRIM(cExcelFile) // Это только в системе Эйдос mFlagExcel = .F. #if XPPVER > 1900000 // Create the "Excel.Application" object oExcel := CreateObject("Excel.Application") // Как определить, какой Excel проинсталлирован на компьютере: 2003 или 2007-2010 IF Empty( oExcel ) mFlagExcel = .T. * DC_WinAlert( "Excel is not installed" ) * RETURN .f. ELSE oExcel:Visible := .f. ENDIF #else DC_WinAlert('This feature is available in Xbase++ 1.9 and later only!') RETURN .f. #endif // Load a Workbook from an .XLS file // Get path from ini file *MsgBox(cExcelFile) IF !File(cExcelFile) LB_Warning(L('Файл не найден: ') + cExcelFile, L('Загрузка Excel-листа в DBF-таблицу' )) RETURN .F. ENDIF // Активизация чтения Excel-листа ****** Обработка ошибки ****************** bError := ErrorBlock( {|e| Break(e)} ) // установить новый кодовый блок обработки ошибок BEGIN SEQUENCE // код нормального исполнения *** код нормального исполнения oScrn := DC_WaitOn( L('Открытие XLS-файла' ),,,,,,,,,,,.F.) oBook := oExcel:Workbooks:Open(cExcelFile) // Если Экселя нет или он той версии, то здесь возникнет ошибка oSheet := oBook:activeSheet *aValues := oBook:workSheets(1):usedRange:value // Загрузка 1-го листа Excel-книги целиком // Определение количества строк и столбцов с данными в Excel-дисте без его загрузки в оперативную память oUsedRange := oSheet:usedRange N_Col := oUsedRange:Columns:Count() // Количество колонок с данными в xls-файле N_Rec := oUsedRange:Rows:Count() // Количество строк с данными в xls-файле DC_Impl(oScrn) RECOVER // код обработки ошибки DC_Impl(oScrn) mFlagExcel = .T. aMess := {} AADD(aMess, L('При попытке конвертации Excel-файла "Inp_dat.xls(x)" в DBF-файл: "Inp_data.dbf" возникла ошибка,')) IF mFlagExcel AADD(aMess, L('связанная с тем, что на компьютере не установлен MS Excel.')) ELSE AADD(aMess, L('связанная с тем, что на компьютере установлен MS Excel, в котором нет XLSX=>DBF конвертора.')) ENDIF AADD(aMess, L('Эта проблемы решаются путем инсталляции MS Excel-2010, в котором XLSX=>DBF конвертор точно есть.')) AADD(aMess, L('')) AADD(aMess, L('Поэтому будет запущен XLSX=>DBF конвертор, реализованный на ПИТОНЕ, вообще не использующий Excel.')) AADD(aMess, L('')) AADD(aMess, L('Процесс запуска этого конвертора занимает некоторое время, немного подождите !!!')) LB_Warning(aMess, L('Загрузка Excel-листа в DBF-таблицу')) * Запуск функции, аналогичной LC_Excel2WorkArea, но реализованной на Питоне <<<===############################ mPos = RAT('\',cExcelFile) * MsgBox(SUBSTR(cExcelFile,mPos+1,LEN(cExcelFile)-mPos)) DIRCHANGE(Disk_dir) // Папка с исполнимым модулем системы Эйдос StrFile(SUBSTR(cExcelFile,mPos+1,LEN(cExcelFile)-mPos), 'LC_Excel2WorkArea.txt') LC_RunShell("__AIDOS-PY.exe", 717400306, "LC_Excel2WorkArea") // Мой вариант на Питоне в системе __AIDOS-PY.exe CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций Name_SS = Disk_dir+"\AID_DATA\Inp_data\Inp_data.dbf" Name_DD = M_NewAppl +"Inp_data.dbf" COPY FILE (Name_SS) TO (Name_DD) Name_SS = Disk_dir+"\_2_3_2_2.arx" Name_DD = Disk_dir+"\AID_DATA\Inp_data\_2_3_2_2.arx" COPY FILE (Name_SS) TO (Name_DD) * Сделать и записать в папку эти файлы: ************************************ * DC_ASave(aColumnNames, M_ApplsPath+"/Inp_data/_ColumnNames.arx") // Запись массива наименований шкал (колонок) в виде файла * DC_ASave(aInp_name , M_ApplsPath+"/Inp_data/_Inp_name.arx") // Запись массива наименований шкал (колонок) в виде файла ********* Загрузить файл Inp_name.txt и сформировать массив: aColumnNames DIRCHANGE(Disk_dir+"\AID_DATA\Inp_data\") // Перейти в папку Inp_data CrLf = CHR(13)+CHR(10) // Конец строки (абзаца) (CrLf) M_InpName = ALLTRIM(FILESTR('Inp_name.txt')) // Загрузка Inp_name.txt * MsgBox(M_InpName) 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") // Загрузка массива наименований шкал (колонок) из файла * LB_Warning(aInp_name) ENDSEQUENCE ErrorBlock( bError ) // переустановить старый кодовый ****************************************** IF mFlagExcel // Выход, если MS Excel не установлен или установлен, но не той версии, т.е. без XLSX=>DBF конвертора Running(.F.) RETURN .T. ENDIF ******** XLSX=>DBF конвертор, использущий MS Excel ******************** ********* Сформировать файл Inp_name.txt // Наименования классификационных и описательных шкал // R1C1_A1() возвращает буквенные имена колонок по их номеру // чтобы сформировать текстовую переменную для обращения к Range() mLinkBlock = "A1:"+R1C1_A1(N_Col)+'1' // Традиционное буквенное обозначение столбцов xls-листа aValues := oUsedRange:Range(mLinkBlock):Value // Загрузка ДВУМЕРНОГО массива из одной строки с именами колонок 1-го листа Excel-книги PUBLIC aInp_name := aValues[1] // Присвоение массиву имен колонок aInp_name значений первой строки массива aValues // Убрать пробелы и записать массив имен колонок в виде файла FOR j=1 TO LEN(aInp_name) IF VALTYPE(aInp_name[j]) = 'C' aInp_name[j] = ALLTRIM(aInp_name[j]) ELSE aMess := {} AADD(aMess, L('КОЛОНКА "#" НЕ ИМЕЕТ ПРАВИЛЬНОГО НАИМЕНОВАНИЯ !!! ')) AADD(aMess, L('')) AADD(aMess, L('Если в этой колонке есть данные, которые надо вводить в систему, то надо открыть ')) AADD(aMess, L('файл исходных данных и написать в этой колонке правильное наименование. ')) AADD(aMess, L('')) AADD(aMess, L('Если в этой колонке нет данных, которые надо вводить в систему, то надо открыть ')) AADD(aMess, L('файл исходных данных, поместить курсор в клетку A1 (нажав Ctrl+Home), выделить ')) AADD(aMess, L('область данных, которую будет обрабтывать система "Эйдос", нажав: Ctrl+Shift+End, ')) AADD(aMess, L('затем с помощью стрелок управления куросором скорректировать выделенную блоком ')) AADD(aMess, L('область данных таким образом, чтобы она совпала с той областью, в которой действи-')) AADD(aMess, L('тельно есть данные для обработки, а затем СКОПИРОВАТЬ выделенную часть таблицы ')) AADD(aMess, L('с данными в буфер обмена (Ctrl+C), создать новый лист и скопировать в него данные ')) AADD(aMess, L('из буфера обмена (Ctrl+V), а исходный лист просто удалить. ')) AADD(aMess, L('')) AADD(aMess, L('И, чтобы здесь не повторяться, рекомендуется также ВНИМАТЕЛЬНО прочитать ОБЕ ')) AADD(aMess, L('экранные формы Help в режиме 2.3.2.2 "Требования к файлу исходных данных". ')) aMess[1] = STRTRAN(aMess[1],"#",ALLTRIM(STR(j))) LB_Warning(aMess, L('Загрузка Excel-листа в DBF-таблицу' )) ENDIF NEXT DC_ASave(aInp_name, "_ColumnNames.arx") // Запись массива наименований шкал (колонок) в виде файла DC_ASave(aInp_name, "_Inp_name.arx") // Запись массива наименований шкал (колонок) в виде файла * aInp_name = DC_ARestore("_Inp_name.arx") // Загрузка массива наименований шкал (колонок) из файла // Проверка на то, что в 1-й строке ТЕКСТОВЫЙ тип данных (заголовки колонок), и, если нет, выдать сообщение об этом и выйти FOR j=1 TO N_Col IF VALTYPE(aInp_name[j]) <> 'C' * DC_WinAlert(L('В 1-й строке Excel-файла во всех столбцах должны быть текстовые заголовки колонок' )) aMess := {} AADD(aMess, L('В 1-й строке Excel-файла есть колонки без ТЕКСТОВЫХ заголовков, возможно правее колонок с данными')) AADD(aMess, L('В 1-й строке Excel-файла ВО ВСЕХ столбцах, в т.ч. в 1-м, должны быть ТЕКСТОВЫЕ заголовки колонок ')) AADD(aMess, L('В 1-й строке Excel-файла НЕ ДОЛЖНО БЫТЬ быть объединенных ячеек, концов абзацев и разрывов строк ')) AADD(aMess, L('В 1-й строке Excel-файла ДОПУСКАЮТСЯ заголовки, повернутые на 90 градусов')) LB_Warning(aMess, L('Загрузка Excel-листа в DBF-таблицу')) oBook:close() oBook:destroy() // Quit Excel oExcel:Quit() oExcel:Destroy() RETURN .F. ENDIF NEXT **** Наименования колонок со 1-й по последнюю aFields := {} CrLf = CHR(13)+CHR(10) // Конец строки (абзаца) (CrLf) mCol_name = "" FOR j=1 TO N_Col // 1-ю колонку включаем в Inp_nameAll.txt, для других целей mNameJ = ALLTRIM(aInp_name[j]) mNameJ = UPPER(SUBSTR(mNameJ,1,1)) + SUBSTR(mNameJ,2) // Сделать первые символы заголовков колонок большими, а остальные оставить как есть mCol_name = mCol_name + mNameJ + CrLf AADD(aFields, mNameJ) NEXT StrFile(mCol_name, 'Inp_nameAll.txt') // Добавить путь на папку Inp_data DC_ASave(aFields, '_FieldName.arx') // Запись массива наименований всех полей создаваемого файла DC_ASave(aFields, Disk_dir+'/_FieldName.arx') // Запись массива наименований всех полей создаваемого файла в папку с системой для использования при включенном ADS *aFields = DC_ARestore(Disk_dir+'/_FieldName.arx') // Загрузка массива наименований всех полей файла Inp_data из папки с системой для использования при включенном ADS **** Наименования колонок со 2-й по последнюю CrLf = CHR(13)+CHR(10) // Конец строки (абзаца) (CrLf) mCol_name = "" FOR j=2 TO N_Col // 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') // Добавить путь на папку Inp_data: Disk_dir+"/AID_DATA/Inp_data/" StrFile(mCol_name, Disk_dir+'/AID_DATA/Inp_data/Inp_name.txt') *MsgBox(mCol_name) // Создание пустой dbf-таблицы для записи в нее данных из 1-го листа xls-файла ****************** // Определение структуры для dbf-таблицы по значениям всех строк (тип и формат данных в колонках) // На основе просмотра ВСЕГО xls-файла сделать массивы описания полей и для создания структуры брать MAX из каждого массива // В dbf-таблицу переносить данные, начиная со 2-й строки xls-листа // 1-ю строку с наименованиями полей использовать вместо Inp_name.txt или чтобы автоматически его делать aStructure := {} // Массив структуры dbf-таблицы PRIVATE aFieldName[N_col] // Наименования колонок для базы данных Inp_data.dbf PRIVATE aFieldType[N_Col] // Тип значений в j-й колонке (если есть хотя бы одно текстовое, то текстовое) PRIVATE aFieldSize[N_Col] // Максимальный размер значения в j-й колонке в символах (<=19 для числовых полей) PRIVATE aFieldInt [N_Col] // Максимальное количество значащих цифр до десятичной точки в значениях j-й колонки PRIVATE aFieldDeci[N_Col] // Максимальное количество значащих цифр после десятичной точки в значениях j-й колонки PRIVATE aFlag_neg [N_Col] // Флаг наличия отрицательных значений в j-й колонке AFILL(aFieldType, "X" ) AFILL(aFieldSize, 1 ) AFILL(aFieldInt , 1 ) AFILL(aFieldDeci, 0 ) AFILL(aFlag_neg , .F. ) // Если имена полей латинские оставить их, но заменить пробелы на "_" и обрезать до 12 символов // aInp_name - массив имен колонок исходного файла **** Проверить, есть ли в наименованиях колонок исходного файла символы, недопустимые в именах полей (русские, пробелы, спец.символы) Flag = .F. FOR j=1 TO LEN(aInp_name) FOR i=1 TO LEN(aInp_name[j]) s = ASC(SUBSTR(STRTRAN(ALLTRIM(aInp_name[j])," ","_"), i, 1)) IF (48 <= s .AND. s <= 57) .OR.; // Цифры (65 <= s .and. s <= 90) .OR.; // Латинские большие (97 <= s .and. s <=122) // Латинские маленькие ELSE Flag = .T. ENDIF NEXT NEXT IF Flag FOR j=1 TO N_Col aFieldName[j] = "N"+ALLTRIM(STR(j, 15)) NEXT ELSE FOR j=1 TO N_Col * aFieldName[j] = SUBSTR(ALLTRIM(STRTRAN(aInp_name[j]," ","_")), 1, 12) * aFieldName[j] = SUBSTR(ALLTRIM(STRTRAN(aInp_name[j]," ","_")), 1, 10) aFieldName[j] = "N"+ALLTRIM(STR(j, 15)) NEXT ENDIF // Здесь сделать цикл по загружаемым блокам xls-листа по N_BlockRec записей * N_Rec // Кол-во записей в исходном xls-файле * N_Col // Кол-во колонок в исходном xls-файле N_RecBlock = 65535 // Кол-во записей в блоке загрузки * N_RecBlock = 1024 // Кол-во записей в блоке загрузки N_Block = 1 + INT( N_Rec / N_RecBlock ) // Кол-во полных блоков загрузки N_RecBlockEnd = ABS( N_Rec - N_RecBlock * ( N_Block - 1 ) ) // Кол-во записей в споследнем (неполном) блоке загрузки, если он есть (число записей в нем > 0) ***** Отображение стадии исполнения в кратком варианте ***************************************** nMax = N_Col * N_Rec + N_Rec - 1 nTime = 0 @ 4,5 DCPROGRESS oProgressm SIZE 150,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 DCREAD GUI TITLE L('Идет преобразование Excel-файла:')+' '+ALLTRIM(cExcelFile)+' '+L('в DBF-таблицу !!!') PARENT @oDialogm FIT EXIT oDialogm:show() DC_GetProgress(oProgressm,0,nMax) ************************************************************************************************ FOR j=1 TO N_Col // Цикл по колонкам блока загрузки FOR mNumBlock = 1 TO N_Block IF mNumBlock = 1 mRec1 = 2 + (mNumBlock - 1) * N_RecBlock // Начальная запись блока загрузки (в 1-м блоке наим.колонок здесь не загружать) ELSE mRec1 = 1 + (mNumBlock - 1) * N_RecBlock // Начальная запись блока загрузки ENDIF IF mNumBlock * N_RecBlock <= N_Rec mRec2 = mNumBlock * N_RecBlock // Конечная запись блока загрузки ELSE mRec2 = N_Rec // Конечная запись блока загрузки = конечной записи xls-листа ENDIF ********* Обработка случая, когда в файле 1 запись mFlagNRec = .T. IF mRec2 = mRec1 mRec2 = mRec1 + 1 mFlagNRec = .F. ENDIF mLinkBlock = R1C1_A1(j)+ALLTRIM(STR(mRec1,19))+":"+R1C1_A1(j)+ALLTRIM(STR(mRec2,19)) // Код обращения к j-му столбцу блока загрузки для Range() aValues := oUsedRange:Range(mLinkBlock):Value // Загрузка ДВУМЕРНОГО массива из одной строки с именами колонок 1-го листа Excel-книги <===############# Иногда здесь возникает тошибка. Надо разобраться * DC_DebugQout( aValues ) FOR i=1 TO mRec2 - mRec1 + IF(mFlagNRec,1,0) // Цикл по строкам блока загрузки (посчитать сколько в нем строк) * MsgBox(STR(mRec1)+STR(mRec2)+STR(i)) mFieldType = VALTYPE(aValues[i,1]) DO CASE CASE mFieldType = "C" // ************************************************************************** aFieldType[j] = "C" // Тип значений в j-й колонке (если есть хотя бы одно текстовое, то текстовое) * aFieldSize[j] = LEN(ALLTRIM(aValues[i,1])) * aFieldSize[j] = MAX(aFieldSize[j], LEN(ALLTRIM(aValues[i,1]))) aFieldSize[j] = MAX(aFieldSize[j], LEN(ALLTRIM(aValues[i,1]))+32) // К длине текстового поля добавлять 32 символа для режима разделения классов на типичную и нетипичную части aFieldSize[j] = IF(aFieldSize[j] <= 255, aFieldSize[j], 255 ) // <<<########################### * aFieldSize[j] = 255 aFieldDeci[j] = 0 CASE mFieldType = "N" // ************************************************************************** IF aValues[i,1] < 0 aFlag_neg[j] = .T. ENDIF IF aFieldType[j] <> 'C' aFieldType[j] = 'N' ENDIF IF aValues[i,1] <= 99999999999 * 1234567890123456789 * 1 10 19 * 12345678901.1234567 * 99999999999 mVal = ALLTRIM(STR(aValues[i,1],19,7)) ELSE mVal = ALLTRIM(STR(aValues[i,1],19,3)) ENDIF mVal = REMRIGHT(mVal,"0") // Убрать подряд идущие нули справа до 1-й значащей цифры Pos = AT('.', MVal) aFieldInt [j] = Pos - 1 // Определить число значащих цифр ДО запятой без ведущих нулей mFieldDeci = LEN(ALLTRIM(mVal)) - aFieldInt [j] - 1 * aFieldDeci[j] = MAX(aFieldDeci[j], mFieldDeci) aFieldDeci[j] = 7 // Всегда 7 знаков после запятой, в т.ч. и для целых, т.к. в шаг в Inp_sh * IF aFieldDeci[j] = 0 * aFieldDeci[j] = 1 // Целые не использовать, т.к. по ним не правильно индексируется * ELSE * aFieldDeci[j] = IF(aFieldDeci[j] <= 7, aFieldDeci[j], 7) // Ограничить точность исходных данных 7 десятичными знаками * ENDIF // Если с дробной частью, то плюс символ на точку // Если отрицательное, то символ на знак * aFieldSize[j] = MAX(aFieldSize[j], aFieldInt[j] + aFieldDeci[j] + 1 + IF(aFlag_neg[j],1,0)) * aFieldSize[j] = IF(aFieldSize[j]<=19, aFieldSize[j], 19) // В Excel числовые поля не могут больше 19 символов aFieldSize[j] = 19 // Всегда 19 знаков, т.к. в Excel числовые поля не могут больше 19 символов CASE mFieldType = "D" .OR. mFieldType = "X" // **************************************************** aFieldType[j] = "C" aFieldSize[j] = 255 aFieldDeci[j] = 0 OTHERWISE aFieldType[j] = "C" aFieldSize[j] = 255 aFieldDeci[j] = 0 ENDCASE * aFieldSize[j] = IF(aFieldSize[j]<= 250,aFieldSize[j], 250) aFieldSize[j] = IF(aFieldSize[j]<=32000,aFieldSize[j],32000) DC_GetProgress(oProgressm, ++nTime, nMax) NEXT NEXT // Ограничить точность исходных данных 7 десятичными знаками // Ограничить длину имени поля 10 знаками * AADD(aStructure, { aFieldName[j] , aFieldType[j], aFieldSize[j]+7-aFieldDeci[j], 7 }) // Добавить строку в структуру dbf-таблицы AADD(aStructure, { SUBSTR(ALLTRIM(aFieldName[j]),1,10) , aFieldType[j], aFieldSize[j] , aFieldDeci[j] }) // Добавить строку в структуру dbf-таблицы NEXT ******** Иногда невозможно создать базу данных, если она пуста, тогда возникает ошибка <<<############ *MsgBox(cDBaseFile) // Отладка *aDir := directory() // Отладка *DC_ArrayView( aStructure ) // Отладка *DC_DebugQout( aStructure ) // Отладка *LB_Warning(L('Stop') *LB_Warning(aStructure) ************************************************************************************************************************************************ DbCreate( cDBaseFile , aStructure ) // Создание файла Inp_data.dbf (или другого, например, Inp_rasp.dbf) по сформированной структуре DC_ASave( aStructure ,"_Structure.arx") // Запись массива структуры создаваемого файла ************************************************************************************************************************************************ ***** Цикл переноса данных из xls-листа в dbf-таблицу cDBaseFile = SUBSTR(cDBaseFile,1,AT('.',cDBaseFile)-1) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (cDBaseFile) EXCLUSIVE NEW;ZAP SELECT (cDBaseFile) // Сдесь сделать цикл по загружаемым блокам xls-листа по N_BlockRec записей * N_Rec // Кол-во записей в исходном xls-файле * N_Col // Кол-во колонок в исходном xls-файле * N_RecBlock = 65535 // Кол-во записей в блоке загрузки N_RecBlock = 1024 // Кол-во записей в блоке загрузки N_Block = 1 + INT( N_Rec / N_RecBlock ) // Кол-во полных блоков загрузки N_RecBlockEnd = ABS( N_Rec - N_RecBlock * ( N_Block - 1 ) ) // Кол-во записей в споследнем блоке FOR mNumBlock = 1 TO N_Block IF mNumBlock = 1 mRec1 = 2 + (mNumBlock - 1) * N_RecBlock // Начальная запись блока загрузки (в 1-м блоке наим.колонок здесь не загружать) ELSE mRec1 = 1 + (mNumBlock - 1) * N_RecBlock // Начальная запись блока загрузки ENDIF IF mNumBlock * N_RecBlock <= N_Rec mRec2 = mNumBlock * N_RecBlock // Конечная запись блока загрузки ELSE mRec2 = N_Rec // Конечная запись блока загрузки = конечной записи xls-листа ENDIF mLinkBlock = "A"+ALLTRIM(STR(mRec1,19))+":"+R1C1_A1(N_Col)+ALLTRIM(STR(mRec2,19)) // Код обращения к блоку загрузки для Range() aValues := oUsedRange:Range(mLinkBlock):Value // Загрузка ДВУМЕРНОГО массива из одной строки с именами колонок 1-го листа Excel-книги FOR i=1 TO mRec2 - mRec1 + 1 // Цикл по строкам блока загрузки (посчитать сколько в нем строк) APPEND BLANK FOR j=1 TO N_Col // Цикл по колонкам блока загрузки // Преобразовывать значения с типами числа и даты в текст, если тип поля текст DO CASE CASE VALTYPE(aValues[i,j]) = 'C' .AND. aFieldType[j] = 'C' FIELDPUT(j, SUBSTR(aValues[i,j],1,aFieldSize[j])) // Просто занести CASE VALTYPE(aValues[i,j]) = 'N' .AND. aFieldType[j] = 'N' FIELDPUT(j, VAL(STR(aValues[i,j], aFieldSize[j], aFieldDeci[j] ))) // Просто занести CASE VALTYPE(aValues[i,j]) = 'N' .AND. aFieldType[j] = 'C' FIELDPUT(j, STR(aValues[i,j], aFieldSize[j], aFieldDeci[j] )) // Преобразовать число к текстовому виду CASE VALTYPE(aValues[i,j]) = 'D' .AND. aFieldType[j] = 'C' FIELDPUT(j, DTOC(aValues[i,j])) // Преобразовать дату к текстовому виду ENDCASE NEXT DC_GetProgress(oProgressm, ++nTime, nMax) NEXT NEXT DC_GetProgress(oProgressm,nMax,nMax) oDialogm:Destroy() oBook:close() oBook:destroy() // Quit Excel oExcel:Quit() oExcel:Destroy() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций oSheet := nil oUsedRange := nil aValues := nil RETURN .T. * ###################### Окончание программы конвертации XLS -> DBF ################# ******** Функция преобразования номера колонки в ее буквенное наименование FUNCTION R1C1_A1(mNumColumn) aLiterCol := {} ******** Однобуквенные наименования столбцов FOR j1=1 TO 26 AADD(aLiterCol, CHR(j1+64)) NEXT *DC_DebugQout( { aLiterCol } ) ******** Двухбуквенные наименования столбцов FOR j1=1 TO 26 FOR j2=1 TO 26 AADD(aLiterCol, CHR(j1+64)+CHR(j2+64)) NEXT NEXT ******** Трехбуквенные наименования столбцов FOR j1=1 TO 26 FOR j2=1 TO 26 FOR j3=1 TO 26 AADD(aLiterCol, CHR(j1+64)+CHR(j2+64)+CHR(j3+64)) NEXT NEXT NEXT RETURN(aLiterCol[mNumColumn]) ************************************** * cEnde := ZAHL2CHR(numColumns) * aExcel := oSheet:range( "A1:"+cEnde+LTRIM(STR(numRows)) ):value FUNCTION ZAHL2CHR(numColumns) LOCAL nMal LOCAL cEnde IF numColumns > 26 nMal := INT(numColumns/26) cEnde := CHR(nMal+64)+CHR((numColumns-(nMal*26))+64) ELSE cEnde := CHR(numColumns+64) ENDIF RETURN cEnde ******************* ******** DBF => XLS ******************* FUNCTION DC_WorkArea2Excel( cExcelFile, nOrientation, lDisplayAlerts, ; // Original DC lVisible, aFields, lAutoFit, cDateFormat, aFieldEvals, ; cPassword, lFreezeRow1, lCsvFallBack, aColumnNames ) LOCAL oExcel, oBook, oSheet, nRow, aStru, i, cHeader, ; cFieldName, cFieldType, nFieldLen, nFieldDec, cFormat, ; xValue, GetList[0], GetOptions, oDlg, nCount := 0, ; cDbfName, nKeyCount, oProgress, lStatus := .t., aData, ; cRow, cColumns, cRange, aRow, bError, aStru2, nFound, ; cFieldValue, nFieldBlock DEFAULT nOrientation := xlLandscape, ; lDisplayAlerts := .f., ; lVisible := .f., ; lAutoFit := .f., ; cDateFormat := "US", ; // US, USSHORT, EURO, EUROSHORT, or send custom? aFieldEvals := {}, ; cExcelFile := DC_Path(AppName(.t.)) + 'worksheet.xls', ; lFreezeRow1 := .t., ; lCsvFallBack := .f. // aFieldEvals -> {{FIELDNAME,CodeBlock},....} Code blocks to evaluate for specific fields #if XPPVER > 1900000 // Create the "Excel.Application" object IF '.CSV' $ Upper(cExcelFile) RETURN DC_WorkArea2Csv(cExcelFile) ENDIF 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_WorkArea2Csv(cExcelFile) ELSE RETURN .f. ENDIF ELSE DC_WinAlert( "Excel is not installed" ) ENDIF RETURN .f. ENDIF #else DC_WinAlert('This feature is available in Xbase++ 1.9 and later only!') RETURN .f. #endif IF upper(cDateFormat) = "USSHORT" cDateFormat := "m\/d\/yyyy;@" ELSEIF upper(cDateFormat) = "US" cDateFormat := "mm\/dd\/yyyy;@" ELSEIF upper(cDateFormat) = "EUROSHORT" cDateFormat := "d\/m\/yyyy;@" ELSEIF upper(cDateFormat) = "EURO" cDateFormat := "dd\/mm\/yyyy;@" ENDIF // Avoid message boxes such as "File already exists". Also, // ensure the Excel application is visible. oExcel:DisplayAlerts := lDisplayAlerts oExcel:visible := lVisible // Add a workbook to the Excel application. Query for // the active sheet (sheet-1) and set up page/paper // orientation. cDbfName := dbInfo(DBO_FILENAME) IF cDbfName = '' nKeyCount := RecCount() ELSE nKeyCount := DC_KeyCount() ENDIF @ 0,0 DCSAY L('Creating Excel Worksheet: ') + cExcelFile SAYSIZE 0 @ 1,0 DCPROGRESS oProgress SIZE 50,1 ; TYPE XBPSTATIC_TYPE_TEXT ; COLOR GRA_CLR_CYAN, GRA_CLR_WHITE ; PERCENT ; PERCENTCOLOR GRA_CLR_RED ; RADIUS 20 ; OUTLINE ; DYNAMIC ; EVERY Int(nKeyCount/100) @ 3,0 DCPUSHBUTTON CAPTION L('Cancel') SIZE 9,1.2 ACTION {||lStatus:=.f.} DCGETOPTIONS NORESIZE ALWAYSONTOP _PIXEL .f. DCREAD GUI FIT TITLE L('Exporting to Excel') ; MODAL EXIT PARENT @oDlg OPTIONS GetOptions NOAUTORESTORE oBook := oExcel:workbooks:Add() oSheet := oBook:ActiveSheet oSheet:PageSetup:Orientation := nOrientation DC_DbGoTop() nRow := 1 // Feed in the data from the table to the Cells // of the sheet. aStru := dbStruct() IF Valtype(aFields) == 'A' aStru2 := AClone(aStru) aStru := Array(0) FOR i := 1 TO Len(aFields) cFieldName := Upper(Alltrim(aFields[i])) nFound := AScan(aStru2,{|a|Upper(a[1])==cFieldName}) IF nFound > 0 AAdd( aStru, aStru2[nFound] ) ENDIF NEXT ENDIF aFields := Array(0) FOR i := 1 TO Len(aStru) cFieldName := aStru[i,1] nFieldDec := aStru[i,4] IF Valtype(&(cFieldName)) $ 'NF' IF nFieldDec == 0 cFormat := '0' ELSE cFormat := '0.' + Repl('0',nFieldDec) ENDIF ELSEIF Valtype(&(cFieldName))=='D' cFormat := cDateFormat ELSEIF Valtype(&(cFieldName)) $ 'CM' cFormat := "@" // Preserves leading 0s on strings that look like numbers ELSE cFormat := '' ENDIF AAdd(aFields,{cFieldName,cFieldName,cFormat}) NEXT FOR i := 1 TO Len(aFields) IF Len(aFields[i]) < 3 ASize(aFields[i],3) ENDIF IF Valtype(aColumnNames) == 'A' .AND. Len(aColumnNames) == Len(aFields) cHeader := aColumnNames[i] ELSE cHeader := aFields[i,2] ENDIF IF !Empty(cHeader) oSheet:Cells(nRow,i):Value := cHeader ENDIF cFormat := aFields[i,3] IF !Empty(cFormat) oSheet:Columns(i):NumberFormat := cFormat ENDIF NEXT aRow := Array(Len(aStru)) aData := Array(0) cColumns := Get_Excel_Column_ID(Len(aRow)) nRow += 2 DO WHILE !DC_Eof() .AND. lStatus DC_CompleteEvents() DC_GetProgress(oProgress,nCount++,nKeyCount) FOR i := 1 TO Len(aFields) cFieldName := aFields[i,1] cFieldValue := &(cFieldName) nFieldBlock := aScan(aFieldEvals,{|a|upper(a[1])==upper(cFieldName)}) IF nFieldBlock > 0 cFieldValue := Eval(aFieldEvals[nFieldBlock,2],cFieldValue) ENDIF IF Valtype(cFieldValue) == 'D' aRow[i] := Dtoc(cFieldValue) ELSEIF Valtype(cFieldValue) $ 'CM' aRow[i] := Trim(cFieldValue) ELSE aRow[i] := cFieldValue ENDIF NEXT AAdd( aData, AClone(aRow) ) nRow++ DC_DbSkip(1) ENDDO *cRange := 'A3:' + cColumns + Ltrim(Str(nRow-1)) // Оригинал Роджера cRange := 'A2:' + cColumns + Ltrim(Str(nRow-2)) // Чтобы не было пустой строки после заголовка oDlg:destroy() oSheet:Range(cRange):Value := aData // Force a reformat for the size of the first column IF lAutoFit FOR i := 1 TO Len(aFields) oSheet:Columns(i):AutoFit() NEXT ENDIF IF lFreezeRow1 oSheet:Range("A1:A1"):EntireRow:Font:Bold := .t. oSheet:Activate() oSheet:Application:ActiveWindow:SplitRow := 1 oSheet:Application:ActiveWindow:FreezePanes := .T. ENDIF bError := ErrorBlock( {|e| Break(e) } ) BEGIN SEQUENCE // Save workbook as ordinary excel file. oBook:SaveAs(cExcelFile,xlWorkbookNormal,cPassword) RECOVER END SEQUENCE ErrorBlock(bError) oSheet:destroy() oBook:close() oBook:destroy() // Quit Excel oExcel:Quit() oExcel:Destroy() RETURN .t. * ------------- FUNCTION DC_BaseFontSize(nPointSize) // Jack Duijf 17-07-2014 STATIC scPointSize := 8 If ValType(nPointSize) = "N" ; scPointSize := nPointSize ; Endif Return scPointSize * ------------- FUNCTION DC_BaseFont(nPointSize,cFontName,lBold) // Jack Duijf 17-07-2014 LOCAL cRet := "" STATIC scFont := "MS Sans Serif" iF Valtype(lBold) <> "L" ; lBold := .F. ; Endif If ValType(cFontName) = "C" ; scFont := AllTrim(cFontName) ; Endif If ValType(nPointSize) <> "N" ; nPointSize := DC_BaseFontSize() ; Endif cRet := AllTrim(Var2Char(Int(nPointSize))) + "." + AllTrim(scFont) If lBold cRet += " Bold" Endif Return cRet * -------------- FUNCTION DC_Recursion( cProcName, nTimes, lMessage ) LOCAL nLen := Len(cProcName), nCount := 0, i := 1 DO WHILE .t. IF Empty(ProcName(i)) EXIT ELSEIF Substr(Upper(Alltrim(ProcName(i))),1,nLen) == Upper(Alltrim(cProcName)) nCount++ IF nCount >= nTimes IF lMessage DC_MsgBox({'Excessive Recursions in procedure ' + cProcName, ; 'Remove any calls from to ' + cProcName + ; '() from DATALINK clauses'}) ENDIF RETURN .t. ENDIF ENDIF i++ ENDDO RETURN .f. * ------------ FUNCTION DC_VersionExpress( n ) n := IIF( Valtype(n)='N',n,0 ) IF n = 0 RETURN 'eXPress++ (c) Version 1.9' ELSEIF n = 1 RETURN '1' ELSEIF n = 2 RETURN '9' ELSEIF n = 3 RETURN '260' ENDIF RETURN '' * ------------ FUNCTION DC_CompleteEvents( aGetList, oDialog ) LOCAL i, mp1, mp2, oXbp, nEvent, nSeconds := Seconds() If Valtype(aGetList) = 'A' RETURN DC_ReadGuiEventLoop( aGetList,,,oDialog,,.001,.1,.f. ) ENDIF nEvent := -1 DO WHILE nEvent # 0 .AND. Seconds() - nSeconds < 2 nEvent := AppEvent( @mp1, @mp2, @oXbp, .1 ) IF nEvent == DCGUI_EVENT_ACTION Eval(mp1) ELSEIF nEvent > 0 .AND. Valtype(oXbp) == 'O' .AND. !(nEvent = xbeM_Motion .AND. mp1 == NIL) oXbp:handleEvent( nEvent, mp1, mp2 ) ENDIF ENDDO RETURN .T. * ------------- FUNCTION DC_MergeBlocks( bBlock1, bBlock2 ) IF Valtype(bBlock1) = 'B' .AND. Valtype(bBlock2) = 'B' RETURN {|mp1,mp2,oXbp|Eval(bBlock1,mp1,mp2,oXbp),Eval(bBlock2,mp1,mp2,oXbp)} ELSEIF Valtype(bBlock1) = 'B' RETURN bBlock1 ELSEIF Valtype(bBlock2) = 'B' RETURN bBlock2 ENDIF RETURN nil * -------------- FUNCTION DC_MoveObject( oXbp, mp1, nDragMode, nCursor, aDesign, nStopEvent, ; nGridRows, nGridCols ) LOCAL oPS, oParent, nEvent, mp2, ; aSize, aPos, oObject, nRowOffset, nColOffset, ; nColPos, nRowPos, nWidth, nHeight, oThread, nTop, nRight, ; lSnap, lHotMove, nGridType, nSaveWidth, nSaveHeight, ; nSaveRow, nSaveCol, nSaveBG, nSaveFG, aCoords DEFAULT aDesign := {} ASize(aDesign,6) lSnap := aDesign[1] DEFAULT lSnap := .t. lHotMove := aDesign[2] DEFAULT lHotMove := .t. nGridType := aDesign[3] DEFAULT nGridType := 0 IF Empty(nGridCols) nGridCols := aDesign[4] ENDIF DEFAULT nGridCols := 7 IF Empty(nGridRows) nGridRows := aDesign[5] ENDIF DEFAULT nGridRows := 10 DEFAULT nCursor := POINTER_ARROW_1 DEFAULT mp1 := {0,0} DEFAULT nDragMode := DCGUI_DRAG_ENTIRE_OBJECT DEFAULT nStopEvent := xbeM_LbUp STORE -1 TO nSaveWidth, nSaveHeight, nSaveRow, nSaveCol oParent := oXbp:SetParent() oParent:CaptureMouse(.t.) oParent:SetPointer( nil, nCursor, 1 ) nColOffset := mp1[1] nRowOffset := mp1[2] IF oParent:isDerivedFrom('XbpTabPage') IF oParent:tabHeight <= 0 nRowOffset += 20 ELSE nRowOffset += oParent:tabHeight ENDIF ENDIF nSaveBG := oXbp:setColorBG() IF nSaveBG == nil nSaveBG := oXbp:setParent():setColorBG() ENDIF nSaveFG := oXbp:setColorFG() IF nSaveFG == nil nSaveFG := oXbp:setParent():setColorFG() ENDIF oXbp:setColorBG(GRA_CLR_RED) oXbp:setColorFG(GRA_CLR_WHITE) IF Valtype(nSaveBG) # 'N' nSaveBG := GRA_CLR_BACKGROUND ENDIF IF Valtype(nSaveFG) # 'N' nSaveFG := GRA_CLR_DEFAULT ENDIF oObject := oXbp SetAppFocus(oObject) nEvent := xbeP_None // DC_ClearEvents() aSize := oXbp:CurrentSize() aPos := oXbp:CurrentPos() IF nGridType > 0 oThread := Thread():new() Sleep(10) oPS := oParent:lockPS() oThread:start( {||_FillGrid( oPS, oParent, nGridCols, nGridRows, nGridType )} ) ENDIF nColPos := aPos[1] nRowPos := aPos[2] nWidth := aSize[1] nHeight := aSize[2] aCoords := { nColPos, nil, nRowPos, nil, nWidth, nil, nHeight, nil } nTop := nRowPos + nHeight nRight := nColPos + nWidth IF nDragMode = DCGUI_DRAG_ENTIRE_OBJECT ELSEIF nDragMode = DCGUI_DRAG_TOP nWidth := aSize[1] ELSEIF nDragMode = DCGUI_DRAG_BOTTOM nWidth := aSize[1] nRowPos += nHeight ELSEIF nDragMode = DCGUI_DRAG_LEFT nHeight := aSize[2] nColPos += nWidth ELSEIF nDragMode = DCGUI_DRAG_RIGHT .OR. nDragMode = DCGUI_DRAG_LEFT nHeight := aSize[2] ENDIF DO WHILE nEvent <> xbeP_Close nEvent := AppEvent( @mp1, @mp2, @oXbp, 0 ) IF nEvent = xbeM_Motion .AND. mp1 == NIL Sleep(1) LOOP ELSEIF nEvent == 0 .OR. Empty(oXbp) Sleep(1) LOOP ENDIF oXbp:handleEvent( nEvent, mp1, mp2 ) IF nEvent = xbeM_Motion aPos := mp1 IF nDragMode = DCGUI_DRAG_ENTIRE_OBJECT nColPos := aPos[1]-nColOffset nRowPos := aPos[2]-nRowOffset ELSEIF nDragMode = DCGUI_DRAG_TOP nHeight := aPos[2]-nRowPos ELSEIF nDragMode = DCGUI_DRAG_BOTTOM nRowPos := aPos[2] nHeight := nTop - aPos[2] ELSEIF nDragMode = DCGUI_DRAG_LEFT nColPos := aPos[1] nWidth := nRight - aPos[1] ELSEIF nDragMode = DCGUI_DRAG_RIGHT nWidth := aPos[1]-nColPos ELSEIF nDragMode = DCGUI_DRAG_RIGHT_TOP nWidth := aPos[1]-nColPos nHeight := aPos[2]-nRowPos ELSEIF nDragMode = DCGUI_DRAG_LEFT_TOP nColPos := aPos[1] nWidth := nRight - aPos[1] nHeight := aPos[2]-nRowPos ELSEIF nDragMode = DCGUI_DRAG_LEFT_BOTTOM nColPos := aPos[1] nWidth := nRight - aPos[1] nRowPos := aPos[2] nHeight := nTop - aPos[2] ELSEIF nDragMode = DCGUI_DRAG_RIGHT_BOTTOM nRowPos := aPos[2] nHeight := nTop - aPos[2] nWidth := aPos[1]-nColPos ENDIF ELSEIF nEvent = xbeP_Keyboard .AND. mp1 = K_ESC EXIT ELSEIF nEvent = nStopEvent IF oObject:isDerivedFrom('XbpTabPage') nRowOffset-=20 ENDIF IF lSnap nColPos := Round( nColPos / nGridCols, 0 ) * nGridCols nRowPos := Round( nRowPos / nGridRows, 0 ) * nGridRows ENDIF IF nWidth > 0 .AND. nHeight > 0 //.AND. nDragMode # DCGUI_DRAG_ENTIRE_OBJECT oObject:setPos( { nColPos, nRowPos } ) oObject:setSize( { nWidth, nHeight } ) ENDIF EXIT ENDIF IF lHotMove IF nWidth > 0 .AND. nHeight > 0 IF nColPos # nSaveCol .OR. nRowPos # nSaveRow oObject:setPos( { nColPos, nRowPos } ) oObject:toFront() ENDIF IF (nWidth # nSaveWidth .OR. nHeight # nSaveHeight) .AND. nDragMode # DCGUI_DRAG_ENTIRE_OBJECT oObject:setSize( { nWidth, nHeight } ) ENDIF ENDIF ENDIF nSaveWidth := nWidth nSaveHeight := nHeight nSaveCol := nColPos nSaveRow := nRowPos ENDDO aCoords[2] := nColPos aCoords[4] := nRowPos aCoords[6] := nWidth aCoords[8] := nHeight IF Valtype(nSaveBG) = 'N' oObject:setColorBG(nSaveBG) ENDIF IF Valtype(nSaveFG) = 'N' oObject:setColorFG(nSaveFG) ELSE oObject:setColorFG(GRA_CLR_BLACK) ENDIF oParent:CaptureMouse(.f.) IF Valtype(oPS) = 'O' oParent:unlockPS( oPS ) ENDIF oParent:hide() oParent:show() oXbp:toFront() RETURN aCoords * -------------- STATIC PROCEDURE _FillGrid ( oPS, oParent, nGridCols, nGridRows, nGridType ) LOCAL i, j, nWidth, nHeight, aAttr[ GRA_AA_COUNT ] nWidth := oParent:currentSize()[1] nHeight := oParent:currentSize()[2] aAttr[ GRA_AL_COLOR ] := GRA_CLR_DARKGRAY oPS := oParent:lockPS() IF nGridType = 1 // dots aAttr[ GRA_AL_TYPE ] := GRA_LINETYPE_DOT GraSetAttrLine( oPS, aAttr ) FOR i := 1 TO nWidth STEP nGridCols FOR j := 1 TO nHeight STEP nGridRows GraLine( oPS, { i, j }, { i+1, j+1 } ) NEXT Sleep(.1) NEXT ELSEIF nGridType = 2 // lines GraSetAttrLine( oPS, aAttr ) FOR i := 1 TO nWidth STEP nGridCols GraLine( oPS, {i,1}, {i,nHeight} ) NEXT FOR j := 1 TO nHeight STEP nGridRows GraLine( oPS, {1, j }, {nWidth, j} ) NEXT ENDIF RETURN * ------------- FUNCTION DC_FontHeight( cFont, oXbp, oParent ) IF Empty(cFont) IF Valtype(oXbp)='O' cFont := oXbp:SetFontCompoundName() ENDIF IF Empty(cFont) .AND. Valtype(oParent)='O' cFont := oParent:SetFontCompoundName() ENDIF ENDIF IF !Empty(cFont) RETURN Val(Substr(cFont,1,At('.',cFont)-1)) ENDIF RETURN 0 * ------------ FUNCTION DC_GetBlock( aBlock, cType, lDisplayError ) LOCAL bBlock, cVar, cPicture, bLink, cValue, cValtype, xSetVal, ; bErrorBlock IF Valtype(aBlock)='C' bBlock := nil IF !Empty(aBlock) bErrorBlock := ErrorBlock({||_BlockError(aBlock,lDisplayError)}) BEGIN SEQUENCE bBlock := &(aBlock) END SEQUENCE ErrorBlock(bErrorBlock) ENDIF RETURN bBlock ELSEIF Valtype(aBlock)='A' .AND. !Empty(aBlock) IF Valtype(aBlock[1]) $ 'BNA' RETURN aBlock[1] ENDIF IF Len(aBlock) == 2 RETURN nil ENDIF bBlock := aBlock[1] ASize( aBlock, 8 ) cVar := aBlock[2] IF Valtype(cType) # 'C' cType := aBlock[3] IF Empty(cType) .AND. !Empty(cVar) cType := Type(cVar) ENDIF ENDIF cPicture := aBlock[5] bLink := aBlock[6] cValue := aBlock[7] IF !Empty(cVar) bErrorBlock := ErrorBlock({||_BlockError()}) BEGIN SEQUENCE bBlock := NIL IF Left(Alltrim(Strtran(cVar,' ','')),2) = '{|' bBlock := &(cVar) ELSE cValtype := Valtype(&cVar) IF !Empty(bLink) bLink := &(bLink) ENDIF IF !Empty(cValue) xSetVal := cValue IF Valtype(bLink)='B' bBlock := {|x,u| IIf( PCount()==0, u:=&cVar,; &cVar := IIF(Valtype(x)='L',IIF(x,xSetVal,&cVar),xSetVal)), ; Eval(bLink),u} ELSE bBlock := {|x| IIf( PCount()==0, &cVar, ; &cVar := IIF(Valtype(x)='L',IIF(x,xSetVal,&cVar),xSetVal))} ENDIF ELSEIF cType $ 'OLANCM' IF Valtype(bLink)='B' bBlock := {|x,u| IIf( PCount()==0 , u:=&cVar, &cVar:=x), ; Eval(bLink), u } ELSE bBlock := {|x| IIf( PCount()==0 , &cVar, &cVar:=x) } ENDIF ELSEIF cValType = 'D' IF Valtype(bLink)='B' bBlock := {|x| IIF( PCount()==0 , Transform(&cVar,cPicture), ; &cVar := Ctod(x) ), Eval(bLink), &cVar } ELSE bBlock := {|x| IIF( PCount()==0 , Transform(&cVar,cPicture), ; &cVar := Ctod(x) ) } ENDIF ELSEIF cValType = 'L' IF Valtype(bLink)='B' bBlock := {|x| IIF( PCount()==0 , IIF(&cVar,'Y','N'), ; &cVar := IIF(UPPER(x)='Y',.t.,.f.) ), Eval(bLink), &cVar } ELSE bBlock := {|x| IIF( PCount()==0 , IIF(&cVar,'Y','N'), ; &cVar := IIF(UPPER(x)='Y',.t.,.f.) ) } ENDIF ELSEIF cValType = 'N' IF Valtype(bLink)='B' bBlock := {|x| IIF( PCount()==0 , Transform(&cVar,cPicture), ; &cVar := Val(x) ), Eval(bLink), &cVar } ELSE bBlock := {|x| IIF( PCount()==0 , Transform(&cVar,cPicture), ; &cVar := Val(x) ) } ENDIF ELSE IF Valtype(bLink)='B' bBlock := {|x| IIF( PCount()==0 , Transform(&cVar,cPicture), ; &cVar := Val(x) ), Eval(bLink), &cVar } ELSE bBlock := {|x| IIF( PCount()==0 , Transform(&cVar,cPicture), ; &cVar := Val(x) ) } ENDIF ENDIF ENDIF END SEQUENCE ErrorBlock(bErrorBlock) ELSE bBlock := NIL ENDIF aBlock[1] := bBlock ELSE bBlock := aBlock ENDIF RETURN bBlock * --------------------- STATIC PROCEDURE _BlockError( cBlock, lDisplayError ) DEFAULT lDisplayError := .t. IF !Empty(cBlock) .AND. lDisplayError DC_WinAlert('Invalid Code Block' + Chr(13) + cBlock ) ENDIF BREAK RETURN * --------------------- FUNCTION DC_BitMapDraw ( oParent, ncbResource, lClearBox, nBGColor ) LOCAL aSize, aTarget, aSource, nAspect, lAutoScale, oPS, ; aCargo, aAttr, lCenter, oBitmap DEFAULT lClearBox := .t., ; nBGColor := GRA_CLR_BACKGROUND IF oParent:status() <= 0 RETURN nil ENDIF aCargo := oParent:cargo[LEN(oParent:cargo)] oPS := oParent:lockPS() // oPS := aCargo[1] oBitMap := aCargo[2] IF Valtype(ncbResource) = 'B' ncbResource := Eval(ncbResource) ENDIF /* IF Valtype(ncbResource)='N' .AND. !Empty(ncbResource) oBitMap:load( NIL, ncbResource ) ELSEIF Valtype(ncbResource)='C' .AND. (Empty(ncbResource) .OR. File(ncbResource)) IF '.JPG' $ Upper(ncbResource) .OR. '.GIF' $ Upper(ncbResource) .OR. ; '.BMP' $ Upper(ncbResource) .OR. '.PNG' $ Upper(ncbResource) .OR. Empty(ncbResource) oBitMap:LoadFile( ncbResource ) ENDIF ELSEIF Valtype(ncbResource)$'MC' oBitMap:setBuffer(ncbResource) ELSEIF Valtype(ncbResource)='O' oBitMap := ncbResource ENDIF */ aTarget := nil // aCargo[3] aSource := aCargo[4] lAutoScale := aCargo[5] lCenter := aCargo[6] DEFAULT lCenter := .t. aSize := oParent:currentSize() IF Valtype(aTarget) # 'A' aTarget := {1,1,aSize[1]-2,aSize[2]-2} ENDIF IF lClearBox aAttr := Array( GRA_AA_COUNT ) aAttr [ GRA_AA_COLOR ] := nBGColor GraSetAttrArea( oPS, aAttr ) GraBox( oPS, {aTarget[1],aTarget[2]}, {aTarget[3],aTarget[4]} , GRA_FILL ) ENDIF // // oBitmap := DC_GetBitmap( ncbResource ) // J. Duijf 11-01-2013 Also allow icons // J. Duijf 17-06-2013 Pass parent size for optimal icon size. // oBitmap := DC_GetBitmap( ncbResource,,,,,.T.,{aTarget[3],aTarget[4]} ) IF Valtype(oBitmap) # 'O' RETURN oPS ENDIF IF Valtype(aSource) # 'A' aSource := {0,0,oBitmap:xSize,oBitmap:ySize} IF aSource[3] <= 0 aSource := aTarget ENDIF ENDIF IF oBitMap:xSize <=0 .OR. oBitMap:ySize <=0 oParent:unlockPS() RETURN oPS ENDIF nAspect := aSource[3] / aSource[4] IF lAutoScale // IF nAspect > 1 IF nAspect > aTarget[3] / aTarget[4] aTarget[4] := aTarget[3] / nAspect ELSE aTarget[3] := aTarget[4] * nAspect ENDIF // ELSE // aTarget[3] := aTarget[4] * nAspect // ENDIF ENDIF IF lCenter IF aTarget[3] < aSize[1]-2 nAspect := ( aSize[1]-2-aTarget[3] ) / 2 aTarget[1] += nAspect aTarget[3] += nAspect ENDIF IF aTarget[4] < aSize[2]-2 nAspect := ( aSize[2]-2-aTarget[4] ) / 2 aTarget[2] += nAspect aTarget[4] += nAspect ENDIF ENDIF IF oBitmap:isDerivedFrom('XbpIcon') oBitmap:draw( oPS, aTarget ) ELSE oBitmap:draw( oPS, aTarget, aSource, , GRA_BLT_BBO_IGNORE ) ENDIF Sleep(1) oParent:unlockPS() RETURN oPS * ------------- FUNCTION DC_ClearEvents ( nClearEvent, oClearXbp, aKeyboardQueue, aKeepEvents ) LOCAL nEvent := 1, aNewQueue := {}, mp1, mp2, oXbp, lAddToQueue,i DO WHILE nEvent <> 0 nEvent := AppEvent( @mp1, @mp2, @oXbp, .01 ) IF Valtype(aKeyboardQueue) = 'A' .AND. nEvent == xbeP_Keyboard AAdd(aKeyboardQueue,mp1) ENDIF IF Valtype(nClearEvent) = 'N' .AND. Valtype(oClearXbp) = 'O' .AND. ; !( nEvent == nClearEvent .AND. oXbp == oClearXbp ) lAddToQueue := .t. ELSEIF Valtype(nClearEvent) = 'N' .AND. !( nEvent == nClearEvent ) lAddToQueue := .t. ELSEIF Valtype(oClearXbp) = 'O' .AND. !( oXbp == oClearXbp ) lAddToQueue := .t. ELSEIF Valtype(aKeepEvents) == 'A' .AND. nEvent $ aKeepEvents lAddToQueue := .t. ELSE lAddToQueue := .f. ENDIF IF lAddToQueue AADD( aNewQueue, { nEvent, mp1, mp2, oXbp } ) ENDIF ENDDO FOR i := 1 TO LEN(aNewQueue) PostAppEvent( aNewQueue[i,1], aNewQueue[i,2], aNewQueue[i,3], aNewQueue[i,4] ) NEXT RETURN nil * ------------- FUNCTION DC_SaveEvents () LOCAL aEventQueue := {}, nEvent := 1, mp1, mp2, oXbp DO WHILE nEvent <> 0 nEvent := AppEvent( @mp1, @mp2, @oXbp, .01 ) IF nEvent # 0 AAdd( aEventQueue, { nEvent, mp1, mp2, oXbp } ) ENDIF ENDDO RETURN aEventQueue * ------------- FUNCTION DC_RestoreEvents( aEventQueue ) LOCAL i, nEvent, mp1, mp2, oXbp FOR i := 1 TO Len(aEventQueue) nEvent := aEventQueue[i,1] mp1 := aEventQueue[i,2] mp2 := aEventQueue[i,3] oXbp := aEventQueue[i,4] PostAppEvent( nEvent, mp1, mp2, oXbp ) NEXT RETURN nil * ------------ FUNCTION DC_GetCodeBlockText( bBlock ) RETURN Var2Char(bBlock) * ------------ FUNCTION DC_CenterObject( oXbp, oRel ) LOCAL nRelWidth, nRelHeight, nWidth, nHeight, nCol, nRow, aPos DEFAULT oRel := oXbp:setParent() nWidth := oXbp:currentSize()[1] nHeight := oXbp:currentSize()[2] nRelWidth := oRel:currentSize()[1] nRelHeight := oRel:currentSize()[2] nCol := (nRelWidth-nWidth)/2 nRow := (nRelHeight-nHeight)/2 IF oRel == oXbp:setParent() oXbp:setPos( {nCol,nRow} ) ELSE aPos := DC_CalcAbsolutePosition({0,0},oRel) oXbp:setPos( {aPos[1]+nCol,aPos[2]+nRow} ) ENDIF RETURN nil * ------------------------ FUNCTION DC_CenterObject_X( oXbp ) oXbp:setPos({(oXbp:setParent():currentSize()[1]-oXbp:currentSize()[1])/2, ; oXbp:currentPos()[2]}) RETURN nil * ------------------------ FUNCTION DC_CenterObject_Y( oXbp ) oXbp:setPos({oXbp:currentPos()[1], ; (oXbp:setParent():currentSize()[2]-oXbp:currentSize()[2])/2}) RETURN nil * ------------------------ CLASS MagicHelp FROM Thread HIDDEN: METHOD DisplayToolTip() METHOD PaintTheTip() EXPORTED: VAR producerID VAR oLastMotionXBP VAR oLastTipXBP VAR oBlockedXBP VAR nLastTipTime VAR nLastShowTime VAR aLastMotionPos VAR oTip VAR lTipIsShown VAR nTipSensitivity // VAR aToolTips VAR lActive VAR aToolColor VAR cToolFont VAR nToolTime PROTECTED: VAR terminated // VAR nLastCellPos INLINE METHOD init() IF DC_LangSet() == DCLANG_CHINESE ::nTipSensitivity := .5 ELSE ::nTipSensitivity := DC_ToolTipSensitivity() ENDIF ::thread:init() ::producerID := ThreadID() ::terminated := .F. ::lActive := .t. ::aToolColor := { GRA_CLR_BLACK, GRA_CLR_WHITE } ::nLastShowTime := 0 RETURN EXPORTED: METHOD execute() METHOD atStart() METHOD showTip() METHOD hideTip() METHOD terminate() METHOD CheckTermination() ENDCLASS * -------------------- METHOD MagicHelp:atStart() ::lTipIsShown := .F. ::oLastMotionXBP := NIL ::aLastMotionPos := NIL // ::nLastCellPos := 0 RETURN * -------------------- METHOD MagicHelp:Execute() LOCAL nEvent, mp1:=0, mp2:=0, oXbp:=NIL, nLastMotionTime := 0, oSaveXbp, ; xSavemp1, nSaveEvent, nTimeOut := DC_ToolTipTimeOut(), oLastXbp, ; lastmp1, nLastEvent DO WHILE !::Terminated nEvent := LastAppEvent(@mp1,@mp2,@oXbp,::producerID) IF Valtype(oXbp) # 'O' LOOP ELSEIF oXbp:isDerivedFrom('DC_SetTimerEvent') oXbp := oSaveXbp mp1 := xSavemp1 nEvent := nSaveEvent IF Empty(oXbp) LOOP ENDIF ELSE oSaveXbp := oXbp xSavemp1 := mp1 nSaveEvent := nEvent ENDIF Sleep( 10 ) IF(oXbp:isDerivedFrom("XbpIWindow")) oXbp := oXbp:setParent() ENDIF IF(ValType(::oBlockedXBP)=="O" .AND. oXbp == ::oBlockedXBP ) LOOP ENDIF IF Valtype(oLastXbp) # 'O' oLastXbp := oXbp nLastEvent := nEvent lastmp1 := mp1 ELSEIF oXbp == oLastXbp .AND. Valtype(lastmp1) = 'A' .AND. Valtype(mp1) = 'A' .AND. lastmp1[1] == mp1[1] .AND. ; lastmp1[2] == mp1[2] .AND. nLastEvent == nEvent IF ::nLastShowTime == -1 LOOP ENDIF ELSEIF oXbp == oLastXbp .AND. Valtype(lastmp1) = 'A' .AND. Valtype(mp1) = 'A' .AND. (lastmp1[1] # mp1[1] .OR. lastmp1[2] # mp1[2]) ::nLastShowTime := Seconds() oLastXbp := oXbp lastmp1 := mp1 nLastEvent := nEvent LOOP ENDIF IF Valtype(::oLastTipXBP) == 'O' .AND. ::nLastShowTime >= 0 .AND. Seconds() - ::nLastShowTime > nTimeOut ::nLastShowTime := -1 ::hideTip() oLastXbp := oXbp lastmp1 := mp1 nLastEvent := nEvent LOOP ENDIF IF(nEvent == xbeM_Motion) .AND. ::lActive .AND. Valtype(mp1) = 'A' .AND. ; Len(mp1) == 2 .AND. mp1[1] > 0 .AND. mp1[2] > 0 ::oBlockedXBP := NIL IF ( ValType( ::oLastMotionXBP) == "O" .AND. oXbp == ::oLastMotionXBP ) IF( ::aLastMotionPos[1] == mp1[1] .AND. ::aLastMotionPos[2] == mp1[2] ) IF ((Seconds() - nLastMotionTime) > ::nTipSensitivity) // IF oXbp:isderivedFrom("XbpCellGroup") // ::nLastCellPos := oXbp:cellFromPos(mp1) //ENDIF ::showTip(oXbp) ENDIF ELSEIF ValType(::oLastTipXBP) == 'O' .AND. ; oXbp:setParent() == ::oLastTipXBP:setParent() .AND. ; (oXbp:isderivedFrom("XbpCellGroup") .OR. oXbp:isDerivedFrom("XbpScrollBar") ) ::hideTip() ::oLastMotionXBP := oXbp ::aLastMotionPos := AClone(mp1) nLastMotionTime := Seconds() IF( ::nLastTipTime>0 .AND. (Seconds()-::nLastTipTime)<=0.5 ) // ::nLastCellPos := oXbp:cellFromPos(mp1) ::showTip(oXbp) ENDIF ELSE ::aLastMotionPos := AClone(mp1) nLastMotionTime := Seconds() ENDIF ELSEIF ( ValType(::oLastTipXBP) == "O" .AND. ; oXbp:setParent() == ::oLastTipXBP:setParent() .AND. oXbp != ::oLastTipXBP ) ::hideTip() ::oLastMotionXBP := oXbp ::aLastMotionPos := AClone(mp1) nLastMotionTime := Seconds() IF( ::nLastTipTime>0 .AND. (Seconds()-::nLastTipTime)<=0.5 ) // IF oXbp:isderivedFrom("XbpCellGroup") // ::nLastCellPos := oXbp:cellFromPos(mp1) // ENDIF ::showTip(oXbp) ENDIF ELSE ::oLastMotionXBP := oXbp ::aLastMotionPos := AClone(mp1) nLastMotionTime := Seconds() ::hideTip() ENDIF ELSEIF nEvent != xbeP_Paint .AND. Valtype(oXbp)='O' IF(oXbp==::oLastTipXBP .AND. !oXbp:isDerivedFrom("XbpCellGroup")) ::oBlockedXBP := oXbp ENDIF ::oLastMotionXBP := NIL ::hideTip() ENDIF ::checkTermination() ENDDO RETURN * -------------------- METHOD MagicHelp:showTip() IF(!::lTipIsShown) ::DisplayToolTip(::oLastMotionXBP) IF Valtype(::oTip) = 'O' ::oTip:show() ::lTipIsShown := .T. ::oLastTipXBP := ::oLastMotionXBP ::nLastShowTime := Seconds() ELSEIF !::oLastMotionXBP:isDerivedFrom("XbpCellGroup") ::lTipIsShown := .F. ::oLastTipXBP := nil ELSEIF !::oLastMotionXBP:isDerivedFrom("XbpScrollBar") ::lTipIsShown := .F. ::oLastTipXBP := nil ENDIF ::oBlockedXBP := NIL ENDIF RETURN * -------------------- METHOD MagicHelp:hideTip() IF(::lTipIsShown) // ::oTip:hide() IF ::oTip:status() > 0 ::oTip:destroy() ENDIF ::lTipIsShown := .F. ::nLastTipTime := Seconds() ENDIF RETURN * -------------------- METHOD MagicHelp:terminate RETURN ( ::terminated := .T. ) * -------------------- METHOD MagicHelp:checkTermination IF ::terminated ::hideTip() ::terminated := .F. ::quit() Sleep(5) ENDIF RETURN self * -------------------- METHOD MagicHelp:DisplayToolTip(oXbpRequestingHint) LOCAL cText := "(nil)" LOCAL aPos LOCAL oHelpLink LOCAL cFont, nColorFG, nColorBG, nDelayTime LOCAL aMax := Dc_DeskTopSize() // J. Duijf 02-01-2006 IF oXbpRequestingHint:isDerivedFrom('XbpCrt') RETURN self ENDIF aPos := DC_CalcAbsolutePosition(::aLastMotionPos,oXbpRequestingHint) IF aPos[1] > aMax[1] // J. Duijf 02-01-2006 aPos[1] := aMax[1] // Maximum horizontal position of tooltip ENDIF IF aPos[2] > aMax[2] // Maximum vertical position of tooltip aPos[2] := aMax[2] ENDIF //IF aPos[1] > 2000 // aPos[1] := 2000 //ENDIF //IF aPos[2] > 2000 // aPos[2] := 2000 //ENDIF aPos[1] += 6 aPos[2] -= 16 oHelpLink := DC_GetHelpLink(oXbpRequestingHint,DCGUI_HELP_TOOLTIP) IF (ValType(oHelpLink)=="O" .AND. oHelpLink:isDerivedFrom("MagicHelpLabel")) ; .OR. DC_ToolTipShowSource() IF Valtype(oHelpLink) == 'O' cText := oHelpLink:getToolTip() ELSE cText := '' ENDIF IF !Empty(cText) IF Valtype(cText) = 'A' ASize(cText,5) cFont := cText[2] nColorFG := cText[3] IF Valtype(nColorFG) == 'A' nColorFG := GraMakeRGBColor(nColorFG) ENDIF nColorBG := cText[4] IF Valtype(nColorBG) == 'A' nColorBG := GraMakeRGBColor(nColorBG) ENDIF nDelayTime := cText[5] cText := cText[1] ENDIF IF Valtype(cText) = 'B' cText := DC_XtoC(Eval(cText,oXbpRequestingHint)) IF cText == nil RETURN self ENDIF elseif ValType(cText) = "N" cText := alltrim(str(cText)) elseif ValType(cText) = "D" cText := dtoc(cText) elseif ValType(cText) = "L" cText := if(cText,"TRUE","FALSE") ENDIF ENDIF IF DC_ToolTipShowSource() IF !Empty(cText) cText += Chr(13)+Chr(13) ENDIF cText += DC_ShowSourceCode(oXbpRequestingHint) ENDIF ENDIF IF cText == '(nil)' .AND. oXbpRequestingHint:isDerivedFrom('XbpCellGroup') .AND. ; Valtype(oXbpRequestingHint:cargo) = 'A' .AND. Len(oXbpRequestingHint:cargo) >= 3 .AND. ; !Empty(oXbpRequestingHint:cargo[3]) cText := oXbpRequestingHint:cargo[3] ELSEIF cText == '(nil)' .AND. oXbpRequestingHint:isDerivedFrom('XbpScrollBar') .AND. ; Valtype(oXbpRequestingHint:cargo) = 'A' .AND. Len(oXbpRequestingHint:cargo) >= 3 .AND. ; !Empty(oXbpRequestingHint:cargo[3]) cText := oXbpRequestingHint:cargo[3] ENDIF IF (Valtype(cText) $ 'CM' .AND. ( cText # '(nil)' .AND. !Empty(cText) )) .OR. ; Valtype(cText) == 'O' ::oTip := XbpStatic():new() ::oTip:options := XBPSTATIC_TYPE_FGNDFRAME ::oTip:create(AppDesktop(),AppDesktop(), aPos, { 0 , 0 }) IF Empty(cFont) .AND. !Empty(::cToolFont) cFont := ::cToolFont ENDIF IF Valtype(cFont) == 'C' ::oTip:setFontCompoundName(cFont) ELSEIF Valtype(cFont) == 'O' ::oTip:setFont(cFont) ENDIF ::oTip:cargo := { cText, cFont, nColorFG, nColorBG, nDelayTime } ::PaintTheTip(cText) ELSE ::oTip := nil ENDIF RETURN(SELF) * -------------------- METHOD MagicHelp:PaintTheTip(cText) LOCAL aAttr, oPS, aText, i, nOffset, aPoints, aSize, oBitMap, ; aOrigPos := ::oTip:currentPos(), nMaxWidth, aMaxSize, aPos IF Valtype(cText) = 'O' .AND. cText:isDerivedFrom('XbpBitMap') oBitMap := cText aSize := {oBitMap:xSize,oBitMap:ySize } aPos := {aOrigPos[1]+15,aOrigPos[2]+10-aSize[2]} aMaxSize := DC_DeskTopSize() nMaxWidth := aMaxSize[1] IF aPos[1] + aSize[1] > aMaxSize[1] aPos[1] := aMaxSize[1] - aSize[1] ENDIF IF aPos[2] < 0 aPos[2] := 0 ENDIF ::oTip:setPos(aPos) ::oTip:setSize(aSize,.F.) oPS := ::oTip:lockPS() oBitMap:draw( oPS ) ELSE oPS := ::oTip:lockPS() cText := Strtran(cText,';',Chr(13)+Chr(10)) cText := Strtran(cText,'<%059>',';') aText := DC_TokenArray(cText,Chr(13)+Chr(10)) aSize := { 0,0 } FOR i := 1 TO Len(aText) aPoints := GraQueryTextBox( oPS, aText[i] ) aSize[1] := Max(aSize[1],(aPoints[3,1] - aPoints[1,1]) + 8 ) // width NEXT IF aPoints == nil ::oTip:unLockPS( oPS) RETURN(SELF) ENDIF aSize[2] := ((aPoints[1,2] - aPoints[2,2]) * Len(aText)) + 4 // height ::oTip:setPos({::oTip:currentPos()[1], ; ::oTip:currentPos()[2]-aSize[2]}) ::oTip:unlockPS() aMaxSize := DC_DeskTopSize() // J. Duijf 02-01-2006 nMaxWidth := aMaxSize[1] IF ::oTip:currentPos()[1] + aSize[1] > aMaxSize[1] .AND. ::oTip:currentPos()[1] < aMaxSize[1] ::oTip:setPos( { aMaxSize[1] - aSize[1], ; ::oTip:currentPos()[2] - aSize[2] } ) ENDIF IF ::oTip:currentPos()[2] < 0 ::oTip:setPos( { ::oTip:currentPos()[1], 0 } ) ENDIF ::oTip:setSize(aSize,.F.) oPS := ::oTip:lockPS() DEFAULT ::oTip:cargo[3] := ::aToolColor[1], ; ::oTip:cargo[4] := ::aToolColor[2] aAttr := Array( GRA_AA_COUNT ) aAttr [ GRA_AA_COLOR ] := ::oTip:cargo[4] GraSetAttrArea( oPS, aAttr ) GraBox( oPS, { 1, 1}, { aSize[ 1] + 4, aSize[ 2] + 4}, GRA_FILL) aAttr := Array( GRA_AS_COUNT ) aAttr [ GRA_AS_COLOR ] := ::oTip:cargo[3] GraSetAttrString( oPS, aAttr ) GraBox( oPS, {0,0}, {aSize[1] - 1, aSize[2] - 1}) nOffset := 0 FOR i := Len(aText) TO 1 STEP -1 GraStringAt( oPS, {4,4+nOffset}, aText[i]) nOffset += (aPoints[1,2] - aPoints[2,2]) NEXT ENDIF ::oTip:unLockPS( oPS) RETURN(SELF) * -------------------- CLASS MagicHelpLabel CLASS VAR nLangID VAR nID VAR bcToolTip INLINE CLASS METHOD initClass() ::nLangID := 1 RETURN INLINE METHOD init(nID,bcToolTip) ::nID := nID ::bcToolTip := bcToolTip RETURN EXPORTED: INLINE CLASS METHOD setLanguage(nID) ::nLangID := nID RETURN INLINE METHOD getID() RETURN ::nID INLINE METHOD getToolTip() RETURN ::bcToolTip ENDCLASS * -------------------- FUNCTION DC_CalcAbsolutePosition(aPos,oXbp,oTop) LOCAL aAbsPos, oParent := oXbp DEFAULT oTop := AppDeskTop() DEFAULT aPos := {0,0} aAbsPos := AClone(aPos) DO WHILE oParent <> oTop // .AND. !(oParent:isDerivedFrom('XbpCrt')) IF !oParent:isderivedFrom('XbpCellGroup') .OR. Val(Version(3)) >= 330 // Xbase 1.9 aAbsPos[1] += oParent:currentPos()[1] aAbsPos[2] += oParent:currentPos()[2] ENDIF oParent := oParent:setParent() IF Valtype(oParent) # 'O' EXIT ENDIF ENDDO RETURN(aAbsPos) * --------------------- FUNCTION DC_SetHelpLink( helpLink, nMode, oHelp, oHelpObject ) IF Valtype(helpLink) = 'A' ASize(helpLink,3) ELSE helpLink := Array(3) ENDIF helpLink[nMode] := oHelp IF Valtype(oHelpObject) = 'O' helpLink[nMode] := oHelp oHelp:helpObject := oHelpObject ELSEIF Valtype(oHelpObject) = 'B' helpLink[nMode] := oHelpObject ENDIF RETURN helpLink * --------------------- FUNCTION DC_GetHelpLink( oXbp, nMode ) IF Valtype(oXbp:helpLink) = 'O' RETURN oXbp:helpLink ELSEIF Valtype(oXbp:helpLink) = 'A' ASize(oXbp:helpLink,3) ELSE oXbp:helpLink := Array(3) ENDIF RETURN oXbp:helpLink[nMode] * ---------------------- FUNCTION DC_AddSetKeys( GetList ) LOCAL nInkey, nKey, bKey IF Valtype(GetList) # 'A' GetList := {} ENDIF FOR nInkey := -47 TO 421 bKey := SetKey( nInkey ) IF VALTYPE(bKey) = 'B' nKey := DC_KeyTran(nInkey,2) DCHOTKEY nKey ACTION bKey ENDIF NEXT RETURN GetList * ----------------------- FUNCTION DC_CascadeCoords( oParent, lTextBased, aDefault, lTranslate, oExclude ) LOCAL nTop, nLeft, i, j, aChildList, aChildChildList, oXbp, ; lSiblingFound, nBottom DEFAULT lTextBased := .f., ; lTranslate := .t. IF Valtype(oParent) # 'O' oParent := AppDeskTop() ENDIF IF Valtype(aDefault) # 'A' aDefault := {0,0} ENDIF aChildList := oParent:childlist() IF Empty(aChildList) RETURN aDefault ENDIF IF lTextBased nTop := 0 ELSE nTop := oParent:currentSize()[2] ENDIF nLeft := 0 lSiblingFound := .f. FOR i := 1 TO Len(aChildList) oXbp := aChildList[i] IF Valtype(oExclude) = 'O' .AND. oXbp == oExclude LOOP ELSEIF Valtype(oExclude) = 'A' .AND. AScan( oExclude, oXbp ) > 0 LOOP ELSEIF !oXbp:isVisible() LOOP ELSEIF oXbp:isderivedFrom('XBPDIALOG') .AND. !oXbp:titleBar LOOP ELSEIF oXbp:isderivedFrom('XBPDIALOG') .AND. oXbp:getFrameState() # XBPDLG_FRAMESTAT_NORMALIZED LOOP ELSEIF oXbp:isderivedFrom('XBPMENUBAR') .OR. oXbp:isderivedFrom('XBPCRT') LOOP ELSEIF oXbp:isderivedFrom('XBPIWINDOW') aChildChildList := oXbp:childList() FOR j := 1 TO Len(aChildChildList) oXbp := aChildChildList[j] IF !oXbp:isVisible() LOOP ELSEIF oXbp:isderivedFrom('XBPDIALOG') .AND. oXbp:getFrameState() # XBPDLG_FRAMESTAT_NORMALIZED LOOP ENDIF IF lTextBased nTop := Max(nTop,oXbp:SetParent():currentSize()[2]-(oXbp:CurrentPos()[2]+oXbp:CurrentSize()[2])) nBottom := nTop - oXbp:currentSize()[2] ELSE nTop := Min(nTop,oXbp:CurrentPos()[2]+oXbp:CurrentSize()[2]) nBottom := oXbp:currentSize()[2] ENDIF nLeft := oXbp:CurrentPos()[1] lSiblingFound := .t. NEXT ELSEIF !oXbp:isDerivedFrom('XbpDialog') LOOP ELSE IF lTextBased nTop := Max(nTop,oXbp:SetParent():currentSize()[2]-(oXbp:CurrentPos()[2]+oXbp:CurrentSize()[2])) nBottom := nTop - oXbp:currentSize()[2] ELSE nTop := Min(nTop,oXbp:CurrentPos()[2]+oXbp:CurrentSize()[2]) nBottom := oXbp:currentSize()[2] ENDIF nLeft := oXbp:CurrentPos()[1] lSiblingFound := .t. ENDIF NEXT IF lSiblingFound IF lTranslate IF lTextBased nTop += 25 ELSE nTop -= 25 ENDIF nLeft += 25 ELSE nTop := nBottom - 25 nLeft += 25 ENDIF ELSE nTop := aDefault[1] nLeft := aDefault[2] ENDIF IF lTextBased nTop /= 20 nLeft /= 7 ENDIF RETURN { nTop, nLeft } * -------------- FUNCTION DC_FieldWBlock( cFieldName, xDataSource, bFormat, aStru ) LOCAL cAlias, bGetSet, oCol, nLen, nDec, cDataType := Valtype(xDataSource), ; cType, xValue, nPos IF xDataSource == NIL .OR. cDataType == 'C' // alias IF xDataSource == NIL cAlias := Alias() ELSE cAlias := xDataSource ENDIF IF Empty(aStru) aStru := (cAlias)->(dbStruct()) ENDIF nPos := (cAlias)->(FieldPos( cFieldName )) cType := aStru[nPos,2] nLen := aStru[nPos,3] IF cType $ 'CMT' xValue := "Space(" + Alltrim(Str(nLen)) + ")" ELSEIF cType $ 'NI' xValue := "0" ELSEIF cType == 'D' xValue := "Ctod('')" ELSEIF cType == 'L' xValue := ".f." ELSE xValue := "''" ENDIF IF '->' $ cFieldName bGetSet := &( '{|x|IIF(x==NIL .OR. x==' + cFieldName + ',' + ; 'IsNull(' + cFieldName +',' + xValue + '),' + cFieldName + ':=x)}' ) ELSE bGetSet := &( '{|x|IIF(x==NIL .OR. x==' + cAlias + '->' + cFieldName + ',' + ; 'IsNull(' + cAlias + '->' + cFieldName + ',' + xValue + '),' + cAlias + '->' + cFieldName + ':=x)}' ) ENDIF ELSEIF cDataType == 'N' // ADS SQL cursor bGetSet := DC_AdsFieldBlock( xDataSource, cFieldName, bFormat ) ELSEIF cDataType == 'O' // SQLexpress cursor oCol := xDataSource:getSQLColumn(cFieldName) nLen := oCol:length IF oCol:ValType == "C" bGetSet := {|x|if(PCount()==0,PadR(xDataSource:fieldGet(cFieldName),nLen),; xDataSource:fieldPut(cFieldName,Trim(x)))} ELSEIF oCol:ValType == "N" nDec := oCol:decimals bGetSet := {|x|if(PCount()==0,Str(xDataSource:fieldGet(cFieldName),nLen,nDec),; xDataSource:fieldPut(cFieldName,val(x)))} ELSE bGetSet := {|x|if(PCount()==0,xDataSource:fieldGet(cFieldName),; xDataSource:fieldPut(cFieldName,x))} ENDIF ENDIF RETURN bGetSet * ------------------ FUNCTION DC_FieldWDebug( lDebug, cField, lWriteOnly ) STATIC slDebug := .f., scField := '', slWriteOnly := .t. IF Valtype(cField) = 'C' scField := cField ELSE cField := scField ENDIF IF Valtype(lDebug) = 'L' slDebug := lDebug ENDIF IF Valtype(lWriteOnly) = 'L' slWriteOnly := lWriteOnly ELSE lWriteOnly := slWriteOnly ENDIF RETURN slDebug * ------------------ FUNCTION DC_FieldWDisplay( x, xFieldName, cAlias, cFieldName ) LOCAL cField, lWriteOnly DC_FieldWDebug( nil, @cField, @lWriteOnly ) IF lWriteOnly .AND. x == NIL RETURN nil ENDIF IF Empty(cField) .OR. Empty(cFieldName) .OR. Upper(cField) == Upper(cFieldName) DC_Qout({x,xFieldName,cAlias,cFieldName}) DC_QoutCallStack(5) DC_Qout(dbrLockList()) ENDIF RETURN nil * ------------------ FUNCTION DC_PopFile( cFileName, cDirectory, cWildCard, cTitle, aFileFilter, ; lSaveAs, lRestoreDir, lMultiple, oParent, oOwner ) LOCAL oXbp, cNewFile, nLength DEFAULT cFileName := '', ; cDirectory := '', ; cWildCard := '*.*', ; cTitle := '', ; aFileFilter := {}, ; lSaveAs := .F., ; lRestoreDir := .T.,; lMultiple := .F. oXbp := XbpFileDialog():new( oParent, oOwner ) oXbp:center := .T. oXbp:restoreDir := lRestoreDir IF !Empty(cTitle) oXbp:Title := cTitle ENDIF IF Valtype(aFileFilter)='A' oXbp:fileFilters := aFileFilter ENDIF oXbp:create(,SetAppWindow()) nLength := Len(cFileName) IF Empty(cFileName) .AND. (!Empty(cDirectory) .OR. !Empty(cWildCard)) IF !Empty(cDirectory) .AND. Right(cDirectory,1) # '\' cDirectory += '\' ENDIF cFileName := cDirectory + cWildCard ELSE IF !Empty(cDirectory) .AND. Right(cDirectory,1) # '\' cDirectory += '\' ENDIF cFileName := cDirectory + cFileName ENDIF IF lSaveAs cNewFile := oXbp:saveAs( Alltrim(cFileName),.t. ) ELSE cNewFile := oXbp:open( Alltrim(cFileName),.t.,lMultiple,.t. ) // Modified S.B.Drakos 6/29/2005 0:27AM ENDIF oXbp:destroy() IF Empty(cNewFile) RETURN cFileName ELSE //cNewFile := StrTran(cNewFile,'\:\\','\\') // Original IF ValType(cNewFile) == 'A' // Added S.B.Drakos 6/29/2005 0:27AM AEval(cNewFile,{|a| a := StrTran(a,'\:\\','\\')}) // ... ELSE // ... cNewFile := StrTran(cNewFile,'\:\\','\\') // ... ENDIF // ... ENDIF IF nLength == 0 .OR. !Empty(cFileName) //nLength := Len(cNewFile) // Original IF ValType(cNewFile) == 'A' // Added S.B.Drakos 6/29/2005 0:27AM AEval(cNewFile,{|a| nLength := Len(a), a := Pad(a,nLength)}) // ... ELSE // ... nLength := Len(cNewFile) // ... ENDIF // ... ENDIF nLength := Max(nLength,Len(cNewFile)) RETURN IIF( ValType(cNewFile) == 'A', cNewFile, Pad(cNewFile,nLength)) // Modified S.B.Drakos 6/29/2005 0:27AM * ----------------------- FUNCTION DC_SourceRead( cSource, nLine, nStartPos, nEndPos ) LOCAL cString := '', nSourceLine, cLine nSourceLine := nLine DO WHILE .t. cLine := Trim( MemoLine( cSource, 1024, nSourceLine ) ) + Chr(13) + Chr(10) IF nLine = nSourceLine nEndPos := MLPos( cSource, 1024, nLine + 1 ) ENDIF IF Empty(Strtran(cLine,Chr(13)+Chr(10),'')) .OR. nSourceLine == 1 EXIT ELSEIF Right(Trim(Strtran(cLine,Chr(13)+Chr(10),'')),1) # ';' .AND. nSourceLine # nLine EXIT ENDIF cString := cLine + cString nSourceLine-- ENDDO nStartPos := MLPos( cSource, 1024, nSourceLine+1 ) RETURN cString * ----------------------- FUNCTION DC_SourceWrite( cSource, cSourceLine, nStartPos, nEndPos ) LOCAL cString1 := SubStr(cSource, 1, nStartPos - 1) LOCAL cString2 := SubStr(cSource, nEndPos) RETURN cString1 + cSourceLine + cString2 * ----------------------- FUNCTION DC_SourceRepl( cString, nStartRow, nStartCol, nWidth, nHeight, nType, aCoords ) LOCAL i, cOutput, lStart := .t., lGetRow := .f., lGetCol := .f., ; lGetWidth := .f., lGetHeight := .f., aTokens, lGetWidthOnly := .f., ; lGetHeightOnly := .f. aTokens := DC_ParseArray( cString ) cOutput := '' FOR i := 1 TO Len(aTokens) IF aTokens[i] = '@' .AND. lStart lStart := .f. lGetRow := .t. ELSEIF lGetRow .AND. ( Val(aTokens[i]) # 0 .OR. '0' $ Alltrim(aTokens[i]) ) lGetRow := .f. lGetCol := .t. IF aCoords[3] # aCoords[4] .OR. aCoords[7] # aCoords[8] aTokens[i] := DC_PadZero(Alltrim(Str(nStartRow,6,2)),6) + IIF( Chr(13)+Chr(10) $ aTokens[i], Chr(13)+Chr(10), '' ) ENDIF ELSEIF lGetCol .AND. ( Val(aTokens[i]) # 0 .OR. '0' $ Alltrim(aTokens[i]) ) lGetCol := .f. IF aCoords[1] # aCoords[2] aTokens[i] := DC_PadZero(Alltrim(Str(nStartCol,6,2)),6) + IIF( Chr(13)+Chr(10) $ aTokens[i], Chr(13)+Chr(10), '' ) ENDIF ELSEIF lGetWidth .AND. ( Val(aTokens[i]) # 0 .OR. '0' $ Alltrim(aTokens[i]) ) lGetWidth := .f. lGetHeight := .t. IF aCoords[5] # aCoords[6] aTokens[i] := DC_PadZero(Alltrim(Str(nWidth,6,2)),6) + IIF( Chr(13)+Chr(10) $ aTokens[i], Chr(13)+Chr(10), '' ) ENDIF ELSEIF lGetWidthOnly .AND. ( Val(aTokens[i]) # 0 .OR. '0' $ Alltrim(aTokens[i]) ) lGetWidthOnly := .f. IF aCoords[5] # aCoords[6] aTokens[i] := DC_PadZero(Alltrim(Str(nWidth,6,2)),6) + IIF( Chr(13)+Chr(10) $ aTokens[i], Chr(13)+Chr(10), '' ) ENDIF ELSEIF lGetHeight .AND. ( Val(aTokens[i]) # 0 .OR. '0' $ Alltrim(aTokens[i]) ) lGetWidth := .f. lGetHeight := .f. IF aCoords[7] # aCoords[8] aTokens[i] := DC_PadZero(Alltrim(Str(nHeight,6,2)),6) + IIF( Chr(13)+Chr(10) $ aTokens[i], Chr(13)+Chr(10), '' ) ENDIF ELSEIF lGetHeightOnly .AND. ( Val(aTokens[i]) # 0 .OR. '0' $ Alltrim(aTokens[i]) ) lGetHeightOnly := .f. IF aCoords[7] # aCoords[8] aTokens[i] := DC_PadZero(Alltrim(Str(nHeight,6,2)),6) + IIF( Chr(13)+Chr(10) $ aTokens[i], Chr(13)+Chr(10), '' ) ENDIF ELSEIF Alltrim(Upper(aTokens[i])) == 'GETSIZE' .AND. nType == GETLIST_GET lGetWidth := .t. ELSEIF Alltrim(Upper(aTokens[i])) == 'SAYSIZE' .AND. nType == GETLIST_SAY lGetWidth := .t. ELSEIF Alltrim(Upper(aTokens[i])) == 'SIZE' lGetWidth := .t. ELSEIF Alltrim(Upper(aTokens[i])) == 'WIDTH' lGetWidthOnly := .t. ELSEIF Alltrim(Upper(aTokens[i])) == 'HEIGHT' lGetHeightOnly := .t. ELSEIF Alltrim(aTokens[i]) # ',' .AND. !Empty(aTokens[i]) IF lGetHeight cOutput := Trim(cOutput) + ', ' + Alltrim(Str(nHeight)) + ' ' ENDIF lGetWidth := .f. lGetHeight := .f. lGetRow := .f. lGetCol := .f. ENDIF cOutput += aTokens[i] NEXT IF nType == GETLIST_GET .AND. AScan(aTokens,{|a|Upper(Alltrim(a)) == 'GETSIZE'}) = 0 ; .AND. ( aCoords[5] # aCoords[6] .OR. aCoords[7] # aCoords[8] ) cOutput := SubStr(cOutput,1,Len(cOutput)-2) + ; ' GETSIZE ' + Alltrim(Str(nWidth)) + ', ' + Alltrim(Str(nHeight)) + Chr(13) + Chr(10) ELSEIF nType == GETLIST_SAY .AND. AScan(aTokens,{|a|Upper(Alltrim(a)) == 'SAYSIZE'}) = 0 ; .AND. ( aCoords[5] # aCoords[6] .OR. aCoords[7] # aCoords[8] ) cOutput := SubStr(cOutput,1,Len(cOutput)-2) + ; ' SAYSIZE ' + Alltrim(Str(nWidth)) + ', ' + Alltrim(Str(nHeight)) + Chr(13) + Chr(10) ENDIF RETURN cOutput * -------------------- FUNCTION DC_ParseArray( cString ) LOCAL cStartDelims := "'({[" + '"' LOCAL cEndDelims := "')}]" + '"' + Chr(10) + ';' LOCAL cChar, cEnd LOCAL nLen, nStart LOCAL i, nFound LOCAL aParse := {} LOCAL lStart := .t. LOCAL lStartSpace := .f. nLen := Len(cString) nStart := 1 FOR i := 1 TO nLen cChar := Substr(cString,i,1) IF lStart .AND. (cChar = ' ' .OR. cChar = Chr(K_TAB)) nStart++ LOOP ELSEIF cChar = '@' .AND. lStart lStart := .f. IF Substr(cString,i+1,1) # ' ' AAdd( aParse, '@' ) nStart := i + 1 ENDIF ELSEIF cChar $ cStartDelims cEnd := SubStr(cEndDelims,AT(cChar,cStartDelims),1) nFound := At(cEnd,cString,i+1) IF nFound > 0 i := nFound ELSE EXIT ENDIF lStartSpace := .f. ELSEIF cChar = ' ' .AND. !lStartSpace lStartSpace := .t. AAdd( aParse, SubStr(cString,nStart,i-nStart) ) AAdd( aParse, ' ') nStart := i + 1 ELSEIF cChar = ',' lStartSpace := .f. AAdd( aParse, SubStr(cString,nStart,i-nStart) ) AAdd( aParse,',') nStart := i+1 ELSEIF cChar = Chr(13) AAdd( aParse, SubStr(cString,nStart,i-nStart) ) AAdd( aParse, Chr(13) + Chr(10)) nStart := i+2 ELSEIF cChar # ' ' lStart := .f. lStartSpace := .f. ENDIF NEXT AAdd( aParse, SubStr(cString,nStart,nLen) ) RETURN aParse * ----------------------- FUNCTION DC_PopDir( cDirectory, cAvailDrives, cExcludeDrives, cWildCard ) LOCAL GetList := {}, oDirs, cSaveDir := cDirectory, oFiles, cFile, lOk, ; GetOptions, cCurPath := DC_CurPath(), oStatic DEFAULT cDirectory := '', ; cWildCard := '*.*' IF !Empty(cDirectory) DC_ChDir(Alltrim(cDirectory)) ENDIF @ 0,0 DCSTATIC TYPE XBPSTATIC_TYPE_TEXT SIZE 50,8 OBJECT oStatic cFile := '' @ 0,0 DCDIRTREE ; DIRS oDirs VAR cDirectory ; FILES oFiles VAR cFile ; SIZE 50,8 ; PARENT oStatic ; EXT cWildCard ; TITLE DCMSG_DIR_CHOOSE ; AVAILDRIVES cAvailDrives ; EXCLUDEDRIVES cExcludeDrives DCGETOPTIONS AUTORESIZE DCREAD GUI ; EXPRESS ; FIT ; ADDBUTTONS ; MODAL ; TO lOk ; TITLE DC_LangMsg(DCMSG_DIR_CHOOSE) ; OPTIONS GetOptions ; ;// EVAL {||oDirs:dirTree:itemSelected := {||DC_ReadGuiEvent(DCGUI_EXIT_OK,GetList)} } DC_ChDir(cCurPath) IF !lOk RETURN cSaveDir ENDIF RETURN cDirectory * ----------------------- FUNCTION DC_DisplayTabStops( oParent, nLevel, cString ) LOCAL oXbp, i, aChildren := oParent:childList(), GetList := {} DEFAULT nLevel := 0, cString := '' FOR i := 1 TO Len(aChildren) oXbp := aChildren[i] IF IsMemberVar(oXbp,'TABSTOP') cString += Space(nLevel) + IIF( oXbp:tabstop,'YES','NO ') + ' ' + oXbp:classname() + Chr(13) + Chr(10) ENDIF DC_DisplayTabStops(oXbp,nLevel+2,@cString) NEXT IF nLevel = 0 @ 0,0 DCMULTILINE cString SIZE 50,20 FONT '10.Courier' DCREAD GUI ; EXPRESS ; FIT ; ADDBUTTONS ; MODAL ; TITLE 'Display Tabstops in Dialog Tree' ENDIF RETURN nil * ------------------------ FUNCTION DC_GraQueryTextBox( cCaption, cFont, nOption, nMode ) LOCAL oXbp , aArray, nWidth, nHeight DEFAULT nMode := 2 oXbp := XbpStatic():new(AppDeskTop()) IF Valtype(nOption) == 'N' oXbp:option := nOption ENDIF IF nMode == 1 oXbp:create() ENDIF IF Valtype(cFont) = 'C' oXbp:setFontCompoundName(cFont) ENDIF IF nMode == 2 oXbp:create() ENDIF aArray := GraQueryTextBox( oXbp:lockPS(), cCaption ) nWidth := aArray[3,1] - aArray[1,1] // width nHeight := aArray[1,2] - aArray[2,2] // height oXbp:unlockPS() oXbp:destroy() RETURN {nWidth, nHeight} * ------------------------ FUNCTION DC_MakeBlock( xData ) RETURN {||xData} * ------------------------ FUNCTION DC_SetAppFocus( oXbp ) LOCAL aTabPages := {}, oParent, i oParent := oXbp DO WHILE .t. oParent := oParent:setParent() IF Valtype(oParent) # 'O' EXIT ELSEIF oParent:isDerivedFrom('XbpTabPage') AAdd(aTabPages,oParent) ENDIF ENDDO FOR i := Len(aTabPages) TO 1 STEP -1 IF aTabPages[i]:minimized DC_TabActivate(aTabPages[i]) ENDIF NEXT RETURN SetAppFocus( oXbp ) * ------------------------ FUNCTION DC_TabActivate( oTabPage, lCompleteEvents) LOCAL nRow, nCol, aChildList, oXbp, i DEFAULT lCompleteEvents := .f. IF !oTabPage:isDerivedFrom('XbpTabPage') RETURN nil ENDIF nCol := oTabPage:currentPos()[1] nRow := oTabPage:currentPos()[2] aChildList := oTabPage:setParent():ChildList() FOR i := 1 TO Len(aChildList) oXbp := aChildList[i] IF oXbp:isderivedFrom('XbpTabPage') .AND. oXbp:currentPos()[1] == nCol ; .AND. oXbp:currentPos()[2] == nRow oXbp:minimize() ENDIF NEXT oTabPage:maximize() PostAppEvent(xbeP_SetInputFocus,,,oTabPage) IF lCompleteEvents DC_CompleteEvents() ENDIF RETURN nil * --------------------- FUNCTION DC_CrtWindow( cTitle, cColorString, oParent, oOwner, aOptions, lModal, lSuspend ) LOCAL oCrtWindow, cSaveColor, oThread, lSuspended := .f. DEFAULT cTitle := 'eXPress++ Crt Window', ; cColorString := '', ; aOptions := {}, ; lModal := Empty(oParent), ; lSuspend := .t. lSuspend := .f. ASize(aOptions,7) DEFAULT aOptions[1] := 8, ; aOptions[2] := 12, ; aOptions[3] := "Alaska Crt", ; aOptions[4] := DC_IconDefault(), ; aOptions[5] := 25, ; aOptions[6] := 80 DEFAULT oParent := AppDesktop ( SetAppWindow() ) DEFAULT oOwner := SetAppWindow() // oParent oCrtWindow := XbpCrt():New( oParent, oOwner, { 0, 0 }, aOptions[5], aOptions[6], cTitle, .f. ) oCrtWindow:FontWidth := aOptions[1] oCrtWindow:FontHeight := aOptions[2] oCrtWindow:FontName := Alltrim(aOptions[3]) oCrtWindow:icon := aOptions[4] IF lSuspend oCrtWindow:setInputFocus := {|a,b,o|SetAppWindow(o),lSuspended := .f.} oCrtWindow:setDisplayFocus := {|a,b,o|SetAppWindow(o),lSuspended := .f.} ELSE oCrtWindow:setInputFocus := {|a,b,o|SetAppWindow(o)} oCrtWindow:setDisplayFocus := {|a,b,o|SetAppWindow(o)} ENDIF IF lSuspend oCrtWindow:killInputFocus := ; {|| lSuspended := .t., ; oThread := Thread():new(),; Sleep(10),; oThread:start({||_Suspend(@lSuspended)} ) } ENDIf oCrtWindow:close := aOptions[7] oCrtWindow:Create() oCrtWindow:PresSpace() DC_CenterObject(oCrtWindow) oCrtWindow:show() IF lModal oCrtWindow:setModalState(XBP_DISP_APPMODAL) ENDIF SetAppWindow(oCrtWindow) IF !Empty(cColorString) cSaveColor := SetColor(cColorString) ELSE cSaveColor := SetColor('N/W') ENDIF CLS SetColor(cSaveColor) RETURN oCrtWindow * --------------- STATIC FUNCTION _Suspend( lSuspended ) // DCQQDEBUG 'Start Suspend' DO WHILE lSuspended Sleep(50) ENDDO // DCQQDEBUG 'End Suspend' RETURN nil * --------------- FUNCTION DC_CrtRun( bBlock, cTitle, cColorString, oParent, oOwner, lUnique, aOptions, ; lModal, oCrt, lSuspend, lGui, bPreBlock ) LOCAL oAppWindow, lNewCrt, i, lStatus, ; aChildList, cBlock := DC_GetCodeBlockText(bBlock) DEFAULT lUnique := .f., ; oParent := AppDeskTop(), ; cTitle := 'CRT', ; lGui := .f. lGui := DC_Gui(lGui) oCrt := DC_CrtRunWindow() oAppWindow := SetAppWindow() lNewCrt := Valtype(oCrt) # 'O' .OR. !oCrt:isDerivedFrom('XbpCrt') IF lUnique aChildList := oParent:childList() FOR i := 1 TO Len(aChildList) IF aChildList[i]:isDerivedFrom('XbpCrt') .AND. Valtype(aChildList[i]:cargo)=='C' .AND. ; cBlock == aChildList[i]:cargo DC_WinAlert('Cannot run (' + cTitle + ') program more than once!') RETURN .f. ENDIF NEXT ENDIF IF lNewCrt oCrt := DC_CrtWindow( cTitle, cColorString, oParent, oOwner, aOptions, lModal, lSuspend ) oCrt:cargo := cBlock ELSEIF Valtype(cTitle) = 'C' oCrt:setTitle(cTitle) oCrt:cargo := cBlock ENDIF BEGIN SEQUENCE SetAppFocus(oCrt) SET CURSOR ON IF Valtype(bPreBlock) == 'B' Eval(bPreBlock,oCrt) ENDIF lStatus := Eval(bBlock,oCrt) END SEQUENCE IF lNewCrt oCrt:setModalState(XBP_DISP_MODELESS) oCrt:Destroy() ENDIF IF Valtype(oAppWindow) = 'O' .AND. oAppWindow:status() > 0 SetAppWindow(oAppWindow) ENDIF IF Valtype(oParent) = 'O' aChildList := oParent:ChildList() FOR i := 1 TO Len(aChildList) IF aChildList[i] == SetAppFocus() SetAppWindow(aChildList[i]) EXIT ENDIF NEXT ENDIF DC_Gui(lGui) RETURN lStatus * --------------------- FUNCTION DC_CrtRunWindow( oCrt ) LOCAL oOldCrt STATIC soCrt oOldCrt := soCrt IF Valtype(oCrt) = 'O' soCrt := oCrt ENDIF RETURN oOldCrt * --------------------- FUNCTION DC_ExeLoaded( cProgramToRun ) LOCAL aPrograms := {}, nHandle, i, cProgram DEFAULT cProgramToRun := AppName() nHandle := DC_TxtOpen('XPPLOAD.TXT') IF nHandle >= 0 DO WHILE !DC_TxtEof(nHandle) cProgram := Alltrim(Upper(DC_TxtLine(nHandle))) DC_TxtSkip(nHandle,1) IF Empty(cProgram) EXIT ELSEIF cProgram == cProgramToRun LOOP ENDIF AAdd(aPrograms,Alltrim(Upper(cProgram))) ENDDO FClose(nHandle) IF Empty(aPrograms) FErase('XPPLOAD.TXT') ELSE nHandle := FCreate('XPPLOAD.TXT') IF nHandle >= 0 FOR i := 1 TO Len(aPrograms) FWrite(nHandle,aPrograms[i]+Chr(13)+Chr(10)) NEXT FClose(nHandle) ENDIF ENDIF ENDIF RETURN .t. * ----------------- ***************************************************************************************************** DLLFUNCTION SystemParametersInfoA( nAction, nParam1, @Param2, nWinIni ) USING STDCALL FROM USER32.DLL ***************************************************************************************************** * ---------------- *FUNCTION DC_GetWorkArea() *LOCAL cBuffer := SPACE(16) *LOCAL aRet := ARRAY(4) *SystemParametersInfoA( SPI_GETWORKAREA, 0, @cBuffer, SPIF_SENDCHANGE ) *aRet[1] := BIN2U( SUBSTR( cBuffer, 1,4 )) *aRet[2] := BIN2U( SUBSTR( cBuffer, 5,4 )) *aRet[3] := BIN2U( SUBSTR( cBuffer, 9,4 )) *aRet[4] := BIN2U( SUBSTR( cBuffer, 13,4 )) *RETURN aRet * ----------------- FUNCTION DC_SetWorkArea( aArea ) LOCAL cBuffer := SPACE(16) LOCAL aRet := ARRAY(4) cBuffer := U2BIN(aArea[1]) + U2BIN(aArea[2]) + U2BIN(aArea[3]) + U2BIN(aArea[4]) SystemParametersInfoA( SPI_SETWORKAREA, 0, @cBuffer, SPIF_SENDCHANGE ) aRet[1] := BIN2U( SUBSTR( cBuffer, 1,4 )) aRet[2] := BIN2U( SUBSTR( cBuffer, 5,4 )) aRet[3] := BIN2U( SUBSTR( cBuffer, 9,4 )) aRet[4] := BIN2U( SUBSTR( cBuffer, 13,4 )) RETURN aRet * ----------------- FUNCTION DC_GetTitleBarHeight() RETURN GetSystemMetrics( SM_CYCAPTION ) * ----------------- FUNCTION DC_GetMenuBarHeight() RETURN GetSystemMetrics( SM_CYMENU ) * ----------------- FUNCTION DC_GetBorderHeight() RETURN GetSystemMetrics( SM_CYBORDER ) * ----------------- DLLFUNCTION GetSystemMetrics( nAction ) ; USING STDCALL FROM USER32.DLL * ----------------- /* DC_IsAppRunning() was contributed by: Alain Boucher aboucher@acti-soft.com */ FUNCTION DC_IsAppRunning( cClass, cTitle, cFile, lRestore ) Local nHwndFind, nHwndForeground, nForegroundId Local nFindId, nHwndLast Local cWinTitle := Space(250) Local cWinFile := Space(250) DEFAULT lRestore := .f., ; cFile := '' nHwndFind := FindWindowA( cClass, cTitle ) If nHwndFind == 0 Return( .f. ) End GetWindowModuleFileNameA( nHwndFind,@cWinFile,250 ) GetWindowTextA( nHwndFind,@cWinTitle,250 ) if !Upper( cTitle ) $ Upper( cWinTitle ) .and. !Upper( cFile ) $ Upper( cWinFile ) Return( .f. ) End if !lRestore Return( .t. ) End nHwndForeground := GetForegroundWindow() nForeGroundId := GetWindowThreadProcessId( nHwndForeground, 0 ) nFindId := GetWindowThreadProcessId( nHwndFind, 0 ) If !nForeGroundId == nFindId .or. !IsIconic( nHwndFind ) == 0 nHwndLast := GetLastActivePopup( nHwndFind ) If !IsIconic( nHwndLast ) == 0 ShowWindow( nHwndLast, SW_RESTORE ) End BringWindowToTop( nHwndLast ) SetForegroundWindow( nHwndLast ) End Return( .t. ) * ----------------------- FUNCTION DC_Scrn2ClipBoard( oXbp ) LOCAL oSourcePS, oBitmap, oClipBoard, aPos IF oXbp == NIL keybd_event(VK_SNAPSHOT, 1, 0, 0) keybd_event(VK_MENU, 0, 0, 0) keybd_event(VK_SNAPSHOT, 0, 0, 0) keybd_event(VK_SNAPSHOT, 0, KEYEVENTF_KEYUP, 0) keybd_event(VK_MENU, 0, KEYEVENTF_KEYUP, 0) ELSE oSourcePS := oXbp:lockPS() IF oXbp:isDerivedFrom('XbpDialog') aPos := { -4, -4 } ELSE aPos := { 0, 0 } ENDIF oBitmap := GraSaveScreen( oSourcePS, aPos, oXbp:currentSize() ) oClipBoard := XbpClipboard():new():create() oClipBoard:open() oClipBoard:setBuffer(oBitmap) oClipBoard:close() oClipBoard:destroy() ENDIF RETURN nil * ----------------------- DLLFUNCTION keybd_event(mvkey, nscan, flags, xtra) USING STDCALL FROM USER32.DLL * ----------------------- FUNCTION DC_SetModalState( oDialog, oParent ) LOCAL nCol, nRow, nColParent, nRowParent IF Empty(oDialog) oDialog := SetAppFocus() DO WHILE !oDialog:isDerivedFrom('XbpDialog') .AND. !oDialog==AppDeskTop() oDialog := oDialog:setParent() ENDDO IF oDialog == AppDeskTop() RETURN nil ENDIF ENDIF nCol := oDialog:currentPos()[1]+oDialog:setParent():currentPos()[1] nRow := oDialog:currentPos()[2]+oDialog:setParent():currentPos()[2] IF Valtype(oParent) == 'O' nColParent := oParent:currentPos()[1] nRowParent := oParent:currentPos()[2] oDialog:setParent( oParent ) oDialog:setPos( { nColParent - nCol, nRowParent - nRow } ) oDialog:setModalState(XBP_DISP_MODELESS) ELSE oParent := oDialog:setParent():setParent() nColParent := oParent:currentPos()[1] nRowParent := oParent:currentPos()[2] oDialog:setParent( AppDeskTop() ) // oDialog:setOwner( SetAppWindow() ) oDialog:setPos( { nColParent + nCol, nRowParent + nRow } ) oDialog:setModalState(XBP_DISP_APPMODAL) oDialog:configure() RETURN oParent ENDIF RETURN nil * -------------- CLASS DC_SetTimerEvent FROM XbpStatic EXPORTED: VAR interval, evalBlock, thread METHOD Init, Destroy, HandleEvent, TimerLoop ENDCLASS * ----------------- METHOD DC_SetTimerEvent:Init( nInterval, bEval ) ::xbpStatic:init(AppDeskTop()):create() DEFAULT nInterval := 0 IF nInterval > 0 ::interval := nInterval ::evalBlock := bEval ::thread := Thread():new() Sleep(10) ::thread:start({||::TimerLoop()}) ENDIF RETURN self * --------------- METHOD DC_SetTimerEvent:destroy() ::interval := 0 Sleep(5) ::xbpStatic:destroy() Sleep(5) RETURN self * --------------- METHOD DC_SetTimerEvent:handleEvent( nEvent, mp1, mp2 ) IF Valtype(mp1) == 'B' Eval(mp1) Grok(nEvent,mp2) ENDIF RETURN self * --------------- METHOD DC_SetTimerEvent:TimerLoop() LOCAL nCount := -1, nSleep DO WHILE ::interval > 0 IF nCount >= ::interval .OR. nCount == -1 Eval(::evalBlock) nCount := 0 ENDIF IF ::interval < 100 nSleep := ::interval ELSE nSleep := 100 ENDIF IF ::interval <= 0 exit ENDIF Sleep(nSleep) nCount += nSleep ENDDO RETURN nil * --------------- FUNCTION DC_RegionArray( nMode, nWidth, nHeight ) LOCAL i, nCropSize, aRegion := { { 0, 0, 0, 0 } } DEFAULT nMode := 0, ; nWidth := 0, ; nHeight := nWidth IF nMode == DCGUI_REGION_OCTAGON .OR. nMode == DCGUI_REGION_DIAMOND IF nMode == DCGUI_REGION_OCTAGON nCropSize := Int(nWidth/3.33) ELSE nCropSize := Int(nWidth/2) ENDIF FOR i := nCropSize TO 0 STEP -1 AAdd(aRegion, {i,nCropSize-i,nWidth-i,nWidth-nCropSize+i}) NEXT AAdd( aRegion, { 0, nCropSize, nWidth, nWidth-nCropSize }) FOR i := 0 TO nCropSize AAdd(aRegion, {i,i+nWidth-nCropSize,nWidth-1-i,i+nWidth-nCropSize+1}) NEXT ELSEIF nMode == DCGUI_REGION_ELLIPSE RETURN { 0, 0, nWidth, nHeight } ENDIF RETURN aRegion * --------------- FUNCTION DC_ThreadStack( nThread, nMode ) LOCAL nFound STATIC saThreadStack := {} DEFAULT nMode := 0 nFound := AScan( saThreadStack, nThread ) IF nMode == 1 // push AAdd( saThreadStack, nThread ) ELSEIF nMode == 2 // pop IF nFound > 0 ARemove( saThreadStack, nFound ) ENDIF ENDIF RETURN saThreadStack * --------------- FUNCTION DC_NextAppEvent( mp1, mp2, oNextXbp ) LOCAL nEvent LOCAL bErrorBlock bErrorBlock := ErrorBlock({|e|_TrapError(e)}) // bug in Xbase++ sometimes causes error here BEGIN SEQUENCE nEvent := NextAppEvent(@mp1,@mp2,@oNextXbp) END SEQUENCE ErrorBlock(bErrorBlock) RETURN nEvent * ------------------- STATIC PROCEDURE _TrapError() BREAK RETURN * ---------------- FUNCTION DC_ObjectScan( oParent, aStats ) LOCAL aChildList, i, oXbp, cClassName, nFound DEFAULT oParent := AppDesktop(), ; aStats := {} aChildList := oParent:childList() FOR i := 1 TO Len(aChildList) oXbp := aChildList[i] cClassName := oXbp:className() nFound := AScan(aStats,{|a|a[1]==cClassName}) IF nFound == 0 AAdd(aStats,{cClassName,0,0,0,0}) nFound := Len(aStats) ENDIF aStats[nFound,2]++ IF IsMethod(oXbp,'isVisible') .AND. oXbp:isVisible() aStats[nFound,3]++ ENDIF IF IsMethod(oXbp,'status') .AND. oXbp:status()>0 aStats[nFound,4]++ ENDIF DC_ObjectScan(oXbp,aStats) NEXT RETURN aStats * ---------------- FUNCTION DC_ObjectReport( aStats ) LOCAL GetList[0], oBrowse, nVisible := 0, nIterations := 0, ; nActive := 0, i IF Valtype(aStats) # 'A' aStats := DC_ObjectScan() ASort(aStats,,,{|x,y|x[1](recno()),8) + "/" + padr(ltrim(str((cAlias)->(lastrec()),8)),8) + " " + ; padr((cAlias)->(ordbagname()),12) + " " + ; padr((cAlias)->(ordsetfocus()),10) + " " + ; iif((cAlias)->(eof()), "Yes", "No ") + " " + ; iif((cAlias)->(bof()), "Yes", "No ") + " " + ; iif((cAlias)->(deleted()), "Yes", "No ") + " " + ; iif((cAlias)->(found()), "Yes", "No ") + CRLF endif next i cText += CRLF RETURN nil * -------------- STATIC FUNCTION BrowseMenuBlock( oBrowse, aThreadInfo, nPointer ) RETURN {|x,y,z,o|o := BrowseMenu( oBrowse, aThreadInfo, @nPointer ), ; o:popup( nil, x, 1 , ; XBPMENU_PU_DEFAULT + XBPMENU_PU_MOUSE_RBDOWN ) } * ------------- STATIC FUNCTION BrowseMenu( oBrowse, aThreadInfo, nPointer ) LOCAL GetList[0], i IF Valtype(soMenu) # 'O' .OR. soMenu:status()<=0 .OR. soBrowse # oBrowse IF Valtype(soMenu) = 'O' soMenu := nil ENDIF soBrowse := oBrowse DCSUBMENU soMenu DCMENUITEM L('Open Dot-Prompt in this thread') PARENT soMenu ; ACTION {||PostAppEvent(DCGUI_EVENT_ACTION, ; {||DllLoad('dclip1.dll'),&('DC_Dot(.f.)')},,aThreadInfo[nPointer,5]:cargo)} ; WHEN {||Valtype(aThreadInfo[nPointer,5]:cargo)=='O'} DCMENUITEM L('Display Info on ALL threads') PARENT soMenu ; ACTION {||DC_ThreadInfoText()} DCREAD GUI ; PARENT oBrowse ; EXIT ENDIF RETURN soMenu * ----------- FUNCTION DC_ThreadInfoText(cText,lDisplay) LOCAL GetList[0], i, oDlg, lDone := .f., oMemo, aThreadInfo cText := '' DEFAULT lDisplay := .t. aThreadInfo := ThreadInfo(THREADINFO_TID + ; THREADINFO_SYSTHND + ; THREADINFO_FUNCINFO + ; THREADINFO_TOBJ) FOR i := 1 TO Len(aThreadInfo) oDlg := aThreadInfo[i,5]:cargo IF Valtype(oDlg) = 'O' .AND. oDlg:isDerivedFrom('XbpPartHandler') PostAppEvent( DCGUI_EVENT_ACTION,{||ShowWorkArea(@cText)},,oDlg) ENDIF NEXT IF lDisplay @ 0,0 DCMULTILINE cText OBJECT oMemo SIZE 100,25 ; FONT '10.Lucida Console' DCREAD GUI FIT TITLE 'Thread Info' MODAL ; EVAL {|o|o:=Thread():new(),Sleep(5),o:start({||_RefreshWindow(oMemo,@lDone)})} ENDIF lDone := .t. Sleep(5) RETURN cText * ----------- STATIC FUNCTION _RefreshWindow(oMemo,lDone) LOCAL i FOR i := 1 TO 20 IF lDone EXIT ENDIF DC_GetRefresh(oMemo) Sleep(20) NEXT RETURN nil * ----------- // Create Data Record Object FUNCTION DC_DbRecord( cClassName, cRecNoFieldName, cDeletedFieldName ) LOCAL aIVar, oClass, nAttr, aStruct LOCAL aSuperClass := { ClassObject('DC_NoIvarContainer') } DEFAULT cRecNoFieldName := 'RECORD_NUMBER', ; cDeletedFieldName := 'RECORD_DELETED' DEFAULT cClassName := Eval(DC_DbRecordClassName()) oClass := ClassObject( cClassName ) IF oClass <> NIL RETURN oClass // Class already exists ENDIF aStruct := DbStruct() AAdd(aStruct, { cRecnoFieldName, 'N', 12, 0 }) AAdd(aStruct, { cDeletedFieldName, 'L', 1, 0 }) nAttr := CLASS_EXPORTED + VAR_INSTANCE aIVar := AEval( aStruct, {|a| a:={a[1], nAttr} } ,,, .T.) RETURN ClassCreate( cClassName, aSuperClass, aIVar ) * --------------- GETSETFUNCTION DC_DbRecordClassName DEFAULT {||'DATA_' + Alias()} * --------------- // Transfer values from fields to instance variables FUNCTION DC_DbScatter( oRecord, cRecNoFieldName, cDeletedFieldName ) LOCAL i, aStruct, xData, cFieldName DEFAULT cRecNoFieldName := 'RECORD_NUMBER', ; cDeletedFieldName := 'RECORD_DELETED' aStruct := dbStruct() FOR i := 1 TO Len(aStruct) cFieldName := aStruct[i,1] xData := FieldGet(i) IF IsMemberVar(oRecord,cFieldName) xData := FieldGet(i) oRecord:&(aStruct[i,1]) := xData ENDIF NEXT IF IsMemberVar(oRecord,'RECORD_NUMBER') oRecord:record_number := RecNo() ENDIF IF IsMemberVar(oRecord,'RECORD_DELETED') oRecord:record_deleted := Deleted() ENDIF RETURN oRecord * -------------- // Write instance variables to database fields FUNCTION DC_DbGather( oRecord, lNew, lCommit, bLock ) LOCAL i, aStruct, cFieldName, xData, cLogFile, cAlias, aLog, ; nSaveArea, cDatabase, cLogAlias, cDbe, aData, aFields DEFAULT lNew := Eof(), ; lCommit := .f. IF Empty(bLock) bLock := DC_DbGatherLock() ENDIF IF Valtype(bLock) == 'B' IF !Eval(bLock,lNew) RETURN .f. ENDIF ELSE IF lNew IF !_dbAppend() RETURN .f. ENDIF ELSEIF !_dbRlock() RETURN .f. ENDIF ENDIF aLog := DC_DbGatherLog() ASize(aLog,6) DEFAULT aLog[6] := .f. IF !Empty(aLog[1]) cAlias := Alias() DEFAULT aLog[4] := {} IF (!aLog[6] .AND. !_GoodAlias(cAlias,aLog,@aFields,oRecord)) .OR. ; (aLog[6] .AND. _GoodAlias(cAlias,aLog,@aFields,oRecord)) nSaveArea := Select() cDatabase := aLog[1] cLogAlias := aLog[2] cDbe := aLog[3] DEFAULT cDbe := dbeSetDefault() OpenLogFile( cDatabase, cLogAlias, cDbe ) IF (cLogAlias)->(DC_AddRec(5)) (cLogAlias)->alias := cAlias (cLogAlias)->recno := (cAlias)->(RecNo()) (cLogAlias)->type := Valtype(oRecord) (cLogAlias)->date := Date() (cLogAlias)->time := Time() IF Valtype(aLog[5]) == 'B' (cLogAlias)->login := Eval(aLog[5]) ENDIF (cLogAlias)->mode := IIF(lNew,'A','E') IF !lNew aData := Object2Array((cAlias)->(DC_DbScatter(DC_DbRecord():new()))) (cLogAlias)->dataOld := DC_Ar2Str(aData) ENDIF aData := Object2Array(oRecord) (cLogAlias)->dataNew := DC_Ar2Str(aData) (cLogAlias)->callStack := Stack2String() (cLogAlias)->(dbRUnlock()) SELE (nSaveArea) ENDIF ENDIF ENDIF aStruct := DbStruct() FOR i := 1 TO Len(aStruct) cFieldName := aStruct[i,1] IF IsMemberVar(oRecord,cFieldName) xData := oRecord:&(cFieldName) FieldPut(i,xData) ENDIF NEXT dbRUnlock() IF lCommit dbCommit() ENDIF RETURN .t. * ---------- STATIC FUNCTION _GoodAlias( cAlias, aLog, aFields, oRecord ) LOCAL i, acFile, oRecordNew, aData1, aData2 aFields := nil FOR i := 1 TO Len(aLog[4]) acFile := aLog[4,i] IF Valtype(acFile) == 'C' .AND. cAlias == Upper(acFile) RETURN .t. ELSEIF Valtype(acFile) == 'A' .AND. cAlias == Upper(acFile[1]) aFields := acFile[2] IF Empty(aFields) RETURN .t. ENDIF oRecordNew := (cAlias)->(DC_DbScatter(DC_DbRecord():new())) aData1 := Object2Array(oRecord,aFields) aData2 := Object2Array(oRecordNew,aFields) IF !DC_Acompare(aData1,aData2) RETURN .t. ENDIF ENDIF NEXT RETURN .f. * ---------- FUNCTION DC_DbGatherLock( bLock ) STATIC sbLock LOCAL bOldLock := sbLock IF PCount() == 1 .AND. Valtype(bLock) $ 'UB' sbLock := bLock ENDIF RETURN bOldLock * ---------- STATIC FUNCTION OpenLogFile( cDatabase, cLogAlias, cDbe ) LOCAL aStru, aLog, cIndex, lExclusive := .f. IF Empty(cDatabase) aLog := DC_DbGatherLog() cDatabase := aLog[1] cLogAlias := aLog[2] cDbe := aLog[3] ENDIF IF Select(cLogAlias) > 0 RETURN cLogAlias ENDIF cIndex := Strtran(Upper(cDatabase),'.DBF','.CDX') IF !File(cDatabase) aStru := { ; { 'ALIAS ','C', 10, 0 },; { 'RECNO ','N', 10, 0 },; { 'TYPE ','C', 1, 0 },; { 'DATE ','D', 8, 0 },; { 'TIME ','C', 8, 0 },; { 'LOGIN ','C', 10, 0 },; { 'MODE ','C', 1, 0 },; { 'CALLSTACK ','C', 150, 0 },; { 'DATAOLD ','M', 10, 0 },; { 'DATANEW ','M', 10, 0 }} dbCreate( cDatabase, aStru, cDbe ) lExclusive := .t. ENDIF IF lExclusive USE (cDatabase) ALIAS (cLogAlias) VIA (cDbe) NEW EXCLUSIVE INDEX ON FIELD->login TAG 'LOGIN' INDEX ON FIELD->alias + Str(FIELD->recno,10) TAG 'RECNO' ELSE USE (cDatabase) ALIAS (cLogAlias) VIA (cDbe) NEW SET INDEX TO (cIndex) ENDIF RETURN cLogAlias * ---------- STATIC FUNCTION Stack2String() LOCAL i, cStack := '' i := 2 DO WHILE .t. cStack += Trim(ProcName(i))+'('+Alltrim(Str(ProcLine(i))) + '), ' i++ IF Empty(ProcName(i)) .OR. i > 6 EXIT ENDIF ENDDO RETURN cStack * ----------- STATIC FUNCTION Object2Array( oRecord, aFields ) LOCAL aResults[0], i, aData[0] DC_InspectObject( oRecord, .f., @aResults ) FOR i := 1 TO Len(aResults[1]) IF !Empty(aFields) .AND. !(Upper(aResults[1,i,1]) $ aFields) LOOP ENDIF IF .f. // aResults[1,i,5] == 'M' AAdd( aData, Trim(aResults[1,i,1]) + ':' ) ELSE AAdd( aData, Trim(aResults[1,i,1]) + ':' + Trim(aResults[1,i,2]) ) ENDIF NEXT RETURN aData * ------------- FUNCTION DC_DbGatherLog( aLog ) STATIC saLog[5] IF Valtype(aLog) == 'A' ASize(aLog,6) saLog := aLog ENDIF RETURN saLog * ------------- FUNCTION DC_DbGatherLogBrowse() LOCAL GetList[0], GetOptions, oBrowse, oTreeDataOld, oTreeDataNew, cLogAlias cLogAlias := OpenLogFile() @ 0,0 DCPUSHBUTTON CAPTION L('Print') SIZE 7 ACTION {||DC_PrintBrowse(oBrowse)} @ 1,0 DCBROWSE oBrowse ALIAS (cLogAlias) SIZE 150,9 ; FONT '9.Lucida Console' ; ITEMMARKED {||FillTrees(oTreeDataOld,oTreeDataNew,cLogAlias)} ; RESIZE DCGUI_RESIZE_AUTORESIZE ; COLOR {||IIF((cLogAlias)->dataOld==(cLogAlias)->dataNew,{nil,GRA_CLR_WHITE},{nil,GRA_CLR_CYAN})} DCBROWSECOL FIELD (cLogAlias)->alias WIDTH 10 HEADER L('Alias') PARENT oBrowse ; SORT {||(cLogAlias)->(OrdSetFocus('RECNO'))} DCBROWSECOL FIELD (cLogAlias)->recno WIDTH 10 PICTURE '9999999999' HEADER L('Record') PARENT oBrowse DCBROWSECOL FIELD (cLogAlias)->type WIDTH 1 HEADER L('Type') PARENT oBrowse DCBROWSECOL FIELD (cLogAlias)->date WIDTH 10 HEADER L('Date') PARENT oBrowse DCBROWSECOL FIELD (cLogAlias)->time WIDTH 8 HEADER L('Time') PARENT oBrowse DCBROWSECOL FIELD (cLogAlias)->login WIDTH 10 HEADER L('Login') PARENT oBrowse ; SORT {||(cLogAlias)->(OrdSetFocus('LOGIN'))} DCBROWSECOL FIELD (cLogAlias)->mode WIDTH 1 HEADER L('Mode') PARENT oBrowse DCBROWSECOL FIELD (cLogAlias)->callStack WIDTH 100 HEADER L('Stack') PARENT oBrowse @ 11,2 DCSAY L('WAS:') SAYSIZE 0 @ 12,0 DCTREEROOT OBJECT oTreeDataOld SIZE 75,20 FONT '10.Lucida Console' ; RESIZE DCGUI_RESIZE_AUTORESIZE @ 11,78 DCSAY L('IS:') SAYSIZE 0 @ 12,76 DCTREEROOT OBJECT oTreeDataNew SIZE 75,20 FONT '10.Lucida Console' ; RESIZE DCGUI_RESIZE_AUTORESIZE DCGETOPTIONS RESIZE DCREAD GUI FIT TITLE 'Browsing Transaction Database' OPTIONS GetOptions ; MODAL SETAPPWINDOW EXPRESS NOAUTORESTORE RETURN nil * ---------- STATIC FUNCTION FillTrees( oTreeDataOld, oTreeDataNew, cLogAlias ) LOCAL cAlias, aRecord1, aRecord2, i, aItems, cItem, nFound, nIcon, ; oItem cAlias := Trim((cLogAlias)->alias) oTreeDataOld:lockUpdate(.t.) oTreeDataNew:lockUpdate(.t.) oTreeDataOld:setColorBG(GRA_CLR_WHITE) oTreeDataNew:setColorBG(GRA_CLR_WHITE) aItems := oTreeDataOld:rootItem:getChildItems() FOR i := 1 TO Len(aItems) oTreeDataOld:rootItem:delItem(aItems[i]) NEXT aItems := oTreeDataNew:rootItem:getChildItems() FOR i := 1 TO Len(aItems) oTreeDataNew:rootItem:delItem(aItems[i]) NEXT aRecord1 := DC_Str2Ar((cLogAlias)->dataOld) aRecord2 := DC_Str2Ar((cLogAlias)->dataNew) IF !Empty((cLogAlias)->dataOld) FOR i := 1 TO Len(aRecord1) cItem := aRecord1[i] nFound := At(':',cItem) cItem := Pad(Substr(cItem,1,nFound),15) + Substr(cItem,nFound+1) IF Empty(aRecord1) .OR. Empty(aRecord2) .OR. (Len(aRecord1)==Len(aRecord2) ; .AND. !(aRecord1[i] == aRecord2[i])) nIcon := ICON_QUESTION oTreeDataOld:setColorBG(GRA_CLR_CYAN) ELSE nIcon := ICON_CHECKED ENDIF oItem := oTreeDataOld:rootItem:additem(cItem,nIcon,nIcon,nIcon) NEXT ENDIF IF !Empty((cLogAlias)->dataNew) FOR i := 1 TO Len(aRecord2) cItem := aRecord2[i] nFound := At(':',cItem) cItem := Pad(Substr(cItem,1,nFound),15) + Substr(cItem,nFound+1) oItem := oTreeDataNew:rootItem:additem(cItem) NEXT ENDIF oTreeDataOld:lockUpdate(.f.) oTreeDataNew:lockUpdate(.f.) RETURN nil * ---------------- STATIC FUNCTION _DbAppend() LOCAL i, lStatus := .f. FOR i := 1 TO 3 dbAppend(1) IF !NetErr() lStatus := .t. EXIT ENDIF Sleep(100) NEXT RETURN lStatus * ---------------- STATIC FUNCTION _DbRLock() LOCAL i, lStatus := .f. FOR i := 1 TO 3 IF dbRLock() lStatus := .t. EXIT ENDIF Sleep(100) NEXT RETURN lStatus * ---------------- FUNCTION DC_DbRecordClone( oRecord ) LOCAL oNewRec oNewRec := DC_DbRecord(oRecord:className()):new() DC_DbRecordCopy( ORecord, oNewRec ) IF IsMemberVar(oRecord,'RECORD_NUMBER') oRecord:record_number := oNewRec:record_number ENDIF IF IsMemberVar(oRecord,'RECORD_DELETED') oRecord:record_deleted := oNewRec:record_deleted ENDIF RETURN oNewRec * ---------------- FUNCTION DC_DbRecordCopy( oRecordFrom, oRecordTo ) LOCAL aResults, aIvars, i, cFieldName aResults := oRecordFrom:classDescribe() aIvars := {} FOR i := 1 TO Len(aResults[3]) AAdd(aIvars,Alltrim(aResults[3,i,1])) NEXT FOR i := 1 TO Len(aIvars) cFieldName := aIvars[i] IF Upper(cFieldName) == '__NOIVAR' LOOP ENDIF IF IsMemberVar(oRecordTo,cFieldName) .AND. IsMemberVar(oRecordFrom,cFieldName) oRecordTo:&(cFieldName) := oRecordFrom:&(cFieldName) ENDIF NEXT RETURN nil * ---------------- FUNCTION DC_DbRecordCompare( oRecord1, oRecord2, aFields ) LOCAL aResults, aIvars, i, cFieldName, lStatus := .t. aResults := oRecord1:classDescribe() aIvars := {} FOR i := 1 TO Len(aResults[3]) AAdd(aIvars,Alltrim(aResults[3,i,1])) NEXT FOR i := 1 TO Len(aIvars) cFieldName := aIvars[i] IF IsMemberVar(oRecord1,cFieldName) .AND. IsMemberVar(oRecord2,cFieldName) IF !( Trim(DC_Xtoc( oRecord1:&(cFieldName))) == Trim(DC_Xtoc(oRecord2:&(cFieldName))) ) lStatus := .f. IF Valtype(aFields) == 'A' AAdd( aFields, ; { cFieldName, ; Trim(DC_Xtoc( oRecord1:&(cFieldName))), ; Trim(DC_Xtoc( oRecord2:&(cFieldName))) } ) ENDIF ENDIF ELSE lStatus := .f. ENDIF IF !lStatus .AND. Empty(aFields) EXIT ENDIF NEXT RETURN lStatus * ----------- FUNCTION DC_DbRecordIsEmpty( oRecord ) LOCAL aResults, lEmpty := .t., i, cFieldName, xValue aResults := oRecord:classDescribe() FOR i := 1 TO Len(aResults[3]) cFieldName := aResults[3,i,1] xValue := oRecord:&(cFieldName) IF !Empty(xValue) lEmpty := .f. EXIT ENDIF NEXT RETURN lEmpty * ----------- FUNCTION DC_DbRecordTrim( oRecord ) LOCAL aResults, i, cFieldName, xValue aResults := oRecord:classDescribe() FOR i := 1 TO Len(aResults[3]) cFieldName := aResults[3,i,1] xValue := oRecord:&(cFieldName) IF Valtype(xValue) $ 'CM' oRecord:&(cFieldName) := Trim(xValue) ENDIF NEXT RETURN nil * ----------- FUNCTION DC_DbRecord2Array( oRecord ) LOCAL aResults, aData[0], i, cFieldName aResults := oRecord:classDescribe() FOR i := 1 TO Len(aResults[3]) cFieldName := aResults[3,i,1] AAdd(aData, oRecord:&(cFieldName) ) NEXT RETURN aData * ---------------- FUNCTION DC_DbRecord2File( oRecord, cFileName ) LOCAL aData := { Alias(), Var2Bin(oRecord), RecNo() } RETURN DC_ASave( aData, cFileName ) * ---------------- FUNCTION DC_DbFile2Record( cFileName, nRecord ) LOCAL cAlias, oRecord, aData aData := DC_ARestore( cFileName ) IF Valtype(aData) == 'A' .AND. Len(aData) == 3 cAlias := aData[1] IF Select(cAlias) > 0 oRecord := (cAlias)->(DC_DbRecord():new()) oRecord := Bin2Var( aData[2] ) ENDIF ENDIF RETURN oRecord * ------------- FUNCTION DC_DbRecordEdit( oRecord ) LOCAL aResults, i, cFieldName, GetList[0], GetOptions, lStatus, nRow := 0, ; bPopup, nGetLen, xValue aResults := oRecord:classDescribe() FOR i := 1 TO Len(aResults[3]) cFieldName := aResults[3,i,1] xValue := oRecord:&(cFieldName) IF cFieldName # 'RECORD_NUMBER' bPopup := nil nGetLen := nil IF Valtype(xValue) == 'D' bPopup := {|d|DC_PopDate(d,,,,,,2)} ELSEIF Valtype(xValue) $ 'CM' .AND. Len(xValue) > 50 nGetLen := 50 ENDIF @ nRow++, 0 DCSAY cFieldName GET oRecord:&(cFieldName) POPUP bPopup GETSIZE nGetLen ENDIF NEXT DCGETOPTIONS SAYWIDTH 100 SAYRIGHTBOTTOM DCREAD GUI FIT TITLE 'Editing ' + Alias() + ' record #' + Alltrim(Str(RecNo())) ; TO lStatus ADDBUTTONS OPTIONS GetOptions MODAL IF lStatus DC_DbGather( oRecord ) ENDIF RETURN lStatus * ------------- FUNCTION DC_RecordDupes( bExpr ) LOCAL aDupes[0], aRecords[0], nSaveRec, nSaveOrder, nFound, ; cString, i, j, oRecord nSaveRec := RecNo() nSaveOrder := OrdSetFocus() dbGoTop() DO WHILE !Eof() IF !Deleted() cString := Eval(bExpr) nFound := AScan(aRecords,{|a|a[1]==cString}) IF nFound == 0 AAdd( aRecords, {cString, {{RecNo(),nil}}} ) ELSE AAdd( aRecords[nFound,2],{RecNo(),nil}) ENDIF ENDIF dbSkip() ENDDO dbGoTo(nSaveRec) OrdSetFocus(nSaveOrder) FOR i := 1 TO Len(aRecords) IF Len(aRecords[i,2]) > 1 FOR j := 1 TO Len(aRecords[i,2]) dbGoTo(aRecords[i,2,j,1]) oRecord := DC_DbRecord():new() DC_DbScatter(oRecord) aRecords[i,2,j,2] := oRecord NEXT AAdd(aDupes,aRecords[i]) ENDIF NEXT RETURN aDupes * ---------------- FUNCTION DC_ToolTipTimeOut( nTimeOut ) STATIC snTimeOut := 5 LOCAL nOldTimeOut nOldTimeOut := snTimeOut IF Valtype(nTimeOut) == 'N' snTimeOut := nTimeOut ENDIF IF DC_ToolTipShowSource() nOldTimeOut := 100 ENDIF RETURN nOldTimeOut * ---------------- FUNCTION DC_ToolTipSensitivity( nSensitivity ) STATIC snSensitivity := .8 LOCAL nOldSensitivity nOldSensitivity := snSensitivity IF Valtype(nSensitivity) == 'N' snSensitivity := nSensitivity ENDIF RETURN nOldSensitivity * -------------- GETSETFUNCTION DC_ToolTipEnable DEFAULT .t. * -------------- FUNCTION DC_ToolTipThreadActive( nThreadID ) IF Empty(nThreadID) nThreadID := ThreadID() ENDIF RETURN nil * ----------------- GETSETFUNCTION DC_TooltipShowSource DEFAULT .f. * ------------------ FUNCTION VScrollBarSize() RETURN {DllCall("USER32.DLL", DLL_STDCALL, "GetSystemMetrics",SM_CXVSCROLL),; DllCall("USER32.DLL", DLL_STDCALL, "GetSystemMetrics",SM_CYVSCROLL)} FUNCTION HScrollBarSize() RETURN {DllCall("USER32.DLL", DLL_STDCALL, "GetSystemMetrics",SM_CXHSCROLL),; DllCall("USER32.DLL", DLL_STDCALL, "GetSystemMetrics",SM_CYHSCROLL)} * ----------------- FUNCTION DC_MoveParentWindow( mp1, mp2, oXbp, nStopEvent ) LOCAL oParent := oXbp, oDeskTop := AppDeskTop(), nEvent, aPos, aPosXbp DEFAULT nStopEvent := xbeM_LbUp DO WHILE !(oParent == oDesktop) oParent := oParent:setParent() IF oParent:isDerivedFrom('XbpDialog') EXIT ENDIF ENDDO aPosXbp := DC_CalcAbsolutePosition( mp1, oXbp, oParent ) oParent:captureMouse(.t.) nEvent := 0 aPos := oParent:currentPos() DO WHILE nEvent # nStopEvent nEvent := AppEvent( @mp1, @mp2, @oXbp, .1 ) IF nEvent # 0 oXbp:handleEvent(nEvent,mp1,mp2) ENDIF IF nEvent == xbeM_Motion aPos := DC_CalcAbsolutePosition(mp1,oXbp) aPos[1] -= aPosXbp[1] aPos[2] -= aPosXbp[2] oParent:setPos( aPos ) DC_CompleteEvents() ENDIF ENDDO oParent:captureMouse(.f.) RETURN nil * ------------------ FUNCTION DC_IsObscured( oXbp ) LOCAL i, aCoords := DC_CalcAbsolutePosition( nil, oXbp ), ; aSize := oXbp:currentSize(), aChildCoords, aChildSize, ; nStartRow, nStartCol, nEndRow, nEndCol, nStartRow2, ; nStartCol2, nEndRow2, nEndCol2, aChildList, oParentWindow oParentWindow := ParentWindow(oXbp) DO WHILE oXbp:setParent() # AppDesktop() oXbp := oXbp:setParent() ENDDO nStartRow := aCoords[2] nStartCol := aCoords[1] nEndRow := nStartRow + aSize[2] nEndCol := nStartCol + aSize[1] aChildList := oXbp:drawingArea:childList() FOR i := 1 TO Len(aChildList) aChildCoords := DC_CalcAbsolutePosition( nil, aChildList[i] ) aChildSize := aChildList[i]:currentSize() nStartRow2 := aChildCoords[2] nStartCol2 := aChildCoords[1] nEndRow2 := nStartRow2 + aChildSize[2] nEndCol2 := nStartCol2 + aChildSize[1] IF !aChildList[i]:isDerivedFrom('XbpDialog') LOOP ENDIF IF aChildList[i] == oParentWindow LOOP ELSEIF !aChildList[i]:hasInputFocus() LOOP ELSEIF nEndRow2 < nStartRow LOOP ELSEIF nStartCol2 > nEndCol LOOP ELSEIF nEndCol2 < nStartCol LOOP ELSEIF nStartRow2 > nEndRow LOOP ELSE RETURN .T. ENDIF NEXT RETURN .F. * -------------- STATIC FUNCTION ParentWindow( oXbp ) oXbp := oXbp:setParent():setParent():setParent() DO WHILE !(oXbp:isDerivedFrom('XbpDialog')) oXbp := oXbp:setParent() ENDDO RETURN oXbp * -------------- GETSETFUNCTION DC_TooltipThread DEFAULT 2 * -------------- FUNCTION DC_ReSize( aOldSize, aNewSize, oDlg, aGetList, oGetList, nRecurs ) LOCAL nY, nX, aReSize, aPos, aSize, nStatus, aChildList, i, oXbp, ; bSetPos, bSetSize, lScaleFont, nHDelta, nVDelta, cCompoundName, ; nPointSize, nY2, nX2, nXRatio, nYRatio, nCurrentCol, nCurrentRow, ; nCurrentWidth, nCurrentHeight, nFound, nHRatio, nVRatio, nSpacing, ; aState, nDataStore, bPostEval DEFAULT nRecurs := 0 IF (aOldSize[1] = aNewSize[1] .AND. aOldSize[2] == aNewSize[2]) .OR. aOldSize[2] < 50 .AND. ; oDlg:isDerivedFrom('XbpDialog') RETURN nil ENDIF IF oDlg:isDerivedFrom('XbpDialog') .AND. ; Empty(DC_GetProperty(oDlg,aGETLIST_RESIZE)) oDlg := oDlg:drawingArea ENDIF IF oDlg:isDerivedFrom('XbpIWindow') .AND. ; ;// oDlg:setParent():isDerivedFrom('DC_XbpDialog1') .AND. ; oDlg:setParent():isDerivedFrom('XbpDialog') .AND. ; nRecurs = 0 IF isMemberVar(oDlg:setParent(),'resizeState') aState := oDlg:setParent():resizeState ENDIF IF Empty(aState) aState := Array(3) oDlg:setParent():resizeState := aState ENDIF DEFAULT aState[1] := aNewSize[1], ; aState[2] := aNewSize[2], ; aState[3] := -1 IF aState[3] == oDlg:setParent():getFrameState() .AND. ; aState[3] $ { XBPDLG_FRAMESTAT_MINIMIZED,XBPDLG_FRAMESTAT_MAXIMIZED} RETURN nil ENDIF IF oDlg:setParent():getFrameState() == XBPDLG_FRAMESTAT_MINIMIZED aState[3] := XBPDLG_FRAMESTAT_MINIMIZED aState[1] := aOldSize[1] aState[2] := aOldSize[2] RETURN nil ELSEIF aState[3] == XBPDLG_FRAMESTAT_MINIMIZED aOldSize := { aState[1], aState[2] } aState[3] := oDlg:setParent():getFrameState() // RETURN nil ELSEIF aState[3] == XBPDLG_FRAMESTAT_MAXIMIZED .AND. ; oDlg:setParent():getFrameState() == XBPDLG_FRAMESTAT_NORMALIZED ENDIF aState[1] := aNewSize[1] aState[2] := aNewSize[2] aState[3] := oDlg:setParent():getFrameState() ENDIF nX := (aNewSize[1]-aOldSize[1]) nY := (aNewSize[2]-aOldSize[2]) nXRatio := aNewSize[1]/aOldsize[1] nYRatio := aNewSize[2]/aOldSize[2] IF nX = 0 .AND. nY = 0 RETURN nil ENDIF IF oDlg:isDerivedFrom('XbpDialog') oDlg:drawingArea:lockUpdate(.t.) ENDIF aChildList := oDlg:childList() IF Valtype(oGetList) # 'O' nDataStore := AScan(aGetList,{|a|a[nGETLIST_TYPE]==GETLIST_DATASTORE}) oGetList := aGetList[nDataStore,oGETLIST_OBJECT] ENDIF IF Valtype(oGetList:reSize) # 'A' oGetList:reSize := {} ENDIF FOR i := 1 TO Len(aChildList) oXbp := aChildList[i] nStatus := 0 aResize := DC_GetProperty(oXbp,aGETLIST_RESIZE,,,,@nStatus) IF nStatus == 0 LOOP ELSEIF Valtype(aResize) # 'A' aResize := oGetList:resizeDefault ENDIF ASize(aResize,4) DEFAULT aResize[3] := .f. bSetPos := aResize[1] bSetSize := aResize[2] lScaleFont := aResize[3] aOldSize := oXbp:currentSize() nFound := AScan( oGetList:reSize, {|a|a[1] == oXbp} ) IF nFound > 0 nCurrentCol := oGetList:reSize[nFound,2] nCurrentRow := oGetList:reSize[nFound,3] nCurrentWidth := oGetList:reSize[nFound,4] nCurrentHeight := oGetList:reSize[nFound,5] oGetList:reSize[nFound,2] := nCurrentCol * nXRatio oGetList:reSize[nFound,3] := nCurrentRow * nYRatio oGetList:reSize[nFound,4] := Max(nCurrentWidth * nXRatio,1) oGetList:reSize[nFound,5] := Max(nCurrentHeight * nYRatio,1) ELSE nCurrentCol := oXbp:currentPos()[1] nCurrentRow := oXbp:currentPos()[2] nCurrentWidth := oXbp:currentSize()[1] nCurrentHeight := oXbp:currentSize()[2] AADD( oGetList:reSize, { oXbp, nCurrentCol * nXRatio, ; nCurrentRow * nYRatio, ; Max(nCurrentWidth * nXRatio,1), ; Max(nCurrentHeight * nYRatio,1) } ) ENDIF nSpacing := -1 IF oXbp:isDerivedFrom('DC_XbpGet') .AND. !Empty(oXbp:popupbutton) .AND. ; !(oXbp==oXbp:popupbutton:setParent()) nSpacing := oXbp:popupbutton:currentPos()[1] - ( oXbp:currentPos()[1] + oXbp:currentSize()[1] ) ENDIF IF Valtype(bSetPos) = 'B' aPos := Eval( bSetPos, nX, nY, oXbp, nCurrentCol, nCurrentRow, nXRatio, nYRatio ) oXbp:setPos(aPos) ENDIF IF Valtype(bSetSize) = 'B' .AND. IsMethod(oXbp,'SETSIZE') aSize := Eval( bSetSize, nX, nY, oXbp, nCurrentWidth, nCurrentHeight, nXRatio, nYRatio ) IF aSize[1] # oXbp:currentSize()[1] .OR. aSize[2] # oXbp:currentSize()[2] IF lScaleFont .AND. IsMemberVar(oXbp,'origFont') .AND. Valtype(oXbp:origFont) == 'O' nHRatio := aSize[1]/oXbp:origSize[1] nVRatio := aSize[2]/oXbp:origSize[2] nPointSize := nVRatio*oXbp:origFontSize IF nPointSize # oXbp:origFont:nominalPointSize cCompoundName := Alltrim(Str(nPointSize,3,0)) + '.' +oXbp:fontFamilyName oXbp:setFontCompoundName(cCompoundName) ENDIF ENDIF IF oXbp:isDerivedFrom('DC_XbpGet') oXbp:resizeSetSize(aSize) ELSE oXbp:setSize(aSize) ENDIF IF oXbp:isDerivedFrom('DC_XbpGet') .AND. !Empty(oXbp:popupbutton) .AND. ; (oXbp==oXbp:popupbutton:setParent()) oXbp:popupButton:setPos({oXbp:currentSize()[1]-oXbp:popupButton:currentSize()[1]-5,0}) ENDIF ENDIF ENDIF IF nSpacing >= 0 oXbp:popupButton:setPos({oXbp:currentPos()[1] + oXbp:currentSize()[1] + nSpacing, ; oXbp:currentPos()[2]} ) oXbp:popupButton:setSize({oXbp:currentSize()[2],oXbp:currentSize()[2]}) ENDIF aNewSize := oXbp:currentSize() IF oXbp:isDerivedFrom('XbpDialog') oXbp := oXbp:drawingArea ENDIF IF oXbp:isDerivedFrom('DC_XbpTabPage') IF oXbp:angle > 0 oXbp:configure() ENDIF IF Valtype(oXbp:staticArea) == 'O' Eval(oXbp:resize,aOldSize,aNewSize,oXbp) oXbp := oXbp:staticArea ENDIF ENDIF bPostEval := aResize[4] IF Valtype(bPostEval) == 'B' Eval(bPostEval,oXbp) ENDIF IF !Empty(oXbp:childList()) .AND. ; !oXbp:isDerivedFrom('XbpBrowse') .AND. ; !oXbp:isDerivedFrom('DC_XbpGet') .AND. ; !oXbp:isDerivedFrom('MxPushButton') DC_Resize( aOldSize, aNewSize, oXbp, aGetList, oGetList, ++nRecurs ) ELSEIF oXbp:isDerivedFrom('DC_XbpBrowse') .AND. oXbp:resizeColumns oXbp:resizeColumns( aOldSize, aNewSize ) ENDIF NEXT IF oDlg:isDerivedFrom('XbpDialog') oDlg:drawingArea:lockUpdate(.f.) ENDIF RETURN nil * ------------- FUNCTION DC_FormatMemoToWidth( cString, nWidth, oPS ) LOCAL aTokens, cOutString, cLine, i, cFont, nLineWidth, aRect, cCaption IF !(Valtype(cString) $ 'CM') RETURN '' ENDIF DEFAULT nWidth := 200 aTokens := DC_TokenArray( cString, ' '+Chr(10) ) cOutString := '' cLine := '' FOR i := 1 TO Len(aTokens) IF aTokens[i] == Chr(13) cLine += aTokens[i] cOutString += cLine cLine := '' LOOP ENDIF cCaption := cLine + ' ' + aTokens[i] IF Valtype( oPS ) == 'C' // It's a font cFont := Alltrim(oPS) nLineWidth := DC_GraQueryTextBox(cCaption,cFont)[1] ELSE // It's a presentation space aRect := GraQueryTextBox(oPS, cCaption ) nLineWidth := aRect[3,1] - aRect[1,1] ENDIF IF nLineWidth <= nWidth cLine += ' ' + aTokens[i] ELSE cOutString += cLine + Chr(13) cLine := aTokens[i] ENDIF NEXT IF !Empty(cLine) cOutString += cLine ENDIF cOutString := Strtran(cOutString,Chr(13)+' ',Chr(13)) cOutString := Strtran(cOutString,Chr(13),Chr(13)+Chr(10)) RETURN LTrim(cOutString) * -------------- FUNCTION DC_SendMailToDefault( cTo, cCC, cSubject, cBody ) LOCAL cParams, cCommand cParams := 'url.dll,FileProtocolHandler mailto:' IF !Empty(cTo) // cParams += '?to=' + cTo cParams += cTo ENDIF IF !Empty(cCC) cParams += Chr(38) + 'cc=' + cCC ENDIF IF !Empty(cSubject) cParams += Chr(38) + 'subject=' + cSubject ENDIF IF !Empty(cBody) cBody := Strtran(cBody,Chr(13),'%0d') cBody := Strtran(cBody,Chr(10),'%0a') cBody := Strtran(cBody,' ','%20') cBody := Strtran(cBody,Chr(38),'%26') cBody := Strtran(cBody,'?','%3f') cBody := Strtran(cBody,'=','%3d') cParams += Chr(38) + 'body=' + cBody ENDIF cCommand := 'Rundll32.exe' RunShell( cParams, cCommand, .t., .t. ) RETURN nil * ------------- FUNCTION ShellOpenFile( cUrl, lBackground, lAsync ) LOCAL cParams, cCommand DEFAULT lBackground := .F., ; lAsync := .t. cParams := 'url.dll,FileProtocolHandler ' + Alltrim(cURL) // + ; // IIF('?'$cUrl,'','?') cCommand := 'Rundll32.exe' RunShell( cParams, cCommand, lAsync, lBackground ) RETURN 1 * ----------------- FUNCTION Grok() RETURN nil * ----------------- #define UNIVERSAL_NAME_INFO_LEVEL 0x00000001 #define REMOTE_NAME_INFO_LEVEL 0x00000002 #define NO_ERROR 0 #define ERROR_BAD_DEVICE 1200 #define ERROR_CONNECTION_UNAVAIL 1201 #define ERROR_EXTENDED_ERROR 1208 *#define ERROR_MORE_DATA 234 #define ERROR_NOT_SUPPORTED 50 #define ERROR_NO_NET_OR_BAD_PATH 1203 #define ERROR_NO_NETWORK 1222 #define ERROR_NOT_CONNECTED 2250 #DEFINE MAX_BUFFER_SIZE 500 #DEFINE STRUCTURE_HEADER 0 FUNCTION DC_Drive2UNC( cMappedPath ) local cReturnValue local cDrive, cPath local cLocalPath, cBuffer, nBufferSize, nResult, cStructureString IF !EMPTY(cMappedPath) DO CASE CASE LEN(cMappedPath) > 2 cDrive = LEFT(cMappedPath, 2) cPath = SUBSTR(cMappedPath, 3) CASE len(cMappedPath) <= 2 cDrive = cMappedPath cPath = "" ENDCASE nBufferSize = 255 cLocalPath = cDrive cBuffer = space(nBufferSize) nResult := WNetGetConnectionA( @cLocalPath, @cBuffer, @nBufferSize ) DO CASE CASE nResult = NO_ERROR // string translated sucessfully cStructureString = ALLTRIM(SUBSTR(cBuffer, STRUCTURE_HEADER + 1)) cReturnValue = LEFT(cStructureString, AT(CHR(0), cStructureString) - 1) + cPath CASE nResult = ERROR_BAD_DEVICE // The string pointed to by lpLocalPath is invalid. cReturnValue = cMappedPath CASE nResult = ERROR_CONNECTION_UNAVAIL // There is no current connection to the remote device, but there is a remembered (persistent) connection to it. cReturnValue = cMappedPath CASE nResult = ERROR_EXTENDED_ERROR // A network-specific error occurred. Use the WNetGetLastError function to obtain a description of the error. cReturnValue = cMappedPath CASE nResult = ERROR_MORE_DATA // The buffer pointed to by lpBuffer is too small. The function sets the variable pointed to by lpBufferSize to the required buffer size. cReturnValue = cMappedPath CASE nResult = ERROR_NOT_SUPPORTED // The dwInfoLevel parameter was set to UNIVERSAL_NAME_INFO_LEVEL, but the network provider does not support UNC names. This function is not supported by any of the network providers. cReturnValue = cMappedPath CASE nResult = ERROR_NO_NET_OR_BAD_PATH // None of the providers recognized this local name as having a connection. However, the network is not available for at least one provider to whom the connection may belong. cReturnValue = cMappedPath CASE nResult = ERROR_NO_NETWORK // There is no network present. cReturnValue = cMappedPath CASE nResult = ERROR_NOT_CONNECTED // The device specified by cLocalPath is not redirected. cReturnValue = cMappedPath OTHERWISE cReturnValue = cMappedPath ENDCASE ELSE cReturnValue = cMappedPath ENDIF RETURN Alltrim(cReturnValue) * ------------- FUNCTION DC_SetUNC( cFileName ) LOCAL cUNC, cCurDir := CurDir() IF !('\\' $ cFileName) IF !(':' $ cFileName) IF Empty(cUNC) cUNC := DC_Drive2UNC( CurDrive() + ':') ENDIF IF !( ':' $ cUNC ) cFileName := cUNC + '\' + IIF(!Empty(cCurDir),cCurDir + '\','') + cFileName ENDIF ENDIF ENDIF RETURN cFileName *+-------------------------------------------------------------------- *+ *+ Function DC_ConfigDialogButtons(obj,nMode) *+ *+ Based on various code examples in the programming community *+ *+ ++Configures buttons on dialog *+ *+ Usage: Call this function via the eval clause of a DCREAD GUI statement *+ with the appropriate parameters *+ *+ DC_ConfigDialogButtons(oDlg,DC_BUTTON_REMOVEALL) // to remove minimize/maximize/close buttons *+ DC_ConfigDialogButtons(oDlg,DC_DISABLEMINIMIZE) // to disable the minimize button *+ DC_ConfigDialogButtons(oDlg,DC_DISABLEMAXIMIZE) // to disable the maximize button *+ DC_ConfigDialogButtons(oDlg,DC_REMOVEMINMAX) // to remove minimize/maximize buttons *+ DC_ConfigDialogButtons(oDlg,DC_HELP) // to remove minimize/maximize buttons and add "?" help button *+ // this option would require additional hooks into the dialog to *+ // implement the help feature; this option can be removed with *+ // the corresponding changes to the function to remove the DC_BUTTON_ADDHELP *+ // modifications *+ *+-------------------------------------------------------------------- *+ FUNCTION DC_ConfigDialogButtons(oDlg,nMode) LOCAL nHwnd, nIndex, nNewIndex nHwnd := oDlg:xbpDialog:GetHwnd() nIndex := GetWindowLongA(nHwnd,GWL_STYLE) nNewIndex := nIndex nNewIndex := DC_XorBitsLong(nIndex, iif(nMode==DC_BUTTON_ADDHELP, ; DC_BUTTON_REMOVEMINMAX,nMode)) IF nNewIndex != 0 SetWindowLongA(nHwnd,GWL_STYLE, nNewIndex) IF nMode == DC_BUTTON_ADDHELP SetWindowLongA(nHwnd,GWL_EXSTYLE, WS_EX_CONTEXTHELP) ENDIF ENDIF RETURN NIL *+-------------------------------------------------------------------- *+ *+ Function DC_Dec2LongInt(n) *+ *+ ++ Converts a Long Integer (32 bits) TO binary character representation *+ Thanks to Cliff Wiernik *+-------------------------------------------------------------------- FUNCTION DC_Dec2LongInt(n) LOCAL i, cBin := '' FOR i := 32 TO 1 step -1 IF n >= 2^(i-1) n -= 2^(i-1) cBin := cBin + '1' ELSE cBin := cBin + '0' ENDIF NEXT RETURN cBin *+-------------------------------------------------------------------- *+ *+ Function DC_XorBitsLong ( n1, n2 ) *+ *+ ++ Performs an exclusive OR on 2 long integer (32 bit values) values *+ Thanks to Cliff Wiernik *+-------------------------------------------------------------------- *+ FUNCTION DC_XorBitsLong ( n1, n2 ) LOCAL c1, c2, c3, i n1 := IIF(Valtype(n1)='N',n1,0) n2 := IIF(Valtype(n2)='N',n2,0) c1 := DC_Dec2LongInt(n1) c2 := DC_Dec2LongInt(n2) c3 := '' FOR i := 1 TO 32 IF Substr(c1,i,1)='1' .AND. Substr(c2,i,1)='0' c3 += '1' ELSEIF Substr(c1,i,1)='0' .AND. Substr(c2,i,1)='1' c3 += '1' ELSE c3 += '0' ENDIF NEXT RETURN DC_Bin2Num(c3) * --------------- FUNCTION DC_HourGlassOn() SetAppWindow():SetPointer( nil, XBPSTATIC_SYSICON_WAIT, XBPWINDOW_POINTERTYPE_SYSPOINTER ) SetAppWindow():captureMouse(.t.) RETURN nil * --------------- FUNCTION DC_HourGlassOff() SetAppWindow():SetPointer( nil, XBPSTATIC_SYSICON_SYSTEM, XBPWINDOW_POINTERTYPE_SYSPOINTER ) SetAppWindow():captureMouse(.f.) RETURN nil //////////////////////////////////////////////////////////////////////////////////////////// // // // Date : 02-01-2006 // // By : Jack Duijf (jdsoftware@tiscali.nl) // // // // New function to find the size of the desktop. // // // // This code take in account that there could be 2 monitors with a shared desktop. // // It assumes that AppDesktop() only returns the App windows that belong to the Xbase++ // // application. In case there are multiple monitors, it assumes the same resolution for // // both. // // // // Parameters None // // Return aSize : aSize[1] = Total width of desktop // // : aSize[2] = Total height of desktop // // // // // // 02-01-2006 J. Duijf - Initial release // // // //////////////////////////////////////////////////////////////////////////////////////////// Function Dc_DeskTopSize() LOCAL aChild := AppDeskTop():ChildList() // List of Xbase++ windows LOCAL aRet := AppDeskTop():CurrentSize() // Current size of main desktop. LOCAL nWidth := 0 if Len(aChild) > 0 // There are Xbase++ windows nWidth := aChild[1]:CurrentPos()[1] + aChild[1]:CurrentSize()[1] - 8 // // If the app window is maximized, then the aChild[1]:CurrentPos()[1] = -4, and the with is 8 point larger then // AppDesktop():CurrentSize(). Therefore, i correct the App window size by 8 points. In later calculations, // i can ignore the discrepancy. // // nWidth = the position of the right edge of the main app window. // if nWidth > aRet[1] // Width exeeds main AppDesktop() aRet[1] += aRet[1] // Width is double with dual monitor, assuming same resolution // I do not know how to figure out the 2nd monitor resolution endif endif Return aRet // Size of AppDesktop() * ----------------- FUNCTION DC_MoveCursorToObject( oXbp ) LOCAL nCol, nRow, aPos, nHeight := AppDeskTop():currentSize()[2] nCol := oXbp:currentSize()[1]/2 nRow := oXbp:currentSize()[2]/2 aPos := DC_CalcAbsolutePosition({nCol,nRow},oXbp) nCol := aPos[1] nRow := aPos[2] nRow := nHeight - nRow SetCursorPos( nCol, nRow ) RETURN nil * ----------------- FUNCTION DC_AvailableDrives() LOCAL i, nDrives, cDrives, cAvailDrives := '', nDrive nDrives := GetLogicalDrives() cDrives := DC_Dec2Bin(nDrives,4) nDrive := 0 FOR i := Len(cDrives) to 1 STEP -1 IF cDrives[i] = '1' cAvailDrives += Chr(Asc('A')+nDrive) ENDIF nDrive++ NEXT RETURN cAvailDrives * --------------- FUNCTION DC_GetNetName() LOCAL nHKey := 2147483650 LOCAL cKeyName := "System\CurrentControlSet\Control\ComputerName\ComputerName" LOCAL cEntryName := "Computername" LOCAL cName := "", rc LOCAL nNameSize LOCAL nKeyHandle LOCAL nValueType nKeyHandle := 0 IF RegOpenKeyExA(nHKey, cKeyName,0, 1, @nKeyHandle) = 0 nValueType := 0 nNameSize := 0 RegQueryValueExA(nKeyHandle, cEntryName, 0, @nValueType, 0, @nNameSize) IF nNameSize > 0 cName := space( nNameSize ) rc := RegQueryValueExA(nKeyHandle, cEntryName,; 0, @nValueType, @cName, @nNameSize) ENDIF RegCloseKey( nKeyHandle) ENDIF cName := Strtran(cName,Chr(0),'') RETURN (Upper(Alltrim(cName))) * ---------------- FUNCTION DC_IsDescendant( oXbp, oParent ) LOCAL aChildList := oParent:ChildList(), i FOR i := 1 TO Len(aChildList) IF oXbp == aChildList[i] RETURN .T. ELSEIF DC_IsDescendant( oXbp, aChildList[i] ) RETURN .T. ENDIF NEXT RETURN .f. * ----------------- FUNCTION DC_IsCreateChildren( oParent ) IF oParent == nil RETURN .t. ELSEIF !IsMemberVar(oParent,'isCreateChildren') RETURN .t. ELSEIF !oParent:isCreateChildren RETURN .f. ENDIF RETURN .t. * ----------------- FUNCTION DC_Unc2Drive( cUnc ) LOCAL cDrive, i, cDrives := DC_AvailableDrives(), cSubPath := '', cReturnedUnc FOR i := 1 TO Len(cDrives) cDrive := cDrives[i] + ':' cReturnedUnc := Alltrim(DC_Drive2Unc( cDrive )) IF Lower(Substr(cUnc,1,Len(cReturnedUnc))) == Lower(cReturnedUnc) cSubPath := Strtran(Lower(cUnc),Lower(cReturnedUnc)) EXIT ENDIF NEXT IF i > Len(cDrives) cDrive := '' ENDIF RETURN cDrive + cSubPath * --------- FUNCTION DC_SetWindowTransparency(hWnd,nPercent) #if XPPVER > 1900000 LOCAL nExStyle, nTransparentValue, lActive /* if !("Windows 2000" $ os() .or. "Windows XP" $ os()) return nil endif */ IF Valtype(hWnd) == 'O' hWnd := hWnd:getHWnd() ENDIF nExStyle := GetWindowLongA(hWnd, GWL_EXSTYLE) lActive := Band( nExStyle, WS_EX_LAYERED ) > 0 IF !lActive SetWindowLongA(hWnd, GWL_EXSTYLE, nExStyle + WS_EX_LAYERED) ENDIF nTransparentValue := (1 - nPercent / 100) * 255 SetLayeredWindowAttributes(hWnd, 0, nTransparentValue, LWA_ALPHA) #endif return nil * --------- FUNCTION DC_ZoomTransparent( oDlg, nMode, nSeconds, nPercent ) LOCAL hWnd, i, nExStyle DEFAULT nMode := 0, ; nSeconds := 1, ; nPercent := 100 nSeconds := nSeconds * 100 hWnd := oDlg:getHWnd() nExStyle := GetWindowLongA(hWnd, GWL_EXSTYLE) IF nMode = 0 DC_SetWindowTransparency( hWnd, nPercent ) oDlg:show() FOR i := nPercent TO 0 STEP -5 Sleep( nSeconds / 20 ) DC_SetWindowTransparency( hWnd, i ) NEXT ELSEIF nMode = 1 DC_SetWindowTransparency( hWnd, 0 ) oDlg:show() FOR i := 0 TO nPercent STEP 5 Sleep( nSeconds / 20 ) DC_SetWindowTransparency( hWnd, i ) NEXT ENDIF SetWindowLongA(hWnd, GWL_EXSTYLE, nExStyle) return nil * ---------- FUNCTION DC_GetDropFileList( oData ) #if XPPVER > 1900000 IF oData:QueryGetFormat(XBPCLPBRD_FILELIST) == .T. RETURN oData:GetData( XBPCLPBRD_FILELIST ) ENDIF #endif RETURN nil * ------------- FUNCTION DC_Excel2WorkArea( cExcelFile ) LOCAL lStatus := .f., oExcel, cPath, oSheet, oBook, aValues, i, j, ; aStru, xValue #if XPPVER > 1900000 // Create the "Excel.Application" object oExcel := CreateObject("Excel.Application") IF Empty( oExcel ) DC_WinAlert( "Excel is not installed" ) RETURN .f. ENDIF #else DC_WinAlert('This feature is available in Xbase++ 1.9 and later only!') RETURN .f. #endif oExcel:Visible := .f. // Load a Workbook from an .XLS file // Get path from ini file IF !File(cExcelFile) DC_WinAlert( 'File does not exist:' + Chr(13) + cExcelFile ) RETURN lStatus ENDIF oBook := oExcel:Workbooks:Open(cExcelFile) oSheet := oBook:activeSheet aValues := oBook:workSheets(1):usedRange:value aStru := dbStruct() FOR i := 3 TO Len(aValues) dbAppend() FOR j := 1 TO Len(aValues[i]) xValue := aValues[i,j] IF Valtype(xValue) == 'N' .AND. aStru[j,2] == 'C' xValue := DC_XtoC(xValue) ELSEIF aStru[j,2] == 'D' .AND. Valtype(xValue) == 'N' xValue := Str(xValue) xValue := StoD(xValue) ELSEIF aStru[j,2] == 'D' .AND. Valtype(xValue) == 'C' xValue := Ctod(xValue) ELSEIF aStru[j,2] == 'C' .AND. Valtype(xValue) == 'D' xValue := DtoS(xValue) ENDIF FieldPut(j,xValue) NEXT NEXT oBook:close() oBook:destroy() // Quit Excel oExcel:Quit() oExcel:Destroy() RETURN lStatus * ------------- FUNCTION DC_Array2Excel( cExcelFile, aData, nOrientation, lDisplayAlerts, ; lVisible, lAutoFit, lTrimNilColumns, lCombineSheets, ; cPassword, lFreezeRow1, lCSVFallBack ) LOCAL oExcel, oBook, oSheet, i, j, oScrn, xData, nSheet, xValue, lStatus := .t., ; oProgress1, oProgress2, GetList[0], GetOptions, oDlg, nRowOffset, nLastRow, ; nColumns, nRows, cRange, oCells, cColId, nStartRow, bError DEFAULT nOrientation := xlLandscape, ; lDisplayAlerts := .f., ; lVisible := .f., ; lAutoFit := .t., ; cExcelFile := DC_Path(AppName(.t.)) + 'worksheet.xls', ; lTrimNilColumns := .f., ; lCombineSheets := .f., ; lFreezeRow1 := .f., ; lCSVFallBack := .t. #if XPPVER > 1900000 // Create the "Excel.Application" object IF '.CSV' $ Upper(cExcelFile) RETURN DC_Array2CSV(cExcelFile,aData) ENDIF 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 #else DC_WinAlert('This feature is available in Xbase++ 1.9 and later only!') RETURN .f. #endif IF lTrimNilColumns FOR i := 1 TO Len(aData) aData[i] := DC_ArrayTrim(aData[i]) NEXT ENDIF // Avoid message boxes such as "File already exists". Also, // ensure the Excel application is visible. oExcel:DisplayAlerts := lDisplayAlerts oExcel:visible := lVisible // Add a workbook to the Excel application. Query for // the active sheet (sheet-1) and set up page/paper // orientation. @ 0,0 DCSAY L('Creating Excel Worksheet: ') + cExcelFile SAYSIZE 0 @ 1,0 DCPROGRESS oProgress1 SIZE 50,1 ; TYPE XBPSTATIC_TYPE_TEXT ; COLOR GRA_CLR_CYAN, GRA_CLR_WHITE ; PERCENT ; PERCENTCOLOR GRA_CLR_RED ; RADIUS 20 ; OUTLINE ; DYNAMIC @ 3,0 DCPUSHBUTTON CAPTION L('Cancel') SIZE 9,1.2 ACTION {||lStatus:=.f.} DCGETOPTIONS ; NORESIZE ; ALWAYSONTOP ; _PIXEL .f. DCREAD GUI FIT TITLE L('Exporting to Excel') ; MODAL EXIT PARENT @oDlg OPTIONS GetOptions NOAUTORESTORE oBook := oExcel:workbooks:Add() nRowOffset := 0 nLastRow := 0 nStartRow := 1 FOR nSheet := 1 TO Len(aData) IF Empty(aData[nSheet]) LOOP ENDIF IF !lStatus EXIT ENDIF DC_GetProgress(oProgress1,nSheet,Len(aData)) IF nSheet > oBook:Sheets:Count IF !lCombineSheets oSheet := oBook:Sheets:Add() nStartRow := 1 ELSE oSheet := oBook:Sheets:Item(1) ENDIF ELSEIF lCombineSheets oSheet := oBook:Sheets:Item(1) ELSE oSheet := oBook:Sheets:Item(nSheet) nStartRow := 1 ENDIF oSheet:PageSetup:Orientation := nOrientation // Feed in the data from the table to the Cells // of the sheet. nColumns := Len(aData[nSheet,1]) nRows := Len(aData[nSheet]) cRange := 'A' + Alltrim(Str(nStartRow)) + ':' + Get_Excel_Column_ID(nColumns) + LTrim(Str(nRows+nStartRow-1)) FOR i := 1 TO nRows FOR j := 1 TO nColumns aData[nSheet,i,j] := Alltrim(DC_XtoC(aData[nSheet,i,j])) aData[nSheet,i,j] := Strtran(aData[nSheet,i,j],'=','') // aData[nSheet,i,j] := Strtran(aData[nSheet,i,j],'-','') NEXT NEXT oSheet:Range(cRange):Value := aData[nSheet] // Force a reformat for the size of the first column IF lAutoFit FOR i := 1 TO Len(aData[nSheet,1]) oSheet:Columns(i):AutoFit() NEXT ENDIF nStartRow += Len(aData[nSheet]) IF lFreezeRow1 oSheet:Range("A1:A1"):EntireRow:Font:Bold := .t. oSheet:Activate() oSheet:Application:ActiveWindow:SplitRow := 1 oSheet:Application:ActiveWindow:FreezePanes := .T. ENDIF NEXT IF Empty(DC_Path(cExcelFile)) cExcelFile := DC_Path(AppName(.t.)) + cExcelFile ENDIF cExcelFile := Strtran(cExcelFile,'\\','\',2) bError := ErrorBlock({|e|Break(e)}) BEGIN SEQUENCE oDlg:Destroy() // Save workbook as ordinary excel file. oBook:SaveAs(cExcelFile,xlWorkbookNormal,cPassword) END SEQUENCE ErrorBlock(bError) oBook:close() oBook:destroy() // Quit Excel oExcel:Quit() oExcel:Destroy() RETURN .t. * --------------- FUNCTION Get_Excel_Column_ID( i ) LOCAL cAlpha := "ABCDEFGHIJKLMNOPQRSTUVWXYZ", cLastRow := "" IF i > 26 cLastRow := Substr(cAlpha,Int(i/26),1) + Substr(cAlpha,Mod(i,26),1) ELSE cLastRow := Substr(cAlpha,i,1) ENDIF RETURN cLastRow * --------------- FUNCTION DC_ArrayTrim( aData ) LOCAL nColumns, i, j, lEmpty IF Empty(aData) RETURN aData ENDIF FOR i := 1 TO Len(aData) IF aData[i] == NIL ARemove(aData,i) i-- ENDIF NEXT IF Valtype(aData[1]) == 'A' nColumns := Len(aData[1]) ELSE RETURN aData ENDIF FOR i := 1 TO nColumns lEmpty := .t. FOR j := 1 TO Len(aData) IF !aData[j,i] == NIL lEmpty := .f. EXIT ENDIF NEXT IF lEmpty FOR j := 1 TO Len(aData) ARemove( aData[j], i) NEXT nColumns-- i := 0 ENDIF NEXT RETURN aData // This function was contributed by Brian Wolfsohn FUNCTION DC_JPGSize( cImage, nWidth, nHeight) local nHandle local nBytes,cBuffer,n1,n2,nSize,cMarker,nStart,nPos,i local cError:="" if (nHandle := fopen( cImage, FO_READ + FO_SHARED )) >0 //nSize:=int(fsize(nHandle)/2) nSize:=int(fsize(nHandle)) cBuffer:=space(nSize) nBytes:=fread(nHandle,@cBuffer,nSize) IF nBytes<>nSize cError:="error reading 1/2 file: "+cImage+CRLF fclose(nHandle) return(cError) ENDIF cMarker := CHR(255) + CHR(192) nStart:=1 i:=1 do while .t. if (nPos:=at(cMarker,cBuffer,nStart))>0 nStart:=nPos n1:=asc(subs(cBuffer,nStart+5,1)) n2:=asc(subs(cBuffer,nStart+6,1)) nHeight:= (n1*256) + n2 n1:=asc(subs(cBuffer,nStart+7,1)) n2:=asc(subs(cBuffer,nStart+8,1)) nWidth := (n1*256) + n2 nStart+=8 i++ else exit ENDIF ENDDO endif fclose(nHandle) return(cError) * --------------- CLASS DC_MapDirections EXPORTED: VAR vendor // Microsoft, Google, Yahoo, MapQuest VAR lat1 VAR lon1 VAR street1 VAR city1 VAR state1 VAR zip1 VAR country1 VAR title1 VAR lat2 VAR lon2 VAR street2 VAR city2 VAR state2 VAR zip2 VAR country2 VAR title2 VAR url VAR zoom VAR style VAR secure METHOD Init(), Navigate(), AsString() ENDCLASS * ------------- METHOD DC_MapDirections:init( cVendor ) ::vendor := cVendor ::lat1 := 0 ::lon1 := 0 ::street1 := '' ::city1 := '' ::state1 := '' ::zip1 := '' ::country1 := '' ::title1 := '' ::lat2 := 0 ::lon2 := 0 ::street2 := '' ::city2 := '' ::state2 := '' ::zip2 := '' ::country2 := '' ::title2 := '' ::style := 0 ::zoom := 5 // 1 - 19 ::secure := .f. DEFAULT ::vendor := 'GOOGLE' RETURN self * ------------- METHOD DC_MapDirections:asString() RETURN ::navigate(.f.) * ------------- METHOD DC_MapDirections:navigate( lSpawn ) LOCAL cStyle DEFAULT lSpawn := .t. IF Upper(::vendor) = 'MICROSOFT' .OR. Upper(::vendor) = 'MSN' IF ::style == 1 // map cStyle := 'r' ELSEIF ::style == 2 // satellite cStyle := 'a' ELSEIF ::style == 3 // hybrid cStyle := 'h' ELSE cStyle := 'r' ENDIF ::url := "http" + IIF(::secure,"s","") + "://maps.live.com/default.aspx?v=1&style=" + cStyle + '&' IF !Empty(::lat1) .AND. !Empty(::lon1) .AND. !Empty(::lat2) .AND. !Empty(::lon2) ::url += 'rtp=pos.' + Alltrim(Str(::lat1))+'_'+Alltrim(Str(::lon1)) IF !Empty(::title1) // ::title1 += ' ' + ::street1 + ' ' + ::city1 + ' ' + ::state1 + ' ' + ::zip1 ::url += '_' + ::title1 ENDIF ::url += '~pos.' + Alltrim(Str(::lat2))+'_'+Alltrim(Str(::lon2)) IF !Empty(::title2) // ::title2 += ' ' + ::street2 + ' ' + ::city2 + ' ' + ::state2 + ' ' + ::zip2 ::url += '_' + ::title2 ENDIF ::zoom := 0 ELSEIF !Empty(::lat1) .AND. !Empty(::lon1) ::url += '&cp='+Alltrim(Str(::lat1))+'~'+Alltrim(Str(::lon1)) ELSEIF !Empty(::street1) .AND. !Empty(::street2) ::url += 'rtp=adr.' + Alltrim(::street1)+','+Alltrim(::city1)+','+Alltrim(::state1)+','+Alltrim(::zip1) IF !Empty(::title1) // ::title1 += '_' + ::street1 + '_' + ::city1 + '_' + ::state1 + '_' + ::zip1 ::url += '_' + + Strtran(::title1,' ','_') ENDIF ::url += '~adr.' + Alltrim(::street2)+','+Alltrim(::city2)+','+Alltrim(::state2)+','+Alltrim(::zip2) IF !Empty(::title2) // ::title2 += '_' + ::street2 + '_' + ::city2 + '_' + ::state2 + '_' + ::zip2 ::url += '_' + Strtran(::title2,' ','_') + '_' ENDIF ELSEIF !Empty(::street1) ::url += "where1=" + ::street1 + ' ' + ::city1 + ' ' + ; ::state1 + ' ' + ::zip1 + ' ' + ::country1 ENDIF IF ::zoom > 0 ::url += '&lvl=' + Alltrim(Str(::zoom)) ENDIF ELSEIF Upper(::vendor) = 'GOOGLE' IF ::style == 1 // map cStyle := 'm' ELSEIF ::style == 2 // satellite cStyle := 'k' ELSEIF ::style == 3 // hybrid cStyle := 'h' ELSE cStyle := 'r' ENDIF ::url := "http" + IIF(::secure,"s","") + "://maps.google.com/maps?ie=UTF8&oe=UTF-8&hl=en&t=" + cStyle + '&' IF ::zoom > 0 ::url += 'z=' + Alltrim(Str(::zoom)) + '&' ENDIF IF !Empty(::lat1) .AND. !Empty(::lon1) .AND. !Empty(::lat2) .AND. !Empty(::lon2) ::url += 'q=' + Alltrim(Str(::lat1))+','+Alltrim(Str(::lon1)) IF !Empty(::title1) ::title1 += ' ' + ::street1 + ' ' + ::city1 + ' ' + ::state1 + ' ' + ::zip1 ::url += '+(' + ::title1 + ')' ENDIF ::url += '+to+' + Alltrim(Str(::lat2))+','+Alltrim(Str(::lon2)) IF !Empty(::title2) ::title2 += ' ' + ::street2 + ' ' + ::city2 + ' ' + ::state2 + ' ' + ::zip2 ::url += '+(' + ::title2 + ')' ENDIF ELSEIF !Empty(::lat1) .AND. !Empty(::lon1) ::url += 'q=' + Alltrim(Str(::lat1))+','+Alltrim(Str(::lon1)) IF !Empty(::title1) ::title1 += ' ' + ::street1 + ' ' + ::city1 + ' ' + ::state1 + ' ' + ::zip1 ::url += ' (' + ::title1 + ')' ENDIF ELSEIF !Empty(::street1) .AND. !Empty(::street2) ::url += 'q=' + ::street1 + ',' + ::city1 + ',' + ; ::state1 + ',' + ::zip1 + ',' + ::country1 + ' (' + ::title1 + ')' + '+to+' ::url += ::street2 + ',' + ::city2 + ',' + ; ::state2 + ',' + ::zip2 + ',' + ::country2 + ' (' + ::title2 + ')' ELSEIF !Empty(::street1) ::url += 'q=' + ::street1 + ',' + ::city1 + ',' + ; ::state1 + ',' + ::zip1 + ',' + ::country1 + ' (' + ::title1 + ')' ENDIF ELSEIF Upper(::vendor) = 'MAPQUEST' ::url := "http" + IIF(::secure,"s","") + "://www.mapquest.com/directions/main.adp?" IF !Empty(::street1) .AND. !Empty(::street2) ::url += '&1a=' + ::street1 + '&1c=' + ::city1 + '&1s=' + ; ::state1 + '&1z=' + ::zip1 + '&1y=' + ::country1 ::url += '&2a=' + ::street2 + '&2c=' + ::city2 + '&2s=' + ; ::state2 + '&2z=' + ::zip2 + '&2y=' + ::country2 ELSEIF !Empty(::street1) ::url += '1a=' + ::street1 + '&1c=' + ::city1 + '&1s=' + ; ::state1 + '&1z=' + ::zip1 + '&1y=' + ::country1 ELSEIF !Empty(::street2) ::url += '2a=' + ::street2 + '&2c=' + ::city2 + '&2s=' + ; ::state2 + '&2z=' + ::zip2 + '&2y=' + ::country2 ENDIF ELSEIF Upper(::vendor) = 'YAHOO' ::url := "http" + IIF(::secure,"s","") + "://maps.yahoo.com/dd?" IF !Empty(::street2) IF 'US' $ Strtran(::country2,'.','') .OR. Empty(::country2) ::country2 := 'US' ELSEIF 'CA' $ Strtran(::country2,'.','') ::country2 := 'CA' ENDIF ::url += 'taddr=' + ::street2 ::url += '&tcsz=' + ::city2 + '+' + ::state2 + '+' + ::zip2 ::url += '&tcountry=' + ::country2 ENDIF ENDIF ::url := Strtran(::url,' ','%20') // ::url := Strtran(::url,'~','%7c') ::url := Strtran(::url,Chr(13),'%0d') ::url := Strtran(::url,Chr(10),'%0a') IF lSpawn ShellOpenFile(::url) ENDIF RETURN ::url * -------------- FUNCTION DC_DbeType( cDbf ) LOCAL nHandle, cBuffer:=SPACE(1), nType, aRetVal, cDbe cDbf := IF(RAT(".",cDbf)==0,cDbf+".DBF",cDbf) cDbf := Upper(cDbf) IF !FILE(cDbf) RETURN({0,'File not found','???','???'}) ENDIF IF (nHandle:=Fopen(cDbf))<0 // file is in exclusive use at this time cDbe := DbeInfo(COMPONENT_DATA, DBE_NAME) IF Left(cDbe,3)=="FOX" aRetVal:={nType,'Foxbase','FOXCDX','CDX'} ELSE aRetVal:={nType,'Foxbase/Foxpro/dBaseIII/IV no memo','DBFNTX','NTX'} ENDIF FClose(nHandle) RETURN aRetVal ENDIF FSeek(nHandle,0,0) // Move pointer to first byte FRead(nHandle,@cBuffer,1) FClose(nHandle) nType := Asc(cBuffer) RETURN _GetFileType(nType,cDbf) * ---------------- STATIC FUNCTION _GetFileType(nType,cDbf) LOCAL cDbfType, cDriver, cInxExt, lIsCdx lIsCdx := File(Strtran(cDbf,'.DBF','.CDX')) DO CASE CASE nType=2 cDbfType='Foxbase' cDriver:="FOXCDX" cInxExt:="CDX" CASE nType=3 cDbfType='Foxpro/dBaseIII/Ads/Clipper no memo' IF lIsCdx cDriver := 'DBFCDX/ADSDBE' cInxExt := 'CDX' ELSE cDriver:="DBFNTX/ADSDBE" cInxExt:="NTX" ENDIF CASE nType=48 cDbfType='Visual Foxpro/Ads' cDriver:="FOXCDX/ADSDBE" cInxExt:="CDX" CASE nType=49 cDbfType='Visual Foxpro AutoIncr' cDriver:="FOXCDX" cInxExt:="CDX" CASE nType=67 cDbfType='dBase IV SQL table no memo' CASE nType=99 cDbfType='dBase IV SQL system file no memo' CASE nType=131 cDbfType='FoxPro/dBaseIII/Ads/Clipper with memo' IF lIsCdx cDriver := 'DBFCDX/ADSDBE' cInxExt := 'CDX' ELSE cDriver:="DBFNTX/ADSDBE" cInxExt:="NTX" ENDIF CASE nType=139 cDbfType='dBaseIV with memo' cDriver:="DBFNTX" cInxExt:="NTX" CASE nType=203 cDbfType='dBaseIV SQL table with memo' CASE nType=245 cDbfType='Foxpro 2.x/Ads with memo' cDriver:="FOXCDX/ADSDBE" cInxExt:="CDX" CASE nType=251 cDbfType='Foxbase' cDriver:="FOXCDX" cInxExt:="CDX" OTHERWISE cDbfType='Unknown or invalid type' ENDCASE RETURN({nType,cDbfType,cDriver,cInxExt}) * --------------- FUNCTION DC_VarGroup( cName, aVars ) LOCAL oClass, nAttr, aIvar, xRet, oVars, oVarsInstance, i, ; aVars2 := {} FOR i := 1 TO Len(aVars) AAdd(aVars2,aVars[i,1]) NEXT DEFAULT cName := '1' cName := 'VARGROUP_' + cName oClass := ClassObject( cName ) IF oClass <> NIL RETURN oClass // Class already exists ENDIF nAttr := CLASS_EXPORTED + VAR_INSTANCE aIVar := AEval( aVars2, {|a| a := {a, nAttr} } ,,, .T.) oVars := ClassCreate( cName,, aIVar ) oVarsInstance := oVars:new() FOR i := 1 TO Len(aVars) oVarsInstance:&(aVars[i,1]) := aVars[i,2] NEXT RETURN oVarsInstance * ------------ *FUNCTION DC_VarGroupOld( cName, aVars ) *LOCAL oClass, nAttr, aIvar *DEFAULT cName := '1' *oClass := ClassObject( 'VARGROUP_' + cName ) *IF oClass <> NIL * RETURN oClass // Class already exists *ENDIF *nAttr := CLASS_EXPORTED + VAR_INSTANCE *aIVar := AEval( aVars, {|a| a := {a, nAttr} } ,,, .T.) *RETURN ClassCreate( 'VARGROUP_' + cName,, aIVar ) * -------------- CLASS DC_DbNotify EXPORTED: VAR alias VAR saveRecordObject VAR saveRecordNumber VAR saveOrder VAR saveDeleted VAR saveIsDeleted VAR saveScopeTop VAR saveScopeBottom VAR saveFilter VAR eventList VAR onMoveDone VAR onMoveProlog VAR onGoTop VAR onGoBottom VAR onTableUpdate VAR onTableAppend VAR onTableDeleted VAR onCloseRequest VAR onBulkRequest VAR onBulkComplete VAR onOrderChanged VAR onOrderReversed VAR onRowsetChanged VAR data VAR logFile VAR log2Array VAR browseObject VAR userColumns VAR writeBlock * ---------- INLINE METHOD init ::userColumns := {} ::log2Array := .f. ::data := {} ::alias := Alias() ::eventList := {} ::saveRecordObject := DC_DbRecord():new() ::saveRecordNumber := RecNo() ::saveOrder := OrdSetFocus() ::saveDeleted := Deleted() ::saveFilter := dbFilter() ::saveScopeTop := DC_SetScope(0) ::saveScopeBottom := DC_SetScope(1) ::saveIsDeleted := Set(_SET_DELETED) DC_DbScatter(::saveRecordObject) dbRegisterClient(self) RETURN self * ---------- INLINE METHOD destroy IF Select(::alias) > 0 (::alias)->(dbDeRegisterClient(self)) ENDIF RETURN self * ---------- INLINE METHOD suspend( lChildAreas ) DEFAULT lChildAreas := .f. IF Select(::alias) > 0 (::alias)->(dbSuspendNotifications(lChildAreas)) ENDIF RETURN self * ---------- INLINE METHOD resume( lChildAreas ) DEFAULT lChildAreas := .f. IF Select(::alias) > 0 (::alias)->(dbResumeNotifications(lChildAreas)) ENDIF RETURN self * ---------- INLINE METHOD notify( nEvent, mp1, mp2 ) LOCAL nFound := AScan( ::eventList, {|a|a[1]==mp1}) IF Empty(::alias) .OR. Select(::alias) == 0 RETURN self ENDIF ::suspend() IF mp1 == DBO_MOVE_DONE .AND. !Empty(::onMoveDone) Eval(::onMoveDone, self) ELSEIF mp1 == DBO_TABLE_UPDATE .AND. !Empty(::onTableUpdate) Eval(::onTableUpdate, self) ELSEIF mp1 == DBO_TABLE_DELETED .AND. !Empty(::onTableDeleted) Eval(::onTableDeleted, self) ELSEIF mp1 == DBO_TABLE_APPEND .AND. !Empty(::onTableAppend) Eval(::onTableAppend, self) ELSEIF mp1 == DBO_ORDER_CHANGED .AND. !Empty(::onOrderChanged) Eval(::onOrderChanged, self) ELSEIF mp1 == DBO_GOTOP .AND. !Empty(::onGoTop) Eval(::onGoTop, self) ELSEIF mp1 == DBO_GOBOTTOM .AND. !Empty(::onGoBottom) Eval(::onGoBottom, self) ELSEIF mp1 == DBO_MOVE_PROLOG .AND. !Empty(::onMoveProlog) Eval(::onMoveProlog, self) ELSEIF mp1 == DBO_CLOSE_REQUEST .AND. !Empty(::onCloseRequest) Eval(::onCloseRequest, self) ELSEIF mp1 == DBO_BULK_REQUEST .AND. !Empty(::onBulkRequest) Eval(::onBulkRequest, self) ELSEIF mp1 == DBO_BULK_COMPLETE .AND. !Empty(::onBulkComplete) Eval(::onBulkComplete, self) ELSEIF mp1 == DBO_ROWSET_CHANGED .AND. !Empty(::onRowsetChanged) Eval(::onRowsetChanged, self) ELSEIF mp1 == DBO_ORDER_REVERSED .AND. !Empty(::onOrderReversed) Eval(::onOrderReversed, self) ENDIF IF nFound > 0 Eval(::eventList[nFound,2],self) ENDIF IF mp1 $ { DBO_GOBOTTOM, DBO_GOTOP, DBO_MOVE_DONE } (::alias)->(DC_DbScatter(::saveRecordObject)) ::saveRecordNumber := (::alias)->(RecNo()) ::saveDeleted := (::alias)->(Deleted()) ELSEIF mp1 $ { DBO_ORDER_CHANGED } ::saveOrder := (::alias)->(OrdSetFocus()) ENDIF ::resume() RETURN self * ---------- INLINE METHOD onEvent( nEvent, bBlock ) AAdd(::eventList, { nEvent, bBlock }) RETURN self * ---------- INLINE METHOD processEvent( mp1, aUpdateFields ) LOCAL i, j, aFields, oRecord, cEvent, cDesc IF mp1 == DBO_MOVE_DONE cEvent := 'OnMoveDone' cDesc := '(Record) Is: ' + Alltrim(Str((::alias)->(RecNo()))) + ; ' Was: ' + Alltrim(Str(::saveRecordNumber)) IF ::log2Array AAdd(::data, { cEvent, ::alias, cDesc, Date(), Time() }) FOR j := 1 TO Len(::userColumns) AAdd(Atail(::data),Eval(::userColumns[j,2])) NEXT ENDIF ::write2Log( cEvent, cDesc ) ::writeCustom( cEvent, cDesc ) ELSEIF mp1 == DBO_GOTOP cEvent := 'OnGoTop' cDesc := '(Record) Is: ' + Alltrim(Str((::alias)->(RecNo()))) + ; ' Was: ' + Alltrim(Str(::saveRecordNumber)) IF ::log2Array AAdd(::data, { cEvent, ::alias, cDesc, Date(), Time() }) FOR j := 1 TO Len(::userColumns) AAdd(Atail(::data),Eval(::userColumns[j,2])) NEXT ENDIF ::write2Log( cEvent, cDesc ) ::writeCustom( cEvent, cDesc ) ELSEIF mp1 == DBO_GOBOTTOM cEvent := 'OnGoBottom' cDesc := '(Record) Is: ' + Alltrim(Str((::alias)->(RecNo()))) + ; ' Was: ' + Alltrim(Str(::saveRecordNumber)) IF ::log2Array AAdd(::data, { cEvent, ::alias, cDesc, Date(), Time() }) FOR j := 1 TO Len(::userColumns) AAdd(Atail(::data),Eval(::userColumns[j,2])) NEXT ENDIF ::write2Log( cEvent, cDesc ) ::writeCustom( cEvent, cDesc ) ELSEIF mp1 == DBO_BULK_REQUEST cEvent := 'OnBulkRequest' cDesc := 'Bulk Operation Started' IF ::log2Array AAdd(::data, { cEvent, ::alias, cDesc, Date(), Time() }) FOR j := 1 TO Len(::userColumns) AAdd(Atail(::data),Eval(::userColumns[j,2])) NEXT ENDIF ::write2Log( cEvent, cDesc ) ::writeCustom( cEvent, cDesc ) ELSEIF mp1 == DBO_BULK_COMPLETE cEvent := 'OnBulkComplete' cDesc := 'Bulk Operation Completed' IF ::log2Array AAdd(::data, { cEvent, ::alias, cDesc, Date(), Time() }) FOR j := 1 TO Len(::userColumns) AAdd(Atail(::data),Eval(::userColumns[j,2])) NEXT ENDIF ::write2Log( cEvent, cDesc ) ::writeCustom( cEvent, cDesc ) ELSEIF mp1 == DBO_CLOSE_REQUEST cEvent := 'OnCloseRequest' cDesc := 'Work Area Closed' IF ::log2Array AAdd(::data, { cEvent, ::alias, cDesc, Date(), Time() }) FOR j := 1 TO Len(::userColumns) AAdd(Atail(::data),Eval(::userColumns[j,2])) NEXT ENDIF ::write2Log( cEvent, cDesc ) ::writeCustom( cEvent, cDesc ) ELSEIF mp1 == DBO_TABLE_APPEND cEvent := 'OnTableAppend' cDesc := '(Record) Is: ' + Alltrim(Str((::alias)->(RecNo()))) + ; ' Was: ' + Alltrim(Str(::saveRecordNumber)) IF ::log2Array AAdd(::data, { cEvent, ::alias, cDesc, Date(), Time() }) FOR j := 1 TO Len(::userColumns) AAdd(Atail(::data),Eval(::userColumns[j,2])) NEXT ENDIF ::write2Log( cEvent, cDesc ) ::writeCustom( cEvent, cDesc ) ELSEIF mp1 == DBO_ORDER_CHANGED cEvent := 'OnOrderChanged' cDesc := '(Order) Is: ' + CheckEmpty((::alias)->(OrdSetFocus())) + ' Was: ' + CheckEmpty(::saveOrder) IF ::log2Array AAdd(::data, { cEvent, ::alias, cDesc, Date(), Time() }) FOR j := 1 TO Len(::userColumns) AAdd(Atail(::data),Eval(::userColumns[j,2])) NEXT ENDIF ::write2Log( cEvent, cDesc ) ::writeCustom( cEvent, cDesc ) ELSEIF mp1 == DBO_ORDER_REVERSED cEvent := 'OnOrderReversed' cDesc := '(Order) Is: ' + (::alias)->(OrdSetFocus()) + ' Was: ' + ::saveOrder IF ::log2Array AAdd(::data, { cEvent, ::alias, cDesc, Date(), Time() }) FOR j := 1 TO Len(::userColumns) AAdd(Atail(::data),Eval(::userColumns[j,2])) NEXT ENDIF ::write2Log( cEvent, cDesc ) ::writeCustom( cEvent, cDesc ) ELSEIF mp1 == DBO_ROWSET_CHANGED cEvent := 'OnRowsetChanged' cDesc := '' IF !::saveFilter == (::alias)->(dbFilter()) cDesc += '(Filter) Is: ' + CheckEmpty((::alias)->(dbFilter())) + ' Was: ' + CheckEmpty(::saveFilter) + ' ' ENDIF IF !::saveScopeTop == (::alias)->(DC_SetScope(0)) cDesc += '(Scope Top) Is: ' + CheckEmpty(DC_XtoC((::alias)->(DC_SetScope(0)))) + ; ' Was: ' + CheckEmpty(DC_XtoC(::saveScopeTop)) ENDIF IF !::saveScopeBottom == (::alias)->(DC_SetScope(1)) cDesc += '(Scope Bottom) Is: ' + CheckEmpty(DC_XtoC((::alias)->(DC_SetScope(1)))) + ' Was: ' + CheckEmpty(DC_XtoC(::saveScopeBottom)) ENDIF IF !::saveIsDeleted == Set(_SET_DELETED) cDesc += '(SET DELETED) Is: ' + IIF(Set(_SET_DELETED),'ON','OFF') ENDIF IF ::log2Array AAdd(::data, { cEvent, ::alias, cDesc, Date(), Time() }) FOR j := 1 TO Len(::userColumns) AAdd(Atail(::data),Eval(::userColumns[j,2])) NEXT ENDIF ::saveFilter := (::alias)->(DbFilter()) ::saveScopeTop := (::alias)->(DC_SetScope(0)) ::saveScopeBottom := (::alias)->(DC_SetScope(1)) ::saveIsDeleted := Set(_SET_DELETED) ::write2Log( cEvent, cDesc ) ::writeCustom( cEvent, cDesc ) ELSEIF mp1 == DBO_TABLE_UPDATE .AND. (::alias)->(RecNo()) == ::saveRecordNumber cEvent := 'OnTableUpdate' oRecord := (::alias)->(DC_DbRecord():new()) aFields := {} (::alias)->(DC_DbScatter(oRecord)) (::alias)->(DC_DbRecordCompare( oRecord, ::saveRecordObject, aFields )) IF !Empty(aFields) FOR i := 1 TO Len(aFields) IF !Empty(aUpdateFields) .AND. Ascan(aUpdateFields,aFields[i,1]) == 0 LOOP ENDIF cDesc := 'Record #' + Alltrim(Str((::alias)->(RecNo()))) + ; ' Field: ' + aFields[i,1] + ; ' Is: ' + CheckEmpty(aFields[i,2]) + ; ' Was: ' + CheckEmpty(aFields[i,3]) ::write2Log( cEvent, cDesc, aFields[i,1] ) ::writeCustom( cEvent, cDesc, aFields[i,1] ) IF ::log2Array AAdd( ::data, { cEvent, ::alias, cDesc, Date(), Time() } ) FOR j := 1 TO Len(::userColumns) AAdd(Atail(::data),Eval(::userColumns[j,2])) NEXT ENDIF NEXT ENDIF IF (::alias)->(Deleted()) # ::saveDeleted .AND. ::saveRecordNumber == (::alias)->(RecNo()) cEvent := 'OnTableDeleted' cDesc := 'Record #' + Alltrim(Str((::alias)->(RecNo()))) + ' DELETED FLAG changed to: ' + IIF((::alias)->(Deleted()),'ON','OFF') IF ::log2Array AAdd(::data, { cEvent, ::alias, cDesc, Date(), Time() }) FOR j := 1 TO Len(::userColumns) AAdd(Atail(::data),Eval(::userColumns[j,2])) NEXT ENDIF ::write2Log( cEvent, cDesc ) ::writeCustom( cEvent, cDesc ) ENDIF ::saveRecordObject := oRecord ENDIF IF Valtype(::browseObject) == 'O' .AND. !Empty(::data) ::browseObject:goBottom() ::browseObject:forceStable() ::browseObject:refreshAll() ENDIF RETURN nil * ---------- INLINE METHOD SetNotifications( aList, aFields ) IF DBO_MOVE_DONE $ aList ::onMoveDone := {||::processEvent(DBO_MOVE_DONE)} ENDIF IF DBO_GOTOP $ aList ::onGoTop := {||::processEvent(DBO_GOTOP)} ENDIF IF DBO_GOBOTTOM $ aList ::onGoBottom := {||::processEvent(DBO_GOBOTTOM)} ENDIF IF DBO_TABLE_UPDATE $ aList .OR. DBO_TABLE_DELETED $ aList ::onTableUpdate := {||::processEvent(DBO_TABLE_UPDATE,aFields)} ENDIF IF DBO_TABLE_APPEND $ aList ::onTableAppend := {||::processEvent(DBO_TABLE_APPEND)} ENDIF IF DBO_ORDER_CHANGED $ aList ::onOrderChanged := {||::processEvent(DBO_ORDER_CHANGED)} ENDIF IF DBO_ORDER_REVERSED $ aList ::onOrderReversed := {||::processEvent(DBO_ORDER_REVERSED)} ENDIF IF DBO_ROWSET_CHANGED $ aList ::onRowsetChanged := {||::processEvent(DBO_ROWSET_CHANGED)} ENDIF IF DBO_MOVE_PROLOG $ aList ::onMoveProlog := {||::processEvent(DBO_MOVE_PROLOG)} ENDIF IF DBO_CLOSE_REQUEST $ aList ::onCloseRequest := {||::processEvent(DBO_CLOSE_REQUEST)} ENDIF IF DBO_BULK_REQUEST $ aList ::onBulkRequest := {||::processEvent(DBO_BULK_REQUEST)} ENDIF IF DBO_BULK_COMPLETE $ aList ::onBulkComplete := {||::processEvent(DBO_BULK_COMPLETE)} ENDIF RETURN nil * ---------- INLINE METHOD WriteCustom( cNotifyName, cDescription, cFieldName ) IF Valtype(::writeBlock) == 'B' Eval(::writeBlock, cNotifyName, ::alias, cDescription, self, cFieldName ) ENDIF RETURN self * ---------- INLINE METHOD Write2Log( cNotifyName, cDescription ) LOCAL nHandle, j, cUserColumns := '' IF !Empty(::logFile) IF !Fexists(::logFile) nHandle := FCreate(::logFile) FOR j := 1 TO Len(::userColumns) cUserColumns += Pad(::userColumns[j,1],50) NEXT FWrite( nHandle, Pad('Notification',16) + ; Pad('Alias',11) + ; Pad('Description',101) + ; Pad('Date',11) + ; Pad('Time',9) + ; cUserColumns + ; CRLF + CRLF ) ELSE nHandle := Fopen(::logFile, FO_WRITE + FO_SHARED) ENDIF IF nHandle > 0 cUserColumns := '' FOR j := 1 TO Len(::userColumns) cUserColumns += Pad(DC_XtoC(Eval(::userColumns[j,2])),50) NEXT FSeek( nHandle, 0, FS_END ) Fwrite( nHandle, Pad(cNotifyName,16) + ; Pad(::alias,11) + ; Pad(cDescription,101) + ; Dtoc(Date()) + ' ' + ; Time() + ' ' + ; cUserColumns + ; CRLF ) FClose(nHandle) ENDIF ENDIF RETURN self * ---------- INLINE METHOD AddUserColumn( aColumn ) AAdd( ::userColumns, aColumn ) RETURN self ENDCLASS * ------------ FUNCTION DC_WtfNotify( nType, aEvents, cAlias, aFields, nFGColor, nBGColor, nOutput, aVars, aVarsDesc ) STATIC aNotify[0] LOCAL oNotify, nFound DEFAULT cAlias := Alias(), ; nOutput := 1 IF nType == 1 // create IF Empty(aEvents) aEvents := { DBO_TABLE_UPDATE, DBO_TABLE_APPEND, DBO_TABLE_DELETED } ENDIF oNotify := (cAlias)->(DC_DbNotify():new()) oNotify:setNotifications( aEvents, aFields ) IF nOutput == 1 oNotify:writeBlock := {|Event,Alias,Comments|(wtf Event,Alias,Comments COLOR nFGColor, nBGColor), ; _wtf( aVars, aVarsDesc, nFGColor, nBGColor )} ELSE oNotify:writeBlock := {|Event,Alias,Comments| ; DC_DebugLogOut( {'Event:',Event} ), ; DC_DebugLogOut( {'Alias:',Alias} ), ; DC_DebugLogOut( {'Comments:',Comments} ), ; _wtl( aVars, aVarsDesc) } ENDIF AAdd(aNotify,oNotify) ELSEIF nType == 2 // suspend nFound := AScan(aNotify,{|o|o:alias==cAlias}) IF nFound > 0 oNotify := aNotify[nFound] oNotify:suspend() ENDIF ELSEIF nType == 3 // resume nFound := AScan(aNotify,{|o|o:alias==cAlias}) IF nFound > 0 oNotify := aNotify[nFound] oNotify:resume() ENDIF ELSEIF nType == 4 // destroy nFound := AScan(aNotify,{|o|o:alias==cAlias}) IF nFound > 0 oNotify := aNotify[nFound] oNotify:destroy() ARemove(aNotify,nFound) ENDIF ENDIF RETURN Nil * ----------- FUNCTION DC_DbNotifyBlock( bEval ) STATIC sbEval IF Valtype(bEval) == 'B' sbEval := bEval ENDIF RETURN sbEval * ----------- STATIC FUNCTION CheckEmpty( cString ) IF Empty(cString) RETURN '' ENDIF RETURN cString * ----------- STATIC FUNCTION _wtf( aVars, aVarsDesc, nFGColor, nBGColor ) LOCAL i IF !Empty(aVars) FOR i := 1 TO Len(aVars) DC_DebugBrowse( {Eval(aVars[i])}, {aVarsDesc[i]},, nFGColor, nBGColor ) NEXT ENDIF RETURN nil * ----------- STATIC FUNCTION _wtl( aVars, aVarsDesc ) LOCAL i IF !Empty(aVars) FOR i := 1 TO Len(aVars) DC_DebugLogOut( { aVarsDesc[i]+":", Eval(aVars[i]) } ) NEXT ENDIF RETURN nil * ----------- FUNCTION DC_DebugLogBrowse() LOCAL aDebug[0], nHandle, aTokens, aTokens2, aTokens3, ; aLine[0], i, cLine, GetList[0], oBrowse, GetOptions, ; cString nHandle := DC_TxtOpen( DC_DebugLogFile(), FO_READWRITE ) FSeek( nHandle, 0, FS_END ) FWrite( nHandle, Chr(13)+Chr(10)) FSeek( nHandle, 0, FS_SET ) DO WHILE !DC_TxtEof(nHandle) cLine := DC_TxtLine( nHandle ) DC_TxtSkip(nHandle,1) IF Empty(cLine) LOOP ENDIF cLine := Strtran( cLine, ' <- Called From: ',Chr(255)) IF Left(cLine,1) == ' ' cLine := Substr(cLine,2) ENDIF ASize( aLine, 0 ) aTokens := DC_TokenArray( cLine, Chr(255)) aTokens2 := DC_TokenArray( aTokens[1], ': ') cString := Substr(aTokens[1],1,At(':',aTokens[1])) AAdd( aLine, cString ) cString := Substr(aTokens[1],At(':',aTokens[1])+1) AAdd( aLine, cString ) aTokens3 := DC_TokenArray( aTokens[2], ', ') FOR i := 1 TO Len(aTokens3) IF !Empty(aTokens3[i]) AAdd( aLine, aTokens3[i] ) ENDIF NEXT AAdd( aDebug, AClone( aLine )) ENDDO DC_TxtClose(nHandle) @ 0,0 DCBROWSE oBrowse SIZE 100,20 PRESENTATION LC_BrowPres() ; DATA aDebug RESIZE DCGUI_RESIZE_RESIZEONLY ; FONT '9.Lucida Console' OPTIMIZE DCBROWSECOL ELEMENT 1 HEADER L('Expression') WIDTH 15 PARENT oBrowse ; SORT {||ASort(aDebug,,,{|a,b|a[1] 0 nOccur++ ENDDO RETURN nOccur * ------------- FUNCTION DC_Excel2Array( cExcelFile, bEval ) LOCAL oExcel, oBook, aValues #if XPPVER > 1900000 // Create the "Excel.Application" object oExcel := CreateObject("Excel.Application") IF Empty( oExcel ) DC_WinAlert( "Excel is not installed" ) RETURN nil ENDIF #else DC_WinAlert('This feature is available in Xbase++ 1.9 and later only!') RETURN nil #endif oExcel:Visible := .f. // Load a Workbook from an .XLS file IF !FExists(cExcelFile) DC_WinAlert( 'File does not exist:' + Chr(13) + cExcelFile ) RETURN nil ENDIF oBook := oExcel:Workbooks:Open(cExcelFile) IF Valtype(bEval) == 'B' Eval( bEval, oExcel, oBook ) ENDIF aValues := oBook:workSheets(1):usedRange:value oBook:close() oBook:destroy() // Quit Excel oExcel:Quit() oExcel:Destroy() RETURN aValues * ------------- FUNCTION DC_SetCPU( nCPU, cFile ) LOCAL nHnd := 0 // file handle LOCAL nLast := 1 // last CPU used LOCAL aSet := {} // processor array LOCAL nSet // default new bitmask LOCAL i // counter DEFAULT cFile := GetEnv('WINDIR') + '\Temp\SetCpu.Smp' DEFAULT nCPU := 15 // 15 = 4 CPUs // 7 = 3 CPUs // 3 = 2 CPUs // 1 = 1 CPU nSet := nCPU FOR i := 1 to 32 // count processors IF nCPU[i] // processor present aadd(aSet, i) // add processor id to list ENDIF NEXT IF len(aSet) > 1 // more then one processor IF Fexists(cFile) nHnd := Fopen(cFile, FO_READWRITE) IF nHnd > 0 // file is open nLast := Val(Freadstr(nHnd, 2))+ 1 // get last processor IF nLast > len(aSet) // check against available processors nLast := 1 // recycle number ENDIF Fseek(nHnd, 0, FS_SET) // place pointer at bof Fwrite(nHnd, StrZero(nLast, 2)) // write to file Fclose(nHnd) // close file ENDIF ELSE // first time round nHnd := Fcreate(cFile, FC_NORMAL) IF nHnd > 0 // file is created and open Fwrite(nHnd, StrZero(nLast, 2)) // write to file Fclose(nHnd) // close file ENDIF ENDIF FOR i := 1 to 32 // create new bitmask nSet[i] := (i = aSet[nLast]) // switch on appropriate bit NEXT DllCall("xpprt1.dll", DLL_CDECL, "_sysSetCPU", nSet) ENDIF RETURN nil * --------------- FUNCTION DC_WorkArea2CSV( cFileName, aFields, cDateFormat, aFieldEvals ) LOCAL nRow, aStru, i, cHeader, cCSVFile, nHandle, ; cFieldName, cFieldType, nFieldLen, cLine, ; xValue, GetList[0], GetOptions, oDlg, nCount := 0, ; cDbfName, nKeyCount, oProgress, lStatus := .t., ; aStru2, nFound, xFieldValue, nFieldBlock DEFAULT aFieldEvals := {}, ; cDateFormat := 'mm/dd/yyyy', ; cFileName := DC_Path(AppName(.t.)) + 'workarea.csv' // aFieldEvals -> {{FIELDNAME,CodeBlock},....} Code blocks to evaluate for specific fields cDbfName := dbInfo(DBO_FILENAME) IF cDbfName = '' nKeyCount := RecCount() ELSE nKeyCount := DC_KeyCount() ENDIF @ 0,0 DCSAY L('Creating CSV File: ') + cFileName SAYSIZE 0 @ 1,0 DCPROGRESS oProgress SIZE 50,1 ; TYPE XBPSTATIC_TYPE_TEXT ; COLOR GRA_CLR_CYAN, GRA_CLR_WHITE ; PERCENT ; PERCENTCOLOR GRA_CLR_RED ; RADIUS 20 ; OUTLINE ; DYNAMIC ; EVERY Int(nKeyCount/100) @ 3,0 DCPUSHBUTTON CAPTION L('Cancel') SIZE 9,1.2 ACTION {||lStatus:=.f.} DCGETOPTIONS NORESIZE ALWAYSONTOP _PIXEL .f. DCREAD GUI FIT TITLE L('Exporting to CSV') ; MODAL EXIT PARENT @oDlg OPTIONS GetOptions NOAUTORESTORE nHandle := FCreate(cFileName) IF nHandle <= 0 RETURN .f. ENDIF DC_DbGoTop() aStru := dbStruct() IF Valtype(aFields) == 'A' aStru2 := AClone(aStru) aStru := Array(0) FOR i := 1 TO Len(aFields) cFieldName := Upper(Alltrim(aFields[i])) nFound := AScan(aStru2,{|a|Upper(a[1])==cFieldName}) IF nFound > 0 AAdd( aStru, aStru2[nFound] ) ENDIF NEXT ENDIF // write the header line cLine := '' FOR i := 1 TO Len(aStru) cLine += aStru[i,1] + IIF(i 0 xFieldValue := Eval(aFieldEvals[nFieldBlock,2],xFieldValue) ENDIF IF Valtype(xFieldValue) $ 'CM' cLine += '="' + xFieldValue + '"' ELSEIF Valtype(xFieldValue) = 'L' cLine += IIF(xFieldValue,'Y','N') ELSEIF Valtype(xFieldValue) = 'D' cLine += Transform(xFieldValue,cDateFormat) ELSE cLine += DC_XtoC(xFieldValue) ENDIF IF i < Len(aStru) cLine += ',' ENDIF NEXT FWrite( nHandle, cLine + CRLF ) DC_DbSkip(1) ENDDO oDlg:destroy() FClose(nHandle) RETURN .t. * -------------- FUNCTION DC_Array2CSV( cFileName, aData, aHeader ) LOCAL nHandle, i, j, cLine IF '.XLS' $ Upper(cFileName) cFileName := Strtran(cFileName,'.xls','.csv') cFileName := Strtran(cFileName,'.XLS','.CSV') ENDIF nHandle := FCreate(cFileName) IF nHandle <= 0 RETURN .f. ENDIF IF Valtype(aHeader) == 'A' cLine := '' FOR i := 1 TO Len(aHeader) cLine += aHeader[i] + IIF(i 0 SELECT Priz_per;SET ORDER TO 5;T = DBSEEK(STR(M_kpp_old,4)) IF T M_kpp_new = FIELDGET(12) AADD(A_kpp,M_kpp_new) ENDIF ENDIF ENDIF NEXT ASORT(A_kpp) ****** Присвоение новых ссылок на первичные признаки ****** в обобщенном пр. SELECT Priz_ob FOR i=1 TO LEN(A_kpp) FIELDPUT(2+i,A_kpp[i]) NEXT SET ORDER TO 1 DBSKIP(1) ENDDO CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Priz_Ob INDEX Prob_kod EXCLUSIVE NEW USE Priz_per INDEX Prpe_kod,Prpe_nam,Prpe_ini,Prpe_sii,Prpe_kld,Prpe_kop EXCLUSIVE NEW N_Pr = RECCOUNT() SELECT Priz_per;SET ORDER TO 3;DBGOTOP() ********* Перекодирование классов распознавания CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Object EXCLUSIVE NEW *GenNtxObj(.F.) // Заменить на переинд. в Aidos-X CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Object INDEX Obj_kod,Obj_name,Obj_prp,Obj_Ini EXCLUSIVE NEW SELECT Object;SET ORDER TO 1;DBGOTOP() N_Obj = RECCOUNT() A_KodOld := {} A_KodNew := {} j=0 DBGOTOP() DO WHILE .NOT. EOF() FIELDPUT(3,Kod) FIELDPUT(1,++j) AADD(A_KodOld,Kod_Old) AADD(A_KodNew,Kod) DBSKIP(1) ENDDO ********* Перекодирование БД ObInfZag.dbf и ObInfKpr.dbf CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE ObInfzag INDEX Oiza_ist EXCLUSIVE NEW USE ObInfkpr INDEX OIkpr_is EXCLUSIVE NEW SELECT ObInfZag;DBGOTOP() DO WHILE .NOT. EOF() ***** Взять старые коды из анкеты (только не нули) Ar := {} FOR j=1 TO FCOUNT()-6 Kobj = FIELDGET(2+j) IF Kobj > 0 AADD(Ar,Kobj) ENDIF NEXT ***** Перекодирование LenAr = LEN(Ar) IF LenAr > 0 // Перекодировать, если коды есть FOR j=1 TO LenAr p = ASCAN(A_KodOld,Ar[j]) IF p > 0 Ar[j] = A_KodNew[p] ELSE Ar[j] = 0 ENDIF NEXT ASORT(Ar) ***** Записать новые коды в анкету ***** убирая нули спереди и записывая сзади Arn := {} FOR j=1 TO LenAr IF Ar[j] > 0 AADD(Arn,Ar[j]) // Убрать нули спереди ENDIF NEXT LenArn = LEN(Arn) FOR j=1 TO FCOUNT()-6 IF j <= LenArn FIELDPUT(2+j,Arn[j]) // Записать код в анкету ELSE FIELDPUT(2+j,0) // Записать нули до конца ENDIF NEXT ENDIF DBSKIP(1) ENDDO RETURN NIL ****************************************************************************** ******** Эксперимент по продолжению цикла или выходу из него по нажатию кнопки ****************************************************************************** FUNCTION Push_DoWhile() LOCAL GetList[0], lProcessing := .f., oStatus @ 0,0 DCPUSHBUTTON CAPTION L('Start Process') SIZE 20,1.5 ; ACTION {||ProcessLoop(@lProcessing,GetList,oStatus)} ; WHEN {||!lProcessing} @ 2,0 DCPUSHBUTTON CAPTION L('End Process') SIZE 20,1.5 ; ACTION {||lProcessing := .f.} ; WHEN {||lProcessing} @ 4,0 DCSAY L(' ') SAYSIZE 20 COLOR GRA_CLR_BLUE FONT '10.Arial Bold' OBJECT oStatus DCREAD GUI FIT TITLE 'Processing Test' RETURN nil * --------------- STATIC FUNCTION ProcessLoop( lProcessing, GetList, oStatus ) LOCAL nCount := 1 lProcessing := .t. DC_GetRefresh(GetList) oStatus:setColorFG(GRA_CLR_BLUE) DO WHILE lProcessing DC_CompleteEvents() oStatus:SetCaption(L('Work in progress ') + Alltrim(Str(nCount++))) Sleep(10) ENDDO oStatus:setColorFG(GRA_CLR_RED) oStatus:SetCaption(L('Process stopped!')) DC_GetRefresh(GetList) RETURN nil ************************************************************* ******** Функции создания баз данных старого стандарта ****** ******** Можно брать их прямо из старой системы Эйдос ****** ************************************************************* * GenDBFobj_old() * GenDBFprp_old() * GenDBFpro_old() * GenDBFAbs_old() * GenDBFInf_old() * GenObIzag_old() * GenObIkpr_old() ******** Создание (сброс) базы заголовков анкет обучающей информации ********** FUNCTION GenObIzag_old() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций CREATE Struc APPEND BLANK REPLACE Field_name WITH "Kod_ist",; // Код источника инф. (анкеты) Field_type WITH "N",; // (N° анкеты или корресп) Field_len WITH 15,; Field_dec WITH 0 APPEND BLANK REPLACE Field_name WITH "Name_ist",; // Наименование источника обуч.инф. Field_type WITH "C",; Field_len WITH 15,; Field_dec WITH 0 FOR i = 1 TO 400 APPEND BLANK REPLACE Field_name WITH "Obj_"+ALLTRIM(STR(i,4)),; Field_type WITH "N",; Field_len WITH 4,; Field_dec WITH 0 NEXT APPEND BLANK REPLACE Field_name WITH "Date_ank",; Field_type WITH "D",; Field_len WITH 8,; Field_dec WITH 0 APPEND BLANK REPLACE Field_name WITH "Time_edit",; Field_type WITH "C",; Field_len WITH 16,; Field_dec WITH 0 APPEND BLANK REPLACE Field_name WITH "Mark",; Field_type WITH "C",; Field_len WITH 1,; Field_dec WITH 0 APPEND BLANK REPLACE Field_name WITH "Kod_old",; // Код источника инф. (анкеты) Field_type WITH "N",; // (N° анкеты или корресп) Field_len WITH 5,; Field_dec WITH 0 ******* Создаем базу обучающей информации ****************** CREATE OBINFZAG FROM Struc CREATE RsAnkZAG FROM Struc CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций ERASE Struc.dbf RETURN NIL *** Создание (сброс) базы кодов признаков обучающей информации ****************** FUNCTION GenObIkpr_old() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций CREATE Struc APPEND BLANK REPLACE Field_name WITH "Kod_ist",; // Код инф.источника (анкеты) Field_type WITH "N",; Field_len WITH 15,; Field_dec WITH 0 FOR j=1 TO 11 M_fn = "Kod_pr"+ALLTRIM(STR(j,2)) APPEND BLANK REPLACE Field_name WITH M_fn,; // Код признака Field_type WITH "N",; Field_len WITH 4,; Field_dec WITH 0 NEXT APPEND BLANK REPLACE Field_name WITH "Kod_old",; // Старый код инф.источника (анкеты) Field_type WITH "N",; Field_len WITH 5,; Field_dec WITH 0 ******* Создаем базу кодов признаков обучающей информации ****************** CREATE OBINFKPR FROM Struc CREATE RsAnkKpr FROM Struc CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций ERASE Struc.dbf RETURN NIL ******** Генерация базы данных классов ********************* FUNCTION GenDBFobj_old() CREATE Struc APPEND BLANK REPLACE Field_name WITH "Kod",; Field_type WITH "N",; Field_len WITH 4,; Field_dec WITH 0 APPEND BLANK REPLACE Field_name WITH "Name",; Field_type WITH "C",; Field_len WITH 250; Field_dec WITH 0 APPEND BLANK REPLACE Field_name WITH "Kod_old",; Field_type WITH "N",; Field_len WITH 4,; Field_dec WITH 0 APPEND BLANK REPLACE Field_name WITH "Mark",; Field_type WITH "C",; Field_len WITH 1,; Field_dec WITH 0 APPEND BLANK REPLACE Field_name WITH "Kod_prp",; Field_type WITH "N",; Field_len WITH 4,; Field_dec WITH 0 APPEND BLANK REPLACE Field_name WITH "Int_Inf",; Field_type WITH "N",; Field_len WITH 17,; Field_dec WITH 5 APPEND BLANK REPLACE Field_name WITH "Sum_ii",; Field_type WITH "N",; Field_len WITH 17,; Field_dec WITH 5 APPEND BLANK REPLACE Field_name WITH "Sii_proc",; Field_type WITH "N",; Field_len WITH 7,; Field_dec WITH 3 APPEND BLANK REPLACE Field_name WITH "Sii_gist",; Field_type WITH "C",; Field_len WITH 40,; Field_dec WITH 0 APPEND BLANK REPLACE Field_name WITH "Rang",; Field_type WITH "N",; Field_len WITH 5,; Field_dec WITH 0 APPEND BLANK REPLACE Field_name WITH "Abs",; Field_type WITH "N",; Field_len WITH 15,; Field_dec WITH 0 APPEND BLANK REPLACE Field_name WITH "Perc_fiz",; Field_type WITH "N",; Field_len WITH 7,; Field_dec WITH 3 APPEND BLANK REPLACE Field_name WITH "Ur_merl",; Field_type WITH "N",; Field_len WITH 4,; Field_dec WITH 0 CREATE Object FROM Struc RETURN NIL ******** Генерация базы данных первичных признаков ********** FUNCTION GenDBFprp_old() CREATE Struc APPEND BLANK REPLACE Field_name WITH "Kod",; Field_type WITH "N",; Field_len WITH 4,; Field_dec WITH 0 APPEND BLANK REPLACE Field_name WITH "Name",; Field_type WITH "C",; Field_len WITH 195,; Field_dec WITH 0 APPEND BLANK REPLACE Field_name WITH "Kod_ob_pr",; Field_type WITH "N",; Field_len WITH 4,; Field_dec WITH 0 APPEND BLANK REPLACE Field_name WITH "Int_Inf",; Field_type WITH "N",; Field_len WITH 17,; Field_dec WITH 11 APPEND BLANK REPLACE Field_name WITH "Sum_ii",; Field_type WITH "N",; Field_len WITH 17,; Field_dec WITH 11 APPEND BLANK REPLACE Field_name WITH "Sii_proc",; Field_type WITH "N",; Field_len WITH 7,; Field_dec WITH 3 APPEND BLANK REPLACE Field_name WITH "Sii_gist",; Field_type WITH "C",; Field_len WITH 40,; Field_dec WITH 0 APPEND BLANK REPLACE Field_name WITH "Rnd",; Field_type WITH "N",; Field_len WITH 4,; Field_dec WITH 0 APPEND BLANK REPLACE Field_name WITH "Delete",; Field_type WITH "C",; Field_len WITH 1,; Field_dec WITH 0 APPEND BLANK REPLACE Field_name WITH "Inter",; Field_type WITH "M",; Field_len WITH 10,; Field_dec WITH 0 APPEND BLANK REPLACE Field_name WITH "Kod_old",; Field_type WITH "N",; Field_len WITH 4,; Field_dec WITH 0 APPEND BLANK REPLACE Field_name WITH "Kod_new",; Field_type WITH "N",; Field_len WITH 4,; Field_dec WITH 0 APPEND BLANK REPLACE Field_name WITH "Mark",; Field_type WITH "C",; Field_len WITH 1,; Field_dec WITH 0 APPEND BLANK REPLACE Field_name WITH "Kod_obj",; Field_type WITH "N",; Field_len WITH 4,; Field_dec WITH 0 APPEND BLANK REPLACE Field_name WITH "Rang",; Field_type WITH "N",; Field_len WITH 5,; Field_dec WITH 0 APPEND BLANK REPLACE Field_name WITH "Abs",; Field_type WITH "N",; Field_len WITH 15,; Field_dec WITH 0 APPEND BLANK REPLACE Field_name WITH "Perc_fiz",; Field_type WITH "N",; Field_len WITH 9,; Field_dec WITH 3 APPEND BLANK REPLACE Field_name WITH "Ur_merl",; Field_type WITH "N",; Field_len WITH 4,; Field_dec WITH 0 CREATE Priz_per FROM Struc RETURN NIL ******** Генерация базы данных обобщенных признаков ********** FUNCTION GenDBFpro_old() CREATE Struc APPEND BLANK REPLACE Field_name WITH "Kod",; Field_type WITH "N",; Field_len WITH 4,; Field_dec WITH 0 APPEND BLANK REPLACE Field_name WITH "Name",; Field_type WITH "C",; Field_len WITH 195,; Field_dec WITH 0 FOR i = 1 TO 400 APPEND BLANK REPLACE Field_name WITH "Kpp_"+ALLTRIM(STR(i,4)),; Field_type WITH "N",; Field_len WITH 4,; Field_dec WITH 0 NEXT APPEND BLANK REPLACE Field_name WITH "Delete",; Field_type WITH "C",; Field_len WITH 1,; Field_dec WITH 0 APPEND BLANK REPLACE Field_name WITH "Ur_merl",; Field_type WITH "N",; Field_len WITH 4,; Field_dec WITH 0 APPEND BLANK REPLACE Field_name WITH "AvrIntInf",; Field_type WITH "N",; Field_len WITH 17,; Field_dec WITH 5 CREATE Priz_ob FROM Struc RETURN NIL ******** Создаем файл БД Abs.dbf **************** FUNCTION GenDBFAbs_old() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Object EXCLUSIVE NEW;N_Obj = RECCOUNT() USE Priz_per EXCLUSIVE NEW;N_Pr = RECCOUNT() CREATE Struc APPEND BLANK REPLACE Field_name WITH "Kod_Pr",; Field_type WITH "N",; Field_len WITH 4,; Field_dec WITH 0 SELECT Object;DBGOTOP() FOR j = 1 TO N_Obj SELECT Object;M_KodObj = Kod;DBSKIP(1) SELECT Struc APPEND BLANK REPLACE Field_name WITH "Obj_"+ALLTRIM(STR(M_KodObj,4)),; Field_type WITH "N",; Field_len WITH 17,; Field_dec WITH 2 NEXT APPEND BLANK REPLACE Field_name WITH "SUMMA",; Field_type WITH "N",; Field_len WITH 17,; Field_dec WITH 2 CREATE Abs_old FROM Struc CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций ERASE Struc.dbf RETURN NIL ******** Создаем файл БД Inf.dbf **************** FUNCTION GenDBFInf_old() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Object EXCLUSIVE NEW;N_Obj = RECCOUNT() USE Priz_per EXCLUSIVE NEW;N_Pr = RECCOUNT() CREATE Struc APPEND BLANK REPLACE Field_name WITH "Kod_Pr",; Field_type WITH "N",; Field_len WITH 4,; Field_dec WITH 0 SELECT Object;DBGOTOP() FOR j = 1 TO N_Obj SELECT Object;M_KodObj = Kod;DBSKIP(1) SELECT Struc APPEND BLANK REPLACE Field_name WITH "Obj_"+ALLTRIM(STR(M_KodObj,4)),; Field_type WITH "N",; Field_len WITH 19,; Field_dec WITH 7 NEXT APPEND BLANK REPLACE Field_name WITH "SUMMA",; Field_type WITH "N",; Field_len WITH 19,; Field_dec WITH 7 APPEND BLANK REPLACE Field_name WITH "SREDN",; Field_type WITH "N",; Field_len WITH 19,; Field_dec WITH 7 APPEND BLANK REPLACE Field_name WITH "DISP",; Field_type WITH "N",; Field_len WITH 19,; Field_dec WITH 7 APPEND BLANK REPLACE Field_name WITH "ADMA",; Field_type WITH "N",; Field_len WITH 19,; Field_dec WITH 7 CREATE Inf_old FROM Struc CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций ERASE Struc.dbf RETURN NIL ********************************************************************************************************* *** ГРАФИКА ********************************************************************************************* ********************************************************************************************************* **************************************************************************************************************************************** *** 3.7.1. Поиск и удаление артефактов (робастная процедура) *** Строится частотное распределение абсолютных частот встреч признаков в классах по матрице сопряженности Abs.dbf *** и пользователю предоставляется возможность удалить редко встречающиеся факты (сочетания), как случайные выбросы или артефакты **************************************************************************************************************************************** FUNCTION F3_7_1() 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 Razrab() RETURN NIL Running(.T.) ******* Проверка возможности работать в системе ****************************************** IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF ApplChange("3.7.1()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF IF .NOT. FILE("Abs.dbf") // Нет БД Abs.dbf LB_Warning(L("В текущем приложении нет БД Abs.dbf. Необходимо ее создать в режимах 3.5 и 5.5 !!!")) Running(.F.) RETURN NIL ENDIF *aMess := {} *DO CASE * CASE OSVER() = "3.1" * AADD(aMess, L('На комьютере установлена MS Windows NT 3.1')) * CASE OSVER() = "3.5" * AADD(aMess, L('На комьютере установлена MS Windows NT 3.5')) * CASE OSVER() = "3.51" * AADD(aMess, L('На комьютере установлена MS Windows NT 3.51')) * CASE OSVER() = "4.0" * AADD(aMess, L('На комьютере установлена MS Windows NT 4.0')) * CASE OSVER() = "5.0" * AADD(aMess, L('На комьютере установлена MS Windows 2000')) * CASE OSVER() = "5.1" * AADD(aMess, L('На комьютере установлена MS Windows XP')) * CASE OSVER() = "5.2" * AADD(aMess, L('На комьютере установлена MS Server 2003') *ENDCASE *IF LEN(aMess) > 0 * AADD(aMess, L('А для работы профессиональной графики нужна:')) * AADD(aMess, L('MS Windows Vista / MS Windows Server 2008 или')) // OSVER() = "6.0" * AADD(aMess, L('MS Windows 7 / MS Windows Server 2008 R2')) // OSVER() = "6.1" * LB_Warning(aMess, L('Сообщение о неудачном завершении операции')) * RETURN NIL *ENDIF // Еще сделать проверку на то, проинсталлирован ли ActiveX ******* Подготовка данных (расчет частотного распределения абсолютых частот) ************* * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * USE ABS EXCLUSIVE NEW * SELECT ABS * N_Rec = RECCOUNT() * N_Col = FCOUNT() * * nMax = 2*(N_Rec-2) * Mess = L('3.7.1. Подготовка данных для визуализации частотного распределения абс.частот' * @ 4,5 DCPROGRESS oProgress SIZE 95,1.1 MAXCOUNT nMax COLOR GRA_CLR_BLUE PERCENT EVERY 100 * DCREAD GUI TITLE Mess PARENT @oDialog FIT EXIT * oDialog:show() * nTime = 0 * * mMinX = 0 * mMaxX = 0 * DC_GetProgress(oProgress,0,nMax) * FOR i=1 TO N_Rec-2 * DBGOTO(i) * FOR j=1 TO N_Col-3 * Fv = FIELDGET(2+j) * mMinX = MIN(mMinX, Fv) * mMaxX = MAX(mMaxX, Fv) * NEXT * DC_GetProgress(oProgress, ++nTime, nMax) * NEXT * * PUBLIC aData [mMaxX] * PUBLIC aLabel[mMaxX] * AFILL(aData , 0 ) * AFILL(aLabel,' ') * * mMinY = 0 * mMaxY = 0 * FOR i=1 TO N_Rec-2 * DBGOTO(i) * FOR j=1 TO N_Col-3 * Fv = FIELDGET(2+j) * IF Fv > 0 * aData [Fv] = aData[Fv] + 1 * aLabel[Fv] = ALLTRIM(STR(Fv)) * mMinY = MIN(mMinY, aData[Fv]) * mMaxY = MAX(mMaxY, aData[Fv]) * ENDIF * NEXT * DC_GetProgress(oProgress, ++nTime, nMax) * NEXT * * DC_GetProgress(oProgress,nMax,nMax) * oDialog:Destroy() ***** ВИЗУАЛИЗАЦИЯ ГРАФИКА ************************************************************* ***** Сделать визуализацию без ActiveX ################################################ ***** Размер окна для отображения графика ********************************************** * * --- RMChart ActiveX Control -- * @ 0,0 DCRMCHART oRmChart SIZE 1140, 640 RESIZE DCGUI_RESIZE_RESIZEONLY * ***** Линейный график: исходные данные ************************************************* * IF LEN(aData) < 20 * DcAddLineGroup TO aLineGroupIndus ; * DATA aData ; * WHICHDATAAXIS 2 ; * STYLE RMC_LINE_CABLE ; * COLOR Green ; * LINESTYLE RMC_LSTYLE_LINE ; * SYMBOLSTYLE RMC_SYMBOL_BULLET ; * VALUELABEL 1 * ELSE * DcAddLineGroup TO aLineGroupIndus ; * DATA aData ; * WHICHDATAAXIS 2 ; * STYLE RMC_LINE_CABLE ; * COLOR Green ; * LINESTYLE RMC_LSTYLE_LINE ; * SYMBOLSTYLE RMC_SYMBOL_BULLET * ENDIF **************************************************************************************** * DcAddDataAxis TO aDataAxis6 ; * AXISTEXT "Количество встреч определенной частоты событий" ; // исходное * ALIGN RMC_DATAAXISLEFT ; * MINVALUE mMinY MAXVALUE mMaxY ; * TICKCOUNT 11 FONTSIZE 9 * @ 380,520 DCGRASTRING "Частоты событий" COLOR Black FONT '11.Tahona' * @ 10,10 DcChartRegion oRegion6 ; // Координаты нижнего левого угла поля построения графика в окне * PARENT oRMChart ; * SIZE 1100, 565 PIXEL ; // Размер поля построения графика в окне 1100 x 600 * CAPTION TITLE UPPER(ALLTRIM(M_NameAppl)) BACKCOLOR White TEXTCOLOR Black FONTSIZE 10 BOLD ; * GRID ; * DATAAXIS aDataAxis6 ; * LABELAXIS LABELARRAY aLabel ALIGN RMC_LABELAXISBOTTOM ; * LINEGROUP aLineGroupIndus **************************************************************************************** ***** Кнопки визу ********************************************************************** * @ 620, 0 DCPUSHBUTTON CAPTION L('Помощь' SIZE 60,25 ACTION {||Help371()} * @ DCGUI_ROW, DCGUI_COL + 10 DCPUSHBUTTON CAPTION L('Удалить артефакты' SIZE 150,25 ACTION {||DelArtefact()} * @ DCGUI_ROW, DCGUI_COL + 10 DCPUSHBUTTON CAPTION L('Записать графический файл' SIZE 170,25 ACTION {||SaveChartToBitmap(oRMChart)} * @ DCGUI_ROW, DCGUI_COL + 10 DCPUSHBUTTON CAPTION L('Копировать в буфер обмена' SIZE 170,25 ACTION {||SaveChartToClipboard(oRMChart)} * @ DCGUI_ROW, DCGUI_COL + 10 DCPUSHBUTTON CAPTION L('Печать' SIZE 55,25 ACTION {||PrintChart(oRMChart)} * @ DCGUI_ROW, DCGUI_COL +150 DCPUSHBUTTON CAPTION L('Копировать БД Abs' SIZE 120,25 ACTION {||SaveAbs()} * @ DCGUI_ROW, DCGUI_COL + 10 DCPUSHBUTTON CAPTION L('Восстановить БД Abs' SIZE 130,25 ACTION {||LoadAbs()} * DCGETOPTIONS RESIZE PIXEL * DCREAD GUI ; * SETAPPWINDOW ; * FIT ; * TITLE L('3.7.1. Частотное распределение абсолютных частот по Abs.dbf. (C) Универсальная когнитивная аналитическая система "Эйдос-Х++"' ; * OPTIONS GetOptions ; * EVAL {||oRMChart:RMCToolTipWidth := 100, ; * oRMChart:RMCUserWatermark := '(C) Универсальная когнитивная аналитическая система "Эйдос-Х++"', ; * oRMChart:RMCUserWMAlignment := RMC_TEXTRIGHT, ; * oRMChart:RMCUserWMFontSize := 20, ; * oRMChart:RMCUserWMLucent := 40, ; * oRmChart:mouseDown := ; * {|a,b,c,d,e,o|aData := e,nWhich := a,o:=Thread():new(),o:start({||BrowseCallbackData(nWhich,aData,oRMChart)})}, ; * oRmChart:mouseMove := ; * {|nMouseButton,b,nX,nY,aData|oRMChart:showToolTip( nMouseButton, nX, nY, aData )}, ; * oRmChart:draw(), ; * ShowDebugInfo(oRMChart)} * ************************************************************** * ***** БД, открытые перед запуском главного меню * ***** Восстанавливать их после выхода из функций главного меню * ************************************************************** * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы * USE PathGrAp EXCLUSIVE NEW * USE Appls EXCLUSIVE NEW * USE Users EXCLUSIVE NEW * ************************************************************** Running(.F.) RETURN NIL ************************************************************************************************* FUNCTION SaveAbs() // Сохранить Abs CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций COPY FILE ('Abs.dbf') TO ('Abs_tmp.dbf') RETURN NIL FUNCTION LoadAbs() // Восстановить Abs CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций COPY FILE ('Abs_tmp.dbf') TO ('Abs.dbf') // Нарисовать восстановленную кривую RETURN NIL ************************************************************************************************* ******** Помощь по режиму 3_7_1 ************************************************************************************************* FUNCTION Help371() 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('Поэтому в данном режиме строится частотное распределение частот наблюдения различных событий и ')) AADD(aHelp, L('пользователю по его виду предлагается решить, какую частоту наблюдения событий он предлагает ')) AADD(aHelp, L('считать случайной. Если пользователь затрудняется это сделать, то предлагается считать ')) AADD(aHelp, L('случайными все события, встретившиеся менее 5 раз. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('После задания в диалоге этой частоты все события, наблюдавшиеся реже, считаются не ')) AADD(aHelp, L('наблюдавшимися, т.е. в матрице абсолютных частот Abs.dbf частоты их наблюдения заменяются на ')) AADD(aHelp, L('нули. После этого необходимо в 3-й подсистеме рассчитать базы условных и безусловных процентных')) AADD(aHelp, L('распределений Prc1 и Prc2 (режим 3.2), а также базы знаний Inf1 - Inf7 (режим 3.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-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('Помощь по режиму: 3.7.1. Удаление артефактов (C) Система "ЭЙДОС-X++"') RETURN NIL ************************************************************************************************* ************************************************************************************************* ************* Удаление артефактов ************************************************************************************************* FUNCTION DelArtefact() LOCAL GetList[0], oStatus, lContinue := .T., oProgressm, oDialogm LOCAL lOk, aSay[30], Mess97, Mess98, Mess99, oDialog // Массив сообщений отображаемых стадий исполнения (до 30 на экране) N_Events = 5 @0, 0 DCSAY L("Задайте MIN частоту событий, принимаемую за не случайную:") @0, 47 DCSAY L(" ") GET N_Events PICTURE "#####" DCREAD GUI FIT ADDBUTTONS TITLE L('3.7.1. Удаление артефактов') IF mMinX <= N_Events .AND. N_Events <= mMaxX ELSE aMess := {} AADD(aMess, L('Частота событий, принимаемая за не случайную')) AADD(aMess, L('должна быть больше # и меньше $')) aMess[1] = STRTRAN(aMess[1], "#", ALLTRIM(STR(mMinX))) aMess[1] = STRTRAN(aMess[1], "$", ALLTRIM(STR(mMaxX))) LB_Warning(aMess, L('3.7.1. Удаление артефактов')) ReTURN nil ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE ABS EXCLUSIVE NEW SELECT ABS N_Cls = FCOUNT()-3 N_Atr = RECCOUNT()-2 // Организация отображения стадии процесса исполнения Wsego = N_Atr + N_Cls + N_Atr // Отображение стадии исполнения. Будет написано прямо в окне 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 @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('3.7.1. Процесс удаления артефактов из БД "Abs.dbf"'); 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 ******************************************************************************************** PRIVATE aLine[N_Cls];AFILL(aLine,0) // Итоговая строка SUMMA PRIVATE aColm[N_Atr];AFILL(aColm,0) // Итоговый столбец SUMMA mSum = 0 // Угловой элемент SUUMA SELECT ABS N_Artefact = 0 // Количество "артефактов" aSay[1]:SetCaption(L('1/3: Удаление артефактов из БД Abs.dbf')) FOR i=1 TO N_Atr GO i FOR j=1 TO N_Cls Fv = FIELDGET(2+j) IF 0 < Fv .AND. Fv < N_Events FIELDPUT(2+j, 0) ++N_Artefact Fv = 0 ENDIF mSum = mSum + Fv aColm[i] = aColm[i] + Fv aLine[j] = aLine[j] + Fv NEXT lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) NEXT aSay[1]:SetCaption(aSay[1]:caption+L(' - Готово ')) *** Перенос строки и столбца *СУММА* из массивов в БД aSay[2]:SetCaption(L('2/3: Перенос столбца "Сумма" в БД Abs.dbf')) FOR i=1 TO N_Atr GO i FIELDPUT(3+N_Cls, aColm[i]) lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) NEXT aSay[2]:SetCaption(aSay[2]:caption+L(' - Готово ')) aSay[3]:SetCaption(L('3/3: Перенос строки "Сумма" в БД Abs.dbf')) GO N_Atr+1 FOR j = 1 TO N_Cls FIELDPUT(2+j, aLine[j]) lOk = Time_Progress (++Time_Progress, Wsego, oProgress, lOk ) NEXT FIELDPUT(3+N_Cls,mSum) // SUMM угловой элемент aSay[3]:SetCaption(aSay[3]:caption+L(' - Готово ')) // Вывод информации о завершении процесса исполнения и о том, сколько удалено артефактов Mess = L("ПРОЦЕСС УДАЛЕНИЯ # АРТЕФАКТОВ ЗАВЕРШЕН УСПЕШНО !!!") Mess = STRTRAN(Mess, "#", ALLTRIM(STR(N_Artefact))) 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() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций ReTURN nil ************************************************************************************************* *FUNCTION DCCHART() *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], aLabelText, cRegSvr, ; * cRmChart, cClsId, cRegQuery, aData, nWhich, oStatus *// cClsId := '\CLSID\{8E2EA06D-6ACA-4E52-9D5D-3CE2A89A15BE}' // RMChart Version 3.xx * cClsId := '\CLSID\{4D814D0F-7D71-4E7E-B51E-2885AD0ED9D7}' // RMChart Version 4.xx *cRegSvr := 'regsvr32.exe' *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') * ENDIF *ENDIF ** --- RMChart ActiveX Control -- *@ 0,0 DCRMCHART oRmChart SIZE 1200, 800 RESIZE DCGUI_RESIZE_RESIZEONLY ** --- Bar Group (1) --- *DcAddBarGroup TO aBarGroup DATA { 20,40,60 } TYPE RMC_BARGROUP COLOR CornflowerBlue *DcAddBarGroup TO aBarGroup DATA { 10,50,70 } TYPE RMC_BARGROUP COLOR Gold *DcAddDataAxis TO aDataAxis1 LABELTEXT { '0','50','100'} *@ 5,5 DcChartRegion oRegion1 ; * PARENT oRMChart ; * FOOTER "(c) Copyright - Donnay Software Designs (2008)" ; * SIZE 350, 350 PIXEL ; * CAPTION TITLE 'Bar Group Test' ; * GRID ; * LEGEND TEXT { 'This Year', 'Last Year' } ; * DATAAXIS aDataAxis1 ; * LABELAXIS LABELARRAY { 'Apples','Peaches','Bananas' } ; * BARGROUP aBarGroup ** --- Line Group (2) --- *DcAddLineGroup TO aLineGroup DATA { 20,40,60 } COLOR CornflowerBlue *DcAddLineGroup TO aLineGroup DATA { 10,50,70 } COLOR Gold *@ 5,400 DcChartRegion oRegion2 ; * PARENT oRMChart ; * FOOTER "(c) Copyright - Donnay Software Designs (2008)" ; * SIZE 350, 350 PIXEL ; * CAPTION TITLE 'Line Group Test' ; * GRID ; * LEGEND TEXT { 'This Year', 'Last Year' } ; * DATAAXIS aDataAxis1 ; * LABELAXIS LABELARRAY { 'Apples','Peaches','Bananas' } ; * LINEGROUP aLineGroup ** --- Donut (3) --- *DcAddGridlessGroup TO aDonut DATA { 20,40,60 } ; * COLOR { Red, Yellow, Green } STYLE RMC_DONUT_3D *@ 400,5 DcChartRegion oRegion3 ; * PARENT oRMChart ; * FOOTER "(c) Copyright - Donnay Software Designs (2008)" ; * SIZE 200, 350 ; * CAPTION TITLE 'Donut Test' ; * LEGEND TEXT { 'Apples', 'Peaches', 'Bananas' } ; * GRIDLESSGROUP aDonut ** --- Pie (4) --- *DcAddGridlessGroup TO aPie DATA { 20,40,60 } ; * COLOR { Gold, Silver, SteelBlue } STYLE RMC_PIE_3D *@ 400,250 DcChartRegion oRegion4 ; * PARENT oRMChart ; * FOOTER "(c) Copyright - Donnay Software Designs (2008)" ; * SIZE 200, 350 ; * CAPTION TITLE 'Pie Test' ; * LEGEND TEXT { 'Apples', 'Peaches', 'Bananas' } ; * GRIDLESSGROUP aPie ** --- Floating Bars (5) --- *DcAddBarGroup TO aBarGroupFloat DATA { 20,20,40,10,60,30 } ; * TYPE RMC_FLOATINGBARGROUP COLOR CornflowerBlue HORIZONTAL ; * STYLE RMC_BAR_HOVER *DcAddBarGroup TO aBarGroupFloat DATA { 10,30,50,10,70,20 } ; * TYPE RMC_FLOATINGBARGROUP COLOR Gold HORIZONTAL ; * STYLE RMC_BAR_HOVER *DcAddDataAxis TO aDataAxis5 ; * LABELTEXT { 'Week 1','Week 2','Week 3','Week 4','Week 5','Week 6'} ; * ALIGN RMC_DATAAXISBOTTOM ; *@ 5,800 DcChartRegion oRegion5 ; * PARENT oRMChart ; * FOOTER "(c) Copyright - Donnay Software Designs (2008)" ; * SIZE 350, 350 PIXEL ; * CAPTION TITLE 'Floating Bar Group Test' ; * GRID ; * LEGEND TEXT { 'This Year', 'Last Year' } ; * DATAAXIS aDataAxis5 ; * LABELAXIS LABELARRAY { 'Apples','Peaches','Bananas' } ALIGN RMC_LABELAXISLEFT ; * BARGROUP aBarGroupFloat ** --- Bar and Line (6) --- *DcAddBarGroup TO aBarGroupIndus ; * DATA { 242365,235598,232571,185524,170457,164196,149321,132797,130067,119703 } ; * TYPE RMC_BARSINGLE COLOR Gold ; * STYLE RMC_BAR_FLAT_GRADIENT2 ; * WHICHDATAAXIS 1 *DcAddLineGroup TO aLineGroupIndus ; * DATA { 8.9, 4.1, 4.4, 2.1, .3, .3, 5.9, 11.3, 6.7, 6 } ; * WHICHDATAAXIS 2 ; * STYLE RMC_LINE_CABLE ; * COLOR Green ; * LINESTYLE RMC_LSTYLE_LINE ; * SYMBOLSTYLE RMC_SYMBOL_BULLET ; * VALUELABEL 1 *DcAddDataAxis TO aDataAxis6 ; * AXISTEXT "Total Turnover in Million $" ; * ALIGN RMC_DATAAXISLEFT ; * MINVALUE 100000 MAXVALUE 250000 ; * TICKCOUNT 11 FONTSIZE 9 ; * TEXTCOLOR Black LINECOLOR Black ; * LINESTYLE RMC_LINESTYLESOLID ; * DECDIGITS 0 UNIT '$' *DcAddDataAxis TO aDataAxis6 ; * AXISTEXT "Net Operating Margin" ; * ALIGN RMC_DATAAXISRIGHT ; * TEXTCOLOR Black LINECOLOR Black ; * MINVALUE 0 MAXVALUE 0 ; * DECDIGITS 2 UNIT " %" *aLabelText := { "Exxon Mobil", "Royal Dutch / Shell","BP", "General Motors", ; * "Daimler Chrysler", "Ford Motor", "Toyota Motor", "General Electric", ; * "TOTAL","Chevron Texaco" } *@ 400,500 DcChartRegion oRegion6 ; * PARENT oRMChart ; * SIZE 650, 350 PIXEL ; * CAPTION TITLE 'Bar and Line Test' BACKCOLOR Coral TEXTCOLOR FloralWhite FONTSIZE 10 BOLD ; * GRID ; * DATAAXIS aDataAxis6 ; * LABELAXIS LABELARRAY aLabelText ALIGN RMC_LABELAXISBOTTOM ; * BARGROUP aBarGroupIndus ; * LINEGROUP aLineGroupIndus *@ 805,0 DCPUSHBUTTON CAPTION {||'Mouse Tip ' + IIF(oRMChart:toolTipEnable,'OFF','ON')} ; * SIZE 100,20 ACTION {||oRMChart:toolTipEnable := !oRMChart:toolTipEnable, ; * DC_GetRefresh(GetList), ; * oRMChart:showToolTip(-1)} *@ DCGUI_ROW, DCGUI_COL + 10 DCPUSHBUTTON CAPTION L('Save Chart to RMC File' SIZE 130,20 ; * ACTION {||SaveChartToFile(oRMChart),DC_GetRefresh(GetList)} *@ DCGUI_ROW, DCGUI_COL + 10 DCPUSHBUTTON CAPTION L('Save Chart to Bitmap' SIZE 140,20 ; * ACTION {||SaveChartToBitmap(oRMChart)} *@ DCGUI_ROW, DCGUI_COL + 10 DCPUSHBUTTON CAPTION L('Save Chart to ClipBoard' SIZE 140,20 ; * ACTION {||SaveChartToClipboard(oRMChart)} *@ DCGUI_ROW, DCGUI_COL + 10 DCPUSHBUTTON CAPTION L('Create New Chart from RMC' SIZE 140,20 ; * TOOLTIP L('Open a new window and create chart from DCCHART.RMC' ; * ACTION {||CreateChartFromRMC()} WHEN {||Fexists('DCCHART.RMC')} *@ DCGUI_ROW, DCGUI_COL + 10 DCPUSHBUTTON CAPTION L('Load RMC into this Chart' SIZE 140,20 ; * TOOLTIP L('Load a selected *.RMC file into this Window' ; * ACTION {||LoadChartFromRMC(oRMChart)} *@ DCGUI_ROW, DCGUI_COL + 10 DCPUSHBUTTON CAPTION L('Apply New Data' SIZE 90,20 ; * TOOLTIP L('Apply new RANDOM data to all graph regions' ; * ACTION {||ApplyNewData1(oRMChart:regions[1]), ; * ApplyNewData2(oRMChart:regions[2]), ; * ApplyNewData4(oRMChart:regions[3]), ; * ApplyNewData4(oRMChart:regions[4]), ; * ApplyNewData6(oRMChart:regions[6]), ; * oRMChart:draw()} *@ DCGUI_ROW, DCGUI_COL + 10 DCPUSHBUTTON CAPTION L('Computer Fairs' SIZE 90,20 ; * TOOLTIP L('Make a new graph from "Computer Fairs.RMC"' ; * ACTION {||ComputerFairs()} *@ DCGUI_ROW, DCGUI_COL + 10 DCPUSHBUTTON CAPTION L('eXpress++ Sales' SIZE 90,20 ; * TOOLTIP L('Make a new graph from "eXpress.RMC"' ; * ACTION {||ExpressSales()} *@ DCGUI_ROW, DCGUI_COL + 10 DCPUSHBUTTON CAPTION L('Print' SIZE 50,20 ; * ACTION {||PrintChart(oRMChart)} *DCGETOPTIONS RESIZE PIXEL *DCREAD GUI ; * SETAPPWINDOW ; * FIT ; * TITLE 'DCRMCHART Sample Program' ; * OPTIONS GetOptions ; * EVAL {||oRMChart:RMCToolTipWidth := 100, ; * oRMChart:RMCUserWatermark := 'eXpress++ RMChart System', ; * oRMChart:RMCUserWMAlignment := RMC_TEXTRIGHT, ; * oRMChart:RMCUserWMFontSize := 32, ; * oRMChart:RMCUserWMLucent := 40, ; * oRmChart:mouseDown := ; * {|a,b,c,d,e,o|aData := e,nWhich := a,o:=Thread():new(),o:start({||BrowseCallbackData(nWhich,aData,oRMChart)})}, ; * oRmChart:mouseMove := ; * {|nMouseButton,b,nX,nY,aData|oRMChart:showToolTip( nMouseButton, nX, nY, aData )}, ; * oRmChart:draw(), ; * ShowDebugInfo(oRMChart)} *RETURN nil * -------------- *STATIC FUNCTION ApplyNewData1( oRegion ) *LOCAL i, aBarData1[0], aBarData2[0] *FOR i := 1 TO 3 * Sleep(2) * AAdd(aBarData1,DC_Random(100)) * Sleep(2) * AAdd(aBarData2,DC_Random(100)) *NEXT *oRegion:barGroup[1,DCRMCHART_BARSERIES_DATA] := aBarData1 *oRegion:barGroup[2,DCRMCHART_BARSERIES_DATA] := aBarData2 *oRegion:reset() *RETURN nil * -------------- *STATIC FUNCTION ApplyNewData2( oRegion ) *LOCAL i, aLineData1[0], aLineData2[0] *FOR i := 1 TO 3 * Sleep(2) * AAdd(aLineData1,DC_Random(100)) * Sleep(2) * AAdd(aLineData2,DC_Random(100)) *NEXT *oRegion:lineGroup[1,DCRMCHART_LINESERIES_DATA] := aLineData1 *oRegion:lineGroup[2,DCRMCHART_LINESERIES_DATA] := aLineData2 *oRegion:reset() *RETURN nil * -------------- *STATIC FUNCTION ApplyNewData4( oRegion ) *LOCAL i, aPieData[0] *FOR i := 1 TO 3 * Sleep(2) * AAdd(aPieData,DC_Random(100)) *NEXT *oRegion:gridlessGroup[1,DCRMCHART_GRIDLESSSERIES_DATA] := aPieData *oRegion:reset() *RETURN nil * -------------- *STATIC FUNCTION ApplyNewData6( oRegion ) *LOCAL i, aBarData[0], aLineData[0] *FOR i := 1 TO 10 * Sleep(2) * AAdd(aBarData,(DC_Random(255)*1000)+DC_Random(255)) *NEXT *FOR i := 1 TO 10 * Sleep(2) * AAdd(aLineData,(DC_Random(25)+(DC_Random(10)*.1))) *NEXT *oRegion:barGroup[1,DCRMCHART_BARSERIES_DATA] := aBarData *oRegion:dataAxis[1,DCRMCHART_DATAAXIS_MINVALUE] := 10000 *oRegion:dataAxis[1,DCRMCHART_DATAAXIS_MAXVALUE] := 300000 *oRegion:lineGroup[1,DCRMCHART_LINESERIES_DATA] := aLineData *oRegion:reset() *RETURN nil * -------------- STATIC FUNCTION ShowDebugInfo( oRMChart ) /* wtf oRMChart:Region(4):GridlessSeries wtf oRMChart:Region(4):BarSeries(1) wtf oRMChart:Region(1):BarSeries(1) */ RETURN nil * -------------- *PROC appsys *RETURN * -------------- STATIC FUNCTION BrowseCallbackData( nWhich, aData, oRMChart ) LOCAL GetList[0], oBrowse, nRegion IF nWhich == 1 // left mouse button @ 0,0 DCBROWSE oBrowse DATA aData SIZE 30,37 NOHSCROLL FIT ; PRESENTATION LC_BrowPres() FONT '10.Lucida Console' DCBROWSECOL DATA {||oBrowse:arrayElement} HEADER L('Element') WIDTH 5 PICTURE '99' PARENT oBrowse DCBROWSECOL ELEMENT 1 HEADER L('Desc') WIDTH 20 PARENT oBrowse DCBROWSECOL ELEMENT 2 HEADER L('Data') WIDTH 15 PARENT oBrowse PICTURE '999999999.99' DCREAD GUI FIT ADDBUTTONS TITLE 'RMChart Mouse Data' ELSEIF nWhich == 2 // right mouse button nRegion := aData[5,2] IF nRegion > 0 DC_InspectObject( oRMChart:regions[nRegion] ) ENDIF ENDIF RETURN nil * ------------- *STATIC FUNCTION SaveChartToFile( oRMChart ) *LOCAL cFileName := DC_Path(AppName(.t.)) + 'DCCHART.RMC' *oRMChart:writeRMCFile( cFileName ) *DCMSGBOX 'Chart saved to: ' + cFileName TIMEOUT 3 *RETURN nil * ------------- STATIC FUNCTION SaveChartToBitmap( oRMChart ) LOCAL cFileName := DC_Path(AppName(.t.)) + 'DCCHART.JPG' oRMChart:draw2File( cFileName ) DCMSGBOX 'Chart saved to: ' + cFileName TIMEOUT 3 ShellOpenFile( cFileName ) RETURN nil * ------------- STATIC FUNCTION SaveChartToClipboard( oRMChart ) oRMChart:draw2ClipBoard() DCMSGBOX 'Chart saved to ClipBoard' TIMEOUT 3 RETURN nil * ------------- *STATIC FUNCTION LoadChartFromRMC( oRMChart ) *LOCAL GetList[0], cFileName := Space(50), lStatus *@ 0,0 DCSAY L('RMC File Name:') SAYSIZE 0 *@ 1,0 DCGET cFileName POPUP {|c|DC_PopFile(c)} ; * VALID {||DC_ReadEmpty(cFileName)} *DCREAD GUI FIT TITLE 'Load RMC File into Chart' ; * TO lStatus MODAL ADDBUTTONS *IF lStatus * oRMChart:RMCFile := Alltrim(cFileName) * oRMChart:draw() * oRMChart:mouseMove := {||nil} * oRMChart:mouseDown := {||nil} *ENDIF *RETURN nil * ------------- *STATIC FUNCTION CreateChartFromRMC() *LOCAL GetList[0], oRMChart ** --- RMChart ActiveX Control -- *@ 0,0 DCRMCHART oRmChart SIZE 1200, 800 RESIZE DCGUI_RESIZE_RESIZEONLY PIXEL *DCREAD GUI FIT TITLE 'RMChart created from an RMC File' ; * EVAL {||LoadRMCFile(oRMChart)} MODAL *RETURN nil * ------------- *STATIC FUNCTION LoadRMCFile( oRMChart ) *LOCAL cFileName := DC_Path(AppName(.t.)) + 'DCCHART.RMC' *oRMChart:RMCFile := cFileName *oRMChart:draw() *RETURN nil * ------------- *STATIC FUNCTION ComputerFairs() *LOCAL GetList[0], GetOptions, oRMChart ** --- RMChart ActiveX Control -- *@ 0,0 DCRMCHART oRmChart SIZE 600, 500 RESIZE DCGUI_RESIZE_RESIZEONLY PIXEL *@ 520, 0 DCPUSHBUTTON CAPTION L('Apply Random Data' ; * SIZE 120,20 PIXEL ACTION {||ApplyCFRandomData(oRMChart)} *@ 550,0 DCSAY L('This graph was created with the RMCDesigner. Click on "Apply Random Data" to apply new data') SAYSIZE 0 PIXEL *DCGETOPTIONS RESIZE *DCREAD GUI FIT TITLE 'RMChart created from "Computer Fairs.RMC" File' ; * EVAL {||oRmChart:RMCFile := "Computer Fairs.RMC", oRMChart:draw()} MODAL ; * OPTIONS GetOptions *RETURN nil * ------------ *STATIC FUNCTION ApplyCFRandomData( oRMChart ) *LOCAL i, aData[0], aNames, aData1[0], aNames1[0], aColors[0], nColor *aNames := { 'Xbase++ Devcon', 'eXpress++ Devcon', 'Clipper World', 'CES, Las Vegas', 'Middleton Fair', ; * 'Cebit, Hannover', 'Infocomm, USA', 'IFA, Berlin', 'Simo, Madrid', 'Networld, Las Vegas' } *FOR i := 1 TO 10 * Sleep(2) * AAdd(aData,{DC_Random(255)*20.5,aNames[i]} ) *NEXT *ASort( aData,,,{|a,b|a[1]>b[1]}) *FOR i := 1 TO Len(aData) * AAdd(aData1,aData[i,1]) * AAdd(aNames1,aData[i,2]) * IF aData[i,1] > 3000 * nColor := IndianRed * ELSEIF aData[i,1] > 2000 * nColor := DarkTurquoise * ELSEIF aData[i,1] > 1000 * nColor := AutumnOrange * ELSE * nColor := DarkOrchid * ENDIF * AAdd( aColors, nColor ) *NEXT *oRMChart:applyData( aData1 ) *oRMChart:applyLabelAxis( aNames1 ) *oRMChart:applyColors( aColors ) *oRMChart:draw() *RETURN nil * ------------- *STATIC FUNCTION ExpressSales() *LOCAL GetList[0], GetOptions, oRMChart ** --- RMChart ActiveX Control -- *@ 0,0 DCRMCHART oRmChart SIZE 600, 470 RESIZE DCGUI_RESIZE_RESIZEONLY PIXEL *@ 480, 0 DCPUSHBUTTON CAPTION L('Apply Random Data' ; * SIZE 120,20 PIXEL ACTION {||ApplyEXRandomData(oRMChart)} *@ 510,0 DCSAY L('This graph was created with the RMCDesigner. Click on "Apply Random Data" to apply new data') SAYSIZE 0 PIXEL *DCGETOPTIONS RESIZE *DCREAD GUI FIT TITLE 'RMChart created from "eXPress.RMC" File' ; * EVAL {||oRmChart:RMCFile := "eXpress.RMC", oRMChart:draw()} MODAL ; * OPTIONS GetOptions *RETURN nil * ------------ *STATIC FUNCTION ApplyEXRandomData( oRMChart ) *LOCAL i, aData1[0], aData2[0] *FOR i := 1 TO 12 * Sleep(2) * AAdd(aData1,DC_Random(100) ) * Sleep(2) * AAdd(aData2,DC_Random(100) ) *NEXT *oRMChart:applyData( aData1,,,1 ) *oRMChart:applyData( aData2,,,2 ) *oRMChart:draw() *RETURN nil * ------------ STATIC FUNCTION PrintChart( oRMChart ) oRMChart:draw2Printer(2) RETURN nil ********************************************************************************************************* *CLASS MyRmChart *EXPORTED: *VAR rmChart *VAR data *VAR axis *VAR colors *VAR labels *VAR pointsPerColumn *VAR title *VAR subTitle *VAR seriesType *VAR appWindow *VAR modal *VAR getList *VAR height *VAR width *VAR dialogWindow *VAR pieStyle *VAR pieValueLabel *VAR legendAlignment *VAR legendValues *VAR parent *METHOD Init, Create, DrawLineChart, DrawPieChart, DrawBarChart, Destroy, PrintChart *ENDCLASS * ------------ *METHOD MyRmChart:init() *::title := 'RMChart' *::subTitle := '' *::pointsPerColumn := 100 *::seriesType := RMC_LINE *::width := 800 *::height := 500 *::modal := .f. *::pieStyle := RMC_PIE_3D *// ::pieValueLabel := RMC_VLABEL_TWIN *::pieValueLabel := 0 *// ::legendAlignment := RMC_LEGEND_ONVLABELS *::LegendAlignment := RMC_LEGEND_UL *::legendValues := .f. *RETURN self * ----------------- *METHOD MyRmChart:Create( lAddButtons ) *LOCAL GetList[0], GetOptions, oStatic, oStatTop, oToolBar, ; * nEvent, oXbp, mp1, mp2 *DEFAULT lAddButtons := .f. *::getList := GetList *IF lAddButtons * DCSTATUSBAR oStatTop HEIGHT 20 ALIGN DCGUI_ALIGN_TOP * @ 0,0 DCTOOLBAR oToolBar PARENT oStatTop SIZE 1000,20 PIXEL BUTTONSIZE 90 * DCADDBUTTON CAPTION L('3D Pie') PARENT oToolBar ; * ACTION {||::pieStyle := RMC_PIE_3D, ::drawPieChart()} * DCADDBUTTON CAPTION L('GR Pie') PARENT oToolBar ; * ACTION {||::pieStyle := RMC_PIE_GRADIENT, ::drawPieChart()} * DCADDBUTTON CAPTION L('3D Donut') PARENT oToolBar ; * ACTION {||::pieStyle := RMC_DONUT_3D, ::drawPieChart()} * DCADDBUTTON CAPTION L('GR Donut') PARENT oToolBar ; * ACTION {||::pieStyle := RMC_DONUT_GRADIENT, ::drawPieChart()} * DCADDBUTTON CAPTION L('Bar') PARENT oToolBar ; * ACTION {||::drawBarChart()} * DCADDBUTTON CAPTION L('Print') PARENT oToolBar ; * ACTION {||::printChart()} *ENDIF *@ 0,0 DCSTATIC TYPE XBPSTATIC_TYPE_TEXT ; * SIZE ::width, ::height ; * OBJECT oStatic ; * COLOR nil, GRA_CLR_YELLOW ; * RESIZE DCGUI_RESIZE_RESIZEONLY *@ 0,0 DCACTIVEXCONTROL ::rmChart ; * CLSID 'RMChart.RMChartX' ; * PARENT oStatic ; * SIZE ::width, ::height ; * RESIZE DCGUI_RESIZE_RESIZEONLY *DCGETOPTIONS RESIZE PIXEL *DCREAD GUI ; * FIT ; * TITLE ::title ; * OPTIONS GetOptions ; * NOAUTORESTORE ; * PARENT ::parent ; * APPWINDOW ::appWindow ; * _MODAL ::modal ; * _SETAPPWINDOW ::modal ; * EXIT ; * SAVE ; * EVAL {|o|::dialogWindow := o} *::dialogWindow:close := {|a,b,c|::destroy()} *RETURN self * ------------------ *METHOD MyRmChart:destroy() *::getList := nil *::dialogWindow:destroy() *RETURN self * ------------------ *METHOD MyRmChart:DrawLineChart *Local sTemp, i, j *::RMChart:Reset() *::RMChart:RMCBackColor := PaleGreen *::RMChart:RMCStyle := RMC_CTRLSTYLEFLATSHADOW *::RMChart:AddRegion() *::RMChart:Region(1):SetProperties( 5, 10, -5, -5, ::subTitle ) *::RMChart:Region(1):AddCaption() *::RMChart:Region(1):Caption():SetProperties( ::title, PaleGreen, DarkBlue, 9, True) *::RMChart:Region(1):AddGrid() *::RMChart:Region(1):Grid():SetProperties( LightBlue, True, 0, 0, 0, 0) *::RMChart:Region(1):AddDataAxis() *::RMChart:Region(1):DataAxis(1):Alignment := RMC_DATAAXISLEFT *IF ::seriesType == RMC_LINE_INDEXED * ::RMChart:Region(1):DataAxis(1):MinValue := 0 * ::RMChart:Region(1):DataAxis(1):MaxValue := 200 *ENDIF *::RMChart:Region(1):DataAxis(1):TickCount := 11 *::RMChart:Region(1):DataAxis(1):FontSize := 8 *::RMChart:Region(1):DataAxis(1):TextColor := DarkBlue *::RMChart:Region(1):DataAxis(1):LineColor := DarkSlateGray *::RMChart:Region(1):DataAxis(1):LineStyle := RMC_LINESTYLEDOT *::RMChart:Region(1):DataAxis(1):DecimalDigits := 2 *::RMChart:Region(1):DataAxis(1):AxisUnit := '' *::RMChart:Region(1):DataAxis(1):AxisText := ::subTitle *::RMChart:Region(1):AddLabelAxis() *::RMChart:Region(1):LabelAxis():AxisCount := 1 *::RMChart:Region(1):LabelAxis():TickCount := Len(::axis) *::RMChart:Region(1):LabelAxis():Alignment := RMC_LABELAXISBOTTOM *::RMChart:Region(1):LabelAxis():FontSize := 8 *::RMChart:Region(1):LabelAxis():TextColor := DarkBlue *::RMChart:Region(1):LabelAxis():TextAlignment := RMC_TEXTCENTER *::RMChart:Region(1):LabelAxis():LineColor := DarkSlateGray *::RMChart:Region(1):LabelAxis():LineStyle := RMC_LINESTYLEDOT *IF Valtype(::axis) == 'A' * sTemp := '' * FOR i := 1 TO Len(::axis) * sTemp += Alltrim(DC_XtoC(::axis[i])) + IIF( i < Len(::axis),'*','') * NEXT *ENDIF *::RMChart:Region(1):LabelAxis():LabelString := sTemp *IF Valtype(::labels) == 'A' * ::RMChart:Region(1):AddLegend() * ::RMChart:Region(1):Legend():SetProperties( RMC_LEGEND_TOP, Default, RMC_LEGENDRECT, Default, 8, False) * sTemp := '' * FOR i := 1 TO Len(::labels) * sTemp += Alltrim(DC_XtoC(::labels[i])) + IIF( i < Len(::data),'*','') * NEXT * ::RMChart:Region(1):Legend():LegendString := sTemp *ENDIF *FOR j := 1 TO Len(::data) * sTemp := '' * FOR i := 1 TO Len(::data[j]) * sTemp += Alltrim(DC_XtoC(::data[j,i])) + IIF( i < Len(::data[j]),'*','') * NEXT * ::RMChart:Region(1):AddLineSeries() * ::RMChart:Region(1):LineSeries(j):SeriesType := ::seriesType * ::RMChart:Region(1):LineSeries(j):SeriesStyle := RMC_LINE_FLAT * ::RMChart:Region(1):LineSeries(j):LineStyle := RMC_LSTYLE_LINE * ::RMChart:Region(1):LineSeries(j):Lucent := False * IF Valtype(::colors) == 'A' .AND. j <= Len(::colors) * ::RMChart:Region(1):LineSeries(j):Color := ::colors[j] * ELSE * ::RMChart:Region(1):LineSeries(j):Color := Blue * ENDIF * ::RMChart:Region(1):LineSeries(j):SymbolStyle := RMC_SYMBOL_NONE * ::RMChart:Region(1):LineSeries(j):WhichDataAxis := 0 * ::RMChart:Region(1):LineSeries(j):ValueLabelOn := False * ::RMChart:Region(1):LineSeries(j):HatchMode := RMC_HATCHBRUSH_OFF * ::RMChart:Region(1):LineSeries(j):PointsPerColumnString := Alltrim(Str(::pointsPerColumn)) * ::RMChart:Region(1):LineSeries(j):dataString := sTemp *NEXT *::RMChart:Draw() *RETURN self * -------------- *METHOD MyRMChart:DrawPieChart() *Local sTemp := '', i *::RmChart:Reset() *//************** Design the chart ********************** *::RMChart:RMCBackColor := AliceBlue *::RMChart:RMCStyle := RMC_CTRLSTYLEFLAT *//************** Add Region 1 ***************************** *::RMChart:AddRegion() *::RMChart:Region(1):Left := 5 *::RMChart:Region(1):Top := 5 *::RMChart:Region(1):Width := -5 *::RMChart:Region(1):Height := -5 *::RMChart:Region(1):Footer := "" *IF Valtype(::labels) == 'A' * ::RMChart:Region(1):AddLegend() * ::RMChart:Region(1):Legend():SetProperties( RMC_LEGEND_TOP, Default, RMC_LEGENDRECT, Default, 8, False) * sTemp := '' * FOR i := 1 TO Len(::labels) * sTemp += Alltrim(::labels[i]) + ; * IIF(::legendValues,'-'+Alltrim(Str(::data[i])),'') + ; * IIF( i < Len(::data),'*','') * NEXT * ::RMChart:Region(1):Legend():LegendString := sTemp *ENDIF *//************** Add Series 1 to region 1 ******************************* *::RMChart:Region(1):AddGridlessSeries() *::RMChart:Region(1):GridlessSeries():SeriesStyle := ::pieStyle *::RMChart:Region(1):GridlessSeries():Alignment := RMC_FULL *::RMChart:Region(1):GridlessSeries():ExplodeMode := 2 *::RMChart:Region(1):GridlessSeries():Lucent := True *::RMChart:Region(1):GridlessSeries():ValueLabelOn := ::pieValueLabel *::RMChart:Region(1):GridlessSeries():HatchMode := RMC_HATCHBRUSH_OFF *::RMChart:Region(1):Legend:Alignment := ::legendAlignment *//************** Add caption to region 1 ******************* *::RMChart:Region(1):AddCaption() *::RMChart:Region(1):Caption():Titel := ::title *::RMChart:Region(1):Caption():BackColor := Blue *::RMChart:Region(1):Caption():TextColor := Yellow *::RMChart:Region(1):Caption():FontSize := 11 *::RMChart:Region(1):Caption():Bold := True *//****** Set color values ****** *IF Valtype(::colors) = 'A' * FOR i := 1 TO Len(::colors) * ::RMChart:Region(1):GridlessSeries():SetColorValue( i, ::colors[i] ) * NEXT *ENDIF *//****** Set data values ****** *sTemp := '' *FOR i := 1 TO Len(::data) * sTemp += Alltrim(Str(::data[i])) + IIF(i 9 * ::RMChart:Region(1):GridlessSeries:SetColorValue( i, LightGray ) * ENDIF *NEXT *::RMChart:Region(1):GridlessSeries():DataString := sTemp *::RMChart:Draw() *Return self * ------------------ *METHOD MyRmChart:DrawBarChart() *Local sTemp, i *//************** Design the chart ********************** *::RMChart:Reset() *::RMChart:Font := "Comic Sans MS" *::RMChart:RMCBackColor := AliceBlue *::RMChart:RMCStyle := RMC_CTRLSTYLEFLAT *//************** Add Region 1 ***************************** *::RMChart:AddRegion() *::RMChart:Region(1):Left := 5 *::RMChart:Region(1):Top := 5 *::RMChart:Region(1):Width := -5 *::RMChart:Region(1):Height := -5 *::RMChart:Region(1):Footer := "" *//************** Add caption to region 1 ******************* *::RMChart:Region(1):AddCaption() *::RMChart:Region(1):Caption():Titel := ::title *::RMChart:Region(1):Caption():BackColor := Blue *::RMChart:Region(1):Caption():TextColor := Yellow *::RMChart:Region(1):Caption():FontSize := 11 *::RMChart:Region(1):Caption():Bold := True *//************** Add grid to region 1 ***************************** *::RMChart:Region(1):AddGrid() *::RMChart:Region(1):Grid():BackColor := Beige *::RMChart:Region(1):Grid():AsGradient := False *::RMChart:Region(1):Grid():BicolorMode := RMC_BICOLOR_LABELAXIS *::RMChart:Region(1):Grid():Left := 0 *::RMChart:Region(1):Grid():Top := 0 *::RMChart:Region(1):Grid():Width := 0 *::RMChart:Region(1):Grid():Height := 0 *//************** Add data axis to region 1 ***************************** *::RMChart:Region(1):AddDataAxis() *::RMChart:Region(1):DataAxis(1):Alignment := RMC_DATAAXISLEFT *::RMChart:Region(1):DataAxis(1):FontSize := 8 *::RMChart:Region(1):DataAxis(1):TextColor := Black *::RMChart:Region(1):DataAxis(1):LineColor := Black *::RMChart:Region(1):DataAxis(1):LineStyle := RMC_LINESTYLEDOT *::RMChart:Region(1):DataAxis(1):DecimalDigits := 0 *::RMChart:Region(1):DataAxis(1):AxisUnit := "" *::RMChart:Region(1):DataAxis(1):AxisText := "" *//************** Add label axis to region 1 ***************************** *::RMChart:Region(1):AddLabelAxis() *::RMChart:Region(1):LabelAxis():AxisCount := 1 *::RMChart:Region(1):LabelAxis():Alignment := RMC_LABELAXISBOTTOM *::RMChart:Region(1):LabelAxis():FontSize := 8 *::RMChart:Region(1):LabelAxis():TextColor := Black *::RMChart:Region(1):LabelAxis():TextAlignment := RMC_TEXTCENTER *::RMChart:Region(1):LabelAxis():LineColor := Black *::RMChart:Region(1):LabelAxis():LineStyle := RMC_LINESTYLENONE *sTemp := '' *FOR i := 1 TO Len(::labels) * sTemp += ::labels[i] + IIF(i INF#.DBF <<<===########### // Еще сделать проверку на то, проинсталлирован ли ActiveX ******* Подготовка данных (расчет значимости признаков во всех моделях) ************* CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Attributes EXCLUSIVE NEW SELECT Attributes mLN = -9999 DBGOTOP() DO WHILE .NOT. EOF() mLN = MAX(mLN, LEN(ALLTRIM(Name_atr))) DBSKIP(1) ENDDO mLN = IF( mLN < 0, 250, mLN) ***** Создать БД Zpr_Inf# * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций CLOSE ALL aStructure := { { "Num" , "N", 15, 0 }, ; // Порядковый номер после ранжирования { "Num_prc" , "N", 15, 7 }, ; // Порядковый номер после ранжирования в процентах { "Kod_atr" , "N", 15, 0 }, ; // Код признака, т.е. градации описательной шкалы { "Name_atr" , "C",mLN, 0 }, ; // Наименование признака, т.е. описательной шкалы+"-"+градации описательной шкалы { "Kod_OpSc" , "N", 15, 0 }, ; // Код описательной шкалы { "Znach_Atr", "N", 15, 7 }, ; // Значимость признака в ее единицах измерения { "Zn_AtrNit", "N", 19, 7 }, ; // Значимость признака в ее единицах измерения нарастающим итогом { "Znach_Prc", "N", 15, 7 }, ; // Значимость признака в процентах от суммы значимостей всех признаков { "Zn_PrcNit", "N", 15, 7 }, ; // Значимость признака в процентах от суммы значимостей всех признаков нарастающим итогом { "Delete" , "C", 6, 0 } } // Признак, что данный признак был удален из Abs PRIVATE Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } FOR jj=1 TO LEN(Ar_Model) mNameZpr = "Zpr_"+Ar_Model[jj] DbCreate( mNameZpr , aStructure ) // <<<===######################################## NEXT mNameZpr = "Zpr_tmp.dbf" DbCreate( mNameZpr , aStructure ) // Посчитать БД Zpr_Inf# 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') aMess := {} AADD(aMess, L('Отсутствуют базы статистических и системно-когнитивных моделей:') ) AADD(aMess, L('"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7".')) AADD(aMess, L('Необходимо создать их в режиме 3.5.') ) LB_Warning(aMess, L('Сообщение о завершении операции')) Running(.F.) RETURN NIL ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Abs EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW;N_Atr = RECCOUNT() IF N_Atr = 0 aMess := {} AADD(aMess, L('Отсутствуют градации описательных шкал (признаки).')) AADD(aMess, L('Необходимо создать модель. ')) LB_Warning(aMess, L('Сообщение о завершении операции')) Running(.F.) RETURN NIL ENDIF * nMax = LEN(Ar_Model) * 6 * N_Atr * Mess = L('3.7.5. Подготовка данных для визуализации значимости признаков') * @ 4,5 DCPROGRESS oProgress SIZE 95,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) PUBLIC Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } PUBLIC Ar_ModelQuality := {} // Качество модели - расстояние между точками Red-Blue PUBLIC Ar_ModelRating := {} // Рейтинг модели по ее качеству FOR jj=1 TO LEN(Ar_Model) mNameInf = Ar_Model[jj] mNameZpr = "Zpr_"+Ar_Model[jj] CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mNameInf) EXCLUSIVE NEW USE (mNameZpr) EXCLUSIVE NEW USE Zpr_tmp EXCLUSIVE NEW;ZAP USE Attributes EXCLUSIVE NEW ****** Копирование кодов и наименований атрибутов в базы значимостей SELECT Attributes DBGOTOP() DO WHILE .NOT. EOF() mKodAtr = Kod_atr mNameAtr = Name_atr mKodOpSc = Kod_OpSc SELECT (mNameInf) DBGOTO(mKodAtr) mDisp = Disp SELECT (mNameZpr) APPEND BLANK REPLACE Kod_atr WITH mKodAtr REPLACE Name_atr WITH mNameAtr REPLACE Kod_OpSc WITH mKodOpSc REPLACE Znach_Atr WITH mDisp * DC_GetProgress(oProgress, ++nTime, nMax) // 1 SELECT Attributes DBSKIP(1) ENDDO ****** Сортировка базы по значимости признаков SELECT (mNameZpr) INDEX ON STR(9999999999.9999999 - Znach_Atr, 19, 7) TO (mNameZpr) ****** Расчет значимости признака в ее единицах измерения нарастающим итогом DBGOTOP() mSumZnAtr = 0 DO WHILE .NOT. EOF() mSumZnAtr = mSumZnAtr + Znach_atr REPLACE Zn_AtrNit WITH mSumZnAtr * DC_GetProgress(oProgress, ++nTime, nMax) // 2 DBSKIP(1) ENDDO ****** Расчет значимости признаков в процентах от суммы значимостей всех признаков и нарастающим итогом в процентах mMaxLen = 15 mNumPP = 0 mSumZnPrc = 0 DBGOTOP() DO WHILE .NOT. EOF() mZnPrc = Znach_Atr / mSumZnAtr * 100 mSumZnPrc = mSumZnPrc + mZnPrc REPLACE Num WITH ++mNumPP REPLACE Num_prc WITH mNumPP / N_Atr * 100 REPLACE Znach_Prc WITH mZnPrc REPLACE Zn_PrcNit WITH mSumZnPrc mMaxLen = MAX(mMaxLen, LEN(ALLTRIM(STR(ROUND(Num_prc,0))))) * DC_GetProgress(oProgress, ++nTime, nMax) // 3 DBSKIP(1) ENDDO ***** Физическая сортировка (mNameZpr) SELECT (mNameZpr) DBGOTOP() DO WHILE .NOT. EOF() ar := {} FOR j=1 TO FCOUNT() AADD(ar, FIELDGET(j)) NEXT SELECT Zpr_tmp APPEND BLANK FOR j=1 TO LEN(ar) FIELDPUT(j, ar[j]) NEXT * DC_GetProgress(oProgress, ++nTime, nMax) // 4 SELECT (mNameZpr) DBSKIP(1) ENDDO SELECT (mNameZpr);ZAP SELECT Zpr_tmp DBGOTOP() DO WHILE .NOT. EOF() ar := {} FOR j=1 TO FCOUNT() AADD(ar, FIELDGET(j)) NEXT SELECT (mNameZpr) APPEND BLANK FOR j=1 TO LEN(ar) FIELDPUT(j, ar[j]) NEXT * DC_GetProgress(oProgress, ++nTime, nMax) // 5 SELECT Zpr_tmp DBSKIP(1) ENDDO * RMChartGrOpSc() // Сделать график без ACTIVE X ###################################### ****** График: исходные данные ********************************************************** SELECT (mNameZpr) N_Znach = RECCOUNT() // Кол-во значений в графиках INDEX ON STR(999999.9999999 - Znach_Atr, 15, 7) TO (mNameZpr) PRIVATE aArg[N_Znach] // Массив значений аргумента PRIVATE aVal[N_Znach] // Массив значений функции *** Присвоить массивам параметрически заданные значения отображаемой функции j = 0 DBGOTOP() DO WHILE .NOT. EOF() ++j aArg[j] = NUM_PRC // % от общего числа признаков aVal[j] = ZN_PRCNIT // % от общей значимости * DC_GetProgress(oProgress, ++nTime, nMax) // 6 DBSKIP(1) ENDDO * MsgBox('STOP') ***** ВИЗУАЛИЗАЦИЯ Парето-КРИВОЙ ЗНАЧИМОСТИ ГРАДАЦИЙ ОПИСАТЕЛЬНЫХ ШКАЛ **************** * DrawChart375(jj) 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 ) PRIVATE mArg50f *####################################################################################################### mNumMod = jj LC_DrawChart375( oPS, N_Znach, aArg, aVal, mNumMod ) // Графическая функция <<<===########## *####################################################################################################### *My image original, my image scaled DC_Impl(oScr) ****** Запись полноразмерного графического файла в папку: M_PathAppl+"\ParetoGrOpSc\" DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения IF FILEDATE("ParetoGrOpSc",16) = CTOD("//") DIRMAKE("ParetoGrOpSc") aMess := {} AADD(aMess, L('В папке текущего приложения: "'+UPPER(ALLTRIM(M_PathAppl))+'"')) AADD(aMess, L('не было директории "ParetoGrOpSc" для Парето-диаграмм признаков и она была создана!')) AADD(aMess, L('В эту папку записываются исходные изображения высокого качества (без масштабирования)')) LB_Warning(aMess, L('3.7.5. Значимость градаций описательных шкал и абстрагирование' )) ENDIF DIRCHANGE(M_PathAppl+"\ParetoGrOpSc\") // Перейти в папку ParetoGrOpSc cFileName = "ParetoGrOpSc"+"-"+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() // Закрытие всех баз данных с ожиданием завершения операций ********** Копирование БД Zpr_Inf#.dbf => Zpr_Inf#.xls FOR jj=1 TO LEN(Ar_Model) mNameZprDbf = "Zpr_"+Ar_Model[jj]+".dbf" mNameZprXls = "Zpr_"+Ar_Model[jj]+".xls" COPY FILE (mNameZprDbf) TO (mNameZprXls) NEXT ******* Экранная форма с результатами и заданием **************************** ******* Расчет рейтингов моделей *** PRIVATE mModel, aRating[10] mMax = -99999 aR := {} FOR j=1 TO LEN(Ar_Model) mV = VAL( Ar_ModelQuality[j]) AADD(aR, Ar_ModelQuality[j]) IF mMax < mV mMax = mV mModel = j ENDIF NEXT ASORT(Ar_ModelRating) FOR r=1 TO 10 FOR m=1 TO LEN(Ar_Model) mRating = AT(Ar_Model[m], Ar_ModelRating[r]) IF mRating > 0 aRating[m] = r ENDIF NEXT NEXT ***** Диалог задания модели для удаления незначимых признаов и задание процента остающихся признаков после удаления ******************************** @ 0,0 DCGROUP oGroup1 CAPTION L('Задайте модель, в которой удалять наименее значимые признаки:') SIZE 110,24.5 s=1;d=0.8 @ s,1 DCSAY L('Отображение Парето-диаграмм значимости признаков завершено! ') PARENT oGroup1;s=s+d @ s,1 DCSAY L(' ') PARENT oGroup1;s=s+d @ s,1 DCSAY L('Результаты расчета силы влияния (значимости) признаков или значений факторов содержатся в следующих базах данных, созданных на основе ') PARENT oGroup1;s=s+d @ s,1 DCSAY L('статистических и интеллектуальных моделей: "Zpr_Abs.xlsx", "Zpr_Prc1.xlsx", "Zpr_Prc2.xlsx", "Zpr_Inf1.xlsx", "Zpr_Inf2.xlsx", ') PARENT oGroup1;s=s+d @ s,1 DCSAY L('"Zpr_Inf3.xlsx", "Zpr_Inf4.xlsx", "Zpr_Inf5.xlsx", "Zpr_Inf6.xlsx", "Zpr_Inf7.xlsx" в папке текущего приложения: '+M_PathAppl+'. ') PARENT oGroup1;s=s+d @ s,1 DCSAY L(' ') PARENT oGroup1;s=s+d @ s,1 DCSAY L('Эти MS Excel файлы создаются в в режиме 5.12. Они практичеси готовы для печати и получения графиков. ') PARENT oGroup1;s=s+d @ s,1 DCSAY L(' ') PARENT oGroup1;s=s+d @ s,1 DCSAY L('Сила влияния (значимость) признака или значения фактора представляет собой вариабельность количества информации в этом признаке ') PARENT oGroup1;s=s+d @ s,1 DCSAY L('о переходе объекта моделирования во все будущие состояния, соотвествующие классам, имеющимся в модели, т.е. это "жесткость", с которой') PARENT oGroup1;s=s+d @ s,1 DCSAY L('данное значение фактора обуславливают (детерминируют) переход объекта моделирования в различные состояния, соответствующие классам. ') PARENT oGroup1;s=s+d @ s,1 DCSAY L(' ') PARENT oGroup1;s=s+d @ s,1 DCSAY REPLICATE('-',250) PARENT oGroup1;s=s+d @ s,1 DCSAY L('Рейтинг моделей: Задайте модель, в которой удалять наименее значимые признаки: ') PARENT oGroup1;s=s+d @ s,1 DCSAY REPLICATE('-',250) PARENT oGroup1;s=s+d;s0=s FOR j=1 TO LEN(Ar_Model) @ s+0.27, 7 DCSAY ALLTRIM(Ar_ModelQuality[j])+'%' PARENT oGroup1 @ s+0.27,55 DCSAY STR(aRating[j],2) PARENT oGroup1;s=s+d NEXT PUBLIC mPercLeave := 100 s=s+d @ s+0.15, 3 DCSAY L("Задайте какой % наиболее значимых признаков ОСТАВИТЬ в модели:") PARENT oGroup1 @ s,0.11,55 DCSAY L(" ") GET mPercLeave PICTURE "####.#######" PARENT oGroup1 s=s-0.5 @ s,85 DCPUSHBUTTON CAPTION L('Пояснение по режиму') SIZE LEN(L('Пояснение по режиму'))+3, 1.5 ACTION {||Help375()} PARENT oGroup1 s=s0;w=20 @ s,w DCRADIO mModel VALUE 1 PROMPT L('1. ABS - частный критерий: количество встреч сочетаний: "класс-признак" у объектов обуч.выборки ') PARENT oGroup1;s=s+d @ s,w DCRADIO mModel VALUE 2 PROMPT L('2. PRC1 - частный критерий: усл. вероятность i-го признака среди признаков объектов j-го класса ') PARENT oGroup1;s=s+d @ s,w DCRADIO mModel VALUE 3 PROMPT L('3. PRC2 - частный критерий: условная вероятность i-го признака у объектов j-го класса ') PARENT oGroup1;s=s+d @ s,w DCRADIO mModel VALUE 4 PROMPT L('4. INF1 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC1 ') PARENT oGroup1;s=s+d @ s,w DCRADIO mModel VALUE 5 PROMPT L('5. INF2 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC2 ') PARENT oGroup1;s=s+d @ s,w DCRADIO mModel VALUE 6 PROMPT L('6. INF3 - частный критерий: Xи-квадрат, разности между фактическими и ожидаемыми абс.частотами ') PARENT oGroup1;s=s+d @ s,w DCRADIO mModel VALUE 7 PROMPT L('7. INF4 - частный критерий: ROI (Return On Investment); вероятности из PRC1 ') PARENT oGroup1;s=s+d @ s,w DCRADIO mModel VALUE 8 PROMPT L('8. INF5 - частный критерий: ROI (Return On Investment); вероятности из PRC2 ') PARENT oGroup1;s=s+d @ s,w DCRADIO mModel VALUE 9 PROMPT L('9. INF6 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC1 ') PARENT oGroup1;s=s+d @ s,w DCRADIO mModel VALUE 10 PROMPT L('10.INF7 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC2 ') PARENT oGroup1;s=s+d*3 DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; OPTIONS GetOptions ; ADDBUTTONS; MODAL ; TITLE L('3.7.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(.F.) ENDIF ********************************************************************************************************************** * DC_GetProgress(oProgress,nMax,nMax) * oDialog:Destroy() ***** Удаление из модели наименее значимых признаков: ******************************************************** ***** 1. Выявление наименее значимых признаков в Zpr_Abs.dbf, Zpr_Prc#.dbf, Zpr_Inf#.dbf ЗАДАННОЙ МОДЕЛИ. ***** 2. Удаление наименее значимых признаков в Attributes.dbf, Gr_OpSc.dbf, Opis_Sc.dbf и их перекодирование. ***** 3. Удаление наименее значимых признаков в Obi_Kpr.dbf и ее перекодирование. ***** 4. Переиндексация всех измененных БД ************************************************************************************************************** IF mPercLeave < 100 // Если оставтить 100% признаков, то ничего делать не надо CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций Ar_Model := {"Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } mModelName = 'Zpr_'+Ar_Model[mModel] USE (mModelName) EXCLUSIVE NEW USE Attributes EXCLUSIVE NEW USE Gr_OpSc EXCLUSIVE NEW USE Opis_Sc EXCLUSIVE NEW USE Obi_Zag EXCLUSIVE NEW USE ObI_Kcl EXCLUSIVE NEW USE Obi_Kpr EXCLUSIVE NEW ***** 1. Выявление наименее значимых признаков в Zpr_Abs.dbf, Zpr_Prc#.dbf, Zpr_Inf#.dbf ЗАДАННОЙ МОДЕЛИ. aKodPrDel := {} // Коды удаляемых признаков (старые) SELECT (mModelName) DBGOTO(ROUND(RECCOUNT() * mPercLeave/100, 0)) // Начинать с первого удаляемого признака/ Похоже это не работает DO WHILE .NOT. EOF() AADD(aKodPrDel, KOD_ATR) DBSKIP(1) ENDDO * DC_DebugQout( aKodPrDel ) // Отладка Имя Размер Дата Время ***** 2. Удаление наименее значимых признаков в Attributes.dbf, Gr_OpSc.dbf, Opis_Sc.dbf и их перекодирование. <<<===##################### aKodPrOld := {} // Старые коды всех признаков. В этом массиве нет смысла, т.к. номер элемента равен его значению aKodPrNew := {} // Новые коды всех признаков, т.е. после удаления. Если признак удален, его новый код 0 SELECT Attributes DBGOTOP() n = 1 DO WHILE .NOT. EOF() mKodAtr = KOD_ATR AADD(aKodPrOld, mKodAtr) IF ASCAN(aKodPrDel, mKodAtr) > 0 DELETE // Удаление признака AADD(aKodPrNew, 0) ELSE REPLACE Kod_atr WITH n AADD(aKodPrNew, n++) ENDIF DBSKIP(1) ENDDO PACK * DC_DebugQout( aKodPrOld ) // Отладка Имя Размер Дата Время * DC_DebugQout( aKodPrNew ) // Отладка Имя Размер Дата Время SELECT Gr_OpSc DBGOTOP() n = 1 DO WHILE .NOT. EOF() IF aKodPrNew[KOD_GROS] = 0 DELETE // Удаление градаций описательных шкал ELSE REPLACE KOD_GROS WITH n++ ENDIF DBSKIP(1) ENDDO PACK ***** 3. Удаление наименее значимых признаков в Obi_Kpr.dbf и ее перекодирование. SELECT Obi_Kpr DBGOTOP() DO WHILE .NOT. EOF() FOR j=2 TO 8 mKodAtr = FIELDGET(j) IF mKodAtr > 0 IF ASCAN(aKodPrDel, mKodAtr) > 0 FIELDPUT(j, 0) // Удаление признака ELSE FIELDPUT(j, aKodPrNew[mKodAtr]) // <<<===############################# ENDIF ENDIF NEXT DBSKIP(1) ENDDO DELETE FOR Atr1=0.AND.Atr2=0.AND.Atr3=0.AND.Atr4=0.AND.Atr5=0.AND.Atr6=0.AND.Atr7=0 // Удаление пустых записей PACK OpSc_Ngr() // Сформировать в БД Opis_Sc информацию по числу признаков и начальным и конечным кодам признаков в описательной шкале ***** 4. Переиндексация всех измененных БД GenNtxAttr() // Описательные шкалы и градации GenNtxOpSc() // Описательные шкалы GenNtxGrOpSc() // Градации описательных шкал GenNtxObiKpr() // Коды признаков объектов обучающей выборки LB_Warning('Процесс удаления малозначимых признаков завершен успешно!!!', '3.7.5. Значимость градаций описательных шкал и абстрагирование') ENDIF ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL **************************************************************************************************************************************** ******** 3.7.3. Степень детерминированности классов ******** В данном режиме все градации классификационных шкал (классы) ранжируются в порядке убывания степени детерминированности, ******** т.е. вариабельности значений частных критериев статистических и системно-когнитивных моделей **************************************************************************************************************************************** FUNCTION F3_7_3() 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 Running(.T.) ******* Проверка возможности работать в системе ****************************************** IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF ApplChange("3.7.3()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF COPY_TXT_DBF() // Преобразовать INF#.TXT => INF#.DBF // Еще сделать проверку на то, проинсталлирован ли ActiveX ******* Подготовка данных (расчет значимости признаков во всех моделях) ************* CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW SELECT Classes mLN = -999999999 DBGOTOP() DO WHILE .NOT. EOF() mLN = MAX(mLN, LEN(ALLTRIM(Name_cls))) DBSKIP(1) ENDDO ***** Создать БД Zkl_Inf# CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций aStructure := { { "Num" , "N", 15, 0 }, ; // Порядковый номер после ранжирования { "Num_prc" , "N", 15, 7 }, ; // Порядковый номер после ранжирования в процентах { "Kod_cls" , "N", 15, 0 }, ; // Код класса, т.е. градации классификационной шкалы { "Name_cls" , "C",mLN, 0 }, ; // Наименование класса, т.е. наименование классификационной шкалы+"-"+наименование градации классификационной шкалы из Classes.dbf { "Kod_ClSc" , "N", 15, 0 }, ; // Код классификационной шкалы { "Znach_Cls", "N", 15, 7 }, ; // Значимость класса в ее единицах измерения { "Zn_ClsNit", "N", 19, 7 }, ; // Значимость класса в ее единицах измерения нарастающим итогом { "Znach_Prc", "N", 15, 7 }, ; // Значимость класса в процентах от суммы значимостей всех класса { "Zn_PrcNit", "N", 15, 7 }, ; // Значимость класса в процентах от суммы значимостей всех класса нарастающим итогом { "Delete" , "C", 6, 0 } } // Признак, что данный класса был удален из Abs PUBLIC Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } FOR jj=1 TO LEN(Ar_Model) mNameZkl = "Zkl_"+Ar_Model[jj]+".dbf" DbCreate( mNameZkl , aStructure ) NEXT mNameZkl = "Zkl_tmp.dbf" DbCreate( mNameZkl , aStructure ) // Посчитать БД Zkl_Inf# 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') aMess := {} IF LEN(aMess) > 0 AADD(aMess, L('Отсутствуют базы статистических и системно-когнитивных моделей:') ) AADD(aMess, L('"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7".')) AADD(aMess, L('Необходимо создать их в режиме 3.5.') ) LB_Warning(aMess, L('Сообщение о завершении операции')) ENDIF Running(.F.) RETURN NIL ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Abs EXCLUSIVE NEW USE Classes EXCLUSIVE NEW N_Cls = RECCOUNT() * nMax = LEN(Ar_Model) * 6 * N_Atr * Mess = L('3.7.5. Подготовка данных для визуализации степени детерминированности классов') * @ 4,5 DCPROGRESS oProgress SIZE 95,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) PUBLIC Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } FOR jj=1 TO LEN(Ar_Model) mNameInf = Ar_Model[jj] mNameZkl = "Zkl_"+Ar_Model[jj] CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE (mNameInf) EXCLUSIVE NEW USE (mNameZkl) EXCLUSIVE NEW USE Zkl_tmp EXCLUSIVE NEW;ZAP USE Classes EXCLUSIVE NEW ****** Копирование кодов и наименований классов в базы значимостей SELECT Classes DBGOTOP() DO WHILE .NOT. EOF() mKodCls = Kod_cls mNameCls = Name_cls mKodClSc = Kod_ClSc SELECT (mNameInf) IF jj=1 DBGOBOTTOM();DBSKIP(-1) ELSE DBGOBOTTOM() ENDIF mDisp = FIELDGET(2+mKodCls) SELECT (mNameZkl) APPEND BLANK REPLACE Kod_cls WITH mKodcls REPLACE Name_cls WITH mNameCls REPLACE Kod_ClSc WITH mKodClSc REPLACE Znach_Cls WITH mDisp * DC_GetProgress(oProgress, ++nTime, nMax) // 1 SELECT Classes DBSKIP(1) ENDDO ****** Сортировка базы по значимости классов по степени детерминированности SELECT (mNameZkl) INDEX ON STR(9999999999.9999999 - Znach_Cls, 19, 7) TO (mNameZkl) ****** Расчет значимости класса в ее единицах измерения нарастающим итогом DBGOTOP() mSumZnCls = 0 DO WHILE .NOT. EOF() mSumZnCls = mSumZnCls + Znach_cls REPLACE Zn_ClsNit WITH mSumZnCls * DC_GetProgress(oProgress, ++nTime, nMax) // 2 DBSKIP(1) ENDDO ****** Расчет значимости классов в процентах от суммы значимостей всех классов и нарастающим итогом в процентах mMaxLen = 15 mNumPP = 0 mSumZnPrc = 0 DBGOTOP() DO WHILE .NOT. EOF() mZnPrc = Znach_Cls / mSumZnCls * 100 mSumZnPrc = mSumZnPrc + mZnPrc REPLACE Num WITH ++mNumPP REPLACE Num_prc WITH mNumPP / N_Cls * 100 REPLACE Znach_Prc WITH mZnPrc REPLACE Zn_PrcNit WITH mSumZnPrc mMaxLen = MAX(mMaxLen, LEN(ALLTRIM(STR(ROUND(Num_prc,0))))) * DC_GetProgress(oProgress, ++nTime, nMax) // 3 DBSKIP(1) ENDDO ***** Физическая сортировка БД (mNameZkl) в порядке убывания степени детерминированности SELECT (mNameZkl) DBGOTOP() DO WHILE .NOT. EOF() ar := {} FOR j=1 TO FCOUNT() AADD(ar, FIELDGET(j)) NEXT SELECT Zkl_tmp APPEND BLANK FOR j=1 TO LEN(ar) FIELDPUT(j, ar[j]) NEXT * DC_GetProgress(oProgress, ++nTime, nMax) // 4 SELECT (mNameZkl) DBSKIP(1) ENDDO SELECT (mNameZkl);ZAP SELECT Zkl_tmp DBGOTOP() DO WHILE .NOT. EOF() ar := {} FOR j=1 TO FCOUNT() AADD(ar, FIELDGET(j)) NEXT SELECT (mNameZkl) APPEND BLANK FOR j=1 TO LEN(ar) FIELDPUT(j, ar[j]) NEXT * DC_GetProgress(oProgress, ++nTime, nMax) // 5 SELECT Zkl_tmp DBSKIP(1) ENDDO * RMChartGrOpSc() // Сделать график без ACTIVE X ###################################### ***** График: исходные данные ********************************************************** SELECT (mNameZkl) N_Znach = RECCOUNT() // Кол-во значений в графиках INDEX ON STR(999999.9999999 - Znach_Cls, 15, 7) TO (mNameZkl) PRIVATE aArg[N_Znach] // Массив значений аргумента PRIVATE aVal[N_Znach] // Массив значений функции *** Присвоить массивам параметрически заданные значения отображаемой функции j = 0 DBGOTOP() DO WHILE .NOT. EOF() ++j aArg[j] = NUM_PRC // % от общего числа признаков aVal[j] = ZN_PRCNIT // % от общей значимости * DC_GetProgress(oProgress, ++nTime, nMax) // 6 DBSKIP(1) ENDDO * MsgBox('STOP') ***** ВИЗУАЛИЗАЦИЯ Парето-КРИВОЙ ЗНАЧИМОСТИ ГРАДАЦИЙ ШКАЛ **************** * DrawChart375(jj) 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 ) *####################################################################################################### mNumMod = jj LC_DrawChart373( oPS, N_Znach, aArg, aVal, mNumMod ) // Графическая функция <<<===########## *####################################################################################################### *My image original, my image scaled DC_Impl(oScr) ****** Запись полноразмерного графического файла в папку: M_PathAppl+"\ParetoGrClSc\" DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения IF FILEDATE("ParetoGrClSc",16) = CTOD("//") DIRMAKE("ParetoGrClSc") aMess := {} AADD(aMess, L('В папке текущего приложения: "'+UPPER(ALLTRIM(M_PathAppl))+'"')) AADD(aMess, L('не было директории "ParetoGrClSc" для Парето-диаграмм детерминированности классов и она была создана!')) AADD(aMess, L('В эту папку записываются исходные изображения высокого качества (без масштабирования)')) LB_Warning(aMess, L('3.7.3. Степень детерминированности классов' )) ENDIF DIRCHANGE(M_PathAppl+"\ParetoGrClSc\") // Перейти в папку ParetoGrClSc cFileName = "ParetoGrClSc"+"-"+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() // Закрытие всех баз данных с ожиданием завершения операций ********** Копирование БД Zkl_Inf#.dbf => Zkl_Inf#.xls FOR jj=1 TO LEN(Ar_Model) mNameZklDbf = "Zkl_"+Ar_Model[jj]+".dbf" mNameZklXls = "Zkl_"+Ar_Model[jj]+".xls" COPY FILE (mNameZklDbf) TO (mNameZklXls) NEXT aMess := {} AADD(aMess, L('Отображение Парето-диаграмм степени сформированности классов завершено!')) AADD(aMess, L(' ')) AADD(aMess, L('Результаты расчета степени детерминированности (значимости) классов содержатся в следующих базах данных, созданных на основе')) AADD(aMess, L('статистических и интеллектуальных моделей: "Zkl_Abs.xlsx","Zkl_Prc1.xlsx","Zkl_Prc2.xlsx","Zkl_Inf1.xlsx","Zkl_Inf2.xlsx","Zkl_Inf3.xlsx",')) AADD(aMess, L('"Zkl_Inf4.xlsx","Zkl_Inf5.xlsx","Zkl_Inf6.xlsx","Zkl_Inf7.xlsx" в папке текущего приложения: '+M_PathAppl+'.')) AADD(aMess, L(' ')) AADD(aMess, L('Эти MS Excel файлы создаются в режиме 5.12. Они практичеси готовы для печати и получения графиков.')) AADD(aMess, L(' ')) AADD(aMess, L('Степень детерменированности класса представляет собой вариабельность количества информации в всех признаках модели')) AADD(aMess, L('о принадлежности или не принадлежности объекта с этими признаком к данному классу, т.е. это "жесткость", с которой')) 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 ************************************************************** Running(.F.) RETURN NIL ******************************************************************************************** ********** ВИЗУАЛИЗАЦИЯ Парето-КРИВОЙ ЗНАЧИМОСТИ ГРАДАЦИЙ ОПИСАТЕЛЬНЫХ ШКАЛ **************** ********** без использования RMChart ActiveX ******************************************************************************************** *FUNCTION DrawChart375(mNumMod) * PRIVATE aAttr // Массив атрибутов отображаемых линий * 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 {|| _PresSpace375(oStatic, N_Znach, aArg, aVal, mNumMod) } * DCREAD GUI ; * TITLE L("3.7.5. Значимость градаций описательных шкал и абстрагирование"); // Надпись на окне графика * FIT ; * BUTTONS DCGUI_BUTTON_EXIT *RETURN NIL ************************************************* *STATIC FUNCTION _PresSpace375( oStatic, N_Znach, aArg, aVal, mNumMod ) * 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_DrawChart375( oPS, N_Znach, aArg, aVal, mNumMod ) } *RETURN NIL ********************************************************************************* *************** Визуализация Парето-диаграммы значимости признаков ********************************************************************************* STATIC FUNCTION LC_DrawChart375(oPS, N_Znach, aArg, aVal, mNumMod ) IF LEN(aArg) = 0 RETURN NIL ENDIF ****** Поиск макс и мин значений аргумента и функции ****** X_MinA = +99999999 // Минимальное значение Y отображаемой функции X_MaxA = -99999999 // Максимальное значение Y отображаемой функции Y_MinF = +99999999 // Минимальное значение Y отображаемой функции Y_MaxF = -99999999 // Максимальное значение Y отображаемой функции FOR j=1 TO LEN(aArg) 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 ****** Поиск и рисование значения аргумента mArg50f при котором получается значение функции = 50% от максимального RED 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=2 TO LEN(aVal) IF aVal[j] > 0.5 * Y_MaxF ****** Получение более точного значения аргумента и функции путем линейной интерполяции mArg2 = aArg[j ] mArg1 = aArg[j-1] mVal2 = aVal[j ] mVal1 = aVal[j-1] mArg50f = mArg1 + ( 0.5 * Y_MaxF - mVal1 ) / ( mVal2 - mVal1 ) * ( mArg2 - mArg1 ) EXIT ENDIF NEXT mX = X0 + (mArg50f-aArg[1]) * Kx // <===######################## mY = Y0A + (0.5*Y_MaxF -aVal[1]) * Ky GraLine( oPS, { mX, Y0A }, { mX, mY } ) // Нарисовать вертикальный отрезок прямой линии GraLine( oPS, { X0, mY }, { mX, mY } ) // Нарисовать горизонтальный отрезок прямой линии aAttr [ GRA_AL_WIDTH ] := 2 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты GraSetColor( oPS, GRA_CLR_RED, GRA_CLR_RED ) GraArc( oPS, { mX, mY }, 6, ,,, GRA_OUTLINE ) GraSetColor( oPS, GRA_CLR_BLACK, GRA_CLR_BLACK ) ****** Поиск и рисование значения функции mVal50a которое получается при значении аргумента = 50% от максимального BLUE aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := GRA_CLR_BLUE // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO LEN(aArg) IF aArg[j] > 0.5 * X_MaxA ****** Получение более точного значения аргумента и функции путем линейной интерполяции mArg2 = aArg[j ] mArg1 = aArg[j-1] mVal2 = aVal[j ] mVal1 = aVal[j-1] mVal50a = mVal1 + ( 0.5 * X_MaxA - mArg1 ) / ( mArg2 - mArg1 ) * ( mVal2 - mVal1 ) EXIT ENDIF NEXT mX = X0 + (0.5*X_MaxA-aArg[1]) * Kx // <===######################## mY = Y0A + (mVal50a -aVal[1]) * Ky GraLine( oPS, { mX, Y0A }, { mX, mY } ) // Нарисовать вертикальный отрезок прямой линии GraLine( oPS, { X0, mY }, { mX, mY } ) // Нарисовать горизонтальный отрезок прямой линии aAttr [ GRA_AL_WIDTH ] := 2 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты GraSetColor( oPS, GRA_CLR_BLUE, GRA_CLR_BLUE ) GraArc( oPS, { mX, mY }, 6, ,,, GRA_OUTLINE ) GraSetColor( oPS, GRA_CLR_BLACK, GRA_CLR_BLACK ) ***** Нарисовать линии, соединяющую точки Red-Blue и максимальную линию aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := aColor[107] // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты графической линии *** Координаты точки RED ****************************** mXred = X0 + (mArg50f-aArg[1]) * Kx // <===######################## mYred = Y0A + (0.5*Y_MaxF -aVal[1]) * Ky *** Координаты точки BLUE ****************************** mXblue = X0 + (0.5*X_MaxA-aArg[1]) * Kx // <===######################## mYblue = Y0A + (mVal50a -aVal[1]) * Ky GraLine( oPS, { mXred, mYred }, { mXblue, mYblue } ) // Нарисовать фактический отрезок Red-Blue GraLine( oPS, { X0 , mYred }, { mXblue, Y0+H_Wind } ) // Нарисовать максимальный отрезок Red-Blue ***** Нарисовать оси координат ********************************** 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 } ) GraLine( oPS, { 1270, Y1 }, { 1270, Y2 } ) // Нарисовать вертикальную линию, отделяющую левый комментарий от правого ***** Сделать надписи в легенде aAttr[ GRA_AL_COLOR ] := aColor[17] // Задать цвет линии aAttr[ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты * Значимость градации описательной шкалы (ее числового интервального или номинального текстового значения), т.е. признака, представляет ее полезность для решения задачи разделения * объектов с этим признаком по классам. Количественной мерой значимости признака в системе "Эйдос-X++" является ВАРИАБЕЛЬНОСТЬ ЗНАЧЕНИЙ частных критериев, основанных на этом * признаке, по классам в статистических моделях: Abs, Prc1, Prc2 и в моделях знаний: Inf1, Inf2, Inf3, Inf4, Inf5, Inf6, Inf7. Иначе говоря некоторый признак является тем более значимым, чем * больше он в среднем содержит информации о принадлежности обладающего им объекта к одним классам и не принадлежности к другим. X1 := X0 + 20 Y1 := Y0 + Offset - Interval X2 := X1 + 190 Y2 := Y0 + Offset - 1 * Interval GraStringAt( oPS, { X1, Y2-4 }, L('Значимость градации описательной шкалы (ее числового интервального или номинального текстового значения), т.е. признака, представляет ее полезность для решения задачи разделения')) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLUE GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraStringAt( oPS, { 1285, Y2-4 }, L('50% наиболее значимых признаков обеспечивают')+' '+ALLTRIM(STR(ROUND(mVal50a,0)))+'% '+L('суммарной значимости')) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты Y2 := Y0 + Offset - 2 * Interval GraStringAt( oPS, { X1, Y2-4 }, L('объектов с этим признаком по классам. Количественной мерой значимости признака в системе "Эйдос-X++" является ВАРИАБЕЛЬНОСТЬ ЗНАЧЕНИЙ частных критериев, основанных на этом')) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_RED GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraStringAt( oPS, { 1285, Y2-4 }, ALLTRIM(STR(ROUND(mArg50f,0)))+'% '+L('наиболее значимых признаков обеспечивают 50% суммарной значимости')) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты Y2 := Y0 + Offset - 3 * Interval GraStringAt( oPS, { X1, Y2-4 }, L('признаке, по классам в статистических моделях: Abs, Prc1, Prc2 и в моделях знаний: Inf1, Inf2, Inf3, Inf4, Inf5, Inf6, Inf7. Иначе говоря некоторый признак является тем более значимым, чем')) * *** Координаты точки RED ****************************** * mXred = X0 + (mArg50f-aArg[1]) * Kx // <<<===##################### * mYred = Y0A + (0.5*Y_MaxF -aVal[1]) * Ky * *** Координаты точки BLUE ****************************** * mXblue = X0 + (0.5*X_MaxA-aArg[1]) * Kx // <<<===##################### * mYblue = Y0A + (mVal50a -aVal[1]) * Ky mV = SQRT((50-mArg50f)^2+(mVal50a-50)^2)/SQRT((50-0)^2+(100-50)^2)*100 // <<<===##################### GraStringAt( oPS, { 1285, Y2-4 }, L('Качество модели - длина отрезка: {Red,Blue}')+'='+STR(mV,9)+L('% от максимальной') ) AADD(Ar_ModelQuality, STR(mV,14,3)) // Качество модели - расстояние между точками Red-Blue, Ar_ModelRating AADD(Ar_ModelRating , STR(100-mV,14,3)+' '+Ar_Model[mNumMod]) // Рейтинг модели Y2 := Y0 + Offset - 4 * Interval GraStringAt( oPS, { X1, Y2-4 }, L('больше он в среднем содержит информации о принадлежности обладающего им объекта к одним классам и не принадлежности к другим.')) Y2 := Y0 + Offset - 5 * Interval GraStringAt( oPS, { X1, Y2-4 }, L('Путь на отображаемый файл:')+' '+M_PathAppl+"\ParetoGrOpSc\"+"ParetoGrOpSc-"+UPPER(Ar_Model[mNumMod])+".jpg") GraStringAt( oPS, { 1285, Y2-4 }, 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 LC_DrawChart373(oPS, N_Znach, aArg, aVal, mNumMod ) ****** Поиск макс и мин значений аргумента ****** X_MinA = +99999999 // Минимальное значение Y отображаемой функции X_MaxA = -99999999 // Максимальное значение Y отображаемой функции FOR j=1 TO LEN(aArg) X_MinA = MIN(X_MinA, aArg[j]) X_MaxA = MAX(X_MaxA, aArg[j]) NEXT N_aArg = 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]) 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 := 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 ****** Поиск и рисование значения аргумента mArg50f при котором получается значение функции = 50% от максимального RED 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=2 TO LEN(aVal) IF aVal[j] > 0.5 * Y_MaxF ****** Получение более точного значения аргумента и функции путем линейной интерполяции mArg2 = aArg[j ] mArg1 = aArg[j-1] mVal2 = aVal[j ] mVal1 = aVal[j-1] mArg50f = mArg1 + ( 0.5 * Y_MaxF - mVal1 ) / ( mVal2 - mVal1 ) * ( mArg2 - mArg1 ) EXIT ENDIF NEXT mX = X0 + (mArg50f-aArg[1]) * Kx // <===######################## mY = Y0A + (0.5*Y_MaxF -aVal[1]) * Ky GraLine( oPS, { mX, Y0A }, { mX, mY } ) // Нарисовать вертикальный отрезок прямой линии GraLine( oPS, { X0, mY }, { mX, mY } ) // Нарисовать горизонтальный отрезок прямой линии aAttr [ GRA_AL_WIDTH ] := 2 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты GraSetColor( oPS, GRA_CLR_RED, GRA_CLR_RED ) GraArc( oPS, { mX, mY }, 6, ,,, GRA_OUTLINE ) GraSetColor( oPS, GRA_CLR_BLACK, GRA_CLR_BLACK ) ****** Поиск и рисование значения функции mVal50a которое получается при значении аргумента = 50% от максимального BLUE aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_COLOR ] := GRA_CLR_BLUE // Задать цвет линии aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR j=2 TO LEN(aArg) IF aArg[j] > 0.5 * X_MaxA ****** Получение более точного значения аргумента и функции путем линейной интерполяции mArg2 = aArg[j ] mArg1 = aArg[j-1] mVal2 = aVal[j ] mVal1 = aVal[j-1] mVal50a = mVal1 + ( 0.5 * X_MaxA - mArg1 ) / ( mArg2 - mArg1 ) * ( mVal2 - mVal1 ) EXIT ENDIF NEXT mX = X0 + (0.5*X_MaxA-aArg[1]) * Kx // <===######################## mY = Y0A + (mVal50a -aVal[1]) * Ky GraLine( oPS, { mX, Y0A }, { mX, mY } ) // Нарисовать вертикальный отрезок прямой линии GraLine( oPS, { X0, mY }, { mX, mY } ) // Нарисовать горизонтальный отрезок прямой линии aAttr [ GRA_AL_WIDTH ] := 2 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты GraSetColor( oPS, GRA_CLR_BLUE, GRA_CLR_BLUE ) GraArc( oPS, { mX, mY }, 6, ,,, GRA_OUTLINE ) GraSetColor( oPS, GRA_CLR_BLACK, GRA_CLR_BLACK ) * ***** Нарисовать линии, соединяющую точки Red-Blue и максимальную линию * aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии * aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT * aAttr [ GRA_AL_COLOR ] := aColor[107] // Задать цвет линии * aAttr [ GRA_AL_WIDTH ] := 1 // Задать толщину линии * graSetAttrLine( oPS, aAttr ) // Установить атрибуты графической линии * *** Координаты точки RED ****************************** * mXred = X0 + (mArg50f-aArg[1]) * Kx // <===######################## * mYred = Y0A + (0.5*Y_MaxF -aVal[1]) * Ky * *** Координаты точки BLUE ****************************** * mXblue = X0 + (0.5*X_MaxA-aArg[1]) * Kx // <===######################## * mYblue = Y0A + (mVal50a -aVal[1]) * Ky * GraLine( oPS, { mXred, mYred }, { mXblue, mYblue } ) // Нарисовать фактический отрезок Red-Blue * GraLine( oPS, { X0 , mYred }, { mXblue, Y0+H_Wind } ) // Нарисовать максимальный отрезок Red-Blue ***** Нарисовать оси координат ********************************** 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 } ) GraLine( oPS, { 1270, Y1 }, { 1270, Y2 } ) // Нарисовать вертикальную линию, отделяющую левый комментарий от правого ***** Сделать надписи в легенде aAttr[ GRA_AL_COLOR ] := aColor[17] // Задать цвет линии aAttr[ GRA_AL_WIDTH ] := 1 // Задать толщину линии graSetAttrLine( oPS, aAttr ) // Установить атрибуты * Степень детерминированности класса (градации классификационной шкалы) представляет собой количественную оценку суммарной силы влияния всех факторов на переход объекта модели- * рования в состояние, соответствующее классу. Количественной мерой степени детерминированности класса в системе "Эйдос-X++" является ВАРИАБЕЛЬНОСТЬ силы и направления влияния * различных значений факторов по данному классу в статистических: Abs, Prc1, Prc2 и в системно-когнитивных: Inf1, Inf2, Inf3, Inf4, Inf5, Inf6, Inf7 моделях. Иначе говоря степень детерминирован- * ности класса тем выше, чем больше среднее количество информации в различных значений факторов о переходе объекта моделирования в состояние, соответствующее классу. X1 := X0 + 20 Y1 := Y0 + Offset - Interval X2 := X1 + 190 Y2 := Y0 + Offset - 1 * Interval GraStringAt( oPS, { X1, Y2-4 }, L('Степень детерминированности класса (градации классификационной шкалы) представляет собой количественную оценку суммарной силы влияния всех факторов на переход объекта модели-')) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLUE GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraStringAt( oPS, { 1285, Y2-4 }, L('50% наиболее значимых классов обеспечивают')+' '+ALLTRIM(STR(ROUND(mVal50a,0)))+'% '+L('суммарной значимости')) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты Y2 := Y0 + Offset - 2 * Interval GraStringAt( oPS, { X1, Y2-4 }, L('рования в состояние, соответствующее классу. Количественной мерой степени детерминированности класса в системе "Эйдос-X++" является ВАРИАБЕЛЬНОСТЬ силы и направления влияния')) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_RED GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты GraStringAt( oPS, { 1285, Y2-4 }, ALLTRIM(STR(ROUND(mArg50f,0)))+'% '+L('наиболее значимых классов обеспечивают 50% суммарной значимости')) aAttrF [ GRA_AS_COLOR ] := GRA_CLR_BLACK GraSetAttrString( oPS, aAttrF ) // Установить символьные атрибуты Y2 := Y0 + Offset - 3 * Interval GraStringAt( oPS, { X1, Y2-4 }, L('различных значений факторов по данному классу в статистических: Abs, Prc1, Prc2 и в системно-когнитивных: Inf1, Inf2, Inf3, Inf4, Inf5, Inf6, Inf7 моделях. Иначе говоря степень детерминирован-')) GraStringAt( oPS, { 1285, Y2-4 }, L('Расстояние между точками Red-Blue:')+' '+ALLTRIM(STR(ROUND(SQRT((50-mArg50f)^2+(mVal50a-50)^2)/SQRT((50-0)^2+(100-50)^2)*100,0)))+'% от максимально возможного') Y2 := Y0 + Offset - 4 * Interval GraStringAt( oPS, { X1, Y2-4 }, L('ности класса тем выше, чем больше среднее количество информации в различных значений факторов о переходе объекта моделирования в состояние, соответствующее классу.')) Y2 := Y0 + Offset - 5 * Interval GraStringAt( oPS, { X1, Y2-4 }, L('Путь на отображаемый файл:')+' '+M_PathAppl+"\ParetoGrClSc\"+"ParetoGrClSc-"+UPPER(Ar_Model[mNumMod])+".jpg") GraStringAt( oPS, { 1285, Y2-4 }, 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 *************************************************************************************************** FUNCTION ZnachAtr(jj, oRegion) LOCAL i, aData[0] mNameZpr = "Zpr_Inf"+STR(jj,1) SELECT (mNameZpr) INDEX ON STR(999999999999.9999999 - Znach_Atr, 19, 7) TO (mNameZpr) aData := {} aLabel := {} DBGOTOP() DO WHILE .NOT. EOF() AADD(aData , Zn_PrcNit) * AADD(aData , DC_Random(100)) * AADD(aLabel, "[" + STR(Num_prc,mMaxLen) + "]-" + ALLTRIM(Name_atr)) AADD(aLabel, STR(Num_prc,mMaxLen)) DBSKIP(1) ENDDO StrFile(STR(jj), '_Zpr_Inf.txt') // Запись текстового файла с параметром jj * jj = VAL(FileStr('_Zpr_Inf.txt')) // Загрузка параметра jj из текстового файла *oRegion:Title := SUBSTR(ALLTRIM(M_NameAppl) + ". Модель: " + ALLTRIM(Ar_Model[jj]), 1, 255) // Использовать для обновления изображения блок кода oRegion:lineGroup[1,DCRMCHART_LINESERIES_DATA] := aData oRegion:reset() RETURN NIL ************************************************************************************************* ******** Удалить малозначимые признаки из БД Abs (затереть их нулями, т.к. из спр.нельзя удалять) ************************************************************************************************* FUNCTION DelAtrAbs() LOCAL GetList[0], lOk ***************************** @ 0, 0 DCGROUP oGroup CAPTION L('Задайте способ определения удаляемых признаков') SIZE 63.0, 4.7 nRadio = 1 @ 1, 1 DCRADIO nRadio VALUE 1 PROMPT L('Удалить заданный процент наименее значимых признаков:' ) PARENT oGroup @ 2, 1 DCRADIO nRadio VALUE 2 PROMPT L('Удалить заданное количество наименее значимых признаков:') PARENT oGroup @ 3, 1 DCRADIO nRadio VALUE 3 PROMPT L('Удалить наименее значимые признаки, дающие % значимости:') PARENT oGroup N_DelAtr = 33 @ 1.1,50 DCSAY L(" ") GET N_DelAtr PARENT oGroup PICTURE "#######" EDITPROTECT {|| .NOT.nRadio=1 } HIDE {|| .NOT.nRadio=1 } @ 2.1,50 DCSAY L(" ") GET N_DelAtr PARENT oGroup PICTURE "#######" EDITPROTECT {|| .NOT.nRadio=2 } HIDE {|| .NOT.nRadio=2 } @ 3.1,50 DCSAY L(" ") GET N_DelAtr PARENT oGroup PICTURE "#######" EDITPROTECT {|| .NOT.nRadio=3 } HIDE {|| .NOT.nRadio=3 } DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; OPTIONS GetOptions ; ADDBUTTONS ; MODAL ; TITLE L('3.7.5. Удаление малозначимых признаков из БД "Abs.dbf"') ***************************** *************************************************** 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 *************************************************** * StrFile(STR(jj), '_Zpr_Inf.txt') // Запись текстового файла с параметром jj jj = VAL(FileStr('_Zpr_Inf.txt')) // Загрузка параметра jj из текстового файла mNameZpr = "Zpr_Inf"+STR(jj,1) SELECT (mNameZpr) N_Rec = RECCOUNT() INDEX ON STR(Znach_Atr, 19, 7) TO (mNameZpr) DO CASE CASE nRadio=1 // Удалить заданный процент наименее значимых признаков mNum = 0 DBGOTOP() DO WHILE mNum < N_DelAtr * N_Rec * 0.01 mKodAtr = Kod_atr SELECT Abs DBGOTO(mKodAtr) FOR j=3 TO FCOUNT() FIELDPUT(j, 0) NEXT ++mNum SELECT (mNameZpr) REPLACE Delele WITH "Delete" DBSKIP(1) ENDDO CASE nRadio=2 // Удалить заданное количество наименее значимых признаков mNum = 0 DBGOTOP() DO WHILE mNum < N_DelAtr mKodAtr = Kod_atr SELECT Abs DBGOTO(mKodAtr) FOR j=3 TO FCOUNT() FIELDPUT(j, 0) NEXT ++mNum SELECT (mNameZpr) REPLACE Delete WITH "Delete" DBSKIP(1) ENDDO CASE nRadio=3 // Удалить наименее значимые признаки, дающие % значимости mNum = 0 DBGOTOP() DO WHILE mNum < N_DelAtr mKodAtr = Kod_atr SELECT Abs DBGOTO(mKodAtr) FOR j=3 TO FCOUNT() FIELDPUT(j, 0) NEXT mNum = mNum + Znach_prc SELECT (mNameZpr) REPLACE Delete WITH "Delete" DBSKIP(1) ENDDO ENDCASE // Пересчитать итоговые строки и выдать сообщение об окончании SELECT Abs N_Rec = RECCOUNT() N_Col = FCOUNT() PRIVATE aSummaNj[N_Col] PRIVATE aSummaNi[N_Rec] AFILL(aSummaNj, 0) AFILL(aSummaNi, 0) mSummaNij = 0 FOR i=1 TO N_Rec-2 DBGOTO(i) For j=3 TO N_Col-1 Nij = FIELDGET(j) // Ячейка Nij aSummaNj[j] = aSummaNj[j] + Nij // Строка "Сумма абс.частот" aSummaNi[i] = aSummaNi[i] + Nij // Столбец "Сумма абс.частот" по строкам mSummaNij = mSummaNij + Nij // Сумма Nij по всей БД Abs.dbf NEXT NEXT FOR i=1 TO N_Rec-2 DBGOTO(i) FIELDPUT(N_Col, aSummaNi[i]) NEXT DBGOTO(N_Rec-1) FOR j=3 TO N_Col-1 FIELDPUT(j, aSummaNj[j]) NEXT FIELDPUT(N_Col, mSummaNij) mSummaObj = 0 DBGOTO(N_Rec) FOR j=3 TO N_Col-1 mSummaObj = mSummaObj + FIELDGET(j) NEXT FIELDPUT(N_Col, mSummaObj) aMess := {} AADD(aMess, L('Малозначимые признаки удалены из БД "Abs.dbf"')) AADD(aMess, L('Необходимо пересчитать модели в реж.: 3.5.')) LB_Warning(aMess, L('3.7.5. Значимость градаций описательных шкал и абстрагирование')) RETURN NIL ************************************************************************************************* ******** Помощь по режиму 3_7_5 ************************************************************************************************* FUNCTION Help375() aHelp := {} AADD(aHelp, L('Режим: "3.7.5. ЗНАЧИМОСТЬ ГРАДАЦИЙ ОПИСАТЕЛЬНЫХ ШКАЛ". ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Значимость градации описательной шкалы (ее числового интервального или номинального текстового значения), т.е. признака, представляет ')) AADD(aHelp, L('ее полезность для решения задачи разделения объектов с этим признаком по классам. Количественной мерой значимости признака в системе ')) AADD(aHelp, L('"Эйдос-X++" является ВАРИАБЕЛЬНОСТЬ ЗНАЧЕНИЙ частных критериев, основанных на этом признаке, по классам в статистических моделях: ')) AADD(aHelp, L('Abs, Prc1, Prc2 и в моделях знаний: Inf1, Inf2, Inf3, Inf4, Inf5, Inf6, Inf7. Иначе говоря некоторый признак является тем более значимым,')) AADD(aHelp, L('чем больше он в среднем содержит информации о принадлежности обладающего им объекта к одним классам и не принадлежности к другим. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Полные наименования статистических моделей и системно-когнитивных моделей (моделей знаний), отличающихся видом частных критериев: ')) AADD(aHelp, L('1. ABS - частный критерий: количество встреч сочетаний: "класс-признак" у объектов обуч.выборки. ')) AADD(aHelp, L('2. PRC1 - частный критерий: усл. вероятность i-го признака среди признаков объектов j-го класса. ')) AADD(aHelp, L('3. PRC2 - частный критерий: условная вероятность i-го признака у объектов j-го класса. ')) AADD(aHelp, L('4. INF1 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC1. ')) AADD(aHelp, L('5. INF2 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC2. ')) AADD(aHelp, L('6. INF3 - частный критерий: Xи-квадрат, разности между фактическими и ожидаемыми абс.частотами. ')) AADD(aHelp, L('7. INF4 - частный критерий: ROI (Return On Investment); вероятности из PRC1. ')) AADD(aHelp, L('8. INF5 - частный критерий: ROI (Return On Investment); вероятности из PRC2. ')) AADD(aHelp, L('9. INF6 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC1. ')) AADD(aHelp, L('10.INF7 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC2. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('В данном режиме все признаки ранжируются в порядке убывания значимости, а затем рассчитывается и визуализируется в виде графика ')) AADD(aHelp, L('"Значимость нарастающим итогом", которая по сути представляет собой логистическую Парето-кривую. Эта кривая показывает, что небольшая ')) AADD(aHelp, L('часть признаков содержит основную долю их суммарной значимости. Так 10% признаков может содержать 90% их суммарной значимости. ')) AADD(aHelp, L('Незначимые признаки могут быть удалены из модели без ущерба для ее достоверности. Операция удаления незначимых признаков из модели ')) AADD(aHelp, L('входит в число базовых когнитивных операций и называется "Абстрагирование". В результате абстрагирования резко уменьшается размерность')) AADD(aHelp, L('модели без ущерба для ее достоверности, что позволяет сэкономить различные виды человеческих и компьютерных ресурсов, а также время, и')) AADD(aHelp, L('существенно повысить эффективность их использования. В результате работы режима формируются базы данных: Zpr_Inf1.dbf, Zpr_Inf2.dbf, ')) AADD(aHelp, L('..., Zpr_Inf7.dbf. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Однако при удалении любых признаков значимость оставшихся меняется и ранее малозначимые могут стать более значимыми. Поэтому удалять ')) AADD(aHelp, L('сразу все незначимые признаки не рекомендуется, а предлагается делать это небольшими порциями итерационно, переформировывая модели ')) AADD(aHelp, L('после удаления незначимых признаков в режиме 3.5. В DOS-версии системы "Эйдос-12.5" итерации выполнялись автоматически, а в новой - ')) // <<<===######################### AADD(aHelp, L('"Эйдос-Х++" каждую итерацию нужно задавать вручную. Понятно, что при удалении неоправданно большого количества признаков адекватность ')) AADD(aHelp, L('модели будет снижаться, т.е. остающихся признаов уже будет просто недостаточно для полного описания предметной области. Минимальный ')) AADD(aHelp, L('набор признаков, достаточный для адекватного описания предметной области, называется ее конфигуратором. Таким образом, конфигуратор ')) AADD(aHelp, L('предметной области формируется в результате корректного абстрагирования ее модели. Корректность абстрагирования состоит в том, чтобы ')) AADD(aHelp, L('"не выплескивать из ванной вместе с водой и ребенка", т.е. удалять из модели только малозначимые признаки, а наиболее ценные оставить.')) AADD(aHelp, L(' ')) AADD(aHelp, L('После удаления незначимых признаков из модели необходимо выполнить режим 3.5. ')) 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('Помощь по режиму: 3.7.5. Значимость градаций описательных шкал. (C) Система "ЭЙДОС-X++"') RETURN NIL ************************************************************************************************** ************************************************************************************************************ ******** 3.7.4. Значимость описательных шкал ******** В данном режиме описательные шкалы ранжируются в порядке убывания значимости, ******** т.е. средней значимости их градаций, т.е. признаков. Значимость признака - это ******** вариабельность значений частных критериев статистических баз и баз знаний ************************************************************************************************************ FUNCTION F3_7_4() 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 Running(.T.) * LB_Warning(L("Для работы данного режима необходима установить ActiveX на данном компьютере", "Сообщение о неудачном завершении операции" )) * Running(.F.) * RETURN NIL ******* Проверка возможности работать в системе ****************************************** IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF ApplChange("3.7.4()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения 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.; .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('В текущем приложении нет БД Abs, Prc1, Prc2, Inf1-Inf7.')) AADD(aMess, L('Необходимо их создать в 3-й подсистеме (можно в режиме 3.5 !!!')) LB_Warning(aMess, L('3.7.4. Значимость описательных шкал')) 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() // Закрытие всех баз данных с ожиданием завершения операций USE Opis_Sc EXCLUSIVE NEW SELECT Opis_Sc mLN = -999999999 DBGOTOP() DO WHILE .NOT. EOF() mLN = MAX(mLN, LEN(ALLTRIM(Name_OpSc))) DBSKIP(1) ENDDO ***** Создать БД ZOS_Inf# CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций aStructure := { { "Num" , "N", 15, 0 }, ; // Порядковый номер после ранжирования { "Num_prc" , "N", 15, 7 }, ; // Порядковый номер после ранжирования в процентах { "Kod_OpSc" , "N", 15, 0 }, ; // Код описательной шкалы { "Name_OpSc", "C",mLN, 0 }, ; // Наименование описательной шкалы { "N_GrOpSc" , "N", 15, 0 }, ; // Количество градаций в описательной шкалы { "KodGr_min", "N", 15, 0 }, ; // Минимальный код диапазона градаций описательной шкалы { "KodGr_max", "N", 15, 0 }, ; // Максимальный код диапазона градаций описательной шкалы { "Znach_OS" , "N", 19, 7 }, ; // Значимость описательной шкалы в ее единицах измерения { "Zn_OSNit" , "N", 19, 7 }, ; // Значимость описательной шкалы в ее единицах измерения нарастающим итогом { "Znach_Prc", "N", 15, 7 }, ; // Значимость описательной шкалы в процентах от суммы значимостей всех описательных шкал { "Zn_PrcNit", "N", 15, 7 }, ; // Значимость описательной шкалы в процентах от суммы значимостей всех описательных шкал нарастающим итогом { "Delete" , "C", 6, 0 } } // Признак, что данная описательная шкала была удалена из Abs // Создать БД значимости описательных шкал для разных моделей знаний Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } FOR z=1 TO LEN(Ar_Model) M_Inf = 'ZOS_'+Ar_Model[z] DbCreate( M_Inf+".dbf" , aStructure ) NEXT DbCreate( "ZOS_tmp.dbf" , aStructure ) // Посчитать БД ZOS_Inf# CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Abs EXCLUSIVE NEW USE Opis_Sc EXCLUSIVE NEW;N_OpSc = RECCOUNT() USE Gr_OpSc EXCLUSIVE NEW;N_GrOS = RECCOUNT() nMax = 7 * ( 5 * N_OpSc + 2 * N_GrOS ) + 1 Mess = L('3.7.4. Подготовка данных для визуализации значимости описательных шкал') @ 4,5 DCPROGRESS oProgress SIZE 95,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 jj=1 TO LEN(Ar_Model) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Opis_Sc EXCLUSIVE NEW;N_OpSc = RECCOUNT() USE Gr_OpSc EXCLUSIVE NEW;N_GrOS = RECCOUNT() Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } FOR z=1 TO LEN(Ar_Model) M_Inf = 'ZOS_'+Ar_Model[z] USE (M_Inf) EXCLUSIVE NEW NEXT mNameInf = Ar_Model[jj] mNameZOS = 'ZOS_'+Ar_Model[jj] USE (mNameInf) EXCLUSIVE NEW USE (mNameZOS) EXCLUSIVE NEW USE ZOS_tmp EXCLUSIVE NEW;ZAP ****** 1. Копирование кодов и наименований описательных шкал в базы значимостей SELECT Opis_Sc DBGOTOP() DO WHILE .NOT. EOF() mKodOpSc = Kod_OpSc mNameOpSc = Name_OpSc mKodGrMin = KodGr_min mKodGrMax = KodGr_max SELECT (mNameZOS) APPEND BLANK REPLACE Kod_OpSc WITH mKodOpSc REPLACE Name_OpSc WITH mNameOpSc REPLACE KodGr_min WITH mKodGrMin REPLACE KodGr_max WITH mKodGrMax REPLACE Znach_OS WITH 0 DC_GetProgress(oProgress, ++nTime, nMax) // 1 N_OpSc SELECT Opis_Sc DBSKIP(1) ENDDO **** 2. Расчет значимостей описательных шкал ****** Накопление исходных данных для расчета значимости описательных шкал aGgSc := {} // Массив: по коду градации определяем код описательной шкалы SELECT Gr_OpSc DBGOTOP() DO WHILE .NOT.EOF() AADD(aGgSc, Kod_OpSc) DC_GetProgress(oProgress, ++nTime, nMax) // 1 N_GrOS DBSKIP(1) ENDDO aScNgr := {} // Массив: по коду описательной шкалы определяем кол-во градаций в ней SELECT Opis_Sc DBGOTOP() DO WHILE .NOT.EOF() AADD(aScNgr, N_GrOpSc) DC_GetProgress(oProgress, ++nTime, nMax) // 2 N_OpSc DBSKIP(1) ENDDO SELECT (mNameInf) SET FILTER TO Kod_pr > 0 DBGOTOP() DO WHILE .NOT.EOF() M_Recno = RECNO() M_KodAtr = Kod_pr Znach_GOS = Disp M_KodOpSc = aGgSc[M_KodAtr] SELECT (mNameZOS) DBGOTO(M_KodOpSc) M_ZnachOS = Znach_OS REPLACE Znach_OS WITH M_ZnachOS + Znach_GOS REPLACE N_GrOpSc WITH aScNgr[M_KodOpSc] DC_GetProgress(oProgress, ++nTime, nMax) // 2 N_GrOS SELECT (mNameInf) DBGOTO(M_Recno) DBSKIP(1) ENDDO ****** Дорасчет значимости описательных шкал SELECT (mNameZOS) DBGOTOP() DO WHILE .NOT.EOF() REPLACE Znach_OS WITH Znach_OS / N_GrOpSc DC_GetProgress(oProgress, ++nTime, nMax) // 3 N_OpSc DBSKIP(1) ENDDO ****** Логическая сортировка базы по значимости описательных шкал SELECT (mNameZOS) INDEX ON STR(9999999999.9999999 - Znach_OS, 19, 7) TO (mNameZOS) ****** 3. Расчет значимости описательных шкал в ее единицах измерения нарастающим итогом DBGOTOP() mSumZOS = 0 DO WHILE .NOT. EOF() mSumZOS = mSumZOS + Znach_OS REPLACE Zn_OSNit WITH mSumZOS DC_GetProgress(oProgress, ++nTime, nMax) // 4 N_OpSc DBSKIP(1) ENDDO ****** 4. Расчет значимости описательных шкал в процентах от суммы значимостей всех признаков и нарастающим итогом в процентах mMaxLen = 15 mNumPP = 0 mSumZnPrc = 0 DBGOTOP() DO WHILE .NOT. EOF() mZnPrc = Znach_OS / mSumZOS * 100 mSumZnPrc = mSumZnPrc + mZnPrc REPLACE Num WITH ++mNumPP REPLACE Num_prc WITH mNumPP / N_OpSc * 100 REPLACE Znach_Prc WITH mZnPrc REPLACE Zn_PrcNit WITH mSumZnPrc mMaxLen = MAX(mMaxLen, LEN(ALLTRIM(STR(ROUND(Num_prc,0))))) DC_GetProgress(oProgress, ++nTime, nMax) // 5 N_OpSc DBSKIP(1) ENDDO ***** Физическая сортировка (mNameZOS) SELECT (mNameZOS) DBGOTOP() DO WHILE .NOT. EOF() ar := {} FOR j=1 TO FCOUNT() AADD(ar, FIELDGET(j)) NEXT SELECT ZOS_tmp APPEND BLANK FOR j=1 TO LEN(ar) FIELDPUT(j, ar[j]) NEXT DC_GetProgress(oProgress, ++nTime, nMax) // 4 SELECT (mNameZOS) DBSKIP(1) ENDDO SELECT (mNameZOS);ZAP SELECT ZOS_tmp DBGOTOP() DO WHILE .NOT. EOF() ar := {} FOR j=1 TO FCOUNT() AADD(ar, FIELDGET(j)) NEXT SELECT (mNameZOS) APPEND BLANK FOR j=1 TO LEN(ar) FIELDPUT(j, ar[j]) NEXT DC_GetProgress(oProgress, ++nTime, nMax) // 5 SELECT ZOS_tmp DBSKIP(1) ENDDO ***** ############################################################################################################################## ***** Сюда вставить визуализацию графиков как в значимости градаций описательных шкал или как в режиме 4.7.5. ####### ***** ############################################################################################################################## NEXT DC_GetProgress(oProgress,nMax,nMax) oDialog:Destroy() ***** ВИЗУАЛИЗАЦИЯ ГРАФИКА ************************************************************* CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Opis_Sc EXCLUSIVE NEW;N_OpSc = RECCOUNT() USE Gr_OpSc EXCLUSIVE NEW;N_GrOS = RECCOUNT() Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } FOR jj=1 TO LEN(Ar_Model) mNameInf = Ar_Model[jj] mNameZOS = 'ZOS_'+Ar_Model[jj] USE (mNameInf) EXCLUSIVE NEW USE (mNameZOS) EXCLUSIVE NEW NEXT ***** Закрыть txt-базы ***** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций FOR z=1 TO LEN(nHandle) FClose( nHandle[z] ) // Закрытие txt баз данных ###################################### NEXT ********** Копирование БД Zos_Inf#.dbf => Zos_Inf#.xls CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций FOR jj=1 TO LEN(Ar_Model) mNameZosDbf = "ZOS_"+Ar_Model[jj]+".dbf" mNameZosXls = "ZOS_"+Ar_Model[jj]+".xls" COPY FILE (mNameZosDbf) TO (mNameZosXls) NEXT ************************************************************** aMess := {} AADD(aMess, L('Результаты расчета значимости описательных шкал содержатся в базах данных статистических и интеллектуальных моделей:')) AADD(aMess, L('"ZOS_Abs.xlsx","ZOS_Prc1.xlsx","ZOS_Prc2.xlsx","ZOS_Inf1.xlsx","ZOS_Inf2.xlsx","ZOS_Inf3.xlsx","ZOS_Inf4.xlsx","ZOS_Inf5.xlsx",')) AADD(aMess, L('"ZOS_Inf6.xlsx","ZOS_Inf7.xlsx" в папке текущего приложения: '+M_PathAppl+'.')) AADD(aMess, L(' ')) AADD(aMess, L('Эти MS Excel файлы создаются в режиме 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 ************************************************************************************************* FUNCTION ZnachOS(jj, oRegion) LOCAL i, aData[0] mNameZOS = "ZOS_Inf"+STR(jj,1) SELECT (mNameZOS) INDEX ON STR(99999999.9999999 - Znach_OS, 15, 7) TO (mNameZOS) aData := {} aLabel := {} DBGOTOP() DO WHILE .NOT. EOF() AADD(aData , Zn_PrcNit) * AADD(aData , DC_Random(100)) * AADD(aLabel, "[" + STR(Num_prc,mMaxLen) + "]-" + ALLTRIM(Name_OS)) AADD(aLabel, STR(Num_prc,mMaxLen)) DBSKIP(1) ENDDO StrFile(STR(jj), '_ZOS_Inf.txt') // Запись текстового файла с параметром jj * jj = VAL(FileStr('_ZOS_Inf.txt')) // Загрузка параметра jj из текстового файла *oRegion:lineGroup[1,DCRMCHART_LINESERIES_DATA] := aData *oRegion:reset() RETURN NIL ************************************************************************************************************************** ******** 3.7.2. Значимость классификационных шкал ******** В данном режиме классификационные шкалы ранжируются в порядке убывания значимости, ******** т.е. средней значимости их градаций (степени детерминированности классов). ******** Детерминированность класса - это вариабельность значений частных критериев статистических баз и баз знаний ************************************************************************************************************************** FUNCTION F3_7_2() 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 Running(.T.) ******* Проверка возможности работать в системе ****************************************** IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF ApplChange("3.7.2()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения 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.; .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('В текущем приложении нет БД Abs, Prc1, Prc2, Inf1-Inf7.')) AADD(aMess, L('Необходимо их создать в 3-й подсистеме (можно в режиме 3.5 !!!')) LB_Warning(aMess, L('3.7.4. Значимость описательных шкал')) Running(.F.) RETURN NIL ENDIF ***** Копировать txt=>dbf mLenNameMax = CreateStructAll() // Создание файлов структур баз данных всех моделей CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() // Количество классов (градаций классификационных шкал) USE Gr_ClSc EXCLUSIVE NEW USE Class_Sc EXCLUSIVE NEW COPY_TXT_DBF() // Преобразовать INF#.TXT => INF#.DBF ****** Открытие основных БД.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() // Закрытие всех баз данных с ожиданием завершения операций USE Class_Sc EXCLUSIVE NEW SELECT Class_Sc mLN = -999999999 DBGOTOP() DO WHILE .NOT. EOF() mLN = MAX(mLN, LEN(ALLTRIM(Name_ClSc))) DBSKIP(1) ENDDO ***** Создать БД ZOS_Inf# CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций aStructure := { { "Num" , "N", 15, 0 }, ; // Порядковый номер после ранжирования { "Num_prc" , "N", 15, 7 }, ; // Порядковый номер после ранжирования в процентах { "Kod_ClSc" , "N", 15, 0 }, ; // Код классификационной шкалы { "Name_ClSc", "C",mLN, 0 }, ; // Наименование классификационной шкалы { "N_GrClSc" , "N", 15, 0 }, ; // Количество градаций классификационной шкалы { "KodGr_min", "N", 15, 0 }, ; // Минимальный код диапазона градаций классификационной шкалы { "KodGr_max", "N", 15, 0 }, ; // Максимальный код диапазона градаций классификационной шкалы { "Znach_CS" , "N", 19, 7 }, ; // Значимость классификационной шкалы в ее единицах измерения { "Zn_CSNit" , "N", 19, 7 }, ; // Значимость классификационной шкалы в ее единицах измерения нарастающим итогом { "Znach_Prc", "N", 15, 7 }, ; // Значимость классификационной шкалы в процентах от суммы значимостей всех классификационных шкал { "Zn_PrcNit", "N", 15, 7 }, ; // Значимость классификационной шкалы в процентах от суммы значимостей всех классификационных шкал нарастающим итогом { "Delete" , "C", 6, 0 } } // Признак, что данная классификационная шкала была удалена из Abs // Создать БД значимости описательных шкал для разных моделей знаний Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } FOR z=1 TO LEN(Ar_Model) M_Inf = 'ZCS_'+Ar_Model[z] DbCreate( M_Inf+".dbf" , aStructure ) NEXT DbCreate( "ZCS_tmp.dbf" , aStructure ) // Посчитать БД ZCS_Inf# CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Class_Sc EXCLUSIVE NEW;N_ClSc = RECCOUNT() USE Gr_ClSc EXCLUSIVE NEW;N_GrCS = RECCOUNT() nMax = 7 * ( 5 * N_ClSc + 2 * N_GrCS ) + 1 Mess = L('3.7.4. Подготовка данных для визуализации значимости классификационных шкал') @ 4,5 DCPROGRESS oProgress SIZE 95,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 jj=1 TO LEN(Ar_Model) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Class_Sc EXCLUSIVE NEW;N_ClSc = RECCOUNT() USE Gr_ClSc EXCLUSIVE NEW;N_GrCS = RECCOUNT() Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } FOR z=1 TO LEN(Ar_Model) M_Inf = 'ZCS_'+Ar_Model[z] USE (M_Inf) EXCLUSIVE NEW NEXT mNameInf = Ar_Model[jj] mNameZCS = 'ZCS_'+Ar_Model[jj] USE (mNameInf) EXCLUSIVE NEW USE (mNameZCS) EXCLUSIVE NEW USE ZCS_tmp EXCLUSIVE NEW;ZAP ****** 1. Копирование кодов и наименований классификационных шкал в базы значимостей SELECT Class_Sc DBGOTOP() DO WHILE .NOT. EOF() mKodClSc = Kod_ClSc mNameClSc = Name_ClSc mKodGrMin = KodGr_min mKodGrMax = KodGr_max SELECT (mNameZCS) APPEND BLANK REPLACE Kod_ClSc WITH mKodClSc REPLACE Name_ClSc WITH mNameClSc REPLACE KodGr_min WITH mKodGrMin REPLACE KodGr_max WITH mKodGrMax REPLACE Znach_CS WITH 0 DC_GetProgress(oProgress, ++nTime, nMax) // 1 N_OpSc SELECT Class_Sc DBSKIP(1) ENDDO **** 2. Расчет значимостей описательных шкал ****** Накопление исходных данных для расчета значимости классификационных шкал aGgSc := {} // Массив: по коду градации определяем код классификационной шкалы SELECT Gr_ClSc DBGOTOP() DO WHILE .NOT.EOF() AADD(aGgSc, Kod_ClSc) DC_GetProgress(oProgress, ++nTime, nMax) // 1 N_GrOS DBSKIP(1) ENDDO aScNgr := {} // Массив: по коду классификационной шкалы определяем кол-во градаций в ней SELECT Class_Sc DBGOTOP() DO WHILE .NOT.EOF() AADD(aScNgr, N_GrClSc) DC_GetProgress(oProgress, ++nTime, nMax) // 2 N_OpSc DBSKIP(1) ENDDO SELECT (mNameInf) DBGOBOTTOM();DBGOTOP();DBGOBOTTOM() FOR M_KodCls = 1 TO N_Cls IF jj=1 DBGOBOTTOM();DBSKIP(-1) ELSE DBGOBOTTOM() ENDIF Znach_GCS = FIELDGET(2+M_KodCls) M_KodClSc = aGgSc[M_KodCls] SELECT (mNameZCS) DBGOTO(M_KodClSc) M_ZnachCS = Znach_CS REPLACE Znach_CS WITH M_ZnachCS + Znach_GCS REPLACE N_GrClSc WITH aScNgr[M_KodClSc] DC_GetProgress(oProgress, ++nTime, nMax) // 2 N_GrCS SELECT (mNameInf) NEXT ****** Дорасчет значимости классификационных шкал SELECT (mNameZCS) DBGOTOP() DO WHILE .NOT.EOF() REPLACE Znach_CS WITH Znach_CS / N_GrClSc DC_GetProgress(oProgress, ++nTime, nMax) // 3 N_ClSc DBSKIP(1) ENDDO ****** Логическая сортировка базы по значимости классификационных шкал SELECT (mNameZCS) INDEX ON STR(9999999999.9999999 - Znach_CS, 19, 7) TO (mNameZCS) ****** 3. Расчет значимости классификационных шкал в ее единицах измерения нарастающим итогом DBGOTOP() mSumZCS = 0 DO WHILE .NOT. EOF() mSumZCS = mSumZCS + Znach_CS REPLACE Zn_CSNit WITH mSumZCS DC_GetProgress(oProgress, ++nTime, nMax) // 4 N_ClSc DBSKIP(1) ENDDO ****** 4. Расчет значимости классификационных шкал в процентах от суммы значимостей всех классов и нарастающим итогом в процентах mMaxLen = 15 mNumPP = 0 mSumZnPrc = 0 DBGOTOP() DO WHILE .NOT. EOF() mZnPrc = Znach_CS / mSumZCS * 100 mSumZnPrc = mSumZnPrc + mZnPrc REPLACE Num WITH ++mNumPP REPLACE Num_prc WITH mNumPP / N_ClSc * 100 REPLACE Znach_Prc WITH mZnPrc REPLACE Zn_PrcNit WITH mSumZnPrc mMaxLen = MAX(mMaxLen, LEN(ALLTRIM(STR(ROUND(Num_prc,0))))) DC_GetProgress(oProgress, ++nTime, nMax) // 5 N_OpSc DBSKIP(1) ENDDO ***** Физическая сортировка (mNameZOS) SELECT (mNameZCS) DBGOTOP() DO WHILE .NOT. EOF() ar := {} FOR j=1 TO FCOUNT() AADD(ar, FIELDGET(j)) NEXT SELECT ZCS_tmp APPEND BLANK FOR j=1 TO LEN(ar) FIELDPUT(j, ar[j]) NEXT DC_GetProgress(oProgress, ++nTime, nMax) // 4 SELECT (mNameZCS) DBSKIP(1) ENDDO SELECT (mNameZCS);ZAP SELECT ZCS_tmp DBGOTOP() DO WHILE .NOT. EOF() ar := {} FOR j=1 TO FCOUNT() AADD(ar, FIELDGET(j)) NEXT SELECT (mNameZCS) APPEND BLANK FOR j=1 TO LEN(ar) FIELDPUT(j, ar[j]) NEXT DC_GetProgress(oProgress, ++nTime, nMax) // 5 SELECT ZCS_tmp DBSKIP(1) ENDDO ***** ############################################################################################################################## ***** Сюда можно вставить визуализацию графиков как в значимости градаций описательных шкал или как в режиме 4.7.5. ####### ***** ############################################################################################################################## NEXT DC_GetProgress(oProgress,nMax,nMax) oDialog:Destroy() ***** Закрыть txt-базы ***** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций FOR z=1 TO LEN(nHandle) FClose( nHandle[z] ) // Закрытие txt баз данных ###################################### NEXT ********** Копирование БД Zсs_Inf#.dbf => Zсs_Inf#.xls CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций FOR jj=1 TO LEN(Ar_Model) mNameZcsDbf = "ZCS_"+Ar_Model[jj]+".dbf" mNameZcsXls = "ZCS_"+Ar_Model[jj]+".xls" COPY FILE (mNameZcsDbf) TO (mNameZcsXls) NEXT aMess := {} AADD(aMess, L('Результаты расчета значимости классификационных шкал содержатся в базах данных статистических и интеллектуальных моделей:')) AADD(aMess, L('"ZCS_Abs.xlsx","ZCS_Prc1.xlsx","ZCS_Prc2.xlsx","ZCS_Inf1.xlsx","ZCS_Inf2.xlsx","ZCS_Inf3.xlsx","ZCS_Inf4.xlsx","ZCS_Inf5.xlsx",')) AADD(aMess, L('"ZCS_Inf6.xlsx","ZCS_Inf7.xlsx" в папке текущего приложения: '+M_PathAppl+'.')) AADD(aMess, L(' ')) AADD(aMess, L('Эти MS Excel файлы создаются в режиме 5.12. Они практичеси готовы для печати и получения графиков.')) AADD(aMess, L(' ')) AADD(aMess, L('Значимость классификационной шкалы является средним значимостей ее градаций, т.е. классов.')) AADD(aMess, L(' ')) AADD(aMess, L('Значимость градации классификационной шкалы, т.е. класса, представляет собой вариабельность количества информации')) AADD(aMess, L('в во всех признаках модели о принадлежности или не принадлежности объекта с этим признаками к данному классу.')) AADD(aMess, L('Значимость градации классификационной шкалы (класса) - это степень детерминированности этого класса (см.режим 3.7.3).')) LB_Warning(aMess, L("Сообщение об успешном завершении операции" )) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ************************************************************************************************* FUNCTION ZnachCS(jj, oRegion) LOCAL i, aData[0] mNameZCS = "ZCS_Inf"+STR(jj,1) SELECT (mNameZCS) INDEX ON STR(99999999.9999999 - Znach_OS, 15, 7) TO (mNameZCS) aData := {} aLabel := {} DBGOTOP() DO WHILE .NOT. EOF() AADD(aData , Zn_PrcNit) * AADD(aData , DC_Random(100)) * AADD(aLabel, "[" + STR(Num_prc,mMaxLen) + "]-" + ALLTRIM(Name_OS)) AADD(aLabel, STR(Num_prc,mMaxLen)) DBSKIP(1) ENDDO StrFile(STR(jj), '_ZCS_Inf.txt') // Запись текстового файла с параметром jj * jj = VAL(FileStr('_ZCS_Inf.txt')) // Загрузка параметра jj из текстового файла *oRegion:lineGroup[1,DCRMCHART_LINESERIES_DATA] := aData *oRegion:reset() RETURN NIL *########################################################################################################## *********************************************************************************************************** ******** Удалить малозначимые описательные шкалы из БД Abs (затереть их нулями, т.к. из спр.нельзя удалять) *********************************************************************************************************** FUNCTION DelOSAbs() LOCAL GetList[0], lOk ***************************** @ 0, 0 DCGROUP oGroup CAPTION L('Задайте способ определения удаляемых описательных шкал') SIZE 72.0, 4.7 nRadio = 1 @ 1, 1 DCRADIO nRadio VALUE 1 PROMPT L('Удалить заданный процент наименее значимых описательных шкал:' ) PARENT oGroup @ 2, 1 DCRADIO nRadio VALUE 2 PROMPT L('Удалить заданное количество наименее значимых описательных шкал:') PARENT oGroup @ 3, 1 DCRADIO nRadio VALUE 3 PROMPT L('Удалить наименее знач.опис.шкалы, дающие % суммарной значимости:') PARENT oGroup N_DelOS = 33 @ 1.1,57 DCSAY L(" ") GET N_DelOS PARENT oGroup PICTURE "#######" EDITPROTECT {|| .NOT.nRadio=1 } HIDE {|| .NOT.nRadio=1 } @ 2.1,57 DCSAY L(" ") GET N_DelOS PARENT oGroup PICTURE "#######" EDITPROTECT {|| .NOT.nRadio=2 } HIDE {|| .NOT.nRadio=2 } @ 3.1,57 DCSAY L(" ") GET N_DelOS PARENT oGroup PICTURE "#######" EDITPROTECT {|| .NOT.nRadio=3 } HIDE {|| .NOT.nRadio=3 } DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; OPTIONS GetOptions ; ADDBUTTONS ; MODAL ; TITLE L('3.7.4. Удаление малозначимых описательных шкал из БД "Abs.dbf"') ***************************** *************************************************** 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 *************************************************** * StrFile(STR(jj), '_ZOS_Inf.txt') // Запись текстового файла с параметром jj jj = VAL(FileStr('_ZOS_Inf.txt')) // Загрузка параметра jj из текстового файла mNameZOS = "ZOS_Inf"+STR(jj,1) * MsgBox(mNameZOS) SELECT (mNameZOS) N_Rec = RECCOUNT() INDEX ON STR(Znach_OS, 19, 7) TO (mNameZOS) DO CASE CASE nRadio=1 // Удалить заданный процент наименее значимых описательных шкал mNum = 0 DBGOTOP() DO WHILE mNum < N_DelOS * N_Rec * 0.01 mKodOS = Kod_OpSc SELECT Opis_Sc DBGOTO(mKodOS) mKodGrMin = KodGr_min mKodGrMax = KodGr_max SELECT Abs FOR mr = mKodGrMin TO mKodGrMax DBGOTO(mr) FOR j=3 TO FCOUNT() FIELDPUT(j, 0) NEXT NEXT ++mNum SELECT (mNameZOS) REPLACE Delete WITH "Delete" DBSKIP(1) ENDDO CASE nRadio=2 // Удалить заданное количество наименее значимых описательных шкал mNum = 0 DBGOTOP() DO WHILE mNum < N_DelOS mKodOS = Kod_OpSc SELECT Opis_Sc DBGOTO(mKodOS) mKodGrMin = KodGr_min mKodGrMax = KodGr_max SELECT Abs FOR mr = mKodGrMin TO mKodGrMax DBGOTO(mr) FOR j=3 TO FCOUNT() FIELDPUT(j, 0) NEXT NEXT ++mNum SELECT (mNameZOS) REPLACE Delete WITH "Delete" DBSKIP(1) ENDDO CASE nRadio=3 // Удалить наименее знач.опис.шкалы, дающие % суммарной значимости mNum = 0 DBGOTOP() DO WHILE mNum < N_DelOS mKodOS = Kod_OpSc SELECT Opis_Sc DBGOTO(mKodOS) mKodGrMin = KodGr_min mKodGrMax = KodGr_max SELECT Abs FOR mr = mKodGrMin TO mKodGrMax DBGOTO(mr) FOR j=3 TO FCOUNT() FIELDPUT(j, 0) NEXT NEXT mNum = mNum + Znach_prc SELECT (mNameZOS) REPLACE Delete WITH "Delete" DBSKIP(1) ENDDO ENDCASE // Пересчитать итоговые строки и выдать сообщение об окончании SELECT Abs N_Rec = RECCOUNT() N_Col = FCOUNT() PRIVATE aSummaNj[N_Col] PRIVATE aSummaNi[N_Rec] AFILL(aSummaNj, 0) AFILL(aSummaNi, 0) mSummaNij = 0 FOR i=1 TO N_Rec-2 DBGOTO(i) For j=3 TO N_Col-1 Nij = FIELDGET(j) // Ячейка Nij aSummaNj[j] = aSummaNj[j] + Nij // Строка "Сумма абс.частот" aSummaNi[i] = aSummaNi[i] + Nij // Столбец "Сумма абс.частот" по строкам mSummaNij = mSummaNij + Nij // Сумма Nij по всей БД Abs.dbf NEXT NEXT FOR i=1 TO N_Rec-2 DBGOTO(i) FIELDPUT(N_Col, aSummaNi[i]) NEXT DBGOTO(N_Rec-1) FOR j=3 TO N_Col-1 FIELDPUT(j, aSummaNj[j]) NEXT FIELDPUT(N_Col, mSummaNij) mSummaObj = 0 DBGOTO(N_Rec) FOR j=3 TO N_Col-1 mSummaObj = mSummaObj + FIELDGET(j) NEXT FIELDPUT(N_Col, mSummaObj) aMess := {} AADD(aMess, L('Малозначимые описательные шкалы удалены из БД "Abs.dbf"')) AADD(aMess, L('Необходимо пересчитать модели в реж.: 3.2 и 3.3')) LB_Warning(aMess, L('3.7.4. Значимость описательных шкал')) RETURN NIL ************************************************************************************************* ******** Помощь по режиму 3_7_4 ************************************************************************************************* FUNCTION Help374() aHelp := {} AADD(aHelp, L('Режим: "3.7.4. ЗНАЧИМОСТЬ ОПИСАТЕЛЬНЫХ ШКАЛ". ')) AADD(aHelp, L(' ')) AADD(aHelp, L('За значимость описательной шкалы в системе Эйдос-Х++ принимается СРЕДНЕЕ от значимостей ее градаций. Значимость описательной шкалы ')) AADD(aHelp, L('представляет собой ее полезность для решения задачи разделения объектов по классам. Количественной мерой значимости признака в системе')) AADD(aHelp, L('"Эйдос-X++" является ВАРИАБЕЛЬНОСТЬ ЗНАЧЕНИЙ частных критериев, основанных на этом признаке, по классам в статистических моделях: Abs,')) AADD(aHelp, L('Prc1, Prc2 и в моделях знаний: Inf1, Inf2, Inf3, Inf4, Inf5, Inf6, Inf7. Иначе говоря, некоторый признак является тем более значимым, ')) AADD(aHelp, L('чем больше он в среднем содержит информации о принадлежности обладающего им объекта к одним ')) AADD(aHelp, L('классам и не принадлежности к другим. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Полные наименования стат.моделей и моделей знаний, отличающихся видом частных критериев: ')) AADD(aHelp, L('1. ABS - частный критерий: количество встреч сочетаний: "класс-признак" у объектов обуч.выборки. ')) AADD(aHelp, L('2. PRC1 - частный критерий: усл. вероятность i-го признака среди признаков объектов j-го класса. ')) AADD(aHelp, L('3. PRC2 - частный критерий: условная вероятность i-го признака у объектов j-го класса. ')) AADD(aHelp, L('4. INF1 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC1. ')) AADD(aHelp, L('5. INF2 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC2. ')) AADD(aHelp, L('6. INF3 - частный критерий: Xи-квадрат, разности между фактическими и ожидаемыми абс.частотами. ')) AADD(aHelp, L('7. INF4 - частный критерий: ROI (Return On Investment); вероятности из PRC1. ')) AADD(aHelp, L('8. INF5 - частный критерий: ROI (Return On Investment); вероятности из PRC2. ')) AADD(aHelp, L('9. INF6 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC1. ')) AADD(aHelp, L('10.INF7 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC2. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('В данном режиме все описательные шкалы ранжируются в порядке убывания значимости, а затем рассчитывается и визуализируется в виде ')) AADD(aHelp, L('графика "Значимость нарастающим итогом", которая, по сути, представляет собой логистическую Парето-кривую. Эта кривая показывает, что ')) AADD(aHelp, L('небольшая часть описательных шкал содержит основную долю их суммарной значимости. Так, например, 10% описательных шкал может содержать')) AADD(aHelp, L('90% их суммарной значимости. Незначимые описательные шкалы могут быть удалены из модели без ущерба для ее достоверности. Операция ')) AADD(aHelp, L('удаления незначимых описательных шкал из модели входит в число базовых когнитивных операций и называется "Абстрагирование". В ')) AADD(aHelp, L('результате абстрагирования резко уменьшается размерность модели без ущерба для ее достоверности, что позволяет сэкономить различные ')) AADD(aHelp, L('виды человеческих и компьютерных ресурсов, а также время, и существенно повысить эффективность их использования. В результате работы ')) AADD(aHelp, L('режима формируются базы данных: ZOS_Inf1.dbf, ZOS_Inf2.dbf, ..., ZOS_Inf7.dbf. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Однако при удалении любых описательных шкал значимость оставшихся меняется и ранее малозначимые шкалы могут стать более значимыми. ')) AADD(aHelp, L('Поэтому удалять сразу все малозначимые описательные шкалы не рекомендуется, а предлагается делать это небольшими порциями итерационно,')) AADD(aHelp, L('переформировывая модели после удаления незначимых описательных шкал в режиме 3.4. Необходимо понимать, что при удалении неоправданно ')) AADD(aHelp, L('большого количества описательных шкал адекватность модели будет снижаться, т.е. остающихся уже будет просто недостаточно для ')) AADD(aHelp, L('адекватного описания предметной области. Минимальный набор описательных шкал, достаточный для адекватного описания предметной области,')) AADD(aHelp, L('называется ее конфигуратором. Таким образом, конфигуратор предметной области формируется в результате корректного абстрагирования ее ')) AADD(aHelp, L('модели. Корректность абстрагирования состоит в том, чтобы "не выплескивать из ванной вместе ')) AADD(aHelp, L('с водой и ребенка". ')) AADD(aHelp, L(' ')) AADD(aHelp, L('В данном режиме удаление малозначимых описательных шкал осуществляется путем обнуления абсолютных частот в базе Abs.dbf, связанных со ')) AADD(aHelp, L('всеми градациями удаляемых шкал. Это позволяет оценить параметры модели. Однако эти шкалы остаются в справочнике, а коды их градаций -')) AADD(aHelp, L('в обучающей и распознаваемой выборке. Чтобы удалить их и оттуда необходимо переформировать модель в режиме 2.3.2.2, предварительно ')) AADD(aHelp, L('вручную удалив наименее значимые описательные шкалы из файла исходных данных Inp_data. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('После удаления незначимых признаков в БД Abs.dbf необходимо выполнить режимы 3.2 и 3.3. При желании можно восстановить БД Abs.dbf, ')) 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('Помощь по режиму: 3.7.4. Значимость описательных шкал. (C) Система "ЭЙДОС-X++"') RETURN NIL ************************************************************************************************** *********************************************************************************************************************** ******** 4.3.1. Графическое отображение информационного портрета атрибута (признака) *********************************************************************************************************************** FUNCTION IPA_Chart() IF .NOT. FILE("Abs.dbf") .OR.; // БД абс.частот .NOT. FILE("Prc1.dbf") .OR.; // БД процентных распределений .NOT. FILE("Prc2.dbf") .OR.; .NOT. FILE("Inf1.dbf") .OR.; .NOT. FILE("Inf1.dbf") .OR.; .NOT. FILE("Inf1.dbf") .OR.; .NOT. FILE("Inf1.dbf") .OR.; .NOT. FILE("Inf1.dbf") .OR.; .NOT. FILE("Inf1.dbf") .OR.; .NOT. FILE("Inf1.dbf") aMess := {} AADD(aMess, L('В текущем приложении нет БД Abs, Prc1, Prc2, Inf1-Inf7.')) AADD(aMess, L('Необходимо их создать в 3-й подсистеме (можно в режиме 3.5) !!!')) LB_Warning(aMess, L('4.3.1. Информационные портреты признаков')) RETURN NIL ENDIF SELECT Inf M_Recno = RECNO() M_KodPr = Kod_pr M_NamePr = Name PUBLIC MessIPA := L('Инф.портрет признака: ')+ALLTRIM(STR(M_KodPr, 15))+' "'+ALLTRIM(M_NamePr)+'" в модели: '+ALLTRIM(STR(M_CurrInf, 15))+' "'+UPPER(Ar_Model[M_CurrInf]+'"') LB_Warning(MessIPA) SELECT InfPortAtr aData := {} aLabel := {} DBGOTOP() DO WHILE .NOT. EOF() AADD(aData , Zn_PrcNit) * AADD(aLabel, "[" + STR(Num_prc,mMaxLen) + "]-" + ALLTRIM(Name_OS)) AADD(aLabel, STR(Num_prc,mMaxLen)) DBSKIP(1) ENDDO ***** ВИЗУАЛИЗАЦИЯ ГРАФИКА ************************************************************* ***** Размер окна для отображения графика ********************************************** * --- RMChart ActiveX Control -- @ 0,0 DCRMCHART oRmChart SIZE 1140, 640 RESIZE DCGUI_RESIZE_RESIZEONLY IF LEN(aData) < 20 DcAddLineGroup TO aLineGroupIndus ; DATA aData ; WHICHDATAAXIS 2 ; STYLE RMC_LINE_CABLE ; COLOR Green ; LINESTYLE RMC_LSTYLE_LINE ; SYMBOLSTYLE RMC_SYMBOL_BULLET ; VALUELABEL 1 ELSE DcAddLineGroup TO aLineGroupIndus ; DATA aData ; WHICHDATAAXIS 2 ; STYLE RMC_LINE_CABLE ; COLOR Green ; LINESTYLE RMC_LSTYLE_LINE ; SYMBOLSTYLE RMC_SYMBOL_BULLET ENDIF **************************************************************************************** DcAddDataAxis TO aDataAxis6 ; AXISTEXT L('Суммарная значимость описательных шкал "нарастающим итогом" в %') ; ALIGN RMC_DATAAXISLEFT ; MINVALUE 0 MAXVALUE 100 @ 380,480 DCGRASTRING L("Описательные шкалы в %") COLOR Black FONT '11.Tahona' // Использовать для обновления изображения блок кода mTitle = SUBSTR(ALLTRIM(M_NameAppl) + ". Модель: " + ALLTRIM(Ar_Model[jj]), 1, 255) // Использовать для обновления изображения блок кода @ 10,10 DcChartRegion oRegion6 ; // Координаты нижнего левого угла поля построения графика в окне PARENT oRMChart ; SIZE 1100, 555 PIXEL ; // Размер поля построения графика в окне 1100 x 600 CAPTION TITLE mTitle BACKCOLOR White TEXTCOLOR Black FONTSIZE 10 BOLD ; GRID ; DATAAXIS aDataAxis6 ; LABELAXIS LABELARRAY aLabel ALIGN RMC_LABELAXISBOTTOM ; LINEGROUP aLineGroupIndus **************************************************************************************** ***** Кнопки визу ********************************************************************** @ 620, 0 DCPUSHBUTTON CAPTION L('Помощь') SIZE 60,25 ACTION {||Help374()} @ DCGUI_ROW, DCGUI_COL + 5 DCPUSHBUTTON CAPTION L('Inf1') SIZE 34,25 TOOLTIP L('Переключиться на работу с базой знаний "Inf1"') ACTION {||ZnachOS(1, oRegion6), oRMChart:draw()} @ DCGUI_ROW, DCGUI_COL + 2 DCPUSHBUTTON CAPTION L('Inf2') SIZE 34,25 TOOLTIP L('Переключиться на работу с базой знаний "Inf2"') ACTION {||ZnachOS(2, oRegion6), oRMChart:draw()} @ DCGUI_ROW, DCGUI_COL + 2 DCPUSHBUTTON CAPTION L('Inf3') SIZE 34,25 TOOLTIP L('Переключиться на работу с базой знаний "Inf3"') ACTION {||ZnachOS(3, oRegion6), oRMChart:draw()} @ DCGUI_ROW, DCGUI_COL + 2 DCPUSHBUTTON CAPTION L('Inf4') SIZE 34,25 TOOLTIP L('Переключиться на работу с базой знаний "Inf4"') ACTION {||ZnachOS(4, oRegion6), oRMChart:draw()} @ DCGUI_ROW, DCGUI_COL + 2 DCPUSHBUTTON CAPTION L('Inf5') SIZE 34,25 TOOLTIP L('Переключиться на работу с базой знаний "Inf5"') ACTION {||ZnachOS(5, oRegion6), oRMChart:draw()} @ DCGUI_ROW, DCGUI_COL + 2 DCPUSHBUTTON CAPTION L('Inf6') SIZE 34,25 TOOLTIP L('Переключиться на работу с базой знаний "Inf6"') ACTION {||ZnachOS(6, oRegion6), oRMChart:draw()} @ DCGUI_ROW, DCGUI_COL + 2 DCPUSHBUTTON CAPTION L('Inf7') SIZE 34,25 TOOLTIP L('Переключиться на работу с базой знаний "Inf7"') ACTION {||ZnachOS(7, oRegion6), oRMChart:draw()} @ DCGUI_ROW, DCGUI_COL + 7 DCPUSHBUTTON CAPTION L('Записать графич.файл' ) SIZE 143,25 TOOLTIP L('Записать изображение в виде графического файла' ) ACTION {||SaveChartToBitmap(oRMChart)} @ DCGUI_ROW, DCGUI_COL + 2 DCPUSHBUTTON CAPTION L('Копировать в буфер обмена' ) SIZE 165,25 TOOLTIP L('Скопировать изображение в буфер обмена' ) ACTION {||SaveChartToClipboard(oRMChart)} @ DCGUI_ROW, DCGUI_COL + 2 DCPUSHBUTTON CAPTION L('Печать' ) SIZE 55,25 TOOLTIP L('Распечатать изображение на текущем принтере' ) ACTION {||PrintChart(oRMChart)} @ DCGUI_ROW, DCGUI_COL + 7 DCPUSHBUTTON CAPTION L('Копировать Abs' ) SIZE 103,25 TOOLTIP L('Создать копию БД Abs для возможности отката' ) ACTION {||SaveAbs()} @ DCGUI_ROW, DCGUI_COL + 2 DCPUSHBUTTON CAPTION L('Удалить незн.опис.шкалы из Abs') SIZE 187,25 TOOLTIP L('Удалить малозначимые описательные шкалы из БД Abs') ACTION {||DelOSAbs()} @ DCGUI_ROW, DCGUI_COL + 2 DCPUSHBUTTON CAPTION L('Восстановить Abs' ) SIZE 117,25 TOOLTIP L('Восстановить БД Abs из ранее созданной копии' ) ACTION {||LoadAbs()} DCGETOPTIONS RESIZE PIXEL DCREAD GUI ; SETAPPWINDOW ; FIT ; TITLE L('3.7.5. Значимость градаций описательных шкал. (C) Универсальная когнитивная аналитическая система "Эйдос-Х++"') ; OPTIONS GetOptions ; EVAL {||oRMChart:RMCToolTipWidth := 100, ; oRMChart:RMCUserWatermark := L('(C) Универсальная когнитивная аналитическая система "Эйдос-Х++"'), ; oRMChart:RMCUserWMAlignment := RMC_TEXTRIGHT, ; oRMChart:RMCUserWMFontSize := 20, ; oRMChart:RMCUserWMLucent := 40, ; oRmChart:mouseDown := ; {|a,b,c,d,e,o|aData := e,nWhich := a,o:=Thread():new(),o:start({||BrowseCallbackData(nWhich,aData,oRMChart)})}, ; oRmChart:mouseMove := ; {|nMouseButton,b,nX,nY,aData|oRMChart:showToolTip( nMouseButton, nX, nY, aData )}, ; oRmChart:draw(), ; ShowDebugInfo(oRMChart)} CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций ReTURN nil *********************************************************************************************************************** FUNCTION SetAll4131(GetList) PUBLIC aPar[15] AFILL(aPar, .T.) DC_ASave(aPar, "_4131.arx") DC_GetRefresh(GetList) ReTURN nil FUNCTION ResetAll4131(GetList) PUBLIC aPar[15] AFILL(aPar, .F.) aPar[15] = .T. DC_ASave(aPar, "_4131.arx") DC_GetRefresh(GetList) ReTURN nil *********************************************************************************************************************** ******** 4.1.3.1. Вывод графической диаграммы результатов распознавания: ******** "Один объект - много классов" *********************************************************************************************************************** FUNCTION ChartOn4131(mKodObj, mKodCls) // Код объекта расп.выборки, код класса-сценария по кл.шкале которого делать фильтр LOCAL GetList[0] * MsgBox(STR(mKodObj)+STR(mKodCls)) ***** Проверка на то, что заданный класс mKodCls относится к шкале сценариев ****** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW SELECT Classes DBGOTO(mKodCls) mKodClSc = Kod_ClSc // Код классификационной шкалы для фильтрации mNameCls = ALLTRIM(Name_cls) IF AT("FUTURE", mNameCls ) = 0 LB_Warning(L('Заданный класс:')+' '+ALLTRIM(STR(mKodCls))+'-'+mNameCls+' '+L('не относится к шкале-сценарию! См. режим 2.1. и 2.3.2.2 !'), L("4.1.3.1. Визуализация прогнозных сценариев" )) ***** Восстановление среды и возврат в режим CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rso_Zag INDEX ON Kod_Obj TO Classes CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rsp1k NEW INDEX ON Kod_Obj TO Rsp1k CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rsp1i NEW INDEX ON Kod_Obj TO Rsp1i CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rso_Zag INDEX Rso_Zag EXCLUSIVE USE Rsp1k INDEX Rsp1k EXCLUSIVE NEW USE Rsp1i INDEX Rsp1i EXCLUSIVE NEW SELECT Rso_Zag DBGOTO(mKodObj) ReTURN nil ENDIF ***** ДИАЛОГ ЗАДАНИЯ ПАРАМЕТРОВ ************** // Если ранее параметры были заданы - скачать массив, иначе сформировать и записать в папке приложения PUBLIC aPar[15] IF FILE("_4131.arx") aPar = DC_ARestore("_4131.arx") ELSE AFILL(aPar, .F.) aPar[15] = .T. DC_ASave(aPar, "_4131.arx") ENDIF * =================================================================================================== * | | Ломанные линии |Полином n-й степ.| Сплайны Безье | * |Переключатели | mBez=0 | mBez=1 | mBez=2 | * --------------------------|-----------------|-----------------|-----------------|-----------------| * Инт.критерий: "Сумм.инф." |mIntKrit=1 | 1 | 2 | 3 | * Инт.критерий: "Корреляция"|mIntKrit=2 | 4 | 5 | 6 | * Что будет |mToBeOrNotToBe=1 | 7 | 8 | 9 | * Чего не будет |mToBeOrNotToBe=2 | 10 | 11 | 12 | * Средневзвешенные сценарии |Любое значение | 13 | 14 | 15 | * =================================================================================================== * IF mBez=0 .AND. IF(aPar[ 1] .OR. aPar[ 4] .OR. aPar[ 7] .OR. aPar[10] .OR. aPar[13],.T.,.F.) * mBez=1 .AND. IF(aPar[ 2] .OR. aPar[ 5] .OR. aPar[ 8] .OR. aPar[11] .OR. aPar[14],.T.,.F.) * mBez=2 .AND. IF(aPar[ 3] .OR. aPar[ 6] .OR. aPar[ 9] .OR. aPar[12] .OR. aPar[15],.T.,.F.) * mIntKrit=0 .AND. IF(aPar[13] .OR. aPar[14] .OR. aPar[15],.T.,.F.) * mIntKrit=1 .AND. IF(aPar[ 1] .OR. aPar[ 2] .OR. aPar[ 3],.T.,.F.) * mIntKrit=2 .AND. IF(aPar[ 4] .OR. aPar[ 5] .OR. aPar[ 6],.T.,.F.) * mToBeOrNotToBe=1 .AND. IF(aPar[ 7] .OR. aPar[ 8] .OR. aPar[ 9],.T.,.F.) * mToBeOrNotToBe=2 .AND. IF(aPar[10] .OR. aPar[11] .OR. aPar[12],.T.,.F.) @ 1, 0 DCGROUP oGroup1 CAPTION L('Задайте графические диаграммы для формирования и вывода') FONT "9.Helv Bold" SIZE 78, 8.5 d=0.2 @ 2+d, 2 DCSAY 'Инт.критерий: "Сумм.инф."' FONT "9.Helv" PARENT oGroup1 @ 3+d, 2 DCSAY 'Инт.критерий: "Корреляция"' FONT "9.Helv" PARENT oGroup1 @ 4+d, 2 DCSAY 'Что будет' FONT "9.Helv" PARENT oGroup1 @ 5+d, 2 DCSAY 'Чего не будет' FONT "9.Helv" PARENT oGroup1 @ 6+d, 2 DCSAY 'Средневзвешенные сценарии' FONT "9.Helv" PARENT oGroup1 @ 1,25+17*0 DCGROUP oGroup2 CAPTION L('Ломанные линии' ) FONT "9.Helv" SIZE 16, 6.5 PARENT oGroup1 @ 1,25+17*1 DCGROUP oGroup3 CAPTION L('Полином n-й степ.') FONT "9.Helv" SIZE 16, 6.5 PARENT oGroup1 @ 1,25+17*2 DCGROUP oGroup4 CAPTION L('Сплайны Безье' ) FONT "9.Helv" SIZE 16, 6.5 PARENT oGroup1 @ 1,7 DCCHECKBOX aPar[ 1] PARENT oGroup2;@ 1,7 DCCHECKBOX aPar[ 2] PARENT oGroup3;@ 1,7 DCCHECKBOX aPar[ 3] PARENT oGroup4 @ 2,7 DCCHECKBOX aPar[ 4] PARENT oGroup2;@ 2,7 DCCHECKBOX aPar[ 5] PARENT oGroup3;@ 2,7 DCCHECKBOX aPar[ 6] PARENT oGroup4 @ 3,7 DCCHECKBOX aPar[ 7] PARENT oGroup2;@ 3,7 DCCHECKBOX aPar[ 8] PARENT oGroup3;@ 3,7 DCCHECKBOX aPar[ 9] PARENT oGroup4 @ 4,7 DCCHECKBOX aPar[10] PARENT oGroup2;@ 4,7 DCCHECKBOX aPar[11] PARENT oGroup3;@ 4,7 DCCHECKBOX aPar[12] PARENT oGroup4 @ 5,7 DCCHECKBOX aPar[13] PARENT oGroup2;@ 5,7 DCCHECKBOX aPar[14] PARENT oGroup3;@ 5,7 DCCHECKBOX aPar[15] PARENT oGroup4 *** Установить все *@10, 2 DCPUSHBUTTON CAPTION L('Установить все') SIZE LEN(L('Установить все'))+5, 1.5 ACTION {||SetAll4131(GetList), DC_GetRefresh(GetList)} *** Сбросить все *@10,30 DCPUSHBUTTON CAPTION L('Сбросить все') SIZE LEN(L('Сбросить все')) +5, 1.5 ACTION {||ResetAll4131(GetList), DC_GetRefresh(GetList)} DCREAD GUI ; TO lExit ; FIT ; MODAL ; ADDBUTTONS; TITLE L('4.1.3.1. Прогнозируемые частные и средневзвешенные сценарии') ******************************************************************** IF lExit ** Button Ok ELSE ***** Восстановление среды и возврат в режим CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rso_Zag INDEX ON Kod_Obj TO Classes CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rsp1k NEW INDEX ON Kod_Obj TO Rsp1k CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rsp1i NEW INDEX ON Kod_Obj TO Rsp1i CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rso_Zag INDEX Rso_Zag EXCLUSIVE USE Rsp1k INDEX Rsp1k EXCLUSIVE NEW USE Rsp1i INDEX Rsp1i EXCLUSIVE NEW SELECT Rso_Zag DBGOTO(mKodObj) Running(.F.) RETURN NIL ENDIF ******************************************************************** DC_ASave(aPar, "_4131.arx") // Записать заданные в диалоге параметры ***** КОНЕЦ ДИАЛОГА ЗАДАНИЯ ПАРАМЕТРОВ ***************************** ************************************************************************************************************** ** Параметры графической формы ******************************************************************************* ** Отображать прогнозные сценарии и средневзвешенный сценарий: ** - в верхней части экрана что будет (красным), в нижней чего не будет (синим) - это всегда, задавать не надо ** - по одной заданной шкале FUTURE (задание путем установки фильтра в правом окне формы 4.1.3.1) ** - для заданного объекта распознаваемой выборки (на котром стоит курсор в левом окне формы 4.1.3.1) ** - в заданной модели (в которой посчитана форма 4.1.3.1) ** - с заданным интегральным критерием (в с учетом того в каком окне верхнем или нижнем установлен фильтр) ************************************************************************************************************** ************************************************************************************************************** ** РАСЧЕТ СРЕДНЕВЗВЕШЕННЫХ СЦЕНАРИЕВ ************************************************************************* ************************************************************************************************************** oScr := DC_WaitOn(L('Идет расчет средневзвешенных прогнозных сценариев. Немного подождите!!!'),,,,,,,,,,,.F.) // Определить фактическое кол-во точек в сценарии * DIGITF-FUTURE5-DIGITF-FUTURE5-3,2,4,4,2 // Код объекта расп.выборки=8, наименование=7, код класса=340. Искать справа на лево первую встречу "-" * 123456789012345678901234567890123456789 * 10 20 30 Pos = RAT('-', mNameCls) mNameScen = SUBSTR(mNameCls, Pos+1, LEN(mNameCls)-Pos) N_PointsScenario = NUMTOKEN(mNameScen, ',') // Фактическое кол-во точек в сценарии * MsgBox(STR(N_PointsScenario)+' "'+mNameScen+'"') CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций aStructure := { { "Num_pp" , "N", 15, 0 },; // Порядковый номер сценария после ранжирования по уровню сходства { "Kod_cls" , "N", 15, 0 },; // Код класса-сценария, т.е. градации классификационной шкалы { "Name_cls" , "C",250, 0 },; // Наименование классификационной шкалы"-" + наименование градации классификационной шкалы { "Kod_ClSc" , "N", 15, 0 },; // Код классификационной шкалы { "Int_krit" , "C", 16, 0 },; // Интегральный критерий сходства объекта с классом: "Корреляция" или "Сумма информации" { "Korr" , "N", 19, 7 },; // Уровень сходства-различия "Корреляция" { "Sum_inf" , "N", 19, 7 },; // Уровень сходства-различия "Сумма информации" { "Fakt" , "C", 1, 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( "ChartClsk.dbf" , aStructure ) // БД для классов, к которым отнесен объект по инт.крит."Корреляция" DbCreate( "ChartClsi.dbf" , aStructure ) // БД для классов, к которым отнесен объект по инт.крит."Сумма информации" DbCreate( "AvrScenIK.dbf" , aStructure ) // БД для расчета положительных и отрицательных средневзвешенных сценариев с двумя инт.критериями DbCreate( "DispClsik.dbf" , aStructure ) // БД для расчета разбросов частных положительных и отрицательных прогнозов от среднего по обоим инт.критериям DbCreate( "ChartClsik.dbf" , aStructure ) // БД для рисования средневзешенных положительных и отрицательных прогнозов с разбросами по обоим инт.критериям // Заполнить БД для построения диаграммы * MsgBox(STR(mKodObj)) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций *** Когда известен фактический сценарий, то надо его тоже отобразить и посчитать корреляцию между прогнозом и фактом <<<===################### ******** Создание БД и массива для составной (гладкой) кривой Безье **************************** ******** Все записи должны быть полностью заполнены aStructure := { { "Xp_AVR" , "N", 15, 7 }, ; // 1. Xp_AVR=Xf_AVR предыдущей записи (в 1-й записи = X1) { "Yp_AVR" , "N", 15, 7 }, ; // 1. Yp_AVR=Yf_AVR предыдущей записи (в 1-й записи = Y1) { "X1" , "N", 15, 7 }, ; // 2. 1-я опорная точка { "Y1" , "N", 15, 7 }, ; // 2. 1-я опорная точка { "X2" , "N", 15, 7 }, ; // 3. 2-я опорная точка { "Y2" , "N", 15, 7 }, ; // 3. 2-я опорная точка { "Xf_AVR" , "N", 15, 7 }, ; // 4. Xf_AVR=(X2_текущей записи + X1_следующей записи)/2 (в последней записи = X2) { "Yf_AVR" , "N", 15, 7 }, ; // 4. Yf_AVR=(Y2_текущей записи + Y1_следующей записи)/2 (в последней записи = Y2) { "Korr" , "N", 15, 7 }, ; // Уровень сходства-различия "Корреляция" { "Sum_inf" , "N", 15, 7 }, ; // Уровень сходства-различия "Сумма информации" { "Fakt" , "C", 1, 0 }, ; // Факт { "Int_krit", "C", LEN('Сумма информации'), 0 } } // Инт.критерий DbCreate( 'Points.dbf', aStructure ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rso_Zag EXCLUSIVE NEW DBGOTO(mKodObj) mNameObj = Name_Obj // Для графической формы USE Classes EXCLUSIVE NEW USE Class_Sc EXCLUSIVE NEW USE ChartClsk EXCLUSIVE NEW USE ChartClsi EXCLUSIVE NEW USE AvrScenIK EXCLUSIVE NEW // Для расчета положительных и отрицательных средневзвешенных сценариев с думя инт.критериями USE DispClsik EXCLUSIVE NEW // Для расчета разброса частных сценариев от средневзвешенных USE ChartClsik EXCLUSIVE NEW // Для рисования средневзвешенных сценариев с разбросом USE Rsp1k EXCLUSIVE NEW USE Rsp1i EXCLUSIVE NEW * USE Bezier EXCLUSIVE NEW USE Points EXCLUSIVE NEW ***** Коды классов, к которым отнесен текущий объект распознаваемой выборки ********* PRIVATE aIntKrit[2] aIntKrit[1] = "Корреляция" aIntKrit[2] = "Сумма информации" FOR mToBeOrNotToBe=1 TO 2 FOR mIntKrit = 1 TO 2 DO CASE CASE mIntKrit = 1 SELECT Rsp1k DO CASE CASE mToBeOrNotToBe = 1 // Что будет SET FILTER TO Kod_obj = mKodObj .AND. Kod_ClSc = mKodClSc .AND. Korr > 0 CASE mToBeOrNotToBe = 2 // Чего не будет SET FILTER TO Kod_obj = mKodObj .AND. Kod_ClSc = mKodClSc .AND. Korr < 0 ENDCASE CASE mIntKrit = 2 SELECT Rsp1i DO CASE CASE mToBeOrNotToBe = 1 // Что будет SET FILTER TO Kod_obj = mKodObj .AND. Kod_ClSc = mKodClSc .AND. Sum_inf > 0 CASE mToBeOrNotToBe = 2 // Чего не будет SET FILTER TO Kod_obj = mKodObj .AND. Kod_ClSc = mKodClSc .AND. Sum_inf < 0 ENDCASE ENDCASE DO CASE CASE mIntKrit = 1 * INDEX ON STR(99999999.9999999-ABS(Korr) , 19, 7) TO Rsp1k INDEX ON STRTRAN(Fakt,' ','_')+STR(ABS(Korr) , 19, 7) TO Rsp1k CASE mIntKrit = 2 * INDEX ON STR(99999999.9999999-ABS(Sum_inf) , 19, 7) TO Rsp1i INDEX ON STRTRAN(Fakt,' ','_')+STR(ABS(Sum_inf), 19, 7) TO Rsp1i ENDCASE DBGOTOP() DO WHILE .NOT. EOF() mKodCls = Kod_cls mKodClSc = Kod_ClSc // Код классификационной шкалы для фильтрации mNameCls = ALLTRIM(Name_cls) mKorr = Korr mSumInf = Sum_inf mFakt = Fakt * DIGITF-FUTURE5-DIGITF-FUTURE5-3,2,4,4,2 // Код объекта расп.выборки=8, наименование=7, код класса=340. Искать справа на лево первую встречу "-" * 123456789012345678901234567890123456789 * 10 20 30 mPos = RAT('-', mNameCls) mNameScen = SUBSTR(mNameCls, mPos+1, LEN(mNameCls)-mPos) N_PointsScenario = NUMTOKEN(mNameScen, ',') // Фактическое кол-во точек в сценарии * MsgBox(STR(Pos)+STR(N_PointsScenario)+' "'+mNameScen+'"') * aStructure := { { "Xp_AVR" , "N", 15, 7 }, ; // 1. Xp_AVR=Xf_AVR предыдущей записи (в 1-й записи = X1) * { "Yp_AVR" , "N", 15, 7 }, ; // 1. Yp_AVR=Yf_AVR предыдущей записи (в 1-й записи = Y1) * { "X1" , "N", 15, 7 }, ; // 2. 1-я опорная точка * { "Y1" , "N", 15, 7 }, ; // 2. 1-я опорная точка * { "X2" , "N", 15, 7 }, ; // 3. 2-я опорная точка * { "Y2" , "N", 15, 7 }, ; // 3. 2-я опорная точка * { "Xf_AVR" , "N", 15, 7 }, ; // 4. Xf_AVR=(X2_текущей записи + X1_следующей записи)/2 (в последней записи = X2) * { "Yf_AVR" , "N", 15, 7 }, ; // 4. Yf_AVR=(Y2_текущей записи + Y1_следующей записи)/2 (в последней записи = Y2) * { "Korr" , "N", 15, 7 }, ; // Уровень сходства-различия "Корреляция" * { "Sum_inf" , "N", 15, 7 }, ; // Уровень сходства-различия "Сумма информации" * { "Fakt" , "C", 1, 0 }, ; // Факт * { "Int_krit", "C", LEN('Сумма информации'), 0 } } // Инт.критерий * 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 SELECT Classes FOR k=1 TO LEN(aKodBC) DBGOTO(aKodBC[k]) * DIGITF-1/5-{1.0, 2.6} mNmCls = ALLTRIM(Name_cls) mKdCls = Kod_cls mPos = RAT('-{', mNmCls)+1 // Ищем справа на лево первую встречу '-{' mName = SUBSTR(mNmCls, mPos+1, LEN(mNmCls)-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 = mKdCls mMax = mKdCls mAvrGrInt = mKdCls 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 ** Когда известен фактический сценарий, то надо его тоже отобразить и посчитать корреляцию между прогнозом и фактом <<<===################### DO CASE CASE mIntKrit = 1 SELECT ChartClsk CASE mIntKrit = 2 SELECT ChartClsi ENDCASE APPEND BLANK REPLACE Num_pp WITH RECNO() REPLACE Kod_cls WITH mKodCls REPLACE Name_cls WITH mNameCls REPLACE Kod_ClSc WITH mKodClSc REPLACE Int_krit WITH aIntKrit[mIntKrit] DO CASE CASE mIntKrit = 1 REPLACE Korr WITH mKorr CASE mIntKrit = 2 REPLACE Sum_inf WITH mSumInf ENDCASE REPLACE Fakt WITH mFakt 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 DO CASE CASE mIntKrit = 1 SELECT Rsp1k CASE mIntKrit = 2 SELECT Rsp1i ENDCASE DBSKIP(1) ENDDO NEXT NEXT SELECT ChartClsk SET FILTER TO Kod_ClSc = mKodClSc .AND. Korr > 0 COUNT TO N_RecK1 SET FILTER TO Kod_ClSc = mKodClSc .AND. Korr < 0 COUNT TO N_RecK2 SELECT ChartClsi SET FILTER TO Kod_ClSc = mKodClSc .AND. Sum_inf > 0 COUNT TO N_RecI1 SET FILTER TO Kod_ClSc = mKodClSc .AND. Sum_inf < 0 COUNT TO N_RecI2 * MsgBox(STR(N_RecK1)+STR(N_RecI1)+STR(N_RecK2)+STR(N_RecI2)) ***************************************************************************************************************** ****** Расчет 4-х средневзвешенных сценариев с разными интегральными критериями и с разным знаком уровня сходства <<<===############################## ***************************************************************************************************************** PRIVATE aAvrScen [N_PointsScenario] // Средневзвешенный сценарий (взвешенная суперпозиция частных сценариев с их весами) PRIVATE aSumScen [N_PointsScenario] // Сумма по всем частным сценариям PRIVATE aSredScen[N_PointsScenario] // Простое среднее по всем частным сценариям PRIVATE aSrKvOtkl[N_PointsScenario] // Среднеквадратичное отклонение FOR mToBeOrNotToBe=1 TO 2 FOR mIntKrit = 1 TO 2 DO CASE CASE mIntKrit = 1 SELECT ChartClsk DO CASE CASE mToBeOrNotToBe = 1 // Что будет SET FILTER TO Kod_ClSc = mKodClSc .AND. Korr > 0 mName = L('Средневзвешенный сценарий-"что будет".') +' '+L('Распознаваемый объект:')+' '+ALLTRIM(STR(mKodObj))+'-'+mNameObj CASE mToBeOrNotToBe = 2 // Чего не будет <<<===######### КАК СЧИТАТЬ СРЕДНЕВЗВЕШЕННЫЕ ДЛЯ ОТРИЦАТЕЛЬНЫХ УРОВНЕЙ СХОДСТВА? SET FILTER TO Kod_ClSc = mKodClSc .AND. Korr < 0 mName = L('Средневзвешенный сценарий-"чего не будет".')+' '+L('Распознаваемый объект:')+' '+ALLTRIM(STR(mKodObj))+'-'+mNameObj ENDCASE CASE mIntKrit = 2 SELECT ChartClsi DO CASE CASE mToBeOrNotToBe = 1 // Что будет SET FILTER TO Kod_ClSc = mKodClSc .AND. Sum_inf > 0 mName = L('Средневзвешенный сценарий-"что будет".') +' '+L('Распознаваемый объект:')+' '+ALLTRIM(STR(mKodObj))+'-'+mNameObj CASE mToBeOrNotToBe = 2 // Чего не будет SET FILTER TO Kod_ClSc = mKodClSc .AND. Sum_inf < 0 mName = L('Средневзвешенный сценарий-"чего не будет".')+' '+L('Распознаваемый объект:')+' '+ALLTRIM(STR(mKodObj))+'-'+mNameObj ENDCASE ENDCASE ******** Взвешенное суммирование по точкам mSumUrSx = 0 AFILL(aAvrScen ,0) DBGOTOP() DO WHILE .NOT. EOF() DO CASE CASE mIntKrit = 1 mSumUrSx = mSumUrSx + ABS(Korr) CASE mIntKrit = 2 mSumUrSx = mSumUrSx + ABS(Sum_inf) ENDCASE FOR j=1 TO N_PointsScenario mFieldName = "Avr"+ALLTRIM(STR(j,5)) // Среднее значение числового диапазона базового класса (для рисования и взвешенного усреднения) DO CASE CASE mIntKrit = 1 aAvrScen[j] = aAvrScen[j] + &mFieldName * ABS(Korr) CASE mIntKrit = 2 aAvrScen[j] = aAvrScen[j] + &mFieldName * ABS(Sum_inf) ENDCASE NEXT DBSKIP(1) ENDDO ****** Дорасчет и запись средневзвешенного сценария в БД APPEND BLANK REPLACE Name_cls WITH mName FOR j=1 TO N_PointsScenario mFieldName = "Avr"+ALLTRIM(STR(j,5)) // Среднее значение числового диапазона базового класса (для рисования и взвешенного усреднения) REPLACE &mFieldName WITH aAvrScen[j] / mSumUrSx NEXT REPLACE Kod_ClSc WITH mKodClSc // Чтобы при поиске min и max средневзвешенные сценарии не отфильтровывались (тоже участвовали) REPLACE Int_krit WITH aIntKrit[mIntKrit] ** Передать информацию в поле Fakt для Points.dbf о том, позитивный (+) или негативный (-) прогноз DO CASE CASE AT('Средневзвешенный сценарий-"что будет"' , Name_cls) > 0 REPLACE Fakt WITH "+" DO CASE CASE mIntKrit = 1 REPLACE Korr WITH mSumUrSx/N_RecK1 // <<<===############# Какие значения уровней сходства присвоить ИТОГОВЫМ строкам, может бысть средние? CASE mIntKrit = 2 REPLACE Sum_inf WITH mSumUrSx/N_RecI1 // <<<===############# Какие значения уровней сходства присвоить итоговым строкам, может бысть средние? ENDCASE CASE AT('Средневзвешенный сценарий-"чего не будет"', Name_cls) > 0 REPLACE Fakt WITH "-" DO CASE CASE mIntKrit = 1 REPLACE Korr WITH mSumUrSx/N_RecK2 // <<<===############# Какие значения уровней сходства присвоить ИТОГОВЫМ строкам, может бысть средние? CASE mIntKrit = 2 REPLACE Sum_inf WITH mSumUrSx/N_RecI2 // <<<===############# Какие значения уровней сходства присвоить итоговым строкам, может бысть средние? ENDCASE ENDCASE SELECT AvrScenIK // Все средневзвешенные, положительные и отрицательные прогнозные сценарии со всеми инт.критериями APPEND BLANK REPLACE Name_cls WITH mName FOR j=1 TO N_PointsScenario mFieldName = "Avr"+ALLTRIM(STR(j,5)) // Среднее значение числового диапазона базового класса (для рисования и взвешенного усреднения) REPLACE &mFieldName WITH aAvrScen[j] / mSumUrSx NEXT REPLACE Kod_ClSc WITH mKodClSc // Чтобы при поиске min и max средневзвешенные сценарии не отфильтровывались (тоже участвовали) REPLACE Int_krit WITH aIntKrit[mIntKrit] DO CASE CASE AT('Средневзвешенный сценарий-"что будет"' , Name_cls) > 0 REPLACE Fakt WITH "+" DO CASE CASE mIntKrit = 1 REPLACE Korr WITH mSumUrSx/N_RecK1 // <<<===############# Какие значения уровней сходства присвоить ИТОГОВЫМ строкам, может бысть средние? CASE mIntKrit = 2 REPLACE Sum_inf WITH mSumUrSx/N_RecI1 // <<<===############# Какие значения уровней сходства присвоить итоговым строкам, может бысть средние? ENDCASE CASE AT('Средневзвешенный сценарий-"чего не будет"', Name_cls) > 0 REPLACE Fakt WITH "-" DO CASE CASE mIntKrit = 1 REPLACE Korr WITH mSumUrSx/N_RecK2 // <<<===############# Какие значения уровней сходства присвоить ИТОГОВЫМ строкам, может бысть средние? CASE mIntKrit = 2 REPLACE Sum_inf WITH mSumUrSx/N_RecI2 // <<<===############# Какие значения уровней сходства присвоить итоговым строкам, может бысть средние? ENDCASE ENDCASE ** Передать информацию в поле Fakt для Points.dbf о том, позитивный (+) или негативный (-) прогноз DO CASE CASE AT('Средневзвешенный сценарий-"что будет"' , Name_cls) > 0 REPLACE Fakt WITH "+" CASE AT('Средневзвешенный сценарий-"чего не будет"', Name_cls) > 0 REPLACE Fakt WITH "-" ENDCASE ******* Посчитать разброс (ср.кв.откл.) точек частных прогнозов от средневзвешенного ЧТОБЫ ПОТОМ ОТОБРАЗИТЬ ЕГО НА ИТОГОВЫХ ГРАФИКАХ для каждой точки <<<===################ ******* ЭТО И ЕСТЬ ОЦЕНКА ДОСТОВЕРНОСТИ СРЕДНЕВЗВШЕННЫХ ПРОГНОЗОВ <<<===################ ******* Перенести средневзвешенный сценарий в массив DO CASE CASE mIntKrit = 1 SELECT ChartClsk CASE mIntKrit = 2 SELECT ChartClsi ENDCASE DO CASE CASE mToBeOrNotToBe = 1 // Что будет DBGOTO(RECCOUNT()-1) CASE mToBeOrNotToBe = 2 // Чего не будет DBGOBOTTOM() ENDCASE FOR j=1 TO N_PointsScenario mFieldName = "Avr"+ALLTRIM(STR(j,5)) // Среднее значение числового диапазона базового класса (для рисования и взвешенного усреднения) aAvrScen[j] = &mFieldName NEXT ** Задать БД для работы ********** DO CASE CASE mIntKrit = 1 SELECT ChartClsk DO CASE CASE mToBeOrNotToBe = 1 // Что будет SET FILTER TO Kod_cls > 0 .AND. Kod_ClSc = mKodClSc .AND. Korr > 0 mName = L('Средневзвешенный сценарий-"что будет".') +' '+L('Распознаваемый объект:')+' '+ALLTRIM(STR(mKodObj))+'-'+mNameObj CASE mToBeOrNotToBe = 2 // Чего не будет SET FILTER TO Kod_cls > 0 .AND. Kod_ClSc = mKodClSc .AND. Korr < 0 mName = L('Средневзвешенный сценарий-"чего не будет".')+' '+L('Распознаваемый объект:')+' '+ALLTRIM(STR(mKodObj))+'-'+mNameObj ENDCASE CASE mIntKrit = 2 SELECT ChartClsi DO CASE CASE mToBeOrNotToBe = 1 // Что будет SET FILTER TO Kod_cls > 0 .AND. Kod_ClSc = mKodClSc .AND. Sum_inf > 0 mName = L('Средневзвешенный сценарий-"что будет".') +' '+L('Распознаваемый объект:')+' '+ALLTRIM(STR(mKodObj))+'-'+mNameObj CASE mToBeOrNotToBe = 2 // Чего не будет SET FILTER TO Kod_cls > 0 .AND. Kod_ClSc = mKodClSc .AND. Sum_inf < 0 mName = L('Средневзвешенный сценарий-"чего не будет".')+' '+L('Распознаваемый объект:')+' '+ALLTRIM(STR(mKodObj))+'-'+mNameObj ENDCASE ENDCASE * *** Расчет и запись столбца значимости признаков (градаций описательных шкал) * FOR i = 1 TO N_Gos * DBGOTO(i) * FOR j = 1 TO N_Cls * Iij=FIELDGET(2+j) // Информативность-элемент (i,j) * Ar_Disp_i[i] = Ar_Disp_i[i] + (Ar_Sred_i[i]-Iij)^2 * NEXT * Ar_Disp_i[i] = SQRT(Ar_Disp_i[i]/(N_Cls-1)) // Средн.квадр.отклонение Iij по признаку * FIELDPUT(5+N_Cls,Ar_Disp_i[i]) * NEXT AFILL(aSumScen ,0) // Сумма по всем частным сценариям AFILL(aSredScen,0) // Простое среднее по всем частным сценариям AFILL(aSrKvOtkl,0) // Среднеквадратичное отклонение DBGOTOP() DO WHILE .NOT. EOF() FOR j=1 TO N_PointsScenario mFieldName = "Avr"+ALLTRIM(STR(j,5)) // Среднее значение числового диапазона базового класса (для рисования и взвешенного усреднения) aSumScen[j] = aSumScen[j] + &mFieldName NEXT DBSKIP(1) ENDDO DBGOTOP() DO WHILE .NOT. EOF() FOR j=1 TO N_PointsScenario mFieldName = "Avr"+ALLTRIM(STR(j,5)) // Среднее значение числового диапазона базового класса (для рисования и взвешенного усреднения) aSredScen[j] = aSredScen[j] DO CASE CASE mIntKrit = 1 SELECT ChartClsk DO CASE CASE mToBeOrNotToBe = 1 // Что будет aSredScen[j] = aSumScen[j] / N_RecK1 // Простое среднее CASE mToBeOrNotToBe = 2 // Чего не будет aSredScen[j] = aSumScen[j] / N_RecK2 // Простое среднее ENDCASE CASE mIntKrit = 2 SELECT ChartClsi DO CASE CASE mToBeOrNotToBe = 1 // Что будет aSredScen[j] = aSumScen[j] / N_RecI1 // Простое среднее CASE mToBeOrNotToBe = 2 // Чего не будет aSredScen[j] = aSumScen[j] / N_RecI2 // Простое среднее ENDCASE ENDCASE NEXT DBSKIP(1) ENDDO DBGOTOP() DO WHILE .NOT. EOF() FOR j=1 TO N_PointsScenario mFieldName = "Avr"+ALLTRIM(STR(j,5)) // Среднее значение числового диапазона базового класса (для рисования и взвешенного усреднения) * aSrKvOtkl[j] = aSrKvOtkl[j] + ( &mFieldName - aAvrScen [j] ) ^ 2 // Отклонения от средневзвешенного (почему-то получаются очень большие) aSrKvOtkl[j] = aSrKvOtkl[j] + ( &mFieldName - aSredScen[j] ) ^ 2 // Отклонения от простого среднего (классика) NEXT DBSKIP(1) ENDDO FOR j=1 TO N_PointsScenario DO CASE CASE mIntKrit = 1 SELECT ChartClsk DO CASE CASE mToBeOrNotToBe = 1 // Что будет aSrKvOtkl[j] = SQRT(aSrKvOtkl[j]/(N_RecK1-1)) // Средн.квадр.отклонение mName = L('Разброс прогнозов того "Что будет".') CASE mToBeOrNotToBe = 2 // Чего не будет aSrKvOtkl[j] = SQRT(aSrKvOtkl[j]/(N_RecK2-1)) // Средн.квадр.отклонение mName = L('Разброс прогнозов того "Чего не будет".') ENDCASE CASE mIntKrit = 2 SELECT ChartClsi DO CASE CASE mToBeOrNotToBe = 1 // Что будет aSrKvOtkl[j] = SQRT(aSrKvOtkl[j]/(N_RecI1-1)) // Средн.квадр.отклонение mName = L('Разброс прогнозов того "Что будет".') CASE mToBeOrNotToBe = 2 // Чего не будет aSrKvOtkl[j] = SQRT(aSrKvOtkl[j]/(N_RecI2-1)) // Средн.квадр.отклонение mName = L('Разброс прогнозов того "Чего не будет".') ENDCASE ENDCASE NEXT **** Записать в БД DispClsik ********** SELECT DispClsik // Разброс частных прогнозов от средних положительных и отрицательных прогнозных сценариев со всеми инт.критериями APPEND BLANK REPLACE Name_cls WITH mName REPLACE Kod_ClSc WITH mKodClSc // Чтобы при поиске min и max средневзвешенные сценарии не отфильтровывались (тоже участвовали) REPLACE Int_krit WITH aIntKrit[mIntKrit] ** Передать информацию в поле Fakt для Points.dbf о том, позитивный (+) или негативный (-) прогноз DO CASE CASE AT('Средневзвешенный сценарий-"что будет"' , Name_cls) > 0 REPLACE Fakt WITH "+" CASE AT('Средневзвешенный сценарий-"чего не будет"', Name_cls) > 0 REPLACE Fakt WITH "-" ENDCASE FOR j=1 TO N_PointsScenario mFieldName = "Avr"+ALLTRIM(STR(j,5)) // Среднее значение числового диапазона базового класса (для рисования и взвешенного усреднения) REPLACE &mFieldName WITH aSrKvOtkl[j] NEXT ****** Посчитать БД для визуализации: средневзвешенные полож.и отриц.прогнозы сами и еще +- разбросы по ним * SELECT AvrScenIK // Все средневзвешенные, положительные и отрицательные прогнозные сценарии со всеми инт.критериями * SELECT DispClsik // Разброс частных прогнозов от средних положительных и отрицательных прогнозных сценариев со всеми инт.критериями * SELECT ChartClsik // Для рисования средневзвешенных сценариев с разбросом SELECT AvrScenIK // Все средневзвешенные, положительные и отрицательные прогнозные сценарии со всеми инт.критериями DBGOTOP() DO WHILE .NOT. EOF() SELECT AvrScenIK // Все средневзвешенные, положительные и отрицательные прогнозные сценарии со всеми инт.критериями aAvrScenIK := {} FOR j=1 TO FCOUNT() AADD(aAvrScenIK, FIELDGET(j)) NEXT SELECT DispClsik // Разброс частных прогнозов от средних положительных и отрицательных прогнозных сценариев со всеми инт.критериями aDispClsik := {} FOR j=1 TO FCOUNT() AADD(aDispClsik, FIELDGET(j)) NEXT SELECT ChartClsik // Для рисования средневзвешенных сценариев с разбросом aChartClsik := {} FOR j=1 TO LEN(aAvrScenIK) AADD(aDispClsik, aAvrScenIK[j]) NEXT FOR i=0.01 TO 0.05 STEP 0.01 APPEND BLANK FOR j=1 TO LEN(aAvrScenIK) IF AT('AVR',FIELDNAME(j)) > 0 FIELDPUT(j, aAvrScenIK[j] - i * aDispClsik[j] ) ELSE IF j=3 FIELDPUT(j, STRTRAN(aAvrScenIK[j],'Средневзвешенный сценарий','Разброс частных прогнозов')) ELSE FIELDPUT(j, aAvrScenIK[j]) ENDIF ENDIF NEXT NEXT APPEND BLANK FOR j=1 TO LEN(aAvrScenIK) FIELDPUT(j, aAvrScenIK[j] ) NEXT FOR i=0.01 TO 0.05 STEP 0.01 APPEND BLANK FOR j=1 TO LEN(aAvrScenIK) IF AT('AVR',FIELDNAME(j)) > 0 FIELDPUT(j, aAvrScenIK[j] + i * aDispClsik[j] ) ELSE IF j=3 FIELDPUT(j, STRTRAN(aAvrScenIK[j],'Средневзвешенный сценарий','Разброс частных прогнозов')) ELSE FIELDPUT(j, aAvrScenIK[j]) ENDIF ENDIF NEXT NEXT SELECT AvrScenIK // Все средневзвешенные, положительные и отрицательные прогнозные сценарии со всеми инт.критериями DBSKIP(1) ENDDO NEXT NEXT DC_Impl(oScr) ************************************************************************************************************** ** ОКОНЧАНИЕ РАСЧЕТА СРЕДНЕВЗВЕШЕННЫХ СЦЕНАРИЕВ ************************************************************** ************************************************************************************************************** aIntKrit := {} AADD(aIntKrit, "k") AADD(aIntKrit, "i") aPosNeg := {} AADD(aPosNeg, "Pos") AADD(aPosNeg, "Neg") SELECT Class_sc DBGOTO(mKodClSc) mNameClSc = Name_ClSc * mKodObj, mNameObj *************************************************************************************************** *** ВИЗУАЛИЗАЦИЯ ЧАСТНЫХ И СРЕДНЕВЗВЕШЕННЫХ СЦЕНАРИЕВ ********************************************* *************************************************************************************************** * =================================================================================================== * | | Ломанные линии |Полином n-й степ.| Сплайны Безье | * |Переключатели | mBez=0 | mBez=1 | mBez=2 | * --------------------------|-----------------|-----------------|-----------------|-----------------| * Инт.критерий: "Сумм.инф." |mIntKrit=1 | 1 | 2 | 3 | * Инт.критерий: "Корреляция"|mIntKrit=2 | 4 | 5 | 6 | * Что будет |mToBeOrNotToBe=1 | 7 | 8 | 9 | * Чего не будет |mToBeOrNotToBe=2 | 10 | 11 | 12 | * Средневзвешенные сценарии |Любое значение | 13 | 14 | 15 | * =================================================================================================== * IF mBez=0 .AND. IF(aPar[ 1] .OR. aPar[ 4] .OR. aPar[ 7] .OR. aPar[10] .OR. aPar[13],.T.,.F.) * mBez=1 .AND. IF(aPar[ 2] .OR. aPar[ 5] .OR. aPar[ 8] .OR. aPar[11] .OR. aPar[14],.T.,.F.) * mBez=2 .AND. IF(aPar[ 3] .OR. aPar[ 6] .OR. aPar[ 9] .OR. aPar[12] .OR. aPar[15],.T.,.F.) * mIntKrit=0 .AND. IF(aPar[13] .OR. aPar[14] .OR. aPar[15],.T.,.F.) * mIntKrit=1 .AND. IF(aPar[ 1] .OR. aPar[ 2] .OR. aPar[ 3],.T.,.F.) * mIntKrit=2 .AND. IF(aPar[ 4] .OR. aPar[ 5] .OR. aPar[ 6],.T.,.F.) * mToBeOrNotToBe=1 .AND. IF(aPar[ 7] .OR. aPar[ 8] .OR. aPar[ 9],.T.,.F.) * mToBeOrNotToBe=2 .AND. IF(aPar[10] .OR. aPar[11] .OR. aPar[12],.T.,.F.) FOR mBez = 0 TO 2 IF mBez=0 .AND. IF(aPar[ 1] .OR. aPar[ 4] .OR. aPar[ 7] .OR. aPar[10] .OR. aPar[13],.T.,.F.) .OR.; mBez=1 .AND. IF(aPar[ 2] .OR. aPar[ 5] .OR. aPar[ 8] .OR. aPar[11] .OR. aPar[14],.T.,.F.) .OR.; mBez=2 .AND. IF(aPar[ 3] .OR. aPar[ 6] .OR. aPar[ 9] .OR. aPar[12] .OR. aPar[15],.T.,.F.) FOR mIntKrit = 0 TO 2 IF mIntKrit=0 .AND. IF(aPar[13] .OR. aPar[14] .OR. aPar[15],.T.,.F.) .OR.; mIntKrit=1 .AND. IF(aPar[ 1] .OR. aPar[ 2] .OR. aPar[ 3],.T.,.F.) .OR.; mIntKrit=2 .AND. IF(aPar[ 4] .OR. aPar[ 5] .OR. aPar[ 6],.T.,.F.) IF mIntKrit=0 .AND. IF(aPar[13] .OR. aPar[14] .OR. aPar[15],.T.,.F.) SELECT ChartClsik // Все средневзвешенные, положительные и отрицательные прогнозные сценарии со всеми инт.критериями 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 ) *######################################################################################################################################## Chart4131(oPS, 0, 0, mKodObj, N_PointsScenario, Ar_Model[M_CurrInf], mBez) // Графическая функция <<<===####### *######################################################################################################################################## *My image original, my image scaled DC_Impl(oScr) ****** Запись полноразмерного графического файла в папку: M_PathAppl+"\AverageScenarios\" DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения IF FILEDATE("AverageScenarios",16) = CTOD("//") DIRMAKE("AverageScenarios") aMess := {} AADD(aMess, L('В папке текущего приложения: "'+UPPER(ALLTRIM(M_PathAppl))+'"')) AADD(aMess, L('не было директории "AverageScenarios" для средневзвешенных сценариев и она была создана!')) AADD(aMess, L('В эту папку записываются исходные изображения высокого качества (без масштабирования)')) LB_Warning(aMess, L('4.1.3.1. Прогнозирование средневзвешенных сценариев' )) ENDIF DIRCHANGE(M_PathAppl+"\AverageScenarios\") // Перейти в папку AverageScenarios * cFileName = "AverageScenarios"+"-"+Ar_Model[M_CurrInf]+".jpg" DO CASE CASE mBez=0 .AND. IF(aPar[ 1] .OR. aPar[ 4] .OR. aPar[ 7] .OR. aPar[10] .OR. aPar[13],.T.,.F.) // Ломанная кривая cFileName = 'ALLAvrScen'+'-'+Ar_Model[M_CurrInf]+'-'+ALLTRIM(STR(mKodObj))+'.jpg' CASE mBez=1 .AND. IF(aPar[ 2] .OR. aPar[ 5] .OR. aPar[ 8] .OR. aPar[11] .OR. aPar[14],.T.,.F.) // Полином n-йстепени cFileName = 'ALLAvrScen'+'-'+Ar_Model[M_CurrInf]+'-'+ALLTRIM(STR(mKodObj))+'-Poli.jpg' CASE mBez=2 .AND. IF(aPar[ 3] .OR. aPar[ 6] .OR. aPar[ 9] .OR. aPar[12] .OR. aPar[15],.T.,.F.) // Сплайны Безье cFileName = 'ALLAvrScen'+'-'+Ar_Model[M_CurrInf]+'-'+ALLTRIM(STR(mKodObj))+'-Splain.jpg' ENDCASE 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 FOR mToBeOrNotToBe = 1 TO 2 IF mToBeOrNotToBe=1 .AND. IF(aPar[ 7] .OR. aPar[ 8] .OR. aPar[ 9],.T.,.F.) .OR.; mToBeOrNotToBe=2 .AND. IF(aPar[10] .OR. aPar[11] .OR. aPar[12],.T.,.F.) DO CASE CASE mIntKrit=1 .AND. (aPar[ 1] .OR. aPar[ 2] .OR. aPar[ 3]) SELECT ChartClsk DO CASE CASE mToBeOrNotToBe=1 .AND. (aPar[ 7] .OR. aPar[ 8] .OR. aPar[ 9]) // Что будет ********************************************************************************************* SET FILTER TO Kod_ClSc = mKodClSc .AND. Korr > 0 .AND. KOD_CLS > 0 mName = L('Средневзвешенный сценарий-"что будет".') +' '+L('Распознаваемый объект:')+' '+ALLTRIM(STR(mKodObj))+'-'+mNameObj 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 ) *######################################################################################################################################## Chart4131(oPS, mToBeOrNotToBe, mIntKrit, mKodObj, N_PointsScenario, Ar_Model[M_CurrInf], mBez) // Графическая функция <<<===####### *######################################################################################################################################## *My image original, my image scaled DC_Impl(oScr) ****** Запись полноразмерного графического файла в папку: M_PathAppl+"\AverageScenarios\" DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения IF FILEDATE("AverageScenarios",16) = CTOD("//") DIRMAKE("AverageScenarios") aMess := {} AADD(aMess, L('В папке текущего приложения: "'+UPPER(ALLTRIM(M_PathAppl))+'"')) AADD(aMess, L('не было директории "AverageScenarios" для средневзвешенных сценариев и она была создана!')) AADD(aMess, L('В эту папку записываются исходные изображения высокого качества (без масштабирования)')) LB_Warning(aMess, L('4.1.3.1. Прогнозирование средневзвешенных сценариев' )) ENDIF DIRCHANGE(M_PathAppl+"\AverageScenarios\") // Перейти в папку AverageScenarios * cFileName = "AverageScenarios"+"-"+Ar_Model[M_CurrInf]+".jpg" DO CASE CASE mBez=0 cFileName = 'AvrScen'+'-'+Ar_Model[M_CurrInf]+'-'+aIntKrit[mIntKrit]+'-'+aPosNeg[mToBeOrNotToBe]+'-'+ALLTRIM(STR(mKodObj))+'.jpg' CASE mBez=1 cFileName = 'AvrScen'+'-'+Ar_Model[M_CurrInf]+'-'+aIntKrit[mIntKrit]+'-'+aPosNeg[mToBeOrNotToBe]+'-'+ALLTRIM(STR(mKodObj))+'-Poli.jpg' CASE mBez=2 cFileName = 'AvrScen'+'-'+Ar_Model[M_CurrInf]+'-'+aIntKrit[mIntKrit]+'-'+aPosNeg[mToBeOrNotToBe]+'-'+ALLTRIM(STR(mKodObj))+'-Splain.jpg' ENDCASE 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) // Перейти в папку текущего приложения CASE mToBeOrNotToBe=2 .AND. (aPar[10] .OR. aPar[11] .OR. aPar[12]) // Чего не будет ***************************************************************************************** SET FILTER TO Kod_ClSc = mKodClSc .AND. Korr <= 0 .AND. KOD_CLS > 0 mName = L('Средневзвешенный сценарий-"чего не будет".')+' '+L('Распознаваемый объект:')+' '+ALLTRIM(STR(mKodObj))+'-'+mNameObj 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 ) *######################################################################################################################################## Chart4131(oPS, mToBeOrNotToBe, mIntKrit, mKodObj, N_PointsScenario, Ar_Model[M_CurrInf], mBez) // Графическая функция <<<===####### *######################################################################################################################################## *My image original, my image scaled DC_Impl(oScr) ****** Запись полноразмерного графического файла в папку: M_PathAppl+"\AverageScenarios\" DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения IF FILEDATE("AverageScenarios",16) = CTOD("//") DIRMAKE("AverageScenarios") aMess := {} AADD(aMess, L('В папке текущего приложения: "'+UPPER(ALLTRIM(M_PathAppl))+'"')) AADD(aMess, L('не было директории "AverageScenarios" для средневзвешенных сценариев и она была создана!')) AADD(aMess, L('В эту папку записываются исходные изображения высокого качества (без масштабирования)')) LB_Warning(aMess, L('4.1.3.1. Прогнозирование средневзвешенных сценариев' )) ENDIF DIRCHANGE(M_PathAppl+"\AverageScenarios\") // Перейти в папку AverageScenarios * cFileName = "AverageScenarios"+"-"+Ar_Model[M_CurrInf]+".jpg" DO CASE CASE mBez=0 .AND. IF(aPar[ 1] .OR. aPar[ 4] .OR. aPar[ 7] .OR. aPar[10] .OR. aPar[13],.T.,.F.) cFileName = 'AvrScen'+'-'+Ar_Model[M_CurrInf]+'-'+aIntKrit[mIntKrit]+'-'+aPosNeg[mToBeOrNotToBe]+'-'+ALLTRIM(STR(mKodObj))+'.jpg' CASE mBez=1 .AND. IF(aPar[ 2] .OR. aPar[ 5] .OR. aPar[ 8] .OR. aPar[11] .OR. aPar[14],.T.,.F.) cFileName = 'AvrScen'+'-'+Ar_Model[M_CurrInf]+'-'+aIntKrit[mIntKrit]+'-'+aPosNeg[mToBeOrNotToBe]+'-'+ALLTRIM(STR(mKodObj))+'-Poli.jpg' CASE mBez=2 .AND. IF(aPar[ 3] .OR. aPar[ 6] .OR. aPar[ 9] .OR. aPar[12] .OR. aPar[15],.T.,.F.) cFileName = 'AvrScen'+'-'+Ar_Model[M_CurrInf]+'-'+aIntKrit[mIntKrit]+'-'+aPosNeg[mToBeOrNotToBe]+'-'+ALLTRIM(STR(mKodObj))+'-Splain.jpg' ENDCASE 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) // Перейти в папку текущего приложения ENDCASE CASE mIntKrit=2 .AND. IF(aPar[ 4] .OR. aPar[ 5] .OR. aPar[ 6],.T.,.F.) SELECT ChartClsi DO CASE CASE mToBeOrNotToBe=1 .AND. IF(aPar[ 7] .OR. aPar[ 8] .OR. aPar[ 9],.T.,.F.) // Что будет ********************************************************************************************* SET FILTER TO Kod_ClSc = mKodClSc .AND. Sum_inf > 0 .AND. KOD_CLS > 0 mName = L('Средневзвешенный сценарий-"что будет".') +' '+L('Распознаваемый объект:')+' '+ALLTRIM(STR(mKodObj))+'-'+mNameObj 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 ) *######################################################################################################################################## Chart4131(oPS, mToBeOrNotToBe, mIntKrit, mKodObj, N_PointsScenario, Ar_Model[M_CurrInf], mBez) // Графическая функция <<<===####### *######################################################################################################################################## *My image original, my image scaled DC_Impl(oScr) ****** Запись полноразмерного графического файла в папку: M_PathAppl+"\AverageScenarios\" DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения IF FILEDATE("AverageScenarios",16) = CTOD("//") DIRMAKE("AverageScenarios") aMess := {} AADD(aMess, L('В папке текущего приложения: "'+UPPER(ALLTRIM(M_PathAppl))+'"')) AADD(aMess, L('не было директории "AverageScenarios" для средневзвешенных сценариев и она была создана!')) AADD(aMess, L('В эту папку записываются исходные изображения высокого качества (без масштабирования)')) LB_Warning(aMess, L('4.1.3.1. Прогнозирование средневзвешенных сценариев' )) ENDIF DIRCHANGE(M_PathAppl+"\AverageScenarios\") // Перейти в папку AverageScenarios * cFileName = "AverageScenarios"+"-"+Ar_Model[M_CurrInf]+".jpg" DO CASE CASE mBez=0 cFileName = 'AvrScen'+'-'+Ar_Model[M_CurrInf]+'-'+aIntKrit[mIntKrit]+'-'+aPosNeg[mToBeOrNotToBe]+'-'+ALLTRIM(STR(mKodObj))+'.jpg' CASE mBez=1 cFileName = 'AvrScen'+'-'+Ar_Model[M_CurrInf]+'-'+aIntKrit[mIntKrit]+'-'+aPosNeg[mToBeOrNotToBe]+'-'+ALLTRIM(STR(mKodObj))+'-Poli.jpg' CASE mBez=2 cFileName = 'AvrScen'+'-'+Ar_Model[M_CurrInf]+'-'+aIntKrit[mIntKrit]+'-'+aPosNeg[mToBeOrNotToBe]+'-'+ALLTRIM(STR(mKodObj))+'-Splain.jpg' ENDCASE 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) // Перейти в папку текущего приложения CASE mToBeOrNotToBe=2 .AND. IF(aPar[10] .OR. aPar[11] .OR. aPar[12],.T.,.F.) // Чего не будет ***************************************************************************************** SET FILTER TO Kod_ClSc = mKodClSc .AND. Sum_inf <= 0 .AND. KOD_CLS > 0 mName = L('Средневзвешенный сценарий-"чего не будет".')+' '+L('Распознаваемый объект:')+' '+ALLTRIM(STR(mKodObj))+'-'+mNameObj 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 ) *######################################################################################################################################## Chart4131(oPS, mToBeOrNotToBe, mIntKrit, mKodObj, N_PointsScenario, Ar_Model[M_CurrInf], mBez) // Графическая функция <<<===####### *######################################################################################################################################## *My image original, my image scaled DC_Impl(oScr) ****** Запись полноразмерного графического файла в папку: M_PathAppl+"\AverageScenarios\" DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения IF FILEDATE("AverageScenarios",16) = CTOD("//") DIRMAKE("AverageScenarios") aMess := {} AADD(aMess, L('В папке текущего приложения: "'+UPPER(ALLTRIM(M_PathAppl))+'"')) AADD(aMess, L('не было директории "AverageScenarios" для средневзвешенных сценариев и она была создана!')) AADD(aMess, L('В эту папку записываются исходные изображения высокого качества (без масштабирования)')) LB_Warning(aMess, L('4.1.3.1. Прогнозирование средневзвешенных сценариев' )) ENDIF DIRCHANGE(M_PathAppl+"\AverageScenarios\") // Перейти в папку AverageScenarios * cFileName = "AverageScenarios"+"-"+Ar_Model[M_CurrInf]+".jpg" DO CASE CASE mBez=0 .AND. IF(aPar[ 1] .OR. aPar[ 4] .OR. aPar[ 7] .OR. aPar[10] .OR. aPar[13],.T.,.F.) cFileName = 'AvrScen'+'-'+Ar_Model[M_CurrInf]+'-'+aIntKrit[mIntKrit]+'-'+aPosNeg[mToBeOrNotToBe]+'-'+ALLTRIM(STR(mKodObj))+'.jpg' CASE mBez=1 .AND. IF(aPar[ 2] .OR. aPar[ 5] .OR. aPar[ 8] .OR. aPar[11] .OR. aPar[14],.T.,.F.) cFileName = 'AvrScen'+'-'+Ar_Model[M_CurrInf]+'-'+aIntKrit[mIntKrit]+'-'+aPosNeg[mToBeOrNotToBe]+'-'+ALLTRIM(STR(mKodObj))+'-Poli.jpg' CASE mBez=2 .AND. IF(aPar[ 3] .OR. aPar[ 6] .OR. aPar[ 9] .OR. aPar[12] .OR. aPar[15],.T.,.F.) cFileName = 'AvrScen'+'-'+Ar_Model[M_CurrInf]+'-'+aIntKrit[mIntKrit]+'-'+aPosNeg[mToBeOrNotToBe]+'-'+ALLTRIM(STR(mKodObj))+'-Splain.jpg' ENDCASE 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) // Перейти в папку текущего приложения ENDCASE ENDCASE ENDIF NEXT ENDIF NEXT ENDIF NEXT ************************************************************** ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций aMess := {} AADD(aMess, L('Отображение прогнозируемых средневзвешенных сценариев успешно завершено!')) LB_Warning(aMess, L("Сообщение об успешном завершении операции" )) DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения *********************************************************************************** ***** Восстановление среды и возврат в режим отображения экранной формы 4.1.3.1 *** *********************************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rso_Zag INDEX ON Kod_Obj TO Classes CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rsp1k NEW INDEX ON Kod_Obj TO Rsp1k CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rsp1i NEW INDEX ON Kod_Obj TO Rsp1i CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Rso_Zag INDEX Rso_Zag EXCLUSIVE USE Rsp1k INDEX Rsp1k EXCLUSIVE NEW USE Rsp1i INDEX Rsp1i EXCLUSIVE NEW SELECT Rso_Zag DBGOTO(mKodObj) ReTURN nil ********************************************************************************************************* ****** Отображение частных сценариев и средневзвешенного на одном окне ********************************************************************************************************* STATIC FUNCTION Chart4131(oPS, mToBeOrNotToBe, mIntKrit, mKodObj, N_PointsScenario, mNameMod, mBez) aPar = DC_ARestore("_4131.arx") ****** Поиск макс и мин значений аргумента и функции ****** X_MinA = +99999999 // Минимальное значение X аргумента X_MaxA = -99999999 // Максимальное значение Y аргумента Y_MinF = +99999999 // Минимальное значение Y функции Y_MaxF = -99999999 // Максимальное значение Y функции mKorrMin = +999999 // Минимальный уровень сходства mKorrMax = -999999 // Максимальный уровень сходства mSinfMin = +999999 // Минимальный уровень сходства mSinfMax = -999999 // Максимальный уровень сходства DO CASE CASE mIntKrit=0 SELECT ChartClsik SET FILTER TO CASE mIntKrit=1 SELECT ChartClsk DO CASE CASE mToBeOrNotToBe=1 // Что будет SET FILTER TO Kod_ClSc = mKodClSc .AND. Korr >= 0 // = для того, чтобы при поиске min и max учитывались средневзвешенные сценарии CASE mToBeOrNotToBe=2 // Чего не будет SET FILTER TO Kod_ClSc = mKodClSc .AND. Korr <= 0 ENDCASE CASE mIntKrit=2 SELECT ChartClsi DO CASE CASE mToBeOrNotToBe=1 // Что будет SET FILTER TO Kod_ClSc = mKodClSc .AND. Sum_inf >= 0 CASE mToBeOrNotToBe=2 // Чего не будет SET FILTER TO Kod_ClSc = mKodClSc .AND. Sum_inf <= 0 ENDCASE ENDCASE * SET FILTER TO DBGOTOP() DO WHILE .NOT. EOF() // Цикл по частным сценариям (в конце 2 строки отображать по-другому) <<<===######################## DO CASE CASE mIntKrit=1 mKorrMin = MIN(mKorrMin, ABS(Korr)) mKorrMax = MAX(mKorrMax, ABS(Korr)) CASE mIntKrit=2 mSinfMin = MIN(mSinfMin, ABS(Sum_inf)) mSinfMax = MAX(mSinfMax, ABS(Sum_inf)) ENDCASE **** Присвоить массивам параметрически заданные значения отображаемой функции aArg := {} aVal := {} FOR j=1 TO N_PointsScenario mFieldName = "Avr"+ALLTRIM(STR(j,5)) // Среднее значение числового диапазона базового класса (для рисования и взвешенного усреднения) AADD(aArg, j) AADD(aVal, &mFieldName) NEXT FOR j=1 TO LEN(aArg) 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 IF mBez=1 // Только для полинома сглаженный график функции может выходить за пределы ее значений 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 := 1 TO LEN(aArg) STEP 0.05 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 // Закрыть процесс печати выходной формы ****** Поиск макс и мин значений аргумента и функции *********** FOR j=1 TO LEN(aArgPoli) X_MinA = MIN(X_MinA, aArgPoli[j]) X_MaxA = MAX(X_MaxA, aArgPoli[j]) Y_MinF = MIN(Y_MinF, aValPoli[j]) Y_MaxF = MAX(Y_MaxF, aValPoli[j]) NEXT ENDIF DBSKIP(1) ENDDO * N_PointsScenario = LEN(aArgPoli) * MsgBox('X_MinA,X_MaxA,Y_MinF,Y_MaxF: '+ALLTRIM(STR(X_MinA))+', '+ALLTRIM(STR(X_MaxA))+', '+ALLTRIM(STR(Y_MinF))+', '+ALLTRIM(STR(Y_MaxF))) PRIVATE X0 := 75 * PRIVATE Y0 := 75 // Начало координат по осям X и Y с учетом места для легенды PRIVATE Y0 := 100 // Начало координат по осям X и Y с учетом места для легенды PRIVATE W_Wind := X_MaxW - X0 - 25 // Ширина окна для самого графика 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 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 ) // Установить символьные атрибуты * mToBeOrNotToBe, mNameMod, mIntKrit, mKodObj, mNameObj // Написать в заголовке: что будет или чего не будет, модель, инт.критерий, код и наименование распознаваемого объекта mTitle = 'ALL' IF mIntKrit=0 .AND. IF(aPar[13] .OR. aPar[14] .OR. aPar[15],.T.,.F.) mTitle = L('ВСЕ СРЕДНЕВЗВЕШЕННЫЕ ПРОГНОЗНЫЕ СЦЕНАРИИ ТОГО "ЧТО БУДЕТ" И "ЧЕГО НЕ БУДЕТ"')+' '+L('В МОДЕЛИ: "')+UPPER(mNameMod)+'"' ELSE DO CASE CASE mToBeOrNotToBe=1 .AND. IF(aPar[ 7] .OR. aPar[ 8] .OR. aPar[ 9],.T.,.F.) // Что будет mTitle = L('ЧАСТНЫЕ И СРЕДНЕВЗВЕШЕННЫЙ ПРОГНОЗНЫЕ СЦЕНАРИИ')+' "'+L('ЧТО БУДЕТ') +'" '+L('В МОДЕЛИ: "')+UPPER(mNameMod)+'"' CASE mToBeOrNotToBe=2 .AND. IF(aPar[10] .OR. aPar[11] .OR. aPar[12],.T.,.F.) // Чего не будет mTitle = L('ЧАСТНЫЕ И СРЕДНЕВЗВЕШЕННЫЙ ПРОГНОЗНЫЕ СЦЕНАРИИ')+' "'+L('ЧЕГО НЕ БУДЕТ')+'" '+L('В МОДЕЛИ: "')+UPPER(mNameMod)+'"' ENDCASE 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) * =================================================================================================== * | | Ломанные линии |Полином n-й степ.| Сплайны Безье | * |Переключатели | mBez=0 | mBez=1 | mBez=2 | * --------------------------|-----------------|-----------------|-----------------|-----------------| * Инт.критерий: "Сумм.инф." |mIntKrit=1 | 1 | 2 | 3 | * Инт.критерий: "Корреляция"|mIntKrit=2 | 4 | 5 | 6 | * Что будет |mToBeOrNotToBe=1 | 7 | 8 | 9 | * Чего не будет |mToBeOrNotToBe=2 | 10 | 11 | 12 | * Средневзвешенные сценарии |Любое значение | 13 | 14 | 15 | * =================================================================================================== * IF mBez=0 .AND. IF(aPar[ 1] .OR. aPar[ 4] .OR. aPar[ 7] .OR. aPar[10] .OR. aPar[13],.T.,.F.) * mBez=1 .AND. IF(aPar[ 2] .OR. aPar[ 5] .OR. aPar[ 8] .OR. aPar[11] .OR. aPar[14],.T.,.F.) * mBez=2 .AND. IF(aPar[ 3] .OR. aPar[ 6] .OR. aPar[ 9] .OR. aPar[12] .OR. aPar[15],.T.,.F.) * mIntKrit=0 .AND. IF(aPar[13] .OR. aPar[14] .OR. aPar[15],.T.,.F.) * mIntKrit=1 .AND. IF(aPar[ 1] .OR. aPar[ 2] .OR. aPar[ 3],.T.,.F.) * mIntKrit=2 .AND. IF(aPar[ 4] .OR. aPar[ 5] .OR. aPar[ 6],.T.,.F.) * mToBeOrNotToBe=1 .AND. IF(aPar[ 7] .OR. aPar[ 8] .OR. aPar[ 9],.T.,.F.) * mToBeOrNotToBe=2 .AND. IF(aPar[10] .OR. aPar[11] .OR. aPar[12],.T.,.F.) cFileName = 'ALL' IF mIntKrit=0 .AND. IF(aPar[13] .OR. aPar[14] .OR. aPar[15],.T.,.F.) DO CASE CASE mBez=0 .AND. IF(aPar[ 1] .OR. aPar[ 4] .OR. aPar[ 7] .OR. aPar[10] .OR. aPar[13],.T.,.F.) // Ломанная кривая cFileName = 'ALLAvrScen'+'-'+Ar_Model[M_CurrInf]+'-'+ALLTRIM(STR(mKodObj))+'.jpg' GraStringAt( oPS, { X_MaxW/2, Y_MaxW-52 }, L('Распознаваемый объект:')+' '+ALLTRIM(STR(mKodObj))+'-'+ALLTRIM(mNameObj)+'. '+L('Ломанные линии') ) CASE mBez=1 .AND. IF(aPar[ 2] .OR. aPar[ 5] .OR. aPar[ 8] .OR. aPar[11] .OR. aPar[14],.T.,.F.) // Полином n-йстепени cFileName = 'ALLAvrScen'+'-'+Ar_Model[M_CurrInf]+'-'+ALLTRIM(STR(mKodObj))+'-Poli.jpg' GraStringAt( oPS, { X_MaxW/2, Y_MaxW-52 }, L('Распознаваемый объект:')+' '+ALLTRIM(STR(mKodObj))+'-'+ALLTRIM(mNameObj)+'. '+L('Полиномы n-й степени') ) CASE mBez=2 .AND. IF(aPar[ 3] .OR. aPar[ 6] .OR. aPar[ 9] .OR. aPar[12] .OR. aPar[15],.T.,.F.) // Сплайны Безье cFileName = 'ALLAvrScen'+'-'+Ar_Model[M_CurrInf]+'-'+ALLTRIM(STR(mKodObj))+'-Splain.jpg' GraStringAt( oPS, { X_MaxW/2, Y_MaxW-52 }, L('Распознаваемый объект:')+' '+ALLTRIM(STR(mKodObj))+'-'+ALLTRIM(mNameObj)+'. '+L('Сплайны Безье') ) ENDCASE ELSE DO CASE CASE mBez=0 .AND. IF(aPar[ 1] .OR. aPar[ 4] .OR. aPar[ 7] .OR. aPar[10] .OR. aPar[13],.T.,.F.) // Ломанная кривая cFileName = 'AvrScen'+'-'+Ar_Model[M_CurrInf]+'-'+aIntKrit[mIntKrit]+'-'+aPosNeg[mToBeOrNotToBe]+'-'+ALLTRIM(STR(mKodObj))+'.jpg' GraStringAt( oPS, { X_MaxW/2, Y_MaxW-52 }, L('Распознаваемый объект:')+' '+ALLTRIM(STR(mKodObj))+'-'+ALLTRIM(mNameObj)+L('. Интегральный критерий:')+' '+IF(mIntKrit=1,L('"Резонанс знаний"'),L('"Сумма знаний"'))+'. '+L('Ломанные линии') ) CASE mBez=1 .AND. IF(aPar[ 2] .OR. aPar[ 5] .OR. aPar[ 8] .OR. aPar[11] .OR. aPar[14],.T.,.F.) // Полином n-йстепени cFileName = 'AvrScen'+'-'+Ar_Model[M_CurrInf]+'-'+aIntKrit[mIntKrit]+'-'+aPosNeg[mToBeOrNotToBe]+'-'+ALLTRIM(STR(mKodObj))+'-Poli.jpg' GraStringAt( oPS, { X_MaxW/2, Y_MaxW-52 }, L('Распознаваемый объект:')+' '+ALLTRIM(STR(mKodObj))+'-'+ALLTRIM(mNameObj)+L('. Интегральный критерий:')+' '+IF(mIntKrit=1,L('"Резонанс знаний"'),L('"Сумма знаний"'))+'. '+L('Полиномы n-й степени') ) CASE mBez=2 .AND. IF(aPar[ 3] .OR. aPar[ 6] .OR. aPar[ 9] .OR. aPar[12] .OR. aPar[15],.T.,.F.) // Сплайны Безье cFileName = 'AvrScen'+'-'+Ar_Model[M_CurrInf]+'-'+aIntKrit[mIntKrit]+'-'+aPosNeg[mToBeOrNotToBe]+'-'+ALLTRIM(STR(mKodObj))+'-Splain.jpg' GraStringAt( oPS, { X_MaxW/2, Y_MaxW-52 }, L('Распознаваемый объект:')+' '+ALLTRIM(STR(mKodObj))+'-'+ALLTRIM(mNameObj)+L('. Интегральный критерий:')+' '+IF(mIntKrit=1,L('"Резонанс знаний"'),L('"Сумма знаний"'))+'. '+L('Сплайны Безье') ) ENDCASE ENDIF oFont := XbpFont():new():create("14.Arial Bold") 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] ) ***** Нарисовать оси координат ******************* 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-40, 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-40, Y1-aTxtPar[2]/2 }, ALLTRIM(STR(Y_MaxF,15,2)) ) GraLine ( oPS, { X0 , Y1 }, {X0+W_Wind, Y1} ) // Нарисовать пунктирную линию уровня Y *************************************************************************************************************************************************************** DO CASE CASE mIntKrit=0 .AND. IF(aPar[13] .OR. aPar[14] .OR. aPar[15],.T.,.F.) SELECT ChartClsik CASE mIntKrit=1 .AND. IF(aPar[ 1] .OR. aPar[ 2] .OR. aPar[ 3],.T.,.F.) SELECT ChartClsk DO CASE CASE mToBeOrNotToBe=1 .AND. IF(aPar[ 7] .OR. aPar[ 8] .OR. aPar[ 9],.T.,.F.) // Что будет SET FILTER TO Kod_ClSc = mKodClSc .AND. Korr > 0 CASE mToBeOrNotToBe=2 .AND. IF(aPar[10] .OR. aPar[11] .OR. aPar[12],.T.,.F.) // Чего не будет SET FILTER TO Kod_ClSc = mKodClSc .AND. Korr < 0 ENDCASE CASE mIntKrit=2 .AND. IF(aPar[ 4] .OR. aPar[ 5] .OR. aPar[ 6],.T.,.F.) SELECT ChartClsi DO CASE CASE mToBeOrNotToBe=1 .AND. IF(aPar[ 7] .OR. aPar[ 8] .OR. aPar[ 9],.T.,.F.) // Что будет SET FILTER TO Kod_ClSc = mKodClSc .AND. Sum_inf > 0 CASE mToBeOrNotToBe=2 .AND. IF(aPar[10] .OR. aPar[11] .OR. aPar[12],.T.,.F.) // Чего не будет SET FILTER TO Kod_ClSc = mKodClSc .AND. Sum_inf < 0 ENDCASE ENDCASE ********* Цикл по частным сценариям (в конце 2 строки отображать по-другому) <<<===######################## ************************************************** DBGOTOP() DO WHILE .NOT. EOF() // Цикл по частным сценариям (в конце 2 строки отображать по-другому) <<<===######################## *** Присвоить массивам параметрически заданные значения отображаемой функции aArg := {} aVal := {} FOR j=1 TO N_PointsScenario mFieldName = "Avr"+ALLTRIM(STR(j,5)) // Среднее значение числового диапазона базового класса (для рисования и взвешенного усреднения) AADD(aArg, j) // % от общего числа признаков AADD(aVal, &mFieldName) // % от общей значимости NEXT DO CASE CASE mIntKrit=1 .AND. IF(aPar[ 1] .OR. aPar[ 2] .OR. aPar[ 3],.T.,.F.) mKorr = ABS(Korr) CASE mIntKrit=2 .AND. IF(aPar[ 4] .OR. aPar[ 5] .OR. aPar[ 6],.T.,.F.) mSumInf = ABS(Sum_inf) ENDCASE mFakt = Fakt mNameCls = Name_cls cIntKrit = Int_krit DO CASE CASE mBez=0 .AND. IF(aPar[ 1] .OR. aPar[ 4] .OR. aPar[ 7] .OR. aPar[10] .OR. aPar[13],.T.,.F.) // Ломанные линии ************************************************************************************************************** ** НАРИСОВАТЬ ЛОМАННЫМИ ЛИНИЯМИ ****************************************************************************** ************************************************************************************************************** **** Если данный сценарий осуществился фактически рисовать его по-другому: **** толстой линией разных цветов: внешняя темно-фиолетовый, затем фиолетовый все светлее и в центре линии ярко-фиолетовый DO CASE CASE Fakt <> "v" // Данный сценарий фактически не осуществился ***** Рисование маркеров и отрезков прямых *************************************************** N_Col = 1 + RANDOM()%LEN(aColor) // Случайный номер цвета aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии DO CASE CASE mIntKrit=0 .AND. IF(aPar[13] .OR. aPar[14] .OR. aPar[15],.T.,.F.) DO CASE CASE Fakt = "+" DO CASE CASE Int_krit = 'Корреляция' aAttr [ GRA_AL_COLOR ] := aColor[190] // Ярко-красный - k CASE Int_Krit = 'Сумма информации' aAttr [ GRA_AL_COLOR ] := aColor[192] // Темно-красный - i ENDCASE CASE Fakt = "-" DO CASE CASE Int_krit = 'Корреляция' aAttr [ GRA_AL_COLOR ] := aColor[34] // Ярко-синий - k CASE Int_Krit = 'Сумма информации' aAttr [ GRA_AL_COLOR ] := aColor[12] // Темно-синий - i ENDCASE ENDCASE IF AT('Средневзвешенный сценарий', mNameCls) = 0 aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DOT aAttr [ GRA_AL_WIDTH ] := 1 // Для рисования разброса частных прогнозов от средневзвшенного прогноза задать толщину линии сценария = 1 ELSE aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT DO CASE CASE LEN(ALLTRIM(Int_krit)) = LEN('Корреляция') aAttr [ GRA_AL_WIDTH ] := 10*(mKorrMax-ABS(Korr)) / (mKorrMax-ABS(mKorrMin)) // Задать толщину линии сценария, соответствующую сходству с ним (10 - макс толщина линии) <<<===############## CASE LEN(ALLTRIM(Int_krit)) = LEN('Сумма информации') aAttr [ GRA_AL_WIDTH ] := 10*(mSinfMax-ABS(Sum_inf)) / (mSinfMax-ABS(mSinfMin)) // Задать толщину линии сценария, соответствующую сходству с ним (10 - макс толщина линии) ENDCASE ENDIF CASE mIntKrit=1 .AND. IF(aPar[ 1] .OR. aPar[ 2] .OR. aPar[ 3],.T.,.F.) aAttr [ GRA_AL_COLOR ] := aColor[N_Col] // ЦВЕТА СЦЕНАРИЕВ ВЫБИРАТЬ СЛУЧАЙНЫМ ОБРАЗОМ, КРОМЕ СРЕДНЕВЗВЕШЕННОГО <<<===############## aAttr [ GRA_AL_WIDTH ] := 10*(mKorrMax-ABS(Korr)) /(mKorrMax-ABS(mKorrMin)) // Задать толщину линии сценария, соответствующую сходству с ним (10 - макс толщина линии) CASE mIntKrit=2 .AND. IF(aPar[ 4] .OR. aPar[ 5] .OR. aPar[ 6],.T.,.F.) aAttr [ GRA_AL_COLOR ] := aColor[N_Col] // ЦВЕТА СЦЕНАРИЕВ ВЫБИРАТЬ СЛУЧАЙНЫМ ОБРАЗОМ, КРОМЕ СРЕДНЕВЗВЕШЕННОГО <<<===############## aAttr [ GRA_AL_WIDTH ] := 10*(mSinfMax-ABS(Sum_inf)) / (mSinfMax-ABS(mSinfMin)) // Задать толщину линии сценария, соответствующую сходству с ним (10 - макс толщина линии) ENDCASE 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 Y1 := Y0 + (aVal[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx * Y2 := Y0A + (aVal[j ]-Y_MinF) * Ky Y2 := Y0 + (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 * Y := Y0 + (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 CASE Fakt = "v" // Данный сценарий осуществился фактически ***** Рисование маркеров и отрезков прямых *************************************************** 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 // Задать толщину линии сценария, соответствующую сходству с ним (9 - макс толщина линии) 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 * Y1 := Y0 + (aVal[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx Y2 := Y0A + (aVal[j ]-Y_MinF) * Ky * Y2 := Y0 + (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 * Y := Y0 + (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 NEXT ENDCASE CASE mBez=1 .AND. IF(aPar[ 2] .OR. aPar[ 5] .OR. aPar[ 8] .OR. aPar[11] .OR. aPar[14],.T.,.F.) ************************************************************************************************************** ** НАРИСОВАТЬ ПОЛИНОМ N-Й СТЕПЕНИ **************************************************************************** ************************************************************************************************************** * ?n,InterPolate({{0,2}, {1,3}, {2,12}, {5,147}},n) 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 := 1 TO LEN(aArg) STEP 0.1 // 10 ТОЧЕК МЕЖДУ ОПОРНЫМИ mValPoli = InterPolate(aPoints, p) // <<<===###################### ВЫЧИСЛЕНИЕ ЗНАЧЕНИЙ ПОЛИНОМА N-Й СТЕПЕНИ ?p, mValPoli AADD(aArgPoli, p) AADD(aValPoli, mValPoli) NEXT p Set device to screen;Set printer off;Set printer to;Set console on // Закрыть процесс печати выходной формы **** Если данный сценарий осуществился фактически рисовать его по-другому: **** толстой линией разных цветов: внешняя темно-фиолетовый, затем фиолетовый все светлее и в центре линии ярко-фиолетовый DO CASE CASE Fakt <> "v" // Данный сценарий фактически не осуществился N_Col = 1 + RANDOM()%LEN(aColor) // Случайный номер цвета aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии DO CASE CASE mIntKrit=0 .AND. IF(aPar[13] .OR. aPar[14] .OR. aPar[15],.T.,.F.) DO CASE CASE Fakt = "+" DO CASE CASE Int_krit = 'Корреляция' aAttr [ GRA_AL_COLOR ] := aColor[190] // Ярко-красный - k CASE Int_Krit = 'Сумма информации' aAttr [ GRA_AL_COLOR ] := aColor[192] // Темно-красный - i ENDCASE CASE Fakt = "-" DO CASE CASE Int_krit = 'Корреляция' aAttr [ GRA_AL_COLOR ] := aColor[34] // Ярко-синий - k CASE Int_Krit = 'Сумма информации' aAttr [ GRA_AL_COLOR ] := aColor[12] // Темно-синий - i ENDCASE ENDCASE IF AT('Средневзвешенный сценарий', mNameCls) = 0 aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DOT aAttr [ GRA_AL_WIDTH ] := 1 // Для рисования разброса частных прогнозов от средневзвшенного прогноза задать толщину линии сценария = 1 ELSE aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT DO CASE CASE LEN(ALLTRIM(Int_krit)) = LEN('Корреляция') aAttr [ GRA_AL_WIDTH ] := 10*(mKorrMax-ABS(Korr)) / (mKorrMax-ABS(mKorrMin)) // Задать толщину линии сценария, соответствующую сходству с ним (10 - макс толщина линии) <<<===############## CASE LEN(ALLTRIM(Int_krit)) = LEN('Сумма информации') aAttr [ GRA_AL_WIDTH ] := 10*(mSinfMax-ABS(Sum_inf)) / (mSinfMax-ABS(mSinfMin)) // Задать толщину линии сценария, соответствующую сходству с ним (10 - макс толщина линии) ENDCASE ENDIF CASE mIntKrit=1 .AND. IF(aPar[ 1] .OR. aPar[ 2] .OR. aPar[ 3],.T.,.F.) aAttr [ GRA_AL_COLOR ] := aColor[N_Col] // ЦВЕТА СЦЕНАРИЕВ ВЫБИРАТЬ СЛУЧАЙНЫМ ОБРАЗОМ, КРОМЕ СРЕДНЕВЗВЕШЕННОГО <<<===############## aAttr [ GRA_AL_WIDTH ] := 10*(mKorrMax-ABS(Korr)) /(mKorrMax-ABS(mKorrMin)) // Задать толщину линии сценария, соответствующую сходству с ним (10 - макс толщина линии) CASE mIntKrit=2 .AND. IF(aPar[ 4] .OR. aPar[ 5] .OR. aPar[ 6],.T.,.F.) aAttr [ GRA_AL_COLOR ] := aColor[N_Col] // ЦВЕТА СЦЕНАРИЕВ ВЫБИРАТЬ СЛУЧАЙНЫМ ОБРАЗОМ, КРОМЕ СРЕДНЕВЗВЕШЕННОГО <<<===############## aAttr [ GRA_AL_WIDTH ] := 10*(mSinfMax-ABS(Sum_inf)) / (mSinfMax-ABS(mSinfMin)) // Задать толщину линии сценария, соответствующую сходству с ним (10 - макс толщина линии) ENDCASE graSetAttrLine( oPS, aAttr ) // установить атрибуты FOR p=2 TO LEN(aArgPoli) X1 := X0 + (aArgPoli[p-1]-X_MinA) * Kx Y1 := Y0 + (aValPoli[p-1]-Y_MinF) * Ky X2 := X0 + (aArgpoli[p ]-X_MinA) * Kx Y2 := Y0 + (aValPoli[p ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT ************************************ Конец отображения полинома n-й степени ********************************** CASE Fakt = "v" // Данный сценарий осуществился фактически ***** Рисование маркеров и отрезков прямых *************************************************** 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 // Задать толщину линии сценария, соответствующую сходству с ним (9 - макс толщина линии) graSetAttrLine( oPS, aAttr ) // Установить атрибуты FOR p=2 TO LEN(aArgPoli) X1 := X0 + (aArgPoli[p-1]-X_MinA) * Kx Y1 := Y0 + (aValPoli[p-1]-Y_MinF) * Ky X2 := X0 + (aArgpoli[p ]-X_MinA) * Kx Y2 := Y0 + (aValPoli[p ]-Y_MinF) * Ky GraLine( oPS, { X1, Y1 }, { X2, Y2 } ) // Нарисовать отрезок прямой линии NEXT ************************************ Конец отображения полинома n-й степени ********************************** NEXT ENDCASE CASE mBez=2 .AND. IF(aPar[ 3] .OR. aPar[ 6] .OR. aPar[ 9] .OR. aPar[12] .OR. aPar[15],.T.,.F.) ************************************************************************************************************** ** РИСОВАНИЕ КРИВОЙ БЕЗЬЕ ************************************************************************************ ************************************************************************************************************** ******** Создание БД и массива для составной (гладкой) кривой Безье **************************** ******** Все записи должны быть полностью заполнены * CLOSE ALL * aStructure := { { "Xp_AVR" , "N", 15, 7 }, ; // 1. Xp_AVR=Xf_AVR предыдущей записи (в 1-й записи = X1) * { "Yp_AVR" , "N", 15, 7 }, ; // 1. Yp_AVR=Yf_AVR предыдущей записи (в 1-й записи = Y1) * { "X1" , "N", 15, 7 }, ; // 2. 1-я опорная точка * { "Y1" , "N", 15, 7 }, ; // 2. 1-я опорная точка * { "X2" , "N", 15, 7 }, ; // 3. 2-я опорная точка * { "Y2" , "N", 15, 7 }, ; // 3. 2-я опорная точка * { "Xf_AVR" , "N", 15, 7 }, ; // 4. Xf_AVR=(X2_текущей записи + X1_следующей записи)/2 (в последней записи = X2) * { "Yf_AVR" , "N", 15, 7 }, ; // 4. Yf_AVR=(Y2_текущей записи + Y1_следующей записи)/2 (в последней записи = Y2) * { "Korr" , "N", 15, 7 }, ; // Уровень сходства-различия "Корреляция" * { "Sum_inf" , "N", 15, 7 }, ; // Уровень сходства-различия "Сумма информации" * { "Fakt" , "C", 1, 0 }, ; // Факт * { "Int_krit", "C", LEN('Сумма информации'), 0 } } // Инт.критерий * DbCreate( 'Points.dbf', aStructure ) * CLOSE ALL * USE Bezier EXCLUSIVE NEW * USE Points EXCLUSIVE NEW 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 FOR j=1 TO LEN(aArg) STEP 2 APPEND BLANK REPLACE Fakt WITH mFakt REPLACE Int_krit WITH cIntKrit DO CASE CASE mIntKrit=1 .AND. IF(aPar[ 1] .OR. aPar[ 2] .OR. aPar[ 3],.T.,.F.) REPLACE Korr WITH mKorr CASE mIntKrit=2 .AND. IF(aPar[ 4] .OR. aPar[ 5] .OR. aPar[ 6],.T.,.F.) REPLACE Sum_inf WITH mSumInf ENDCASE 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 ****** Дорасчет координат вставленных точек 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 DO CASE CASE Fakt <> "v" // Данный сценарий фактически не осуществился *** Цикл визуализации сплайнов Безье ************************************************* N_Col = 1 + RANDOM()%LEN(aColor) // Случайный номер цвета aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии DO CASE CASE mIntKrit=0 .AND. IF(aPar[13] .OR. aPar[14] .OR. aPar[15],.T.,.F.) DO CASE CASE Fakt = "+" DO CASE CASE LEN(ALLTRIM(Int_krit)) = LEN('Корреляция') aAttr [ GRA_AL_COLOR ] := aColor[190] // Ярко-красный - k CASE LEN(ALLTRIM(Int_krit)) = LEN('Сумма информации') aAttr [ GRA_AL_COLOR ] := aColor[192] // Темно-красный - i ENDCASE CASE Fakt = "-" DO CASE CASE LEN(ALLTRIM(Int_krit)) = LEN('Корреляция') aAttr [ GRA_AL_COLOR ] := aColor[34] // Ярко-синий - k CASE LEN(ALLTRIM(Int_krit)) = LEN('Сумма информации') aAttr [ GRA_AL_COLOR ] := aColor[12] // Темно-синий - i ENDCASE ENDCASE IF AT('Средневзвешенный сценарий', mNameCls) = 0 aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DOT aAttr [ GRA_AL_WIDTH ] := 1 // Для рисования разброса частных прогнозов от средневзвшенного прогноза задать толщину линии сценария = 1 ELSE aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT DO CASE CASE LEN(ALLTRIM(Int_krit)) = LEN('Корреляция') aAttr [ GRA_AL_WIDTH ] := 10*(mKorrMax-ABS(Korr)) / (mKorrMax-ABS(mKorrMin)) // Задать толщину линии сценария, соответствующую сходству с ним (10 - макс толщина линии) <<<===############## CASE LEN(ALLTRIM(Int_krit)) = LEN('Сумма информации') aAttr [ GRA_AL_WIDTH ] := 10*(mSinfMax-ABS(Sum_inf)) / (mSinfMax-ABS(mSinfMin)) // Задать толщину линии сценария, соответствующую сходству с ним (10 - макс толщина линии) ENDCASE ENDIF CASE mIntKrit=1 .AND. IF(aPar[ 1] .OR. aPar[ 2] .OR. aPar[ 3],.T.,.F.) aAttr [ GRA_AL_COLOR ] := aColor[N_Col] // ЦВЕТА СЦЕНАРИЕВ ВЫБИРАТЬ СЛУЧАЙНЫМ ОБРАЗОМ, КРОМЕ СРЕДНЕВЗВЕШЕННОГО <<<===############## aAttr [ GRA_AL_WIDTH ] := 10*(mKorrMax-ABS(Korr)) / (mKorrMax-ABS(mKorrMin)) // Задать толщину линии сценария, соответствующую сходству с ним (10 - макс толщина линии) <<<===############## CASE mIntKrit=2 .AND. IF(aPar[ 4] .OR. aPar[ 5] .OR. aPar[ 6],.T.,.F.) aAttr [ GRA_AL_COLOR ] := aColor[N_Col] // ЦВЕТА СЦЕНАРИЕВ ВЫБИРАТЬ СЛУЧАЙНЫМ ОБРАЗОМ, КРОМЕ СРЕДНЕВЗВЕШЕННОГО <<<===############## aAttr [ GRA_AL_WIDTH ] := 10*(mSinfMax-ABS(Sum_inf)) / (mSinfMax-ABS(mSinfMin)) // Задать толщину линии сценария, соответствующую сходству с ним (10 - макс толщина линии) ENDCASE * aAttrM := ARRAY( GRA_AM_COUNT ) // Массив для атрибутов маркеров * aAttrM[ GRA_AM_SYMBOL ] := GRA_MARKSYM_SMALLCIRCLE * aAttrM[ GRA_AM_COLOR ] := aColor[190] // Задать цвет вставленной точки 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 NEXT graSetAttrLine( oPS, aAttr ) // установить атрибуты GraSpline( oPS, aPoints, .F. ) // НАРИСОВАТЬ ЧАСТНУЮ КРИВУЮ БЕЗЬЕ <<<===########### * GraSetAttrMarker( oPS, aAttrM ) // установить атрибуты * GraMarker( oPS, aPoints[1] ) // пометить 1-ю точку DBSKIP(1) ENDDO ************************************ Конец отображения кривой Безье *********************** CASE Fakt = "v" // Данный сценарий осуществился фактически * MsgBox('STOP') ***** Рисование маркеров и отрезков прямых *************************************************** 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 * aAttrM := ARRAY( GRA_AM_COUNT ) // Массив для атрибутов маркеров * aAttrM[ GRA_AM_SYMBOL ] := GRA_MARKSYM_SMALLCIRCLE * aAttrM[ GRA_AM_COLOR ] := aColor[190] // Задать цвет вставленной точки 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 // Задать толщину линии сценария, соответствующую сходству с ним (9 - макс толщина линии) 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 NEXT graSetAttrLine( oPS, aAttr ) // установить атрибуты GraSpline( oPS, aPoints, .F. ) // НАРИСОВАТЬ ЧАСТНУЮ КРИВУЮ БЕЗЬЕ <<<===########### * GraSetAttrMarker( oPS, aAttrM ) // установить атрибуты * GraMarker( oPS, aPoints[1] ) // пометить 1-ю точку DBSKIP(1) ENDDO ************************************ Конец отображения кривой Безье *********************** NEXT ENDCASE ENDCASE DO CASE CASE mIntKrit=0 .AND. IF(aPar[13] .OR. aPar[14] .OR. aPar[15],.T.,.F.) SELECT ChartClsik // Все средневзвешенные вместе CASE mIntKrit=1 .AND. IF(aPar[ 1] .OR. aPar[ 2] .OR. aPar[ 3],.T.,.F.) SELECT ChartClsk DO CASE CASE mToBeOrNotToBe=1 .AND. IF(aPar[ 7] .OR. aPar[ 8] .OR. aPar[ 9],.T.,.F.) // Что будет SET FILTER TO Kod_ClSc = mKodClSc .AND. Korr > 0 CASE mToBeOrNotToBe=2 .AND. IF(aPar[10] .OR. aPar[11] .OR. aPar[12],.T.,.F.) // Чего не будет SET FILTER TO Kod_ClSc = mKodClSc .AND. Korr < 0 ENDCASE CASE mIntKrit=2 .AND. IF(aPar[ 4] .OR. aPar[ 5] .OR. aPar[ 6],.T.,.F.) SELECT ChartClsi DO CASE CASE mToBeOrNotToBe=1 .AND. IF(aPar[ 7] .OR. aPar[ 8] .OR. aPar[ 9],.T.,.F.) // Что будет SET FILTER TO Kod_ClSc = mKodClSc .AND. Sum_inf > 0 CASE mToBeOrNotToBe=2 .AND. IF(aPar[10] .OR. aPar[11] .OR. aPar[12],.T.,.F.) // Чего не будет SET FILTER TO Kod_ClSc = mKodClSc .AND. Sum_inf < 0 ENDCASE ENDCASE DBSKIP(1) ENDDO ***** Конец цикла по сценариям ********************************** *************************************************************************************************************************************************************** *** СЮДА ВСТАВИТЬ ОТОБРАЖЕНИЕ СРЕДНЕВЗВЕШЕННОГО СЦЕНАРИЯ ТОЛСТОЙ ТЕМНОЙ ЛИНИЕЙ ВОЗМОЖНО КРИВОЙ БЕЗЬЕ<<<===####### IF mIntKrit > 0 DO CASE CASE mIntKrit=1 .AND. IF(aPar[ 1] .OR. aPar[ 2] .OR. aPar[ 3],.T.,.F.) SELECT ChartClsk CASE mIntKrit=2 .AND. IF(aPar[ 4] .OR. aPar[ 5] .OR. aPar[ 6],.T.,.F.) SELECT ChartClsi ENDCASE SET FILTER TO DO CASE CASE mToBeOrNotToBe=1 .AND. IF(aPar[ 7] .OR. aPar[ 8] .OR. aPar[ 9],.T.,.F.) DBGOTO(RECCOUNT()-1) CASE mToBeOrNotToBe=2 .AND. IF(aPar[10] .OR. aPar[11] .OR. aPar[12],.T.,.F.) DBGOBOTTOM() ENDCASE * MsgBox(STR(mToBeOrNotToBe)+STR(RECNO())) *** Присвоить массивам параметрически заданные значения отображаемой функции aArg := {} aVal := {} FOR j=1 TO N_PointsScenario mFieldName = "Avr"+ALLTRIM(STR(j,5)) // Среднее значение числового диапазона базового класса (для рисования и взвешенного усреднения) AADD(aArg, j) // % от общего числа признаков AADD(aVal, &mFieldName) // % от общей значимости NEXT ***** Рисование маркеров и отрезков прямых *************************************************** ***** Сделать рисование линий двух цветов, внутри посветлее, а снаружи потемнее (эффект объема) ***** для этого рисовать от внешних частей линии к внутренним уменьшающейся толщиной линии и более светлым цветом ПОВЕРХ РАНЕЕ НАРИСОВАННОГО aAttr := Array( GRA_AL_COUNT ) // Массив для атрибутов линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT DO CASE CASE mToBeOrNotToBe=1 .AND. IF(aPar[ 7] .OR. aPar[ 8] .OR. aPar[ 9],.T.,.F.) aAttr [ GRA_AL_COLOR ] := aColor[190] // ЦВЕТ СРЕДН.ВЗВЕШЕННОГО СЦЕНАРИЯ ТОГО "ЧТО БУДЕТ" И ТОГО, "ЧЕГО НЕ БУДЕТ" <<<===################### CASE mToBeOrNotToBe=2 .AND. IF(aPar[10] .OR. aPar[11] .OR. aPar[12],.T.,.F.) aAttr [ GRA_AL_COLOR ] := aColor[12] // ЦВЕТ СРЕДН.ВЗВЕШЕННОГО СЦЕНАРИЯ ТОГО "ЧТО БУДЕТ" И ТОГО, "ЧЕГО НЕ БУДЕТ" <<<===################### ENDCASE aAttr [ GRA_AL_WIDTH ] := 15 // Задать толщину линии средневзвешенного сценария 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 Y1 := Y0 + (aVal[j-1]-Y_MinF) * Ky X2 := X0 + (aArg[j ]-X_MinA) * Kx * Y2 := Y0A + (aVal[j ]-Y_MinF) * Ky Y2 := Y0 + (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 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 IF mIntKrit=0 .AND. IF(aPar[13] .OR. aPar[14] .OR. aPar[15],.T.,.F.) // Легенда: все средневзвешенные прогнозы на одной диаграмме oFont := XbpFont():new():create("10.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 ) // Установить символьные атрибуты P1 = 390 p2 = 610 D = 15 YL = Y0-45 **** Написать текст ********** GraStringAt( oPS, { X0, YL-D*0 }, L('Средневзвешенный прогноз того ЧТО БУДЕТ,' ));GraStringAt( oPS, { P1, YL-D*0 }, L('инт.критерий "Корреляция":' )) GraStringAt( oPS, { X0, YL-D*1 }, L('Средневзвешенный прогноз того ЧТО БУДЕТ,' ));GraStringAt( oPS, { P1, YL-D*1 }, L('инт.критерий "Сумма информации":')) GraStringAt( oPS, { X0, YL-D*2 }, L('Средневзвешенный прогноз того ЧЕГО НЕ БУДЕТ,'));GraStringAt( oPS, { P1, YL-D*2 }, L('инт.критерий "Корреляция":' )) GraStringAt( oPS, { X0, YL-D*3 }, L('Средневзвешенный прогноз того ЧЕГО НЕ БУДЕТ,'));GraStringAt( oPS, { P1, YL-D*3 }, L('инт.критерий "Сумма информации":')) **** Нарисовать сами линии *** aAttr := Array( GRA_AL_COUNT ) // атрибуты линии aAttr [ GRA_AL_TYPE ] := GRA_LINETYPE_DEFAULT aAttr [ GRA_AL_WIDTH ] := 5 // Задать толщину линии aAttr [ GRA_AL_COLOR ] := aColor[190];graSetAttrLine( oPS, aAttr );GraLine(oPS, { P2, YL-D*0 }, { P2+100, YL-D*0 } ) // Что будет, Корреляция , Ярко-красный - k aAttr [ GRA_AL_COLOR ] := aColor[192];graSetAttrLine( oPS, aAttr );GraLine(oPS, { P2, YL-D*1 }, { P2+100, YL-D*1 } ) // Что будет, Сумма информации, Темно-красный - i aAttr [ GRA_AL_COLOR ] := aColor[ 34];graSetAttrLine( oPS, aAttr );GraLine(oPS, { P2, YL-D*2 }, { P2+100, YL-D*2 } ) // Что будет, Корреляция , Ярко-синий - k aAttr [ GRA_AL_COLOR ] := aColor[ 12];graSetAttrLine( oPS, aAttr );GraLine(oPS, { P2, YL-D*3 }, { P2+100, YL-D*3 } ) // Что будет, Сумма информации, Темно-синий - i ENDIF ****** Надписи координатных осей ********************************* oFont := XbpFont():new():create("13.ArialBold") 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]-60 GraStringAt( oPS, { mPosX, Y0-45 }, cFile ) // Полное наименование файла GraStringAt( oPS, { mPosX, Y0-65 }, DTOC(DATE())+'-'+TIME() ) // Время создания файла SELECT Class_sc DBGOTO(mKodClSc) mNameClSc = ALLTRIM(Name_ClSc) AyName = L("Прогнозируемое значение шкалы:")+' "'+mNameClSc+'"' // Написать название классификационной шкалы * AyName = L("Прогнозируемое значение шкалы") // Написать название классификационной шкалы aMatrix := GraInitMatrix() GraRotate( oPS, aMatrix, 90, { X0-57, Y0+H_Wind/2-8*LEN(AyName)/2 }, GRA_TRANSFORM_ADD ) oPS:setGraTransform( aMatrix, GRA_TRANSFORM_REPLACE ) GraStringAt( oPS, { X0-57, 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.1. Классификационые шкалы и градации (xdemo.exe, FUNCTION XSample_130(): sample 4, OneToMany2) *********************************************************************************************************** FUNCTION F2_1win2() LOCAL GetList := {}, GetOptions, oBrowUser, oBrowApp, bApp, bItems Running(.T.) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF FILE("Class_Sc.dbf") // БД описательных шкал ** Переиндексировать БД Class_Sc.dbf, ** если не хватает хотя бы одного какого-нибудь индексного массива IF .NOT. FILE("Cls_kod.ntx" ).OR.; .NOT. FILE("Cls_name.ntx").OR.; .NOT. FILE("Cls_ini.ntx" ).OR.; .NOT. FILE("Cls_abs.ntx" ) GenNtxClSc() ENDIF ELSE GenDbfClSc(.F.) ENDIF IF FILE("Gr_ClSc.dbf") // БД градаций описательных шкал ** Переиндексировать БД Gr_ClSc.dbf, ** если не хватает хотя бы одного какого-нибудь индексного массива IF .NOT. FILE("Gos_kod.ntx" ).OR.; .NOT. FILE("Gos_name.ntx").OR.; .NOT. FILE("Gos_ini.ntx" ).OR.; .NOT. FILE("Gos_abs.ntx" ) GenNtxGrClSc() ENDIF ELSE GenDbfGrClSc(.F.) ENDIF dbeSetDefault('DBFNTX') CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Class_Sc INDEX ON Kod_ClSc TO Class_Sc CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Gr_ClSc NEW INDEX ON Kod_ClSc TO Gr_ClSc CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций *IF FILE("Inp_data.dbf") * USE Inp_data EXCLUSIVE NEW *ENDIF *USE Obi_Kcl EXCLUSIVE NEW *USE Rso_Kcl EXCLUSIVE NEW USE Class_Sc INDEX Class_Sc EXCLUSIVE NEW USE Gr_ClSc INDEX Gr_ClSc EXCLUSIVE NEW /* ----- Create ToolBar 2 ----- */ *@ 27.5, 1 DCTOOLBAR oToolBar SIZE 130, 1.5 @ 29.5, 1 DCTOOLBAR oToolBar SIZE 150, 1.5 DCADDBUTTON CAPTION L('Помощь') ; SIZE LEN(L("Помощь"))+2 ; ACTION {||Help21win2(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Помощь по режиму 2.1.') ** Функции, доступные только сисадмину и администратору приложения IF Flag_SysAdmin .OR. Flag_AdmAppl DCADDBUTTON CAPTION L('Доб.шкалу') ; SIZE LEN(L("Доб.шкалу"))+1 ; ACTION {||AddRec21win2s(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Добавить шкалу') DCADDBUTTON CAPTION L('Доб.град.шкалы') ; SIZE LEN(L("Доб.град.шкалы")) ; ACTION {||AddRec21win2g(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Добавить градацию шкалы') DCADDBUTTON CAPTION L('Копир.шкалу') ; SIZE LEN(L("Копир.шкалу")) ; ACTION {||CopyRec21win2s(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Копирировать шкалу') DCADDBUTTON CAPTION L('Копир.град.шкалы') ; SIZE LEN(l("Копир.град.шкалы"))-1 ; ACTION {||CopyRec21win2g(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP l('Копировать градацию шкалы') DCADDBUTTON CAPTION L('Копир.шкалу с град.') ; // #####################????? SIZE LEN(L("Копир.шкалу с град."))-3 ; ACTION {||CopyRec21win2s(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Копировать шкалу с градациями') DCADDBUTTON CAPTION L('Удал.шкалу с град.') ; SIZE LEN(L("Удал.шкалу с град."))-2 ; ACTION {||DelRec21win2s(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Удалить шкалу с градациями') DCADDBUTTON CAPTION L('Удал.град.шкалы') ; SIZE LEN(L("Удал.град.шкалы"))-1 ; ACTION {||DelRec21win2g(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Удалить градацию шкалы') *DCADDBUTTON CAPTION L('Перекодировать') ; * SIZE LEN(L("Перекодировать")) ; * ACTION {||Recode21win2sg(), DC_GetRefresh(GetList)}; * PARENT oToolBar ; * TOOLTIP L('Перекодировать') *DCADDBUTTON CAPTION L('Очистить') ; * SIZE LEN(L("Очистить"))+2 ; * ACTION {||Zap21win2sg(), DC_GetRefresh(GetList)} ; * PARENT oToolBar ; * TOOLTIP L('Очистить базу данных') DCADDBUTTON CAPTION L('Удаление и перекодирование') ; SIZE LEN(L("Удаление и перекодирование"))-3 ; ACTION {||Servis21win2sg(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Удаление классов и перекодирование классификационных шкал и градаций и обучающей выборки, корректировка файла исходных данных "Inp_data.dbf"') DCADDBUTTON CAPTION L('Графики будущих сценариев') ; SIZE LEN(L("Графики будущих сценариев"))-3 ; ACTION {||DrawScenarios('Cls'), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Отображение и запись в виде файлов графиков будущих сценариев (сценариев классов)') ENDIF *@ DCGUI_ROW, DCGUI_COL + 2 DCPUSHBUTTON CAPTION 'PrtScr' SIZE LEN('PrtScr'), 1.5 ACTION {||SaveScreenAsFile(Disk_dir+'/Aid_data/Screenshots/F2_1.jpg'), DC_GetRefresh(GetList)} PARENT oToolBar /* ----- Create browse-1 ----- */ bScale := {|| Gr_ClSc->(DC_SetScope(0,Class_Sc->KOD_ClSc)), ; Gr_ClSc->(DC_SetScope(1,Class_Sc->KOD_ClSc)), ; Gr_ClSc->(DC_DbGoTop()), ; oBrowGrSc:refreshAll() } *@1, 0 DCBROWSE oBrowScale ALIAS 'Class_Sc' SIZE 48,26 ; @1, 0 DCBROWSE oBrowScale ALIAS 'Class_Sc' SIZE 58,28 ; EDIT xbeBRW_ItemSelected MODE DCGUI_BROWSE_EDITDOWN ; // Редактирование БД Class_Sc NOSOFTTRACK ; SCOPE ; ITEMMARKED {|| Eval(bScale), ; DC_GetRefresh(GetList,, ; DCGETREFRESH_TYPE_EXCLUDE,{GETLIST_BROWSE}) } DCSETPARENT oBrowScale DCBROWSECOL FIELD Class_Sc->KOD_ClSc HEADER L('Код шкалы' ) WIDTH 1 PROTECT {|| .T. } DCBROWSECOL FIELD Class_Sc->NAME_ClSc HEADER L('Наименование классификационной шкалы') WIDTH 28 DCBROWSECOL FIELD Class_Sc->INT_INF HEADER L('Информативность' ) WIDTH 1 /* ----- Create browse-2 ----- */ DCSETPARENT TO *@ 1,50 DCBROWSE oBrowGrSc ALIAS 'Gr_ClSc' SIZE 82,26 ; @ 1,60 DCBROWSE oBrowGrSc ALIAS 'Gr_ClSc' SIZE 92,28 ; EDIT xbeBRW_ItemSelected MODE DCGUI_BROWSE_EDITDOWN ; NOSOFTTRACK ; SCOPE ; ITEMMARKED bItems; COLOR {||IIF(2*INT(Gr_ClSc->KOD_GrCS/2)==Gr_ClSc->KOD_GrCS,nil,{nil,GraMakeRGBColor({230,252,213})})} // Вывод строки цветом RGB DCSETPARENT oBrowGrSc DCBROWSECOL FIELD Gr_ClSc->KOD_GrCS HEADER L('Код градации' ) WIDTH 1 PROTECT {|| .T. } DCBROWSECOL FIELD Gr_ClSc->NAME_GrCS HEADER L('Наименование градации классификационной шкалы') WIDTH 48.5 DCBROWSECOL FIELD Gr_ClSc->Delete HEADER L('DEL' ) WIDTH 1 DCBROWSECOL FIELD Gr_ClSc->INT_INF HEADER L('Информативность' ) WIDTH 1 DCBROWSECOL FIELD Gr_ClSc->ABS HEADER L('N объектов об.выб.(абс)' ) WIDTH 3 DCBROWSECOL FIELD Gr_ClSc->PERC_FIZ HEADER L('N объектов об.выб.(%)' ) WIDTH 3 DCGETOPTIONS SAYFONT '10.Helv Bold' TABSTOP AUTORESIZE cTitle = L('2.1. Классификационные шкалы и градации. Текущая модель: "')+UPPER(Ar_Model[M_CurrInf])+'"' DCREAD GUI ; FIT ; OPTIONS GetOptions ; MODAL ; TITLE cTitle ; EVAL {|o|SetAppFocus(oBrowScale:GetColumn(1))} GenDbfClass(.F.) // Пересоздать БД Classes.dbf ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ****** END OF EXAMPLE *********************** ************************************************************************************************** FUNCTION Help21win2() aHelp := {} AADD(aHelp, L('Режим: "2.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('- [Копир.град.шкалы]: копировать текущую градацию классификационной шкалы; ')) AADD(aHelp, L('- [Копир.шкалу с град.]: копировать текущую классификационную шкалу со всеми градациями; ')) AADD(aHelp, L('- [Удал.шкалу с град.]: удалить текущую классификационную шкалу со всеми градациями; ')) AADD(aHelp, L('- [Удал.град.шкалы]: удалить текущую градацию классификационной шкалы; ')) AADD(aHelp, L('- [Удаление и пере- удалить классы и перекодировать классификационные шкалы и градации')) AADD(aHelp, L(' кодирование]: и обучающую выборку, скорректироваить БД исх.данных Inp_data.dbf ')) 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-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.1. (C) Система "ЭЙДОС-X++"') RETURN NIL ************************************************************************************************** ******** Сортировка по заданному столбцу в режиме 1.3. (xdemo.exe FUNCTION XDemo_4 ( oDialog, lMDI, lGui )) FUNCTION Sort2_1win2() 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 DelRec21win2s() // Проверить является ли БД Class_Sc текущей и если нет - выдать сообщение и выйти M_Kod = Kod_ClSc SELECT Class_Sc DELETE PACK SELECT Gr_ClSc DELETE FOR M_Kod = Kod_ClSc PACK SELECT Class_Sc RETURN NIL ******** Удалить текущую градацию FUNCTION DelRec21win2g() // Проверить является ли БД Gr_ClSc текущей и если нет - выдать сообщение и выйти DELETE PACK RETURN NIL ******** Скопировать классификационную шкалу FUNCTION CopyRec21win2s() SELECT Class_Sc 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_ClSc WITH RECNO() RETURN NIL ******** Скопировать градацию классификационной шкалы FUNCTION CopyRec21win2g() SELECT Gr_ClSc 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_GrCS WITH RECNO() RETURN NIL ******** Скопировать классификационную шкалу со всеми градациями FUNCTION COPY_REC2_1win2SG() LOCAL Getlist := {}, oProgress, oDialog SELECT Class_Sc M_KodOS_Old = Kod_ClSc 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_ClSc WITH RECNO() M_KodOS_New = Kod_ClSc SELECT Gr_ClSc Mess = L('2.1. Копирование классификационной шкалы со всеми градациями') @ 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 DBGOTO(r) IF M_KodOS_Old = Kod_ClSc 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_ClSc WITH M_KodOS_New ENDIF DC_GetProgress(oProgress, ++nTime, nMax) NEXT DC_GetProgress(oProgress,nMax,nMax) oDialog:Destroy() RETURN NIL ******** Добавить шкалу в конец БД FUNCTION AddRec21win2s() SELECT Class_Sc APPEND BLANK REPLACE Kod_ClSc WITH RECNO() RETURN NIL ******** Добавить градацию шкалы в конец БД FUNCTION AddRec21win2g() SELECT Class_Sc M_KodClSc = Kod_ClSc SELECT Gr_ClSc APPEND BLANK REPLACE Kod_ClSc WITH M_KodClSc REPLACE Kod_GrCS WITH RECNO() // Сформировать количество градаций данной шкалы на момент добавления записи RETURN NIL ******** Очистить БД FUNCTION Zap21win2sg() SELECT Class_Sc;ZAP SELECT Gr_ClSc;ZAP RETURN NIL ******** Перекодировать БД классификационных шкал и градаций, обучающей и распознаваемой выборки FUNCTION Recode21win2sg() LOCAL Getl := {}, oProgr, oDial aSaveRECODE2_1win2SG := DC_DataSave() SELECT Gr_ClSc;N_GCS = RECCOUNT() SELECT Obi_Kpr;N_Okp = RECCOUNT() SELECT Rso_Kpr;N_Rkp = RECCOUNT() Mess = L('2.1. Перекодирование классификационных шкал и градаций, обуч.и расп.выборки') @ 4,5 DCPROGRESS oProgr SIZE 80,1.1 MAXCOUNT RecCount() COLOR GRA_CLR_BLUE PERCENT EVERY 100 DCREAD GUI TITLE Mess PARENT @oDial FIT EXIT oDial:show() nMax = 3*N_GCS+N_Okp+N_Rkp nTime = 0 SELECT Gr_ClSc INDEX ON STR(Kod_ClSc,19)+STR(Kod_GrCS,19) TO GCS_kos aKodGCS_Old := {} aKodGCS_New := {} M_KodGrCS = 0 DBGOTOP() Flag = .F. DC_GetProgress(oProgr,0,nMax) DO WHILE .NOT. EOF() AADD(aKodGCS_Old, Kod_GrCS) AADD(aKodGCS_New, ++M_KodGrCS) IF Kod_GrCS <> M_KodGrCS Flag = .T. // Необходимо перекодирование ENDIF DC_GetProgress(oProgr, ++nTime, nMax) DBSKIP(1) ENDDO IF .NOT. Flag LB_Warning(L("В перекодировании нет необходимости!"), L("Информационное сообщение" )) ELSE // Перекодирование классификационных шкал и градаций и сортировка БД градаций классификационных шкал SELECT Gr_ClSc SET ORDER TO DBGOTOP() DO WHILE .NOT. EOF() Pos = ASCAN(aKodGCS_Old, Kod_GrCS) IF Pos > 0 REPLACE Rang WITH aKodGCS_New[Pos] ENDIF DC_GetProgress(oProgr, ++nTime, nMax) DBSKIP(1) ENDDO DbSort( "Temp.dbf", {"Rang" } ) // Физическая сортировка БД по составному ключу SELECT Gr_ClSc USE Temp EXCLUSIVE NEW DBGOTOP() DO WHILE .NOT. EOF() M_Recno = RECNO() M_Rang = Rang M_KodGrCS = Kod_GrCS a := {} FOR j=1 TO FCOUNT() AADD(a, FIELDGET(j)) NEXT SELECT Gr_ClSc DBGOTO(M_Recno) FOR j=1 TO LEN(a) FIELDPUT(j, a[j]) NEXT REPLACE Kod_GrCS WITH M_Rang REPLACE Rang WITH M_KodGrCS DC_GetProgress(oProgr, ++nTime, nMax) SELECT Temp DBSKIP(1) ENDDO CLOSE Temp SELECT Gr_ClSc INDEX ON Kod_ClSc TO Gr_ClSc // Перекодирование обучающей выборки SELECT Obi_Kpr DBGOTOP() DO WHILE .NOT. EOF() FOR j=2 TO FCOUNT() Pos = ASCAN(aKodGCS_Old, FIELDGET(j)) IF Pos > 0 FIELDPUT(j, aKodGCS_New[Pos]) ENDIF NEXT DC_GetProgress(oProgr, ++nTime, nMax) DBSKIP(1) ENDDO // Перекодирование распознаваемой выборки SELECT Rso_Kpr DBGOTOP() DO WHILE .NOT. EOF() FOR j=2 TO FCOUNT() Pos = ASCAN(aKodGCS_Old, FIELDGET(j)) IF Pos > 0 FIELDPUT(j, aKodGCS_New[Pos]) ENDIF NEXT DC_GetProgress(oProgr, ++nTime, nMax) DBSKIP(1) ENDDO ENDIF DC_GetProgress(oProgr,nMax,nMax) oDial:Destroy() DC_DataRest( aSaveRECODE2_1win2SG ) RETURN NIL ************************************************************************************ ******** Удаление классов и перекодирование классификационных шкал и градаций ******** и обучающей выборки, корректировка файла исходных данных Inp_data.dbf ************************************************************************************ FUNCTION Servis21win2sg() aSaveRECODE2_1win2SG := DC_DataSave() ********************************************************************* *** Удалить все классы, встретившиеся менее N раз (если при этом надо удалять и шкалу - выдать сообщение и не делать этого) *** Удалить все классы, отмеченные в поле "###" любым символом (если при этом надо удалять и шкалу - выдать сообщение и не делать этого) *** *** Затем: *** Перекодировать БД классификационных шкал и градаций (если задано) *** Перекодировать обучающую выборку (если задано) *** Корректировать файл исходных данных Inp_data.dbf (если задано) ********************************************************************* @ 0, 0 DCGROUP oGroup1 CAPTION L('Критерии удаления классов:' ) SIZE 72,3.5 @ 4, 0 DCGROUP oGroup2 CAPTION L('Действия после удаления классов:') SIZE 72,4.5 N_DelCls = 0 PRIVATE aRecode[5] AFILL(aRecode,.T.) @ 1, 2 DCCHECKBOX aRecode[ 1] PROMPT L('Удалить все классы, встретившиеся менее N раз:') PARENT oGroup1 @ 2, 2 DCCHECKBOX aRecode[ 2] PROMPT L('Удалить все классы, отмеченные в поле: [DEL] любым символом') PARENT oGroup1 @ 1,49 DCSAY L(" ") GET N_DelCls PARENT oGroup1 PICTURE "###############" EDITPROTECT {|| .NOT.aRecode[ 1] } HIDE {|| .NOT.aRecode[ 1] } @ 1, 2 DCCHECKBOX aRecode[ 3] PROMPT L('Перекодировать классификационные шкалы и градации') PARENT oGroup2 @ 2, 2 DCCHECKBOX aRecode[ 4] PROMPT L('Перекодировать обучающую и распознаваемую выборку') PARENT oGroup2 @ 3, 2 DCCHECKBOX aRecode[ 5] PROMPT L('Скорректировать файл исходных данных Inp_data.dbf') PARENT oGroup2 @5.3,50 DCPUSHBUTTON ; CAPTION L('Пояснение по режиму') ; SIZE LEN(L('Пояснение по режиму'))+0, 2.5 ; ACTION {||Help21Serv()} DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; OPTIONS GetOptions ; ADDBUTTONS; MODAL ; TITLE L('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 *************************************************** ******** ИСПОЛНЕНИЕ ************* aNameDelCls := {} // Массив наименований удаляемых классов aKodGCS_Old := {} // массив старых кодов классов aKodGCS_New := {} // массив новых кодов классов ****** Занести в БД информацию о старых кодах классов SELECT GR_CLSC SET ORDER TO DBGOTOP() DO WHILE .NOT. EOF() REPLACE KodGrCSOld WITH Kod_GrCS DBSKIP(1) ENDDO IF aRecode[ 1] // 'Удалить из БД: GR_CLSC.DBF, CLASSES.DBF все классы, встретившиеся менее N раз:' DELETE FOR Abs < N_DelCls DBGOTOP() DO WHILE .NOT. EOF() IF Abs < N_DelCls IF ASCAN(aNameDelCls, Name_GrCS) = 0 AADD( aNameDelCls, Name_GrCS) ENDIF ENDIF DBSKIP(1) ENDDO PACK ENDIF IF aRecode[ 2] // 'Удалить все классы, отмеченные в поле: [DEL] любым символом' SELECT GR_CLSC DELETE FOR LEN(ALLTRIM(Del)) > 0 DBGOTOP() DO WHILE .NOT. EOF() IF LEN(ALLTRIM(Del)) > 0 IF ASCAN(aNameDelCls, Name_GrCS) = 0 AADD( aNameDelCls, Name_GrCS) ENDIF ENDIF DBSKIP(1) ENDDO PACK ENDIF IF aRecode[ 3] // 'Перекодировать БД классификационных шкал и градаций' * Recode21win2sg() SELECT Gr_ClSc;N_GCS = RECCOUNT() Mess = L('2.1. Перекодирование классификационных шкал и градаций') @ 4,5 DCPROGRESS oProgr SIZE 80,1.1 MAXCOUNT RecCount() COLOR GRA_CLR_BLUE PERCENT EVERY 100 DCREAD GUI TITLE Mess PARENT @oDial FIT EXIT oDial:show() nMax = 3*N_GCS nTime = 0 SELECT Gr_ClSc INDEX ON STR(Kod_ClSc,19)+STR(Kod_GrCS,19) TO GCS_kos aKodGCS_Old := {} aKodGCS_New := {} M_KodGrCS = 0 DBGOTOP() Flag = .F. DC_GetProgress(oProgr,0,nMax) DO WHILE .NOT. EOF() AADD(aKodGCS_Old, Kod_GrCS) AADD(aKodGCS_New, ++M_KodGrCS) IF Kod_GrCS <> M_KodGrCS Flag = .T. // Необходимо перекодирование ENDIF DC_GetProgress(oProgr, ++nTime, nMax) DBSKIP(1) ENDDO IF .NOT. Flag LB_Warning(L("В перекодировании нет необходимости!"), L("Информационное сообщение" )) ELSE // Перекодирование классификационных шкал и градаций и сортировка БД градаций классификационных шкал SELECT Gr_ClSc SET ORDER TO DBGOTOP() DO WHILE .NOT. EOF() Pos = ASCAN(aKodGCS_Old, Kod_GrCS) IF Pos > 0 REPLACE Rang WITH aKodGCS_New[Pos] ENDIF DC_GetProgress(oProgr, ++nTime, nMax) DBSKIP(1) ENDDO DbSort( "Temp.dbf", {"Rang" } ) // Физическая сортировка БД по составному ключу SELECT Gr_ClSc USE Temp EXCLUSIVE NEW DBGOTOP() DO WHILE .NOT. EOF() M_Recno = RECNO() M_Rang = Rang M_KodGrCS = Kod_GrCS a := {} FOR j=1 TO FCOUNT() AADD(a, FIELDGET(j)) NEXT SELECT Gr_ClSc DBGOTO(M_Recno) FOR j=1 TO LEN(a) FIELDPUT(j, a[j]) NEXT REPLACE Kod_GrCS WITH M_Rang REPLACE Rang WITH M_KodGrCS DC_GetProgress(oProgr, ++nTime, nMax) SELECT Temp DBSKIP(1) ENDDO CLOSE Temp SELECT Gr_ClSc INDEX ON Kod_ClSc TO Gr_ClSc ENDIF DC_GetProgress(oProgr,nMax,nMax) oDial:Destroy() ENDIF IF aRecode[ 4] // 'Перекодировать обучающую и распознаваемую выборку' SELECT Obi_Kcl;N_Okc = RECCOUNT() // здесь надо перекодировать не признаки, а классы SELECT Rso_Kcl;N_Rkc = RECCOUNT() // Перекодирование обучающей выборки SELECT Obi_Kcl DBGOTOP() DO WHILE .NOT. EOF() FOR j=2 TO FCOUNT() Fv = FIELDGET(j) IF Fv > 0 Pos = ASCAN(aKodGCS_Old, Fv) IF Pos > 0 FIELDPUT(j, aKodGCS_New[Pos]) ENDIF ENDIF NEXT DC_GetProgress(oProgr, ++nTime, nMax) DBSKIP(1) ENDDO // Перекодирование распознаваемой выборки SELECT Rso_Kcl DBGOTOP() DO WHILE .NOT. EOF() FOR j=2 TO FCOUNT() Fv = FIELDGET(j) IF Fv > 0 Pos = ASCAN(aKodGCS_Old, Fv) IF Pos > 0 FIELDPUT(j, aKodGCS_New[Pos]) ENDIF ENDIF NEXT DC_GetProgress(oProgr, ++nTime, nMax) DBSKIP(1) ENDDO ENDIF IF aRecode[ 5] // 'Скорректировать файл исходных данных "Inp_data.dbf"', т.е. удалить из него элементы, создающие удаляемые классы *** Проверить, есть ли в папке приложения файлы: _2_3_2_2.arx и Inp_data.dbf, если нет, то и корректировать нечего (в этом случае выдать сообщение) *** если оба файла есть, то корректировать файл Inp_data.dbf в папке приложения а потом записать его в d:\ALASKA\AIDOS-X\AID_DATA\Inp_data\ как dbf и xls ** Загрузка файла параметров _2_3_2_2.arx IF .NOT. FILE("_2_3_2_2.arx") LB_Warning(L('Не был выполнен режим: 2.3.2.2. Корректировать нечего!'), L('2.1. Задание параметров удаления классов и перекодирования БД')) ELSE aSoftInt = DC_ARestore(Disk_dir+"\_2_3_2_2.arx") M_ClSc1 = aSoftInt[ 3] M_ClSc2 = aSoftInt[ 4] M_OpSc1 = aSoftInt[ 5] M_OpSc2 = aSoftInt[ 6] mTxtCSField = aSoftInt[28] mTxtOSField = aSoftInt[29] mTxtCSSep = aSoftInt[30] mTxtOSSep = aSoftInt[31] * mScenario = aSoftInt[32] // Старый вариант mScenario = aSoftInt[32] // mScenario=1 Не применять сценарный метод АСК-анализа mSpecInterprCls = aSoftInt[33] // .T. - Применить спец.интерпретацию текстовых полей классов, .F. - не применять mSpecInterprAtr = aSoftInt[34] // .T. - Применить спец.интерпретацию текстовых полей признаков, .F. - не применять ENDIF IF .NOT. FILE("Inp_data.dbf") LB_Warning(L('Не был выполнен режим: 2.3.2.2. Корректировать нечего!'), L('2.1. Задание параметров удаления классов и перекодирования БД')) ELSE SELECT Inp_data DBGOTOP() DO WHILE .NOT. EOF() FOR ff=M_ClSc1 TO M_ClSc2 // Цикл по полям классов (колонкам классифкационных шкал) IF aErrorNum[ff] // Если есть вариабельность Fv=ALLTRIM(FIELDGET(ff)) mEditFlag = .F. ** Цикл по элементам с заданным в _2_3_2_2.arx разделителем DO CASE CASE mTxtCSField = 1 // Значения рассматриваются как целое ** Поиск элемента в массиве: aNameDelCls, если он там есть, то замена элемента в Fv на "" и флаг замены = .T. mFvNew = "" IF ASCAN(aNameDelCls, Fv) = 0 mFvNew = Fv ELSE mEditFlag = .T. ENDIF **** Если флаг замены = .T., то запись Fv в Inp_data.dbf IF mEditFlag FIELDPUT(ff, mFvNew) ENDIF CASE mTxtCSField = 2 // Значения рассматриваются как состоящие из элементов - символов IF LEN(Fv) > 0 mFvNew = "" FOR w=1 TO LEN(Fv) M_Symb = SUBSTR(Fv, w, 1) ** Поиск элемента в массиве: aNameDelCls, если его там нет, то запись, иначе пропуск и флаг замены = .T. IF ASCAN(aNameDelCls, M_Symb) = 0 mFvNew = mFvNew + mTxtCSSep + M_Word ELSE mEditFlag = .T. ENDIF NEXT // Конец цикла по элементам ENDIF **** Если флаг замены = .T., то запись Fv в Inp_data.dbf IF mEditFlag FIELDPUT(ff, mFvNew) ENDIF CASE mTxtCSField = 3 // Значения рассматриваются как состоящие из элементов, разделенных разделителем IF LEN(Fv) > 0 mFvNew = "" FOR w=1 TO NumToken( Fv ) M_Word = TOKEN( Fv,,w ) ** Поиск элемента в массиве: aNameDelCls, если его там нет, то запись, иначе пропуск и флаг замены = .T. IF ASCAN(aNameDelCls, M_Word) = 0 mFvNew = mFvNew + mTxtCSSep + M_Word ELSE mEditFlag = .T. ENDIF NEXT // Конец цикла по элементам ENDIF **** Если флаг замены = .T., то запись Fv в Inp_data.dbf IF mEditFlag FIELDPUT(ff, mFvNew) // Перед записью убрать все подряд идущие пробелы (разделители) ENDIF ENDCASE ENDIF NEXT DBSKIP(1) ENDDO ENDIF **** После корректировки файла Inp_data.dbf в папке приложения записать его в d:\ALASKA\AIDOS-X\AID_DATA\Inp_data\ как dbf как xls * MsgBox(M_ApplsPath+"\Inp_data\Inp_data.dbf") CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций COPY FILE ("Inp_data.dbf") TO ("Inp_data.xls") COPY FILE ("Inp_data.dbf") TO (M_ApplsPath+"\Inp_data\Inp_data.dbf") COPY FILE ("Inp_data.dbf") TO (M_ApplsPath+"\Inp_data\Inp_data.xls") * USE Inp_data EXCLUSIVE NEW * DC_WorkArea2Excel( "Inp_data.xls" ) // Приводит к ошибке * DC_WorkArea2Excel( M_ApplsPath+"\Inp_data\Inp_data.xls" ) ENDIF **************** Переиндексация GenNtxClass() // Классификационные шкалы и градации GenNtxOpSc() // Описательные шкалы GenNtxGrOpSc() // Градации описательных шкал GenNtxObiZag() // Заголовки объектов обучающей выборки GenNtxObiKcl() // Коды классов объектов обучающей выборки GenNtxObiKpr() // Коды признаков объектов обучающей выборки GenNtxRsoZag() // Заголовки объектов распознаваемой выборки GenNtxRsoKcl() // Коды классов объектов распознаваемой выборки GenNtxRsoKpr() // Коды признаков объектов распознаваемой выборки* CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Class_Sc INDEX ON Kod_ClSc TO Class_Sc CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Gr_ClSc NEW INDEX ON Kod_ClSc TO Gr_ClSc CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций IF FILE("Inp_data.dbf") USE Inp_data EXCLUSIVE NEW ENDIF USE Obi_Kcl EXCLUSIVE NEW USE Rso_Kcl EXCLUSIVE NEW USE Class_Sc INDEX Class_Sc EXCLUSIVE NEW USE Gr_ClSc INDEX Gr_ClSc EXCLUSIVE NEW DC_DataRest( aSaveRECODE2_1win2SG ) *Можно попробовать: *ftp://lc.kubagro.ru/Astr/astr-new1.rar *Записать все файлы в корневой каталог папки с системой, а файл Inp_data.xls записать в папку d:\ALASKA\AIDOS-X\AID_DATA\Inp_data\Inp_data.xls там, где система *Запустить систему, режим 2.3.2.2 с параметрами из файла _2_3_2_2.arx *Запустить режим 2.1 и в нем отметить удаляемые классы в поле DEL любым символом *Потом кликнуть по кнопке: Удаление и перекодирование *Отмеченные классы будут удалены из справочников и файлы в папке приложения d:\ALASKA\AIDOS-X\AID_DATA\A0000001\System\Inp_data.dbf и в папке d:\ALASKA\AIDOS-X\AID_DATA\Inp_data\Inp_data.dbf будут изменены так, что если преобразовать его в xls (считать в Excel и записать как xls), то при выполнении режима 2.3.2.2 будут созданы справочники классов уже без удаленных классов и соответственно будут изменены все файлы, в т.ч. обучающая выборка *После этого можно создавать и исследовать модель *PS *Еще много работы над этими делами, это только 1-й вариант. Потом сделаю те же возможности признаков, распознаваемой выборки и для адаптивных интервалов, улучшу диалог, сделаю автоматическое преобразование в Excel. RETURN NIL ************************************************************************************************** ******** Помощь по режиму 2.1. Задание параметров удаления классов и перекодирования БД ************************************************************************************************** FUNCTION Help21Serv() aHelp := {} AADD(aHelp, L('Режим: "2.1. Задание параметров удаления классов и перекодирования БД": ')) AADD(aHelp, L(' ')) AADD(aHelp, L('1. Записать все файлы в корневой каталог папки с системой, а файл Inp_data.xls ')) AADD(aHelp, L(' записать в папку ..\AIDOS-X\AID_DATA\Inp_data\Inp_data.xls там, где система. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('2. Запустить систему, режим 2.3.2.2 с параметрами из файла _2_3_2_2.arx. Если появляется ')) AADD(aHelp, L(' пустой экран с главным меню системы нужно кликнуть один раз по ее иконке в панели задач')) AADD(aHelp, L(' и в окошке Excel выбрать вариант "Не сохранять" изменения в файле исходных данных. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('3. Запустить режим 2.1 и в нем отметить удаляемые классы в поле DEL любым символом. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('4. Потом кликнуть по кнопке: Удаление и перекодирование. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('5. Отмеченные классы будут удалены из справочников и файлы в папке приложения ')) AADD(aHelp, L(' ..\AIDOS-X\AID_DATA\A0000001\System\Inp_data.dbf и в папке ')) AADD(aHelp, L(' ..\AIDOS-X\AID_DATA\Inp_data\Inp_data.dbf будут изменены так, ')) AADD(aHelp, L(' что если преобразовать его в xls (считать в Excel и записать как xls), ')) AADD(aHelp, L(' то при выполнении режима 2.3.2.2 будут созданы справочники классов уже без ')) AADD(aHelp, L(' удаленных классов и соответственно будут изменены все файлы, в т.ч. обучающая выборка. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('6. После этого можно создавать и исследовать модель. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('PS ')) 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('Помощь по режиму: 2.1. (C) Система "ЭЙДОС-X++"') RETURN NIL ************************************************************************************************** ************************************************************************************ ******** Обновление структур всех основных баз данных с сохранением информации в них ************************************************************************************ FUNCTION DbStrUpDate() // Вставить при запуске системы и при выходе из режима 1.3 // Перейти в текущее приложение IF ApplChange("") // Перейти в папку выбранного приложения или выйти из системы RETURN NIL ENDIF GenDbfClSc(.T.) // Классификационные шкалы GenDbfGrClSc(.T.) // Градации классификационных шкал GenDbfClass(.T.) // Классификационные шкалы и градации GenDbfOpSc(.T.) // Описательные шкалы GenDbfGrOpSc(.T.) // Градации описательных шкал GenDbfAttr(.T.) // Описательные шкалы и градации // Перейти в главную директорию системы (с исполнимым модулем) DIRCHANGE(Disk_dir) RETURN NIL ************************************************************************************ ******** Функция Роджера для изменения структуры базы данных с сохранием содержания ************************************************************************************ *FUNCTION dc_dbfile ( cDirectory, cDataFile, lUserPrompt, ; * lExclusive, nWait, xDbe, lReOpen, ; * aStructure, cAlias, lNoErrorDsp, ; * lCreateDbf, lStruUpdated, lStruMsg, ; * lReadOnly ) * ----------------- ************************************************************************************ ******** Закрыть все процессы от Роджера ************************************************************************************ FUNCTION CloseAllWindows() LOCAL i, aChildList, nSeconds := Seconds() ****************************************** ****** Обработка ошибки ****************** bError := ErrorBlock( {|e| Break(e)} ) // установить новый кодовый блок обработки ошибок BEGIN SEQUENCE // код нормального исполнения *** код нормального исполнения DO WHILE !Empty( aChildList := Set_MainWindow():drawingArea:childList()) FOR i := 1 TO Len(aChildList) IF !aChildList[i]:isDerivedFrom('XbpDialog') aChildList[i]:destroy() ELSE PostAppEvent(xbeP_Close,,,aChildList[i]) ENDIF Sleep(10) NEXT IF Seconds() - nSeconds > 10 EXIT ENDIF ENDDO Sleep(10) RECOVER // код обработки ошибки * aMess := {} * AADD(aMess, L('При распознавании была попытка превышения максимального допустимого объема БД 2 Гб.')) // НАПРИМЕР * AADD(aMess, L('Необходимо уменьшить количество классов или/и объектов распознаваемой выборки !!! ')) * AADD(aMess, L('Можно также исключить из результатов распознавания наименее достоверные (режим 3.5)')) * LB_Warning(aMess) ** EXIT ENDSEQUENCE ErrorBlock( bError ) // переустановить старый кодовый ****************************************** ****************************************** RETURN nil ************************************************************************************ ****************************************************************************************** ******** 3.7.8. Генерация сочетаний признаков и докодирование обуч.и расп.выб. ###### ******** На основе сочетания признаков по 2, 3, N формируются подсистемы признаков, ******** которые добавляются в качестве градаций в сочетанные описательные шкалы ******** и в объекты обучающей и распознаваемой выборки. ******** Все это делать во вновь создаваемом специально для этого приложении ###### ****************************************************************************************** FUNCTION F3_7_8() LOCAL GetList[0], oStatus, lContinue := .T., oProgressm, oDialogm, lCancelled := .F. LOCAL lOk, aSay[30], oSay9, Mess9, Mess97, Mess98, Mess99, oDialog // Массив сообщений отображаемых стадий исполнения (до 30 на экране) Running(.T.) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) PUBLIC aSaveMainM := DC_ARestore("_SaveMainM.arx") // Восстановление вычислительной среды (открытые и текущие БД и индексы) с диска DC_DataRest( aSaveMainM ) // Восстановление вычислительной среды (открытые и текущие БД и индексы) Running(.F.) RETURN NIL ENDIF IF ApplChange("3.7.8()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF IF .NOT. FILE('Attributes.dbf') LB_Warning(L("Необходимо выполнить режим 3.4 !!!")) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ***** Создать новое приложение, скопировать все файлы текущего приложения в новое, сделать его текущим N_All = ADIR(M_PathAppl + "*.*") PRIVATE aFileNameAll[N_All] ADIR(M_PathAppl + "*.*", aFileNameAll ) // Имена ВСЕХ файлов в папке текущего приложения ASORT(aFileNameAll) M_NameAppl = ALLTRIM(M_NameAppl)+L("-сочетания признаков") // Наименование текущего приложения M_NewAppl = ADD_ZAPPL(M_NameAppl) // Создать новое приложение на основе текущего FOR j=1 TO LEN(aFileNameAll) Name_SS = M_PathAppl + aFileNameAll[j] Name_DD = M_NewAppl + aFileNameAll[j] * LB_Warning(L("Источник: "+Name_SS+", приемник: "+Name_DD) COPY FILE (Name_SS) TO (Name_DD) NEXT IF ApplChange("") // Перейти в папку выбранного приложения или выйти из системы LB_Warning(L("Необходимо задать (выбрать) хотя бы одно текущее приложение !!!")) Running(.F.) RETURN NIL ENDIF ***** Открытие основных dbf баз данных CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Class_Sc EXCLUSIVE NEW;N_ClSc = RECCOUNT() // * USE Gr_ClSc EXCLUSIVE NEW;N_GrCS = RECCOUNT() // * USE Attributes EXCLUSIVE NEW;N_GrOS = RECCOUNT() USE Opis_Sc EXCLUSIVE NEW;N_OpSc = RECCOUNT() USE Gr_OpSc EXCLUSIVE NEW;N_GrOS = RECCOUNT() USE Obi_Zag EXCLUSIVE NEW;N_ObiObj = RECCOUNT() USE Obi_Kcl EXCLUSIVE NEW;N_ObiCls = RECCOUNT() USE Obi_Kpr EXCLUSIVE NEW;N_ObiKpr = RECCOUNT() USE Rso_Zag EXCLUSIVE NEW;N_RsoObj = RECCOUNT() USE Rso_Kcl EXCLUSIVE NEW;N_RsoCls = RECCOUNT() USE Rso_Kpr EXCLUSIVE NEW;N_RsoKpr = RECCOUNT() ****** Массив с информацией об описательных шкалах для генерации альтернативных сочетаний ЭТИ ЗНАЧЕНИЯ ПОЛЕЙ УЖЕ ДОЛЖНЫ БЫТЬ В БД Opis_Sc.dbf ############# PUBLIC aOpisSc[N_OpSc, 3] SELECT Opis_Sc DBGOTOP() DO WHILE .NOT. EOF() aOpisSc[Kod_OpSc,1] = N_GrOpSc // Количество градаций в шкале РАБОТАЕТ СО 2-ГО РАЗА (1-Й РАЗ НЕ РАБОТАЕТ) ########## с 1-го раза расчет неверный aOpisSc[Kod_OpSc,2] = KodGr_Min // Код минимальной градации шкалы ЭТО ПОМТОМУ, ЧТО В РЕЖИМЕ 2.3.2.2. НЕ ПРОСИТЫВАЮТСЯ ЭТИ ПОЛЯ БД Opis_Sc.dbf ###### aOpisSc[Kod_OpSc,3] = KodGr_Max // Код максимальной градации шкалы DBSKIP(1) ENDDO * DC_DebugQout( aOpisSc ) * MsgBox('STOP') ******* Сделать 2 суммы: ******* - для неальтернативных признаков число сочетаний из n по m РАБОТАЕТ СРАЗУ ******* - для альтернативных признаков оставить только сочетания признаков, относящихся к разным шкалам РАБОТАЕТ СО 2-ГО РАЗА (1-Й РАЗ НЕ РАБОТАЕТ) ########## с 1-го раза расчет неверный PRIVATE aNCochPr[12,3] // массив параметров генерации сочетанных признаков FOR j=1 TO 12;aNCochPr[j,3]=.F.;NEXT nMax = 5 // а почему не 12? Потому, что это для отображения на экранной форме Mess = L('Расчет числа альтернативных и неальтернативных сочетаний признаков') oScr := DC_WaitOn(Mess,,,,,,,,,,,.F.) * @ 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 aNCochPr[my,1] = C (N_GrOS, my) // для неальтернативных признаков число сочетаний из n по m aNCochPr[my,2] = Ca(N_OpSc, my) // для альтернативных признаков оставить только сочетания признаков, относящихся к разным шкалам РАБОТАЕТ СО 2-ГО РАЗА (1-Й РАЗ НЕ РАБОТАЕТ) ########## с 1-го раза расчет неверный aNCochPr[my,3] = .F. * DC_GetProgress(oProgressm, ++nTime, nMax) NEXT aNCochPr[1,3] = .T. aNCochPr[2,3] = .T. * DC_GetProgress(oProgressm,nMax,nMax) * oDialogm:Destroy() DC_Impl(oScr) PRIVATE aCochPar[4] // массив параметров генерации сочетанных признаков aCochPar[1] := 2 // 1 - признаки неальтернативные, 2 - альтернативные aCochPar[2] := 1000000 // Максимальное кол-во признаков в шкале aCochPar[3] := 1 // 1 - Генерация сочетаний признаков и докодирование обучающей выборки, 2 - Докодирование сочетаний признаков в распознаваемой выборке aCochPar[4] := 1000000 // Максимальное кол-во признаков в градации шкалы ************************************************************************************************** *** Формирование массива кодов наиболее значимых признаков, учитываемых при формировании сочетаний ВОЗМОЖНО ЭТО УБРАТЬ ##################################### ************************************************************************************************** * mVidProc = 1 // Заданный процент признаков от суммарного количества признаков * mVidProc = 2 // Заданный процент значимости от суммарной значимости признаков * mVolProc = 100 // Сам процент mLM = -9999999999 SELECT Attributes DBGOTOP() DO WHILE .NOT. EOF() mLM = MAX(mLM, LEN(ALLTRIM(Name_atr))) DBSKIP(1) ENDDO aStructure := { { "Kod_atr" , "N", 15, 0 }, ; { "Name_atr" , "C",mLM, 0 }, ; { "Int_inf" , "N", 19, 7 }, ; { "Sum_IntInf", "N", 19, 7 }, ; { "Fltr_atr" , "C", 1, 0 } } DbCreate( 'FltrAtr', aStructure ) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Attributes EXCLUSIVE NEW SELECT Attributes INDEX ON STR(99999999.9999999-Int_inf,19,7) TO FltrAtr DBGOTOP() mMaxIntInf = Int_inf CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE FltrAtr EXCLUSIVE NEW USE Attributes INDEX FltrAtr EXCLUSIVE NEW;N_GrOS = RECCOUNT() ********** Расчет накопительной значимости признаков mSumIntInf = 0 SELECT Attributes SET ORDER TO 1 DBGOTOP() DO WHILE .NOT. EOF() M_KodAtr = Kod_atr M_NameAtr = Name_atr M_IntInf = Int_inf SELECT FltrAtr APPEND BLANK REPLACE Kod_atr WITH M_KodAtr REPLACE Name_atr WITH M_NameAtr REPLACE Int_inf WITH M_IntInf mSumIntInf = mSumIntInf + Int_inf REPLACE Sum_IntInf WITH mSumIntInf SELECT Attributes DBSKIP(1) ENDDO ************************************************************************************************** ****** Задание параметров докодирования **************************************************************************** mWW = 150 // Ширина окна g = 0 s = 0 IF N_OpSc = 1 aCochPar[1] = 1 ELSE @s++, 0 DCGROUP oGroup1 CAPTION L('Задайте, являются ли градации шкал альтернативными:') SIZE mWW, 3.5 @s++, 2 DCRADIO aCochPar[1] VALUE 1 PROMPT L('НЕТ, т.е. у объекта может быть по нескольку признаков каждой шкалы (неальтернативные признаки)') PARENT oGroup1 @s++, 2 DCRADIO aCochPar[1] VALUE 2 PROMPT L('ДА , т.е. у объекта возможно только по одному признаку каждой шкалы (альтернативные признаки)' ) PARENT oGroup1 ENDIF @1.2, 99.8 DCPUSHBUTTON CAPTION L('Помощь') SIZE 15.9, 1.7 ACTION {||Help378()} PARENT oGroup1 g = g + s s = 1 mVidAbs := 2 mVolAbs := 1 mInf := 4 P = 2 d = 12 @++g, 0 DCGROUP oGroup4 CAPTION L('Учитывать все или только наиболее значимые признаки:') SIZE mWW, 3.5 @1 , 2 DCRADIO mVidAbs VALUE 1 PROMPT L('Учитывать все признаки (будет много градаций описательных шкал, сколько именно - написано ниже)' ) PARENT oGroup4 @2 , 2 DCRADIO mVidAbs VALUE 2 PROMPT L('Учитывать только те сочетания признаков, которые в обучающей выборке встречаются не менее N раз:') PARENT oGroup4 @2 , 88 DCSAY L(" ") GET mVolAbs PICTURE "###############" EDITPROTECT {|| .NOT.mVidAbs=2 } HIDE {|| .NOT.mVidAbs=2} PARENT oGroup4 s = s + 2 g = g + s s = 1 @++g ,0 DCGROUP oGroup2 CAPTION L('Задайте число базовых признаков в сочетаниях:') SIZE mWW, nMax+1.8 @s+0.3,4.8 DCSAY L("1") PARENT oGroup2 @s+0.3, 8 DCSAY L("Число сочетаний из")+' '+ALLTRIM(STR(N_GrOS))+' '+L("признаков по 1 =")+' '+aNCochPr[1,1] PARENT oGroup2 @s+0.0, 60 DCSAY CalcSumPrBlock(aNCochPr,1,1) SAYSIZE 23 SAYLEFTBOTTOM PARENT oGroup2 @s+0.3, 88 DCSAY L("...Только альтернативные =")+' '+aNCochPr[1,2] PARENT oGroup2 @s+0.0,125 DCSAY CalcSumPrBlock(aNCochPr,1,2) SAYSIZE 20 SAYLEFTBOTTOM PARENT oGroup2 FOR i = 2 TO nMax @++s , 2 DCCHECKBOX aNCochPr[i,3] PROMPT ALLTRIM(STR(i,2)) ACTION {||DC_GetRefresh(GetList)} PARENT oGroup2 @s+0.3, 8 DCSAY L("Число сочетаний из")+' '+ALLTRIM(STR(N_GrOS))+' '+L("признаков по")+' '+STR(i,2)+" = "+aNCochPr[i,1] ACTION {||DC_GetRefresh(GetList)} PARENT oGroup2 @s+0.0, 60 DCSAY CalcSumPrBlock(aNCochPr,i,1) SAYSIZE 23 SAYLEFTBOTTOM PARENT oGroup2 @s+0.3, 88 DCSAY L("...Только альтернативные =")+' '+aNCochPr[i,2] ACTION {||DC_GetRefresh(GetList)} PARENT oGroup2 @s+0.0,125 DCSAY CalcSumPrBlock(aNCochPr,i,2) SAYSIZE 20 SAYLEFTBOTTOM PARENT oGroup2 NEXT g = g + s + 1.3 s = 1 @++g, 0 DCGROUP oGroup3 CAPTION L('Задайте, что генерировать:') SIZE mWW, 3.5 @s++, 2 DCRADIO aCochPar[3] VALUE 1 PROMPT L('Генерация сочетаний признаков и докодирование обучающей выборки') PARENT oGroup3 @s++, 2 DCRADIO aCochPar[3] VALUE 2 PROMPT L('Докодирование сочетаний признаков в распознаваемой выборке' ) PARENT oGroup3 // Это отобразить внизу *********************** g = g + s + 1.0 s = 0 @g , 0 DCGROUP oGroup4 CAPTION L('Задайте макс.число признаков в шкалах и градациях шкал:') SIZE mWW, 3.5 @++s+0.2, 8 DCSAY L("Максимальное число признаков в шкалах:") PARENT oGroup4 @ s , 57 DCSAY L(" ") GET aCochPar[2] PICTURE "###############" PARENT oGroup4 @++s+0.2, 8 DCSAY L("Максимальное число признаков в градациях шкал:") PARENT oGroup4 @ s , 57 DCSAY L(" ") GET aCochPar[4] PICTURE "###############" PARENT oGroup4 DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI; TO lExit ; FIT; ADDBUTTONS; OPTIONS GetOptions; MODAL ; TITLE L('3.7.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 *************************************************** // Процесс генерации сочетанных признаков и докодирования обучающей и распознаваемой выборки *********************** // Отработать ситуацию, когда все aNCochPr[i,3]=.F., где i{2-12}=.F. ******************** s = 0 FOR j=2 TO 12 IF aNCochPr[j,3] ++s ENDIF NEXT IF s = 0 LB_Warning(L('Необходимо задать хотя бы один вид сочетаний признаков !!!'), L('3.7.8. Генерация сочетаний признаков')) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN nil ENDIF // Организация отображения стадии процесса исполнения mSumCnm = 0 FOR j=2 TO nMax IF aNCochPr[j,3] mSumCnm = mSumCnm + VAL(aNCochPr[j,aCochPar[1]]) ENDIF NEXT ** Превышено максимальное число признаков *********************************************** IF mSumCnm > aCochPar[2] aMess := {} AADD(aMess, L('Превышено максимальное допустимое суммарное число признаков в шкалах !!!')) AADD(aMess, L('Допустимо: #. Фактически в заданных сочетаниях: $')) aMess[2] = STRTRAN(Mess[2], "#", ALLTRIM(STR(aCochPar[2],250))) aMess[2] = STRTRAN(Mess[2], "$", ALLTRIM(STR(mSumCnm,250))) LB_Warning(aMess,L('3.7.8. Генерация сочетаний признаков')) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN nil ENDIF IF aCochPar[3] = 1 Wsego = N_ObiObj FOR j = 2 TO nMax IF aNCochPr[j,3] IF aCochPar[1] = 1 Wsego = Wsego + N_GrOS ENDIF IF aCochPar[1] = 2 Wsego = Wsego + N_OpSc ENDIF ENDIF NEXT ENDIF IF aCochPar[3] = 2 Wsego = N_RsoObj ENDIF s = 1 IF aCochPar[3] = 1 // Отображение стадии исполнения. Будет написано прямо в окне 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 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[1] FONT "10.Helv" // 1 Генерация подсистем признаков @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[2] FONT "10.Helv" // 2 Докодирование обучающей выборки ENDIF IF aCochPar[3] = 2 // Отображение стадии исполнения. Будет написано прямо в окне Progress-bar @ 0,0 DCGROUP oGroup1 CAPTION L('Стадии исполнения процесса') FONT "6.Helv" SIZE 105, 2.5 PARENT oTabPage1 @ 4,0 DCGROUP oGroup2 CAPTION L('Прогноз времени исполнения') FONT "6.Helv" SIZE 105, 5.0 PARENT oTabPage2 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[3] FONT "10.Helv" // 3 Докодирование распознаваемой выборки ENDIF 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('3.7.8. Генерация сочетаний признаков и докодирование обуч.и расп.выб.'); PARENT @oDialog ; FIT ; EXIT ; MODAL oDialog:show() ******** Формирование массива используемых в сочетаниях признаков aFltrAtr := {} // Наименования сочетаний признаков из кодов исходных признаков SELECT FltrAtr mNum_pp = 0 DBGOTOP() DO WHILE .NOT. EOF() AADD(aFltrAtr, Kod_atr) REPLACE Fltr_atr WITH "#" DBSKIP(1) ENDDO ASORT(aFltrAtr) * MsgBox(STR(LEN(aFltrAtr))) * DC_DebugQout( aFltrAtr ) ***** Открытие основных dbf баз данных CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Class_Sc EXCLUSIVE NEW;N_ClSc = RECCOUNT() // * USE Gr_ClSc EXCLUSIVE NEW;N_GrCS = RECCOUNT() // * USE Attributes EXCLUSIVE NEW;N_GrOS = RECCOUNT() // Если mVidAbs = 2, то Учитывать только СОЧЕТАНИЯ признаков, встретившиеся в обучающей выборке не менее mVolAbs раз ПОСЧИТАТЬ НА ОСНОВЕ ОБУЧАЮЩЕЙ ВЫБОРКИ В Attributes.dbf БЕЗ СИНТЕЗА МОДЕЛЕЙ ################## USE Opis_Sc EXCLUSIVE NEW;N_OpSc = RECCOUNT() USE Gr_OpSc EXCLUSIVE NEW;N_GrOS = RECCOUNT() USE Obi_Zag EXCLUSIVE NEW;N_ObiObj = RECCOUNT() USE Obi_Kcl EXCLUSIVE NEW;N_ObiCls = RECCOUNT() USE Obi_Kpr EXCLUSIVE NEW;N_ObiKpr = RECCOUNT() USE Rso_Zag EXCLUSIVE NEW;N_RsoObj = RECCOUNT() USE Rso_Kcl EXCLUSIVE NEW;N_RsoCls = RECCOUNT() USE Rso_Kpr EXCLUSIVE NEW;N_RsoKpr = RECCOUNT() ******************************************************************************************** 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 *********************************************************************************************** IF aCochPar[3] = 1 ******************************************************************************************** aSay[1]:SetCaption(L('1/2: Генерация подсистем признаков')) IF aCochPar[1] = 1 // признаки неальтернативные *************************************** ******************************************************************************************** SELECT Gr_OpSc mKodGrOS = N_GrOS n = LEN(aFltrAtr) * IF aNCochPr[02,3] * anGrOSKod := {};anGrOSName := {} * FOR i1=1 TO N_GrOS;FOR i2=i1+1 TO N_GrOS * DC_CompleteEvents();IF lCancelled;EXIT;ENDIF * AADD(anGrOSKod , ++mKodGrOS) * AADD(anGrOSName, ALLTRIM(STR(i1))+','+ALLTRIM(STR(i2))) * NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT * AddOpScAtr(2, aCochPar[1]) * ENDIF IF aNCochPr[02,3] anGrOSKod := {};anGrOSName := {} FOR i1=1 TO n;FOR i2=i1+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF AADD(anGrOSKod , ++mKodGrOS) AADD(anGrOSName, ALLTRIM(STR(aFltrAtr[i1]))+','+ALLTRIM(STR(aFltrAtr[i2]))) NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT AddOpScAtr(2, aCochPar[1]) ENDIF IF aNCochPr[03,3] anGrOSKod := {};anGrOSName := {} FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF AADD(anGrOSKod , ++mKodGrOS) AADD(anGrOSName, ALLTRIM(STR(aFltrAtr[i1]))+','+ALLTRIM(STR(aFltrAtr[i2]))+','+ALLTRIM(STR(aFltrAtr[i3]))) NEXT;NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT AddOpScAtr(3, aCochPar[1]) ENDIF IF aNCochPr[04,3] anGrOSKod := {};anGrOSName := {} FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF AADD(anGrOSKod , ++mKodGrOS) AADD(anGrOSName, ALLTRIM(STR(aFltrAtr[i1]))+','+ALLTRIM(STR(aFltrAtr[i2]))+','+ALLTRIM(STR(aFltrAtr[i3]))+','+ALLTRIM(STR(aFltrAtr[i4]))) NEXT;NEXT;NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT AddOpScAtr(4, aCochPar[1]) ENDIF IF aNCochPr[05,3] anGrOSKod := {};anGrOSName := {} FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF AADD(anGrOSKod , ++mKodGrOS) AADD(anGrOSName, ALLTRIM(STR(aFltrAtr[i1]))+','+ALLTRIM(STR(aFltrAtr[i2]))+','+ALLTRIM(STR(aFltrAtr[i3]))+','+ALLTRIM(STR(aFltrAtr[i4]))+','+ALLTRIM(STR(aFltrAtr[i5]))) NEXT;NEXT;NEXT;NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT AddOpScAtr(5, aCochPar[1]) ENDIF IF aNCochPr[06,3] anGrOSKod := {};anGrOSName := {} FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF AADD(anGrOSKod , ++mKodGrOS) AADD(anGrOSName, ALLTRIM(STR(aFltrAtr[i1]))+','+ALLTRIM(STR(aFltrAtr[i2]))+','+ALLTRIM(STR(aFltrAtr[i3]))+','+ALLTRIM(STR(aFltrAtr[i4]))+','+ALLTRIM(STR(aFltrAtr[i5]))+','+ALLTRIM(STR(aFltrAtr[i6]))) NEXT;NEXT;NEXT;NEXT;NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT AddOpScAtr(6, aCochPar[1]) ENDIF IF aNCochPr[07,3] anGrOSKod := {};anGrOSName := {} FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF AADD(anGrOSKod , ++mKodGrOS) AADD(anGrOSName, ALLTRIM(STR(aFltrAtr[i1]))+','+ALLTRIM(STR(aFltrAtr[i2]))+','+ALLTRIM(STR(aFltrAtr[i3]))+','+ALLTRIM(STR(aFltrAtr[i4]))+','+ALLTRIM(STR(aFltrAtr[i5]))+','+ALLTRIM(STR(aFltrAtr[i6]))+','+ALLTRIM(STR(aFltrAtr[i7]))) NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT AddOpScAtr(7, aCochPar[1]) ENDIF IF aNCochPr[08,3] anGrOSKod := {};anGrOSName := {} FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF AADD(anGrOSKod , ++mKodGrOS) AADD(anGrOSName, ALLTRIM(STR(aFltrAtr[i1]))+','+ALLTRIM(STR(aFltrAtr[i2]))+','+ALLTRIM(STR(aFltrAtr[i3]))+','+ALLTRIM(STR(aFltrAtr[i4]))+','+ALLTRIM(STR(aFltrAtr[i5]))+','+ALLTRIM(STR(aFltrAtr[i6]))+','+ALLTRIM(STR(aFltrAtr[i7]))+','+ALLTRIM(STR(aFltrAtr[i8]))) NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT AddOpScAtr(8, aCochPar[1]) ENDIF IF aNCochPr[09,3] anGrOSKod := {};anGrOSName := {} FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n;FOR i9=i8+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF AADD(anGrOSKod , ++mKodGrOS) AADD(anGrOSName, ALLTRIM(STR(aFltrAtr[i1]))+','+ALLTRIM(STR(aFltrAtr[i2]))+','+ALLTRIM(STR(aFltrAtr[i3]))+','+ALLTRIM(STR(aFltrAtr[i4]))+','+ALLTRIM(STR(aFltrAtr[i5]))+','+ALLTRIM(STR(aFltrAtr[i6]))+','+ALLTRIM(STR(aFltrAtr[i7]))+','+ALLTRIM(STR(aFltrAtr[i8]))+','+ALLTRIM(STR(aFltrAtr[i9]))) NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT AddOpScAtr(9, aCochPar[1]) ENDIF IF aNCochPr[10,3] anGrOSKod := {};anGrOSName := {} FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4 =i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n;FOR i9=i8+1 TO n;FOR i10=i9+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF AADD(anGrOSKod , ++mKodGrOS) AADD(anGrOSName, ALLTRIM(STR(aFltrAtr[i1]))+','+ALLTRIM(STR(aFltrAtr[i2]))+','+ALLTRIM(STR(aFltrAtr[i3]))+','+ALLTRIM(STR(aFltrAtr[i4]))+','+ALLTRIM(STR(aFltrAtr[i5]))+','+ALLTRIM(STR(aFltrAtr[i6]))+','+ALLTRIM(STR(aFltrAtr[i7]))+','+ALLTRIM(STR(aFltrAtr[i8]))+','+ALLTRIM(STR(aFltrAtr[i9]))+','+ALLTRIM(STR(aFltrAtr[i10]))) NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT AddOpScAtr(10) ENDIF IF aNCochPr[11,3] anGrOSKod := {};anGrOSName := {} FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4 =i3+1 TO n;FOR i5 =i4 +1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n;FOR i9=i8+1 TO n;FOR i10=i9+1 TO n;FOR i11=i10+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF AADD(anGrOSKod , ++mKodGrOS) AADD(anGrOSName, ALLTRIM(STR(aFltrAtr[i1]))+','+ALLTRIM(STR(aFltrAtr[i2]))+','+ALLTRIM(STR(aFltrAtr[i3]))+','+ALLTRIM(STR(aFltrAtr[i4])) +','+ALLTRIM(STR(aFltrAtr[i5]))+','+ALLTRIM(STR(aFltrAtr[i6]))+','+ALLTRIM(STR(aFltrAtr[i7]))+','+ALLTRIM(STR(aFltrAtr[i8]))+','+ALLTRIM(STR(aFltrAtr[i9]))+','+ALLTRIM(STR(aFltrAtr[i10]))+','+ALLTRIM(STR(aFltrAtr[i11]))) NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT AddOpScAtr(11, aCochPar[1]) ENDIF IF aNCochPr[12,3] anGrOSKod := {};anGrOSName := {} FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4 =i3+1 TO n;FOR i5 =i4 +1 TO n;FOR i6 =i5 +1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n;FOR i9=i8+1 TO n;FOR i10=i9+1 TO n;FOR i11=i10+1 TO n;FOR i12=i11+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF AADD(anGrOSKod , ++mKodGrOS) AADD(anGrOSName, ALLTRIM(STR(aFltrAtr[i1]))+','+ALLTRIM(STR(aFltrAtr[i2]))+','+ALLTRIM(STR(aFltrAtr[i3]))+','+ALLTRIM(STR(aFltrAtr[i4])) +','+ALLTRIM(STR(aFltrAtr[i5])) +','+ALLTRIM(STR(aFltrAtr[i6]))+','+ALLTRIM(STR(aFltrAtr[i7]))+','+ALLTRIM(STR(aFltrAtr[i8]))+','+ALLTRIM(STR(aFltrAtr[i9]))+','+ALLTRIM(STR(aFltrAtr[i10]))+','+ALLTRIM(STR(aFltrAtr[i11]))+','+ALLTRIM(STR(aFltrAtr[i12]))) NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT AddOpScAtr(12, aCochPar[1]) ENDIF ENDIF * ************* Прерывание процесса по нажатию 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() * ************************************************************** * ***** БД, открытые перед запуском главного меню * ***** Восстанавливать их после выхода из функций главного меню * ************************************************************** * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы * USE PathGrAp EXCLUSIVE NEW * USE Appls EXCLUSIVE NEW * USE Users EXCLUSIVE NEW * ************************************************************** * Running(.F.) * RETURN NIL * ENDIF ************* Прерывание процесса по нажатию Cancel ############################################## aSay[1]:SetCaption(aSay[1]:caption+L(' - Готово ')) ******************************************************************************************** aSay[1]:SetCaption(L('1/2: Генерация подсистем признаков')) IF aCochPar[1] = 2 // признаки альтернативные ***************************************** ******************************************************************************************** SELECT Gr_OpSc n = N_OpSc mKodGrOS = N_GrOS * IF aNCochPr[02,3] * anGrOSKod := {};anGrOSName := {} * FOR i1=1 TO n;FOR i2=i1+1 TO n * FOR j1 =aOpisSc[i1, 2] TO aOpisSc[i1, 3] * FOR j2 =aOpisSc[i2, 2] TO aOpisSc[i2, 3] * DC_CompleteEvents();IF lCancelled;EXIT;ENDIF * AADD(anGrOSKod , ++mKodGrOS) * AADD(anGrOSName, ALLTRIM(STR(j1))+','+ALLTRIM(STR(j2))) * NEXT;NEXT * NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT * AddOpScAtr(02, aCochPar[1]) * ENDIF IF aNCochPr[02,3] anGrOSKod := {};anGrOSName := {} FOR i1=1 TO n;FOR i2=i1+1 TO n FOR j1 =aOpisSc[i1, 2] TO aOpisSc[i1, 3];IF ASCAN(aFltrAtr,j1)>0 FOR j2 =aOpisSc[i2, 2] TO aOpisSc[i2, 3];IF ASCAN(aFltrAtr,j2)>0 DC_CompleteEvents();IF lCancelled;EXIT;ENDIF AADD(anGrOSKod , ++mKodGrOS) AADD(anGrOSName, ALLTRIM(STR(j1))+','+ALLTRIM(STR(j2))) ENDIF;NEXT;ENDIF;NEXT NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT AddOpScAtr(02, aCochPar[1]) ENDIF IF aNCochPr[03,3] anGrOSKod := {};anGrOSName := {} FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n FOR j1 =aOpisSc[i1, 2] TO aOpisSc[i1, 3];IF ASCAN(aFltrAtr,j1)>0 FOR j2 =aOpisSc[i2, 2] TO aOpisSc[i2, 3];IF ASCAN(aFltrAtr,j2)>0 FOR j3 =aOpisSc[i3, 2] TO aOpisSc[i3, 3];IF ASCAN(aFltrAtr,j3)>0 DC_CompleteEvents();IF lCancelled;EXIT;ENDIF AADD(anGrOSKod , ++mKodGrOS) AADD(anGrOSName, ALLTRIM(STR(j1))+','+ALLTRIM(STR(j2))+','+ALLTRIM(STR(j3))) ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT NEXT;NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT AddOpScAtr(03, aCochPar[1]) ENDIF IF aNCochPr[04,3] anGrOSKod := {};anGrOSName := {} FOR i1=1 TO n;aKodAllOS:= {};FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n FOR j1 =aOpisSc[i1, 2] TO aOpisSc[i1, 3];IF ASCAN(aFltrAtr,j1)>0 FOR j2 =aOpisSc[i2, 2] TO aOpisSc[i2, 3];IF ASCAN(aFltrAtr,j2)>0 FOR j3 =aOpisSc[i3, 2] TO aOpisSc[i3, 3];IF ASCAN(aFltrAtr,j3)>0 FOR j4 =aOpisSc[i4, 2] TO aOpisSc[i4, 3];IF ASCAN(aFltrAtr,j4)>0 DC_CompleteEvents();IF lCancelled;EXIT;ENDIF AADD(anGrOSKod , ++mKodGrOS) AADD(anGrOSName, ALLTRIM(STR(j1))+','+ALLTRIM(STR(j2))+','+ALLTRIM(STR(j3))+','+ALLTRIM(STR(j4))) ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT NEXT;NEXT;NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT AddOpScAtr(04, aCochPar[1]) ENDIF IF aNCochPr[05,3] anGrOSKod := {};anGrOSName := {} FOR i1=1 TO n;aKodAllOS:= {};FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n FOR j1 =aOpisSc[i1, 2] TO aOpisSc[i1, 3];IF ASCAN(aFltrAtr,j1)>0 FOR j2 =aOpisSc[i2, 2] TO aOpisSc[i2, 3];IF ASCAN(aFltrAtr,j2)>0 FOR j3 =aOpisSc[i3, 2] TO aOpisSc[i3, 3];IF ASCAN(aFltrAtr,j3)>0 FOR j4 =aOpisSc[i4, 2] TO aOpisSc[i4, 3];IF ASCAN(aFltrAtr,j4)>0 FOR j5 =aOpisSc[i5, 2] TO aOpisSc[i5, 3];IF ASCAN(aFltrAtr,j5)>0 DC_CompleteEvents();IF lCancelled;EXIT;ENDIF AADD(anGrOSKod , ++mKodGrOS) AADD(anGrOSName, ALLTRIM(STR(j1))+','+ALLTRIM(STR(j2))+','+ALLTRIM(STR(j3))+','+ALLTRIM(STR(j4))+','+ALLTRIM(STR(j5))) ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT NEXT;NEXT;NEXT;NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT AddOpScAtr(05, aCochPar[1]) ENDIF IF aNCochPr[06,3] anGrOSKod := {};anGrOSName := {} FOR i1=1 TO n;aKodAllOS:= {};FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n FOR j1 =aOpisSc[i1, 2] TO aOpisSc[i1, 3];IF ASCAN(aFltrAtr,j1)>0 FOR j2 =aOpisSc[i2, 2] TO aOpisSc[i2, 3];IF ASCAN(aFltrAtr,j2)>0 FOR j3 =aOpisSc[i3, 2] TO aOpisSc[i3, 3];IF ASCAN(aFltrAtr,j3)>0 FOR j4 =aOpisSc[i4, 2] TO aOpisSc[i4, 3];IF ASCAN(aFltrAtr,j4)>0 FOR j5 =aOpisSc[i5, 2] TO aOpisSc[i5, 3];IF ASCAN(aFltrAtr,j5)>0 FOR j6 =aOpisSc[i6, 2] TO aOpisSc[i6, 3];IF ASCAN(aFltrAtr,j6)>0 DC_CompleteEvents();IF lCancelled;EXIT;ENDIF AADD(anGrOSKod , ++mKodGrOS) AADD(anGrOSName, ALLTRIM(STR(j1))+','+ALLTRIM(STR(j2))+','+ALLTRIM(STR(j3))+','+ALLTRIM(STR(j4))+','+ALLTRIM(STR(j5))+','+ALLTRIM(STR(j6))) ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT NEXT;NEXT;NEXT;NEXT;NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT AddOpScAtr(06, aCochPar[1]) ENDIF IF aNCochPr[07,3] anGrOSKod := {};anGrOSName := {} FOR i1=1 TO n;aKodAllOS:= {};FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n FOR j1 =aOpisSc[i1, 2] TO aOpisSc[i1, 3];IF ASCAN(aFltrAtr,j1)>0 FOR j2 =aOpisSc[i2, 2] TO aOpisSc[i2, 3];IF ASCAN(aFltrAtr,j2)>0 FOR j3 =aOpisSc[i3, 2] TO aOpisSc[i3, 3];IF ASCAN(aFltrAtr,j3)>0 FOR j4 =aOpisSc[i4, 2] TO aOpisSc[i4, 3];IF ASCAN(aFltrAtr,j4)>0 FOR j5 =aOpisSc[i5, 2] TO aOpisSc[i5, 3];IF ASCAN(aFltrAtr,j5)>0 FOR j6 =aOpisSc[i6, 2] TO aOpisSc[i6, 3];IF ASCAN(aFltrAtr,j6)>0 FOR j7 =aOpisSc[i7, 2] TO aOpisSc[i7, 3];IF ASCAN(aFltrAtr,j7)>0 DC_CompleteEvents();IF lCancelled;EXIT;ENDIF AADD(anGrOSKod , ++mKodGrOS) AADD(anGrOSName, ALLTRIM(STR(j1))+','+ALLTRIM(STR(j2))+','+ALLTRIM(STR(j3))+','+ALLTRIM(STR(j4))+','+ALLTRIM(STR(j5))+','+ALLTRIM(STR(j6))+','+ALLTRIM(STR(j7))) ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT AddOpScAtr(07, aCochPar[1]) ENDIF IF aNCochPr[08,3] anGrOSKod := {};anGrOSName := {} FOR i1=1 TO n;aKodAllOS:= {};FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n FOR j1 =aOpisSc[i1, 2] TO aOpisSc[i1, 3];IF ASCAN(aFltrAtr,j1)>0 FOR j2 =aOpisSc[i2, 2] TO aOpisSc[i2, 3];IF ASCAN(aFltrAtr,j2)>0 FOR j3 =aOpisSc[i3, 2] TO aOpisSc[i3, 3];IF ASCAN(aFltrAtr,j3)>0 FOR j4 =aOpisSc[i4, 2] TO aOpisSc[i4, 3];IF ASCAN(aFltrAtr,j4)>0 FOR j5 =aOpisSc[i5, 2] TO aOpisSc[i5, 3];IF ASCAN(aFltrAtr,j5)>0 FOR j6 =aOpisSc[i6, 2] TO aOpisSc[i6, 3];IF ASCAN(aFltrAtr,j6)>0 FOR j7 =aOpisSc[i7, 2] TO aOpisSc[i7, 3];IF ASCAN(aFltrAtr,j7)>0 FOR j8 =aOpisSc[i8, 2] TO aOpisSc[i8, 3];IF ASCAN(aFltrAtr,j8)>0 DC_CompleteEvents();IF lCancelled;EXIT;ENDIF AADD(anGrOSKod , ++mKodGrOS) AADD(anGrOSName, ALLTRIM(STR(j1))+','+ALLTRIM(STR(j2))+','+ALLTRIM(STR(j3))+','+ALLTRIM(STR(j4))+','+ALLTRIM(STR(j5))+','+ALLTRIM(STR(j6))+','+ALLTRIM(STR(j7))+','+ALLTRIM(STR(j8))) ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT AddOpScAtr(08, aCochPar[1]) ENDIF IF aNCochPr[09,3] anGrOSKod := {};anGrOSName := {} FOR i1=1 TO n;aKodAllOS:= {};FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n;FOR i9=i8+1 TO n FOR j1 =aOpisSc[i1, 2] TO aOpisSc[i1, 3];IF ASCAN(aFltrAtr,j1)>0 FOR j2 =aOpisSc[i2, 2] TO aOpisSc[i2, 3];IF ASCAN(aFltrAtr,j2)>0 FOR j3 =aOpisSc[i3, 2] TO aOpisSc[i3, 3];IF ASCAN(aFltrAtr,j3)>0 FOR j4 =aOpisSc[i4, 2] TO aOpisSc[i4, 3];IF ASCAN(aFltrAtr,j4)>0 FOR j5 =aOpisSc[i5, 2] TO aOpisSc[i5, 3];IF ASCAN(aFltrAtr,j5)>0 FOR j6 =aOpisSc[i6, 2] TO aOpisSc[i6, 3];IF ASCAN(aFltrAtr,j6)>0 FOR j7 =aOpisSc[i7, 2] TO aOpisSc[i7, 3];IF ASCAN(aFltrAtr,j7)>0 FOR j8 =aOpisSc[i8, 2] TO aOpisSc[i8, 3];IF ASCAN(aFltrAtr,j8)>0 FOR j9 =aOpisSc[i9, 2] TO aOpisSc[i9, 3];IF ASCAN(aFltrAtr,j9)>0 DC_CompleteEvents();IF lCancelled;EXIT;ENDIF AADD(anGrOSKod , ++mKodGrOS) AADD(anGrOSName, ALLTRIM(STR(j1))+','+ALLTRIM(STR(j2))+','+ALLTRIM(STR(j3))+','+ALLTRIM(STR(j4))+','+ALLTRIM(STR(j5))+','+ALLTRIM(STR(j6))+','+ALLTRIM(STR(j7))+','+ALLTRIM(STR(j8))+','+ALLTRIM(STR(j9))) ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT AddOpScAtr(09, aCochPar[1]) ENDIF IF aNCochPr[10,3] anGrOSKod := {};anGrOSName := {} FOR i1=1 TO n;aKodAllOS:= {};FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n;FOR i9=i8+1 TO n;FOR i10=i9+1 TO n FOR j1 =aOpisSc[i1, 2] TO aOpisSc[i1, 3];IF ASCAN(aFltrAtr,j1)>0 FOR j2 =aOpisSc[i2, 2] TO aOpisSc[i2, 3];IF ASCAN(aFltrAtr,j2)>0 FOR j3 =aOpisSc[i3, 2] TO aOpisSc[i3, 3];IF ASCAN(aFltrAtr,j3)>0 FOR j4 =aOpisSc[i4, 2] TO aOpisSc[i4, 3];IF ASCAN(aFltrAtr,j4)>0 FOR j5 =aOpisSc[i5, 2] TO aOpisSc[i5, 3];IF ASCAN(aFltrAtr,j5)>0 FOR j6 =aOpisSc[i6, 2] TO aOpisSc[i6, 3];IF ASCAN(aFltrAtr,j6)>0 FOR j7 =aOpisSc[i7, 2] TO aOpisSc[i7, 3];IF ASCAN(aFltrAtr,j7)>0 FOR j8 =aOpisSc[i8, 2] TO aOpisSc[i8, 3];IF ASCAN(aFltrAtr,j8)>0 FOR j9 =aOpisSc[i9, 2] TO aOpisSc[i9, 3];IF ASCAN(aFltrAtr,j9)>0 FOR j10=aOpisSc[i10,2] TO aOpisSc[i10,3];IF ASCAN(aFltrAtr,j10)>0 DC_CompleteEvents();IF lCancelled;EXIT;ENDIF AADD(anGrOSKod , ++mKodGrOS) AADD(anGrOSName, ALLTRIM(STR(j1))+','+ALLTRIM(STR(j2))+','+ALLTRIM(STR(j3))+','+ALLTRIM(STR(j4))+','+ALLTRIM(STR(j5))+','+ALLTRIM(STR(j6))+','+ALLTRIM(STR(j7))+','+ALLTRIM(STR(j8))+','+ALLTRIM(STR(j9))+','+ALLTRIM(STR(j10))) ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT AddOpScAtr(10, aCochPar[1]) ENDIF IF aNCochPr[11,3] anGrOSKod := {};anGrOSName := {} FOR i1=1 TO n;aKodAllOS:= {};FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n;FOR i9=i8+1 TO n;FOR i10=i9+1 TO n;FOR i11=i10+1 TO n FOR j1 =aOpisSc[i1, 2] TO aOpisSc[i1, 3];IF ASCAN(aFltrAtr,j1)>0 FOR j2 =aOpisSc[i2, 2] TO aOpisSc[i2, 3];IF ASCAN(aFltrAtr,j2)>0 FOR j3 =aOpisSc[i3, 2] TO aOpisSc[i3, 3];IF ASCAN(aFltrAtr,j3)>0 FOR j4 =aOpisSc[i4, 2] TO aOpisSc[i4, 3];IF ASCAN(aFltrAtr,j4)>0 FOR j5 =aOpisSc[i5, 2] TO aOpisSc[i5, 3];IF ASCAN(aFltrAtr,j5)>0 FOR j6 =aOpisSc[i6, 2] TO aOpisSc[i6, 3];IF ASCAN(aFltrAtr,j6)>0 FOR j7 =aOpisSc[i7, 2] TO aOpisSc[i7, 3];IF ASCAN(aFltrAtr,j7)>0 FOR j8 =aOpisSc[i8, 2] TO aOpisSc[i8, 3];IF ASCAN(aFltrAtr,j8)>0 FOR j9 =aOpisSc[i9, 2] TO aOpisSc[i9, 3];IF ASCAN(aFltrAtr,j9)>0 FOR j10=aOpisSc[i10,2] TO aOpisSc[i10,3];IF ASCAN(aFltrAtr,j10)>0 FOR j11=aOpisSc[i11,2] TO aOpisSc[i11,3];IF ASCAN(aFltrAtr,j11)>0 DC_CompleteEvents();IF lCancelled;EXIT;ENDIF AADD(anGrOSKod , ++mKodGrOS) AADD(anGrOSName, ALLTRIM(STR(j1))+','+ALLTRIM(STR(j2))+','+ALLTRIM(STR(j3))+','+ALLTRIM(STR(j4))+','+ALLTRIM(STR(j5))+','+ALLTRIM(STR(j6))+','+ALLTRIM(STR(j7))+','+ALLTRIM(STR(j8))+','+ALLTRIM(STR(j9))+','+ALLTRIM(STR(j10))+','+ALLTRIM(STR(j11))) ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT AddOpScAtr(11, aCochPar[1]) ENDIF IF aNCochPr[12,3] anGrOSKod := {};anGrOSName := {} FOR i1=1 TO n;aKodAllOS:= {};FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6 =i5+1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n;FOR i9=i8+1 TO n;FOR i10=i9+1 TO n;FOR i11=i10+1 TO n;FOR i12=i11+1 TO n FOR j1 =aOpisSc[i1, 2] TO aOpisSc[i1, 3];IF ASCAN(aFltrAtr,j1)>0 FOR j2 =aOpisSc[i2, 2] TO aOpisSc[i2, 3];IF ASCAN(aFltrAtr,j2)>0 FOR j3 =aOpisSc[i3, 2] TO aOpisSc[i3, 3];IF ASCAN(aFltrAtr,j3)>0 FOR j4 =aOpisSc[i4, 2] TO aOpisSc[i4, 3];IF ASCAN(aFltrAtr,j4)>0 FOR j5 =aOpisSc[i5, 2] TO aOpisSc[i5, 3];IF ASCAN(aFltrAtr,j5)>0 FOR j6 =aOpisSc[i6, 2] TO aOpisSc[i6, 3];IF ASCAN(aFltrAtr,j6)>0 FOR j7 =aOpisSc[i7, 2] TO aOpisSc[i7, 3];IF ASCAN(aFltrAtr,j7)>0 FOR j8 =aOpisSc[i8, 2] TO aOpisSc[i8, 3];IF ASCAN(aFltrAtr,j8)>0 FOR j9 =aOpisSc[i9, 2] TO aOpisSc[i9, 3];IF ASCAN(aFltrAtr,j9)>0 FOR j10=aOpisSc[i10,2] TO aOpisSc[i10,3];IF ASCAN(aFltrAtr,j10)>0 FOR j11=aOpisSc[i11,2] TO aOpisSc[i11,3];IF ASCAN(aFltrAtr,j11)>0 FOR j12=aOpisSc[i12,2] TO aOpisSc[i12,3];IF ASCAN(aFltrAtr,j12)>0 DC_CompleteEvents();IF lCancelled;EXIT;ENDIF AADD(anGrOSKod , ++mKodGrOS) AADD(anGrOSName, ALLTRIM(STR(j1))+','+ALLTRIM(STR(j2))+','+ALLTRIM(STR(j3))+','+ALLTRIM(STR(j4))+','+ALLTRIM(STR(j5))+','+ALLTRIM(STR(j6))+','+ALLTRIM(STR(j7))+','+ALLTRIM(STR(j8))+','+ALLTRIM(STR(j9))+','+ALLTRIM(STR(j10))+','+ALLTRIM(STR(j11))+','+ALLTRIM(STR(j12))) ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT;ENDIF;NEXT NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT AddOpScAtr(12, aCochPar[1]) ENDIF ENDIF ************* Прерывание процесса по нажатию 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() ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ************* Прерывание процесса по нажатию Cancel ############################################## aSay[1]:SetCaption(aSay[1]:caption+L(' - Готово ')) ****************************************************************************************** aSay[2]:SetCaption(L('2/2: Докодирование обучающей выборки')) ****** Записать в массив справочник признаков SELECT Attributes aAtr := {} DBGOTOP() DO WHILE .NOT. EOF() AADD(aAtr, ALLTRIM(Name_atr)) DBSKIP(1) ENDDO SELECT Obi_Kpr FOR i=1 TO N_ObiObj SET FILTER TO Kod_obj = i aKodPr := {} DBGOTOP() DO WHILE .NOT. EOF() FOR j=1 TO 7 mV = FIELDGET(1+j) IF mV > 0 AADD(aKodPr, mV) ENDIF NEXT DBSKIP(1) ENDDO ***** Формирование кодов сочетаний признаков на основе базовых признаков объекта ASORT(aKodPr) aKodPrNew := {} n = LEN(aKodPr) IF aNCochPr[02,3] FOR i1=1 TO n;FOR i2=i1+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF mNameOpSc = 'ПОДСИСТЕМЫ ИЗ 2'+IF(aCochPar[1]=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' ПРИЗНАКОВ' mName = mNameOpSc+'-'+ALLTRIM(STR(aKodPr[i1]))+','+ALLTRIM(STR(aKodPr[i2])) Pos = ASCAN(aAtr, mName);IF Pos > 0;AADD(aKodPrNew, Pos);ENDIF NEXT;NEXT ENDIF IF aNCochPr[03,3] FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF mNameOpSc = 'ПОДСИСТЕМЫ ИЗ 3'+IF(aCochPar[1]=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' ПРИЗНАКОВ' mName = mNameOpSc+'-'+ALLTRIM(STR(aKodPr[i1]))+','+ALLTRIM(STR(aKodPr[i2]))+','+ALLTRIM(STR(aKodPr[i3])) Pos = ASCAN(aAtr, mName);IF Pos > 0;AADD(aKodPrNew, Pos);ENDIF NEXT;NEXT;NEXT ENDIF IF aNCochPr[04,3] FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF mNameOpSc = 'ПОДСИСТЕМЫ ИЗ 4'+IF(aCochPar[1]=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' ПРИЗНАКОВ' mName = mNameOpSc+'-'+ALLTRIM(STR(aKodPr[i1]))+','+ALLTRIM(STR(aKodPr[i2]))+','+ALLTRIM(STR(aKodPr[i3]))+','+ALLTRIM(STR(aKodPr[i4])) Pos = ASCAN(aAtr, mName);IF Pos > 0;AADD(aKodPrNew, Pos);ENDIF NEXT;NEXT;NEXT;NEXT ENDIF IF aNCochPr[05,3] FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF mNameOpSc = 'ПОДСИСТЕМЫ ИЗ 5'+IF(aCochPar[1]=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' ПРИЗНАКОВ' mName = mNameOpSc+'-'+ALLTRIM(STR(aKodPr[i1]))+','+ALLTRIM(STR(aKodPr[i2]))+','+ALLTRIM(STR(aKodPr[i3]))+','+ALLTRIM(STR(aKodPr[i4]))+; ','+ALLTRIM(STR(aKodPr[i5])) Pos = ASCAN(aAtr, mName);IF Pos > 0;AADD(aKodPrNew, Pos);ENDIF NEXT;NEXT;NEXT;NEXT;NEXT ENDIF IF aNCochPr[06,3] FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF mNameOpSc = 'ПОДСИСТЕМЫ ИЗ 6'+IF(aCochPar[1]=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' ПРИЗНАКОВ' mName = mNameOpSc+'-'+ALLTRIM(STR(aKodPr[i1]))+','+ALLTRIM(STR(aKodPr[i2]))+','+ALLTRIM(STR(aKodPr[i3]))+','+ALLTRIM(STR(aKodPr[i4]))+; ','+ALLTRIM(STR(aKodPr[i5]))+','+ALLTRIM(STR(aKodPr[i6])) Pos = ASCAN(aAtr, mName);IF Pos > 0;AADD(aKodPrNew, Pos);ENDIF NEXT;NEXT;NEXT;NEXT;NEXT;NEXT ENDIF IF aNCochPr[07,3] FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF mNameOpSc = 'ПОДСИСТЕМЫ ИЗ 7'+IF(aCochPar[1]=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' ПРИЗНАКОВ' mName = mNameOpSc+'-'+ALLTRIM(STR(aKodPr[i1]))+','+ALLTRIM(STR(aKodPr[i2]))+','+ALLTRIM(STR(aKodPr[i3]))+','+ALLTRIM(STR(aKodPr[i4]))+; ','+ALLTRIM(STR(aKodPr[i5]))+','+ALLTRIM(STR(aKodPr[i6]))+','+ALLTRIM(STR(aKodPr[i7])) Pos = ASCAN(aAtr, mName);IF Pos > 0;AADD(aKodPrNew, Pos);ENDIF NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT ENDIF IF aNCochPr[08,3] FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF mNameOpSc = 'ПОДСИСТЕМЫ ИЗ 8'+IF(aCochPar[1]=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' ПРИЗНАКОВ' mName = mNameOpSc+'-'+ALLTRIM(STR(aKodPr[i1]))+','+ALLTRIM(STR(aKodPr[i2]))+','+ALLTRIM(STR(aKodPr[i3]))+','+ALLTRIM(STR(aKodPr[i4]))+; ','+ALLTRIM(STR(aKodPr[i5]))+','+ALLTRIM(STR(aKodPr[i6]))+','+ALLTRIM(STR(aKodPr[i7]))+','+ALLTRIM(STR(aKodPr[i8])) Pos = ASCAN(aAtr, mName);IF Pos > 0;AADD(aKodPrNew, Pos);ENDIF NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT ENDIF IF aNCochPr[09,3] FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n;FOR i9=i8+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF mNameOpSc = 'ПОДСИСТЕМЫ ИЗ 9'+IF(aCochPar[1]=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' ПРИЗНАКОВ' mName = mNameOpSc+'-'+ALLTRIM(STR(aKodPr[i1]))+','+ALLTRIM(STR(aKodPr[i2]))+','+ALLTRIM(STR(aKodPr[i3]))+','+ALLTRIM(STR(aKodPr[i4]))+; ','+ALLTRIM(STR(aKodPr[i5]))+','+ALLTRIM(STR(aKodPr[i6]))+','+ALLTRIM(STR(aKodPr[i7]))+','+ALLTRIM(STR(aKodPr[i8]))+; ','+ALLTRIM(STR(aKodPr[i9])) Pos = ASCAN(aAtr, mName);IF Pos > 0;AADD(aKodPrNew, Pos);ENDIF NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT ENDIF IF aNCochPr[10,3] FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n;FOR i9=i8+1 TO n;FOR i10=i9+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF mNameOpSc = 'ПОДСИСТЕМЫ ИЗ 10'+IF(aCochPar[1]=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' ПРИЗНАКОВ' mName = mNameOpSc+'-'+ALLTRIM(STR(aKodPr[i1]))+','+ALLTRIM(STR(aKodPr[i2]))+','+ALLTRIM(STR(aKodPr[i3]))+','+ALLTRIM(STR(aKodPr[i4]))+; ','+ALLTRIM(STR(aKodPr[i5]))+','+ALLTRIM(STR(aKodPr[i6]))+','+ALLTRIM(STR(aKodPr[i7]))+','+ALLTRIM(STR(aKodPr[i8]))+; ','+ALLTRIM(STR(aKodPr[i9]))+','+ALLTRIM(STR(aKodPr[i10])) Pos = ASCAN(aAtr, mName);IF Pos > 0;AADD(aKodPrNew, Pos);ENDIF NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT ENDIF IF aNCochPr[11,3] FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n;FOR i9=i8+1 TO n;FOR i10=i9+1 TO n;FOR i11=i10+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF mNameOpSc = 'ПОДСИСТЕМЫ ИЗ 11'+IF(aCochPar[1]=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' ПРИЗНАКОВ' mName = mNameOpSc+'-'+ALLTRIM(STR(aKodPr[i1]))+','+ALLTRIM(STR(aKodPr[i2]))+','+ALLTRIM(STR(aKodPr[i3]))+','+ALLTRIM(STR(aKodPr[i4]))+; ','+ALLTRIM(STR(aKodPr[i5]))+','+ALLTRIM(STR(aKodPr[i6]))+','+ALLTRIM(STR(aKodPr[i7]))+','+ALLTRIM(STR(aKodPr[i8]))+; ','+ALLTRIM(STR(aKodPr[i9]))+','+ALLTRIM(STR(aKodPr[i10]))+','+ALLTRIM(STR(aKodPr[i11])) Pos = ASCAN(aAtr, mName);IF Pos > 0;AADD(aKodPrNew, Pos);ENDIF NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT ENDIF IF aNCochPr[12,3] FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6 =i5+1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n;FOR i9=i8+1 TO n;FOR i10=i9+1 TO n;FOR i11=i10+1 TO n;FOR i12=i11+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF mNameOpSc = 'ПОДСИСТЕМЫ ИЗ 12'+IF(aCochPar[1]=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' ПРИЗНАКОВ' mName = mNameOpSc+'-'+ALLTRIM(STR(aKodPr[i1]))+','+ALLTRIM(STR(aKodPr[i2]))+','+ALLTRIM(STR(aKodPr[i3]))+','+ALLTRIM(STR(aKodPr[i4]))+; ','+ALLTRIM(STR(aKodPr[i5]))+','+ALLTRIM(STR(aKodPr[i6]))+','+ALLTRIM(STR(aKodPr[i7]))+','+ALLTRIM(STR(aKodPr[i8]))+; ','+ALLTRIM(STR(aKodPr[i9]))+','+ALLTRIM(STR(aKodPr[i10]))+','+ALLTRIM(STR(aKodPr[i11]))+','+ALLTRIM(STR(aKodPr[i12])) Pos = ASCAN(aAtr, mName);IF Pos > 0;AADD(aKodPrNew, Pos);ENDIF NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT ENDIF * ************* Прерывание процесса по нажатию 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() * ************************************************************** * ***** БД, открытые перед запуском главного меню * ***** Восстанавливать их после выхода из функций главного меню * ************************************************************** * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы * USE PathGrAp EXCLUSIVE NEW * USE Appls EXCLUSIVE NEW * USE Users EXCLUSIVE NEW * ************************************************************** * Running(.F.) * RETURN NIL * ENDIF * ************* Прерывание процесса по нажатию Cancel ############################################## ** Дозапись кодов сочетаний признаков в БД Obi_Kpr IF LEN(aKodPrNew) > 0 SELECT Obi_Kpr APPEND BLANK REPLACE Kod_Obj WITH i k=1 FOR j=1 TO LEN(aKodPrNew) IF k <= 7 FIELDPUT(1+k++,aKodPrNew[j]) ELSE k=1 APPEND BLANK REPLACE Kod_Obj WITH i FIELDPUT(1+k++,aKodPrNew[j]) ENDIF NEXT ENDIF lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk) NEXT aSay[2]:SetCaption(aSay[2]:caption+L(' - Готово ')) ENDIF ***** ################################################################################################################################ ***** Здесь удалить признаки, встретившиеся менее заданного числа раз и перекодировать обучающую выборку ############################# ***** ################################################################################################################################ ***** Если mVidAbs = 2, то Учитывать только СОЧЕТАНИЯ признаков, встретившиеся в обучающей выборке не менее mVolAbs раз ПОСЧИТАТЬ НА ОСНОВЕ ОБУЧАЮЩЕЙ ВЫБОРКИ В Attributes.dbf БЕЗ СИНТЕЗА МОДЕЛЕЙ ################## * MsgBox(STR(mVidAbs)) mVolAbs = IF(mVidAbs=1, 0, mVolAbs) ****** Посчитать сколько раз какой признак встретился в обучающей выборке SELECT Obi_Kpr DBGOTOP() DO WHILE .NOT. EOF() aKodAtr := {} FOR j=2 TO 8 mKodAtr = FIELDGET(j) IF mKodAtr > 0 AADD(aKodAtr, mKodAtr) ENDIF NEXT IF LEN(aKodAtr) > 0 SELECT Attributes FOR j=1 TO LEN(aKodAtr) DBGOTO(j) mAbs = Abs REPLACE Abs WITH mAbs+1 NEXT ENDIF * MsgBox(STR(LEN(aKodAtr))) // ####################### SELECT Obi_Kpr DBSKIP(1) ENDDO ***** Перекодировать признаки в Attributes.dbf SELECT Attributes DBGOTOP() mKodAtr = N_GrOS DO WHILE .NOT. EOF() IF Kod_atr <= N_GrOS REPLACE Universal WITH Kod_atr ELSE IF Abs >= mVolAbs REPLACE Universal WITH ++mKodAtr ENDIF ENDIF DBSKIP(1) ENDDO ***** Перекодировать признаки в обучающей выборке IF aCochPar[3] = 2 ****************************************************************************************** aSay[3]:SetCaption(L('1/1: Докодирование сочетаний признаков в распознаваемой выборке')) ****** Записать в массив справочник признаков SELECT Attributes aAtr := {} DBGOTOP() DO WHILE .NOT. EOF() AADD(aAtr, ALLTRIM(Name_atr)) DBSKIP(1) ENDDO SELECT Rso_Kpr FOR i=1 TO N_RsoObj SET FILTER TO Kod_obj = i aKodPr := {} DBGOTOP() DO WHILE .NOT. EOF() FOR j=1 TO 7 mV = FIELDGET(1+j) IF mV > 0 AADD(aKodPr, mV) ENDIF NEXT DBSKIP(1) ENDDO ***** Формирование кодов сочетаний признаков на основе базовых признаков объекта ASORT(aKodPr) aKodPrNew := {} n = LEN(aKodPr) IF aNCochPr[02,3] FOR i1=1 TO n;FOR i2=i1+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF mNameOpSc = 'ПОДСИСТЕМЫ ИЗ 2'+IF(aCochPar[1]=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' ПРИЗНАКОВ' mName = mNameOpSc+'-'+ALLTRIM(STR(aKodPr[i1]))+','+ALLTRIM(STR(aKodPr[i2])) Pos = ASCAN(aAtr, mName);IF Pos > 0;AADD(aKodPrNew, Pos);ENDIF NEXT;NEXT ENDIF IF aNCochPr[03,3] FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF mNameOpSc = 'ПОДСИСТЕМЫ ИЗ 3'+IF(aCochPar[1]=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' ПРИЗНАКОВ' mName = mNameOpSc+'-'+ALLTRIM(STR(aKodPr[i1]))+','+ALLTRIM(STR(aKodPr[i2]))+','+ALLTRIM(STR(aKodPr[i3])) Pos = ASCAN(aAtr, mName);IF Pos > 0;AADD(aKodPrNew, Pos);ENDIF NEXT;NEXT;NEXT ENDIF IF aNCochPr[04,3] FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF mNameOpSc = 'ПОДСИСТЕМЫ ИЗ 4'+IF(aCochPar[1]=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' ПРИЗНАКОВ' mName = mNameOpSc+'-'+ALLTRIM(STR(aKodPr[i1]))+','+ALLTRIM(STR(aKodPr[i2]))+','+ALLTRIM(STR(aKodPr[i3]))+','+ALLTRIM(STR(aKodPr[i4])) Pos = ASCAN(aAtr, mName);IF Pos > 0;AADD(aKodPrNew, Pos);ENDIF NEXT;NEXT;NEXT;NEXT ENDIF IF aNCochPr[05,3] FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF mNameOpSc = 'ПОДСИСТЕМЫ ИЗ 5'+IF(aCochPar[1]=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' ПРИЗНАКОВ' mName = mNameOpSc+'-'+ALLTRIM(STR(aKodPr[i1]))+','+ALLTRIM(STR(aKodPr[i2]))+','+ALLTRIM(STR(aKodPr[i3]))+','+ALLTRIM(STR(aKodPr[i4]))+; ','+ALLTRIM(STR(aKodPr[i5])) Pos = ASCAN(aAtr, mName);IF Pos > 0;AADD(aKodPrNew, Pos);ENDIF NEXT;NEXT;NEXT;NEXT;NEXT ENDIF IF aNCochPr[06,3] FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF mNameOpSc = 'ПОДСИСТЕМЫ ИЗ 6'+IF(aCochPar[1]=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' ПРИЗНАКОВ' mName = mNameOpSc+'-'+ALLTRIM(STR(aKodPr[i1]))+','+ALLTRIM(STR(aKodPr[i2]))+','+ALLTRIM(STR(aKodPr[i3]))+','+ALLTRIM(STR(aKodPr[i4]))+; ','+ALLTRIM(STR(aKodPr[i5]))+','+ALLTRIM(STR(aKodPr[i6])) Pos = ASCAN(aAtr, mName);IF Pos > 0;AADD(aKodPrNew, Pos);ENDIF NEXT;NEXT;NEXT;NEXT;NEXT;NEXT ENDIF IF aNCochPr[07,3] FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF mNameOpSc = 'ПОДСИСТЕМЫ ИЗ 7'+IF(aCochPar[1]=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' ПРИЗНАКОВ' mName = mNameOpSc+'-'+ALLTRIM(STR(aKodPr[i1]))+','+ALLTRIM(STR(aKodPr[i2]))+','+ALLTRIM(STR(aKodPr[i3]))+','+ALLTRIM(STR(aKodPr[i4]))+; ','+ALLTRIM(STR(aKodPr[i5]))+','+ALLTRIM(STR(aKodPr[i6]))+','+ALLTRIM(STR(aKodPr[i7])) Pos = ASCAN(aAtr, mName);IF Pos > 0;AADD(aKodPrNew, Pos);ENDIF NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT ENDIF IF aNCochPr[08,3] FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF mNameOpSc = 'ПОДСИСТЕМЫ ИЗ 8'+IF(aCochPar[1]=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' ПРИЗНАКОВ' mName = mNameOpSc+'-'+ALLTRIM(STR(aKodPr[i1]))+','+ALLTRIM(STR(aKodPr[i2]))+','+ALLTRIM(STR(aKodPr[i3]))+','+ALLTRIM(STR(aKodPr[i4]))+; ','+ALLTRIM(STR(aKodPr[i5]))+','+ALLTRIM(STR(aKodPr[i6]))+','+ALLTRIM(STR(aKodPr[i7]))+','+ALLTRIM(STR(aKodPr[i8])) Pos = ASCAN(aAtr, mName);IF Pos > 0;AADD(aKodPrNew, Pos);ENDIF NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT ENDIF IF aNCochPr[09,3] FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n;FOR i9=i8+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF mNameOpSc = 'ПОДСИСТЕМЫ ИЗ 9'+IF(aCochPar[1]=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' ПРИЗНАКОВ' mName = mNameOpSc+'-'+ALLTRIM(STR(aKodPr[i1]))+','+ALLTRIM(STR(aKodPr[i2]))+','+ALLTRIM(STR(aKodPr[i3]))+','+ALLTRIM(STR(aKodPr[i4]))+; ','+ALLTRIM(STR(aKodPr[i5]))+','+ALLTRIM(STR(aKodPr[i6]))+','+ALLTRIM(STR(aKodPr[i7]))+','+ALLTRIM(STR(aKodPr[i8]))+; ','+ALLTRIM(STR(aKodPr[i9])) Pos = ASCAN(aAtr, mName);IF Pos > 0;AADD(aKodPrNew, Pos);ENDIF NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT ENDIF IF aNCochPr[10,3] FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n;FOR i9=i8+1 TO n;FOR i10=i9+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF mNameOpSc = 'ПОДСИСТЕМЫ ИЗ 10'+IF(aCochPar[1]=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' ПРИЗНАКОВ' mName = mNameOpSc+'-'+ALLTRIM(STR(aKodPr[i1]))+','+ALLTRIM(STR(aKodPr[i2]))+','+ALLTRIM(STR(aKodPr[i3]))+','+ALLTRIM(STR(aKodPr[i4]))+; ','+ALLTRIM(STR(aKodPr[i5]))+','+ALLTRIM(STR(aKodPr[i6]))+','+ALLTRIM(STR(aKodPr[i7]))+','+ALLTRIM(STR(aKodPr[i8]))+; ','+ALLTRIM(STR(aKodPr[i9]))+','+ALLTRIM(STR(aKodPr[i10])) Pos = ASCAN(aAtr, mName);IF Pos > 0;AADD(aKodPrNew, Pos);ENDIF NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT ENDIF IF aNCochPr[11,3] FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n;FOR i9=i8+1 TO n;FOR i10=i9+1 TO n;FOR i11=i10+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF mNameOpSc = 'ПОДСИСТЕМЫ ИЗ 11'+IF(aCochPar[1]=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' ПРИЗНАКОВ' mName = mNameOpSc+'-'+ALLTRIM(STR(aKodPr[i1]))+','+ALLTRIM(STR(aKodPr[i2]))+','+ALLTRIM(STR(aKodPr[i3]))+','+ALLTRIM(STR(aKodPr[i4]))+; ','+ALLTRIM(STR(aKodPr[i5]))+','+ALLTRIM(STR(aKodPr[i6]))+','+ALLTRIM(STR(aKodPr[i7]))+','+ALLTRIM(STR(aKodPr[i8]))+; ','+ALLTRIM(STR(aKodPr[i9]))+','+ALLTRIM(STR(aKodPr[i10]))+','+ALLTRIM(STR(aKodPr[i11])) Pos = ASCAN(aAtr, mName);IF Pos > 0;AADD(aKodPrNew, Pos);ENDIF NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT ENDIF IF aNCochPr[12,3] FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6 =i5+1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n;FOR i9=i8+1 TO n;FOR i10=i9+1 TO n;FOR i11=i10+1 TO n;FOR i12=i11+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF mNameOpSc = 'ПОДСИСТЕМЫ ИЗ 12'+IF(aCochPar[1]=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' ПРИЗНАКОВ' mName = mNameOpSc+'-'+ALLTRIM(STR(aKodPr[i1]))+','+ALLTRIM(STR(aKodPr[i2]))+','+ALLTRIM(STR(aKodPr[i3]))+','+ALLTRIM(STR(aKodPr[i4]))+; ','+ALLTRIM(STR(aKodPr[i5]))+','+ALLTRIM(STR(aKodPr[i6]))+','+ALLTRIM(STR(aKodPr[i7]))+','+ALLTRIM(STR(aKodPr[i8]))+; ','+ALLTRIM(STR(aKodPr[i9]))+','+ALLTRIM(STR(aKodPr[i10]))+','+ALLTRIM(STR(aKodPr[i11]))+','+ALLTRIM(STR(aKodPr[i12])) Pos = ASCAN(aAtr, mName);IF Pos > 0;AADD(aKodPrNew, Pos);ENDIF NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT ENDIF * ************* Прерывание процесса по нажатию 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() * * ************************************************************** * ***** БД, открытые перед запуском главного меню * ***** Восстанавливать их после выхода из функций главного меню * ************************************************************** * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы * USE PathGrAp EXCLUSIVE NEW * USE Appls EXCLUSIVE NEW * USE Users EXCLUSIVE NEW * ************************************************************** * Running(.F.) * RETURN NIL * ENDIF ************* Прерывание процесса по нажатию Cancel ############################################## ** Дозапись кодов сочетаний признаков в БД Rso_Kpr IF LEN(aKodPrNew) > 0 SELECT Rso_Kpr APPEND BLANK REPLACE Kod_Obj WITH i k=1 FOR j=1 TO LEN(aKodPrNew) IF k <= 7 FIELDPUT(1+k++,aKodPrNew[j]) ELSE k=1 APPEND BLANK REPLACE Kod_Obj WITH i FIELDPUT(1+k++,aKodPrNew[j]) ENDIF NEXT ENDIF lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk) NEXT aSay[3]:SetCaption(aSay[3]:caption+L(' - Готово ')) ENDIF ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** ****************************************************************************************** // Вывод информации о завершении процесса исполнения IF aCochPar[3] = 1 Mess = L("ГЕНЕРАЦИЯ СОЧЕТАНИЙ ПРИЗНАКОВ И ДОКОДИРОВАНИЕ ОБУЧАЮЩЕЙ ВЫБОРКИ ЗАВЕРШЕНО !!!") ENDIF IF aCochPar[3] = 2 Mess = L("ДОКОДИРОВАНИЕ СОЧЕТАНИЙ ПРИЗНАКОВ В РАСПОЗНАВАЕМОЙ ВЫБОРКЕ ЗАВЕРШЕНО !!!" ) ENDIF 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() Running(.F.) RETURN nil ******** Добавление Opis_Sc и сочетаний признаков в БД Gr_OpSc и Attributes FUNCTION AddOpScAtr(mNSoch, Alt) IF LEN(anGrOSKod) > 0 SELECT Opis_Sc DBGOBOTTOM() mKodOpSc = Kod_OpSc mNameOpSc = 'ПОДСИСТЕМЫ ИЗ '+ALLTRIM(STR(mNSoch))+IF(Alt=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' ПРИЗНАКОВ' APPEND BLANK REPLACE Kod_OpSc WITH ++mKodOpSc REPLACE Name_OpSc WITH mNameOpSc SELECT Gr_OpSc FOR j=1 TO LEN(anGrOSKod) APPEND BLANK REPLACE Kod_OpSc WITH mKodOpSc REPLACE Kod_GrOS WITH anGrOSKod[j] REPLACE Name_GrOS WITH anGrOSName[j] NEXT SELECT Attributes FOR j=1 TO LEN(anGrOSKod) APPEND BLANK REPLACE Kod_atr WITH anGrOSKod[j] REPLACE Name_atr WITH mNameOpSc+'-'+anGrOSName[j] REPLACE Kod_OpSc WITH mKodOpSc REPLACE N_ChrOpSc WITH LEN(mNameOpSc) NEXT ENDIF RETURN nil ***************************************************************************************** ****** Отобразить для каждого числа признаков в сочетании количество сочетаний ****** И сумму числа сочетанных признаков для всех заданных сочетаний ***************************************************************************************** STATIC FUNCTION CalcSumPrBlock( aNCochPr, i, Alt ) RETURN {||CalcSumPr( aNCochPr, i, Alt)} * ----------- ****** Сделать 2 суммы: число сочетаний из n по m и произведение числа градаций шкал STATIC FUNCTION CalcSumPr( aNCochPr, i, Alt ) LOCAL j, n := 0 *wtf i FOR j := 1 TO i IF aNCochPr[j,3] n = n + VAL(aNCochPr[j, Alt]) ENDIF NEXT RETURN L('...Сумма =')+' '+Alltrim(Str(n,250)) ***************************************************************************************** ****** Отобразить для каждого числа классов в сочетании количество сочетаний ****** И сумму числа сочетанных классов для всех заданных сочетаний ***************************************************************************************** STATIC FUNCTION CalcSumClBlock( aNCochCl, i, Alt ) RETURN {||CalcSumCl( aNCochCl, i, Alt)} * ----------- ****** Сделать 2 суммы: число сочетаний из n по m и произведение числа градаций шкал STATIC FUNCTION CalcSumCl( aNCochCl, i, Alt ) LOCAL j, n := 0 *wtf i FOR j := 1 TO i IF aNCochCl[j,3] n = n + VAL(aNCochCl[j, Alt]) ENDIF NEXT RETURN '...Сумма = ' + Alltrim(Str(n)) ************************************************************************************************** ******** Помощь по режиму 3.7.8 ************************************************************************************************** FUNCTION Help378() aHelp := {} AADD(aHelp, L('Режим: "3.7.8. ГЕНЕРАЦИЯ СОЧЕТАНИЙ ПРИЗНАКОВ И ДОКОДИРОВАНИЕ ')) AADD(aHelp, L('ОБУЧАЮЩЕЙ И РАСПОЗНАВАЕМОЙ ВЫБОРКИ" обеспечивает: ')) AADD(aHelp, L('1. Формирование сочетаний признаков в соответствии с параметрами, заданными ')) AADD(aHelp, L(' в диалоге: ')) AADD(aHelp, L(' - альтернативные или неальтернативные признаки; ')) AADD(aHelp, L(' - количество сочетаний признаков в подсистемах признаков; ')) AADD(aHelp, L('2. Дополнение описательных шкал и градаций сочетаниями признаков; ')) AADD(aHelp, L('3. Докодирование объектов обучающей и распознаваемой выборки в соответствии ')) 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('с Advantage Database Server (ADS) и TXT-файлами, ПОЛНОСТЬЮ СНЯТО ограничение')) AADD(aHelp, L('на размер файла базы данных (которое без ADS для DBF-файлов составляет 2 Гб)')) AADD(aHelp, L('и ослаблено на количество полей в базе данных (в DBF не более 2035), а в TXT')) AADD(aHelp, L('ограничение на количество полей отсуствует (используется для матриц моделей)')) AADD(aHelp, L(' ')) AADD(aHelp, L('Результаты работы данного режима можно просмотреть в режимах: 2.2 и 2.3.1. ')) AADD(aHelp, L('После выполнения данного режима необходимо выполнить режим 3.5. ')) 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('Помощь по режиму: 3.7.8. (C) Система "ЭЙДОС-X++"') RETURN NIL ************************************************************************************************** ************************************************************************************************** ******** Помощь по режиму 3.7.7 ************************************************************************************************** FUNCTION Help377() aHelp := {} AADD(aHelp, L('Режим: "3.7.7. ГЕНЕРАЦИЯ СОЧЕТАНИЙ КЛАССОВ И ДОКОДИРОВАНИЕ ')) AADD(aHelp, L('ОБУЧАЮЩЕЙ И РАСПОЗНАВАЕМОЙ ВЫБОРКИ" обеспечивает: ')) AADD(aHelp, L('1. Формирование сочетаний классов в соответствии с параметрами, заданными ')) AADD(aHelp, L(' в диалоге: ')) AADD(aHelp, L(' - альтернативные или неальтернативные классы; ')) AADD(aHelp, L(' - количество сочетаний классов в подсистемах классов; ')) AADD(aHelp, L('2. Дополнение классификационных шкал и градаций сочетаниями классов; ')) AADD(aHelp, L('3. Докодирование объектов обучающей и распознаваемой выборки в соответствии')) AADD(aHelp, L(' с дополненными классификационными шкалами и градациями. ')) AADD(aHelp, L(' ')) AADD(aHelp, L('Необходимо учитывать, что в текущей версии системы Эйдос-Х++, работающей ')) AADD(aHelp, L('с Advantage Database Server (ADS) и TXT-файлами, ПОЛНОСТЬЮ СНЯТО ограничение')) AADD(aHelp, L('на размер файла базы данных (которое без ADS для DBF-файлов составляет 2 Гб)')) AADD(aHelp, L('и ослаблено на количество полей в базе данных (в DBF не более 2035), а в TXT')) AADD(aHelp, L('ограничение на количество полей отсуствует (используется для матриц моделей)')) AADD(aHelp, L(' ')) AADD(aHelp, L('Результаты работы данного режима можно просмотреть в режимах: 2.1 и 2.3.1. ')) AADD(aHelp, L('После выполнения данного режима необходимо выполнить режим 3.5. ')) 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('Помощь по режиму: 3.7.7. (C) Система "ЭЙДОС-X++"') RETURN NIL *************************************************************** ********* С(n,m) = n! / (m! (n - m)!) число сочетаний из n по m *************************************************************** FUNCTION Cf(n,m) RETURN(Fact(n)/(Fact(m)*Fact(n-m))) ************************************************************************** ******** С(n,m) = n! / (m! (n - m)!) число сочетаний из n по m для больших ******** чисел без вычисления промежуточных факториалов путем разложения ******** факториалов на простые множители и их сокращений ******** С(n,m) = P(m+1,n) / P(1,n-m), где P(a,b) произведение целых чисел от a до b с шагом 1 ************************************************************************** ******** 1. Найти все простые числа меньшие n ******** 2. Сформировать массив чисел числителя ******** 3. Сформировать массив простых сомножителей числителя ******** 4. Сформировать массив чисел знаменателя ******** 5. Сформировать массив простых сомножителей чисел знаменателя ******** 6. Сформировать массив простых сомножителей числителя, ******** не входящих в массив простых сомножителей знаменателя ******** 7. Перемножить массив уникальных простых сомножителей числителя ************************************************************************** FUNCTION C(n,m) ***** 1. Найти все простые числа меньшие n, включая 1 и допуская n=1 aPrCh := {} // Массив простых чисел IF n = 1 AADD(aPrCh, 1) ELSE FOR j = 2 TO n **** Проверка, является ли j простым числом Flag = .T. FOR i=2 TO j-1 IF j=i*INT(j/i) // Делится ли j на i нацело? Flag = .F. EXIT ENDIF NEXT IF Flag AADD(aPrCh, j) ENDIF NEXT ENDIF * DC_DebugQout( aPrCh ) ***** 2. Сформировать массив чисел числителя aChis := {} IF m = n AADD(aChis, 1) ELSE IF m < n FOR j=m+1 TO n AADD(aChis, j) NEXT ENDIF ENDIF * DC_DebugQout( aChis ) ******* 3. Сформировать массив простых сомножителей числителя aPSChis := {} FOR i=1 TO LEN(aChis) ***** Разложить число на простые множители aPrMn := {} // Массив простых множителей числа: Chislo Chislo = aChis[i] IF Chislo = 1 AADD(aPrMn,1) ELSE Flag = .T. DO WHILE Flag FOR j=1 TO LEN(aPrCh) **** Проверка, делится ли Chislo на простое число из массива aPrCh Flag = .F. IF Chislo = aPrCh[j] * INT(Chislo/aPrCh[j]) AADD(aPrMn,aPrCh[j]) Chislo = Chislo/aPrCh[j] Flag = .T. EXIT ENDIF NEXT ENDDO ENDIF ***** Занести простые множители числа aChis[j] в массив простых сомножителей числителя FOR j=1 TO LEN(aPrMn) AADD(aPSChis, aPrMn[j]) NEXT NEXT * DC_DebugQout( aPSChis ) ***** 4. Сформировать массив чисел знаменателя aZnam := {} IF m = n AADD(aZnam, 1) ELSE IF m < n FOR j=1 TO n - m AADD(aZnam, j) NEXT ENDIF ENDIF * DC_DebugQout( aZnam ) ******* 5. Сформировать массив простых сомножителей чисел знаменателя aPSZnam := {} FOR i=1 TO LEN(aZnam) ***** Разложить число на простые множители aPrMn := {} // Массив простых множителей числа: Chislo Chislo = aZnam[i] IF Chislo = 1 AADD(aPrMn,1) ELSE Flag = .T. DO WHILE Flag FOR j=1 TO LEN(aPrCh) **** Проверка, делится ли Chislo на простое число из массива aPrCh Flag = .F. IF Chislo = aPrCh[j] * INT(Chislo/aPrCh[j]) AADD(aPrMn,aPrCh[j]) Chislo = Chislo/aPrCh[j] Flag = .T. EXIT ENDIF NEXT ENDDO ENDIF *** Занести простые множители числа aZnam[j] в массив простых сомножителей знаменателя FOR j=1 TO LEN(aPrMn) AADD(aPSZnam, aPrMn[j]) NEXT NEXT * DC_DebugQout( aPSZnam ) ******** 6. Сформировать массив простых сомножителей числителя, ******** не входящих в массив простых сомножителей знаменателя aPS:= {} FOR j=1 TO LEN(aPSChis) Pos = ASCAN(aPSZnam, aPSChis[j]) IF Pos = 0 AADD(aPS, aPSChis[j]) ELSE aPSZnam[Pos] = 1 // Сокращение простых сомножителей числителя и знаменателя ENDIF NEXT * DC_DebugQout( aPS ) ******** 7. Перемножить массив уникальных простых сомножителей числителя и знаменателя mMulChis = 1 FOR j=1 TO LEN(aPS) mMulChis = mMulChis * aPS[j] NEXT mMulZnam = 1 FOR j=1 TO LEN(aPSZnam) mMulZnam = mMulZnam * aPSZnam[j] NEXT * DC_DebugQout( mMulChis, mMulZnam, mMulChis/mMulZnam ) RETURN(ALLTRIM(STR(mMulChis/mMulZnam,250))) ***************************************************************************** ******** С(n,m) = n! / (m! (n - m)!) число сочетаний альтернативных признаков ***************************************************************************** FUNCTION Ca(n,m) * ****** Массив с информацией об описательных шкалах для генерации альтернативных сочетаний * SELECT Opis_Sc;N_OpSc=RECCOUNT() * PUBLIC aOpisSc[N_OpSc, 3] * DBGOTOP() * DO WHILE .NOT. EOF() * aOpisSc[Kod_OpSc,1] = N_GrOpSc // Количество градаций в шкале * aOpisSc[Kod_OpSc,2] = KodGr_Min // Код минимальной градации шкалы * aOpisSc[Kod_OpSc,3] = KodGr_Max // Код максимальной градации шкалы * DBSKIP(1) * ENDDO * DC_DebugQout( aOpisSc ) * MsgBox('STOP') Ca = 0 IF m=1 FOR i1=1 TO n Ca = Ca + aOpisSc[i1,1] NEXT ENDIF IF m=2 FOR i1=1 TO n;FOR i2=i1+1 TO n Ca = Ca + aOpisSc[i1,1] * aOpisSc[i2,1] NEXT;NEXT ENDIF IF m=3 FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n Ca = Ca + aOpisSc[i1,1] * aOpisSc[i2,1] * aOpisSc[i3,1] NEXT;NEXT;NEXT ENDIF IF m=4 FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n Ca = Ca + aOpisSc[i1,1] * aOpisSc[i2,1] * aOpisSc[i3,1] * aOpisSc[i4,1] NEXT;NEXT;NEXT;NEXT ENDIF IF m=5 FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n Ca = Ca + aOpisSc[i1,1] * aOpisSc[i2,1] * aOpisSc[i3,1] * aOpisSc[i4,1] * aOpisSc[i5,1] NEXT;NEXT;NEXT;NEXT;NEXT ENDIF IF m=6 FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n Ca = Ca + aOpisSc[i1,1] * aOpisSc[i2,1] * aOpisSc[i3,1] * aOpisSc[i4,1] * aOpisSc[i5,1] * aOpisSc[i6,1] NEXT;NEXT;NEXT;NEXT;NEXT;NEXT ENDIF IF m=7 FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n Ca = Ca + aOpisSc[i1,1] * aOpisSc[i2,1] * aOpisSc[i3,1] * aOpisSc[i4,1] * aOpisSc[i5,1] * aOpisSc[i6,1] * aOpisSc[i7,1] NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT ENDIF IF m=8 FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n Ca = Ca + aOpisSc[i1,1] * aOpisSc[i2,1] * aOpisSc[i3,1] * aOpisSc[i4,1] * aOpisSc[i5,1] * aOpisSc[i6,1] * aOpisSc[i7,1] * aOpisSc[i8,1] NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT ENDIF IF m=9 FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n;FOR i9=i8+1 TO n Ca = Ca + aOpisSc[i1,1] * aOpisSc[i2,1] * aOpisSc[i3,1] * aOpisSc[i4,1] * aOpisSc[i5,1] * aOpisSc[i6,1] * aOpisSc[i7,1] * aOpisSc[i8,1] * aOpisSc[i9,1] NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT ENDIF IF m=10 FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n;FOR i9=i8+1 TO n;FOR i10=i9+1 TO n Ca = Ca + aOpisSc[i1,1] * aOpisSc[i2,1] * aOpisSc[i3,1] * aOpisSc[i4,1] * aOpisSc[i5,1] * aOpisSc[i6,1] * aOpisSc[i7,1] * aOpisSc[i8,1] * aOpisSc[i9,1] * aOpisSc[i10,1] NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT ENDIF IF m=11 FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n;FOR i9=i8+1 TO n;FOR i10=i9+1 TO n;FOR i11=i10+1 TO n Ca = Ca + aOpisSc[i1,1] * aOpisSc[i2,1] * aOpisSc[i3,1] * aOpisSc[i4,1] * aOpisSc[i5,1] * aOpisSc[i6,1] * aOpisSc[i7,1] * aOpisSc[i8,1] * aOpisSc[i9,1] * aOpisSc[i10,1] * aOpisSc[i11,1] NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT ENDIF IF m=12 FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6 =i5+1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n;FOR i9=i8+1 TO n;FOR i10=i9+1 TO n;FOR i11=i10+1 TO n;FOR i12=i11+1 TO n Ca = Ca + aOpisSc[i1,1] * aOpisSc[i2,1] * aOpisSc[i3,1] * aOpisSc[i4,1] * aOpisSc[i5,1] * aOpisSc[i6,1] * aOpisSc[i7,1] * aOpisSc[i8,1] * aOpisSc[i9,1] * aOpisSc[i10,1] * aOpisSc[i11,1] * aOpisSc[i12,1] NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT ENDIF RETURN(ALLTRIM(STR(Ca))) ********* Добавление Class_Sc и сочетаний признаков в БД Gr_ClSc и Classes *FUNCTION AddClScClold(mNSoch, Alt) * IF LEN(anGrCSKod) > 0 * SELECT Class_Sc * DBGOBOTTOM() * mKodClSc = Kod_ClSc * mNameClSc = 'ПОДСИСТЕМЫ ИЗ '+ALLTRIM(STR(mNSoch))+IF(Alt=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' КЛАССОВ' * APPEND BLANK * REPLACE Kod_ClSc WITH ++mKodClSc * REPLACE Name_ClSc WITH mNameClSc * SELECT Gr_ClSc * FOR j=1 TO LEN(anGrCSKod) * APPEND BLANK * REPLACE Kod_ClSc WITH mKodClSc * REPLACE Kod_GrCS WITH anGrCSKod[j] * REPLACE Name_GrCS WITH anGrCSName[j] * NEXT * SELECT Classes * FOR j=1 TO LEN(anGrCSKod) * APPEND BLANK * REPLACE Kod_cls WITH anGrCSKod[j] * REPLACE Name_cls WITH mNameClSc+'-'+anGrCSName[j] * REPLACE Kod_ClSc WITH mKodClSc * REPLACE N_ChrClSc WITH LEN(mNameClSc) * NEXT * ENDIF *RETURN nil ********************************************************************************************* ******** 3.7.7. Генерация сочетаний классов и докодирование обуч.и расп.выб. ######### ******** На основе сочетания классов по 2, 3, N формируются подсистемы классов, ******** которые добавляются в качестве градаций в сочетанные классификационные шкалы ******** и в объекты обучающей и распознаваемой выборки. ******** Все это делать во вновь создаваемом специально для этого приложении ######### ********************************************************************************************* FUNCTION F3_7_7() LOCAL GetList[0], oStatus, lContinue := .T., oProgressm, oDialogm, lCancelled := .F. LOCAL lOk, aSay[30], oSay9, Mess9, Mess97, Mess98, Mess99, oDialog // Массив сообщений отображаемых стадий исполнения (до 30 на экране) Running(.T.) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF ApplChange("3.7.7()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF ***** Создать новое приложение, скопировать все файлы текущего приложения в новое, сделать его текущим N_All = ADIR(M_PathAppl + "*.*") PRIVATE aFileNameAll[N_All] ADIR(M_PathAppl + "*.*", aFileNameAll ) // Имена ВСЕХ файлов в папке текущего приложения ASORT(aFileNameAll) M_NameAppl = ALLTRIM(M_NameAppl)+"-сочетания классов" // Наименование текущего приложения M_NewAppl = ADD_ZAPPL(M_NameAppl) // Создать новое приложение на основе текущего FOR j=1 TO LEN(aFileNameAll) Name_SS = M_PathAppl + aFileNameAll[j] Name_DD = M_NewAppl + aFileNameAll[j] * LB_Warning(L("Источник: "+Name_SS+", приемник: "+Name_DD) COPY FILE (Name_SS) TO (Name_DD) NEXT IF ApplChange("") // Перейти в папку выбранного приложения или выйти из системы LB_Warning(L("Необходимо задать (выбрать) хотя бы одно текущее приложение !!!")) Running(.F.) RETURN NIL ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Class_Sc EXCLUSIVE NEW;N_ClSc = RECCOUNT() // * USE Gr_ClSc EXCLUSIVE NEW;N_GrCS = RECCOUNT() // * USE Attributes EXCLUSIVE NEW;N_GrOS = RECCOUNT() USE Opis_Sc EXCLUSIVE NEW;N_OpSc = RECCOUNT() USE Gr_OpSc EXCLUSIVE NEW;N_GrOS = RECCOUNT() USE Obi_Zag EXCLUSIVE NEW;N_ObiObj = RECCOUNT() USE Obi_Kcl EXCLUSIVE NEW;N_ObiCls = RECCOUNT() USE Obi_Kpr EXCLUSIVE NEW;N_ObiKpr = RECCOUNT() USE Rso_Zag EXCLUSIVE NEW;N_RsoObj = RECCOUNT() USE Rso_Kcl EXCLUSIVE NEW;N_RsoCls = RECCOUNT() USE Rso_Kpr EXCLUSIVE NEW;N_RsoKpr = RECCOUNT() ****** Массив с информацией об описательных шкалах для генерации альтернативных сочетаний PUBLIC aClassSc[N_ClSc, 3] SELECT Class_Sc DBGOTOP() DO WHILE .NOT. EOF() aClassSc[Kod_ClSc,1] = N_GrClSc // Количество градаций в шкале aClassSc[Kod_ClSc,2] = KodGr_Min // Код минимальной градации шкалы aClassSc[Kod_ClSc,3] = KodGr_Max // Код максимальной градации шкалы DBSKIP(1) ENDDO * DC_DebugQout( aClassSc ) * MsgBox('STOP') ******* Сделать 2 суммы: ******* - для неальтернативных классов число сочетаний из n по m ******* - для альтернативных классов оставить только сочетания классов, относящихся к разным шкалам PRIVATE aNCochCl[12,3] // массив параметров генерации сочетанных классов FOR j=1 TO 12;aNCochCl[j,3]=.F.;NEXT * 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 aNCochCl[my,1] = C (N_GrCS, my) // для неальтернативных классов число сочетаний из n по m aNCochCl[my,2] = Cc(N_ClSc, my) // для альтернативных классов оставить только сочетания классов, относящихся к разным шкалам aNCochCl[my,3] = .F. DC_GetProgress(oProgressm, ++nTime, nMax) NEXT aNCochCl[1,3] = .T. aNCochCl[3,3] = .T. DC_GetProgress(oProgressm,nMax,nMax) oDialogm:Destroy() * DC_Impl(oScr) PRIVATE aCochPar[3] // массив параметров генерации сочетанных классов aCochPar[1] := 2 // 1 - признаки неальтернативные, 2 - альтернативные aCochPar[2] := 3375000000 // Максимальное кол-во классов (сейчас в TXT) aCochPar[3] := 1 // 1 - Генерация сочетаний классов и докодирование обучающей выборки, 2 - Докодирование сочетаний классов в распознаваемой выборке ****** Задание параметров докодирования **************************************************************************** mWW = 150 // Ширина окна g = 0 s = 0 IF N_ClSc = 1 aCochPar[1] = 1 ELSE @s++, 0 DCGROUP oGroup1 CAPTION L('Задайте, являются ли градации шкал альтернативными:') SIZE mWW, 3.5 @s++, 2 DCRADIO aCochPar[1] VALUE 1 PROMPT L('НЕТ, т.е. у объекта может быть по нескольку классов каждой шкалы (неальтернативные классы)' ) PARENT oGroup1 @s++, 2 DCRADIO aCochPar[1] VALUE 2 PROMPT L('ДА , т.е. у объекта возможно только по одному классу каждой шкалы (альтернативные классы)') PARENT oGroup1 ENDIF @1.2, 99.8 DCPUSHBUTTON PARENT oGroup1 ; CAPTION L('Помощь') ; SIZE 15.9, 1.7 ; ACTION {||Help377()} g = g + s s = 1 @++g ,0 DCGROUP oGroup2 CAPTION L('Задайте число базовых классов в сочетаниях:') SIZE mWW, nMax+1.8 @s+0.3,4.8 DCSAY L("1") PARENT oGroup2 @s+0.3, 8 DCSAY L("Число сочетаний из")+' ' +ALLTRIM(STR(N_GrCS))+' '+L("классов по 1 =")+' '+aNCochCl[1,1] PARENT oGroup2 @s+0.0, 60 DCSAY CalcSumClBlock(aNCochCl,1,1) SAYSIZE 23 SAYLEFTBOTTOM PARENT oGroup2 @s+0.3, 88 DCSAY L("...Только альтернативные =")+' '+aNCochCl[1,2] PARENT oGroup2 @s+0.0,125 DCSAY CalcSumClBlock(aNCochCl,1,2) SAYSIZE 20 SAYLEFTBOTTOM PARENT oGroup2 FOR i = 2 TO nMax @++s , 2 DCCHECKBOX aNCochCl[i,3] PROMPT ALLTRIM(STR(i,2)) ACTION {||DC_GetRefresh(GetList)} PARENT oGroup2 @s+0.3, 8 DCSAY L("Число сочетаний из")+' '+ALLTRIM(STR(N_GrCS))+' '+L("классов по")+' '+STR(i,2)+" = "+aNCochCl[i,1] ACTION {||DC_GetRefresh(GetList)} PARENT oGroup2 @s+0.0, 60 DCSAY CalcSumClBlock(aNCochCl,i,1) SAYSIZE 23 SAYLEFTBOTTOM PARENT oGroup2 @s+0.3, 88 DCSAY L("...Только альтернативные =")+' '+aNCochCl[i,2] ACTION {||DC_GetRefresh(GetList)} PARENT oGroup2 @s+0.0,125 DCSAY CalcSumClBlock(aNCochCl,i,2) SAYSIZE 20 SAYLEFTBOTTOM PARENT oGroup2 NEXT g = g + s + 1.3 s = 1 @++g, 0 DCGROUP oGroup3 CAPTION L('Задайте, что генерировать:') SIZE mWW, 3.5 @s++, 2 DCRADIO aCochPar[3] VALUE 1 PROMPT L('Генерация сочетаний классов и докодирование обучающей выборки') PARENT oGroup3 @s++, 2 DCRADIO aCochPar[3] VALUE 2 PROMPT L('Докодирование сочетаний классов в распознаваемой выборке' ) PARENT oGroup3 // Это отобразить внизу *********************** g = g + s + 1.0 s = 0 @g , 0 DCGROUP oGroup4 CAPTION L(' ') SIZE mWW, 2.5 * @++s+0.2, 8 DCSAY L("Задайте максимальное суммарное число классов в шкалах:") PARENT oGroup4 * @ s ,57 DCSAY L(" ") GET aCochPar[2] PICTURE "###############" PARENT oGroup4 @++s+0.2, 8 DCSAY L("Максимальное допустимое суммарное число классов в шкалах = ")+ALLTRIM(STR(aCochPar[2],250)) PARENT oGroup4 DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI; TO lExit ; FIT; ADDBUTTONS; OPTIONS GetOptions MODAL ; TITLE L('3.7.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 *************************************************** // Процесс генерации сочетанных классов и докодирования обучающей и распознаваемой выборки *********************** // Отработать ситуацию, когда все aNCochCl[i,3]=.F., где i{2-12}=.F. ******************** s = 0 FOR j=2 TO 12 IF aNCochCl[j,3] ++s ENDIF NEXT IF s = 0 LB_Warning(L('Необходимо задать хотя бы один вид сочетаний классов !!!','3.7.7. Генерация сочетаний классов')) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN nil ENDIF // Организация отображения стадии процесса исполнения mSumCnm = 0 FOR j=2 TO nMax IF aNCochCl[j,3] mSumCnm = mSumCnm + VAL(aNCochCl[j,aCochPar[1]]) ENDIF NEXT ** Превышено максимальное число классов *********************************************** IF mSumCnm > aCochPar[2] aMess := {} AADD(aMess, L('Превышено максимальное допустимое суммарное число классов в шкалах !!!')) AADD(aMess, L('Допустимо: #. Фактически в заданных сочетаниях: $')) aMess[2] = STRTRAN(aMess[2], "#", ALLTRIM(STR(aCochPar[2],250))) aMess[2] = STRTRAN(aMess[2], "$", ALLTRIM(STR(mSumCnm,250))) LB_Warning(aMess, L('3.7.7. Генерация сочетаний классов')) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN nil ENDIF IF aCochPar[3] = 1 Wsego = N_ObiObj FOR j = 2 TO nMax IF aNCochCl[j,3] IF aCochPar[1] = 1 Wsego = Wsego + N_GrCS ENDIF IF aCochPar[1] = 2 Wsego = Wsego + N_ClSc ENDIF ENDIF NEXT ENDIF IF aCochPar[3] = 2 Wsego = N_RsoObj ENDIF s = 1 IF aCochPar[3] = 1 // Отображение стадии исполнения. Будет написано прямо в окне 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 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[1] FONT "10.Helv" // 1 Генерация подсистем классов @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[2] FONT "10.Helv" // 2 Докодирование обучающей выборки ENDIF IF aCochPar[3] = 2 // Отображение стадии исполнения. Будет написано прямо в окне Progress-bar @ 0,0 DCGROUP oGroup1 CAPTION L('Стадии исполнения процесса') FONT "6.Helv" SIZE 105, 2.5 PARENT oTabPage1 @ 4,0 DCGROUP oGroup2 CAPTION L('Прогноз времени исполнения') FONT "6.Helv" SIZE 105, 5.0 PARENT oTabPage2 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[3] FONT "10.Helv" // 3 Докодирование распознаваемой выборки ENDIF 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('3.7.7. Генерация сочетаний классов и докодирование обуч.и расп.выб.'); 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 *********************************************************************************************** IF aCochPar[3] = 1 ******************************************************************************************** aSay[1]:SetCaption(L('1/2: Генерация подсистем классов')) IF aCochPar[1] = 1 // классы неальтернативные *************************************** ******************************************************************************************** SELECT Gr_ClSc mKodGrCS = N_GrCS IF aNCochCl[02,3] anGrCSKod := {};anGrCSName := {} FOR i1=1 TO N_GrCS;FOR i2=i1+1 TO N_GrCS DC_CompleteEvents();IF lCancelled;EXIT;ENDIF AADD(anGrCSKod , ++mKodGrCS) AADD(anGrCSName, ALLTRIM(STR(i1))+','+ALLTRIM(STR(i2))) NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT AddClScCl(2, aCochPar[1]) ENDIF IF aNCochCl[03,3] anGrCSKod := {};anGrCSName := {} FOR i1=1 TO N_GrCS;FOR i2=i1+1 TO N_GrCS;FOR i3=i2+1 TO N_GrCS DC_CompleteEvents();IF lCancelled;EXIT;ENDIF AADD(anGrCSKod , ++mKodGrCS) AADD(anGrCSName, ALLTRIM(STR(i1))+','+ALLTRIM(STR(i2))+','+ALLTRIM(STR(i3))) NEXT;NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT AddClScCl(3, aCochPar[1]) ENDIF IF aNCochCl[04,3] anGrCSKod := {};anGrCSName := {} FOR i1=1 TO N_GrCS;FOR i2=i1+1 TO N_GrCS;FOR i3=i2+1 TO N_GrCS;FOR i4=i3+1 TO N_GrCS DC_CompleteEvents();IF lCancelled;EXIT;ENDIF AADD(anGrCSKod , ++mKodGrCS) AADD(anGrCSName, ALLTRIM(STR(i1))+','+ALLTRIM(STR(i2))+','+ALLTRIM(STR(i3))+','+ALLTRIM(STR(i4))) NEXT;NEXT;NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT AddClScCl(4, aCochPar[1]) ENDIF IF aNCochCl[05,3] anGrCSKod := {};anGrCSName := {} FOR i1=1 TO N_GrCS;FOR i2=i1+1 TO N_GrCS;FOR i3=i2+1 TO N_GrCS;FOR i4=i3+1 TO N_GrCS;FOR i5=i4+1 TO N_GrCS DC_CompleteEvents();IF lCancelled;EXIT;ENDIF AADD(anGrCSKod , ++mKodGrCS) AADD(anGrCSName, ALLTRIM(STR(i1))+','+ALLTRIM(STR(i2))+','+ALLTRIM(STR(i3))+','+ALLTRIM(STR(i4))+','+ALLTRIM(STR(i5))) NEXT;NEXT;NEXT;NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT AddClScCl(5, aCochPar[1]) ENDIF IF aNCochCl[06,3] anGrCSKod := {};anGrCSName := {} FOR i1=1 TO N_GrCS;FOR i2=i1+1 TO N_GrCS;FOR i3=i2+1 TO N_GrCS;FOR i4=i3+1 TO N_GrCS;FOR i5=i4+1 TO N_GrCS;FOR i6=i5+1 TO N_GrCS DC_CompleteEvents();IF lCancelled;EXIT;ENDIF AADD(anGrCSKod , ++mKodGrCS) AADD(anGrCSName, ALLTRIM(STR(i1))+','+ALLTRIM(STR(i2))+','+ALLTRIM(STR(i3))+','+ALLTRIM(STR(i4))+','+ALLTRIM(STR(i5))+','+ALLTRIM(STR(i6))) NEXT;NEXT;NEXT;NEXT;NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT AddClScCl(6, aCochPar[1]) ENDIF IF aNCochCl[07,3] anGrCSKod := {};anGrCSName := {} FOR i1=1 TO N_GrCS;FOR i2=i1+1 TO N_GrCS;FOR i3=i2+1 TO N_GrCS;FOR i4=i3+1 TO N_GrCS;FOR i5=i4+1 TO N_GrCS;FOR i6=i5+1 TO N_GrCS;FOR i7=i6+1 TO N_GrCS DC_CompleteEvents();IF lCancelled;EXIT;ENDIF AADD(anGrCSKod , ++mKodGrCS) AADD(anGrCSName, ALLTRIM(STR(i1))+','+ALLTRIM(STR(i2))+','+ALLTRIM(STR(i3))+','+ALLTRIM(STR(i4))+','+ALLTRIM(STR(i5))+','+ALLTRIM(STR(i6))+','+ALLTRIM(STR(i7))) NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT AddClScCl(7, aCochPar[1]) ENDIF IF aNCochCl[08,3] anGrCSKod := {};anGrCSName := {} FOR i1=1 TO N_GrCS;FOR i2=i1+1 TO N_GrCS;FOR i3=i2+1 TO N_GrCS;FOR i4=i3+1 TO N_GrCS;FOR i5=i4+1 TO N_GrCS;FOR i6=i5+1 TO N_GrCS;FOR i7=i6+1 TO N_GrCS;FOR i8=i7+1 TO N_GrCS DC_CompleteEvents();IF lCancelled;EXIT;ENDIF AADD(anGrCSKod , ++mKodGrCS) AADD(anGrCSName, ALLTRIM(STR(i1))+','+ALLTRIM(STR(i2))+','+ALLTRIM(STR(i3))+','+ALLTRIM(STR(i4))+','+ALLTRIM(STR(i5))+','+ALLTRIM(STR(i6))+','+ALLTRIM(STR(i7))+','+ALLTRIM(STR(i8))) NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT AddClScCl(8, aCochPar[1]) ENDIF IF aNCochCl[09,3] anGrCSKod := {};anGrCSName := {} FOR i1=1 TO N_GrCS;FOR i2=i1+1 TO N_GrCS;FOR i3=i2+1 TO N_GrCS;FOR i4=i3+1 TO N_GrCS;FOR i5=i4+1 TO N_GrCS;FOR i6=i5+1 TO N_GrCS;FOR i7=i6+1 TO N_GrCS;FOR i8=i7+1 TO N_GrCS;FOR i9=i8+1 TO N_GrCS DC_CompleteEvents();IF lCancelled;EXIT;ENDIF AADD(anGrCSKod , ++mKodGrCS) AADD(anGrCSName, ALLTRIM(STR(i1))+','+ALLTRIM(STR(i2))+','+ALLTRIM(STR(i3))+','+ALLTRIM(STR(i4))+','+ALLTRIM(STR(i5))+','+ALLTRIM(STR(i6))+','+ALLTRIM(STR(i7))+','+ALLTRIM(STR(i8))+','+ALLTRIM(STR(i9))) NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT AddClScCl(9, aCochPar[1]) ENDIF IF aNCochCl[10,3] anGrCSKod := {};anGrCSName := {} FOR i1=1 TO N_GrCS;FOR i2=i1+1 TO N_GrCS;FOR i3=i2+1 TO N_GrCS;FOR i4 =i3+1 TO N_GrCS;FOR i5=i4+1 TO N_GrCS;FOR i6=i5+1 TO N_GrCS;FOR i7=i6+1 TO N_GrCS;FOR i8=i7+1 TO N_GrCS;FOR i9=i8+1 TO N_GrCS;FOR i10=i9+1 TO N_GrCS DC_CompleteEvents();IF lCancelled;EXIT;ENDIF AADD(anGrCSKod , ++mKodGrCS) AADD(anGrCSName, ALLTRIM(STR(i1))+','+ALLTRIM(STR(i2))+','+ALLTRIM(STR(i3))+','+ALLTRIM(STR(i4))+','+ALLTRIM(STR(i5))+','+ALLTRIM(STR(i6))+','+ALLTRIM(STR(i7))+','+ALLTRIM(STR(i8))+','+ALLTRIM(STR(i9))+','+ALLTRIM(STR(i10))) NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT AddClScCl(10) ENDIF IF aNCochCl[11,3] anGrCSKod := {};anGrCSName := {} FOR i1=1 TO N_GrCS;FOR i2=i1+1 TO N_GrCS;FOR i3=i2+1 TO N_GrCS;FOR i4 =i3+1 TO N_GrCS;FOR i5 =i4 +1 TO N_GrCS;FOR i6=i5+1 TO N_GrCS;FOR i7=i6+1 TO N_GrCS;FOR i8=i7+1 TO N_GrCS;FOR i9=i8+1 TO N_GrCS;FOR i10=i9+1 TO N_GrCS;FOR i11=i10+1 TO N_GrCS DC_CompleteEvents();IF lCancelled;EXIT;ENDIF AADD(anGrCSKod , ++mKodGrCS) AADD(anGrCSName, ALLTRIM(STR(i1))+','+ALLTRIM(STR(i2))+','+ALLTRIM(STR(i3))+','+ALLTRIM(STR(i4)) +','+ALLTRIM(STR(i5))+','+ALLTRIM(STR(i6))+','+ALLTRIM(STR(i7))+','+ALLTRIM(STR(i8))+','+ALLTRIM(STR(i9))+','+ALLTRIM(STR(i10))+','+ALLTRIM(STR(i11))) NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT AddClScCl(11, aCochPar[1]) ENDIF IF aNCochCl[12,3] anGrCSKod := {};anGrCSName := {} FOR i1=1 TO N_GrCS;FOR i2=i1+1 TO N_GrCS;FOR i3=i2+1 TO N_GrCS;FOR i4 =i3+1 TO N_GrCS;FOR i5 =i4 +1 TO N_GrCS;FOR i6 =i5 +1 TO N_GrCS;FOR i7=i6+1 TO N_GrCS;FOR i8=i7+1 TO N_GrCS;FOR i9=i8+1 TO N_GrCS;FOR i10=i9+1 TO N_GrCS;FOR i11=i10+1 TO N_GrCS;FOR i12=i11+1 TO N_GrCS DC_CompleteEvents();IF lCancelled;EXIT;ENDIF AADD(anGrCSKod , ++mKodGrCS) AADD(anGrCSName, ALLTRIM(STR(i1))+','+ALLTRIM(STR(i2))+','+ALLTRIM(STR(i3))+','+ALLTRIM(STR(i4)) +','+ALLTRIM(STR(i5)) +','+ALLTRIM(STR(i6))+','+ALLTRIM(STR(i7))+','+ALLTRIM(STR(i8))+','+ALLTRIM(STR(i9))+','+ALLTRIM(STR(i10))+','+ALLTRIM(STR(i11))+','+ALLTRIM(STR(i12))) NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT AddClScCl(12, aCochPar[1]) ENDIF ENDIF ************* Прерывание процесса по нажатию 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() ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ************* Прерывание процесса по нажатию Cancel ############################################## aSay[1]:SetCaption(aSay[1]:caption+L(' - Готово ')) ******************************************************************************************** aSay[1]:SetCaption(L('1/2: Генерация подсистем классов')) IF aCochPar[1] = 2 // классы альтернативные ***************************************** ***************************************************************************************** SELECT Gr_ClSc n = N_ClSc mKodGrCS = N_GrCS IF aNCochCl[02,3] anGrCSKod := {};anGrCSName := {} FOR i1=1 TO n;FOR i2=i1+1 TO n FOR j1 =aClassSc[i1, 2] TO aClassSc[i1, 3] FOR j2 =aClassSc[i2, 2] TO aClassSc[i2, 3] DC_CompleteEvents();IF lCancelled;EXIT;ENDIF AADD(anGrCSKod , ++mKodGrCS) AADD(anGrCSName, ALLTRIM(STR(j1))+','+ALLTRIM(STR(j2))) NEXT;NEXT NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT AddClScCl(02, aCochPar[1]) ENDIF IF aNCochCl[03,3] anGrCSKod := {};anGrCSName := {} FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n FOR j1 =aClassSc[i1, 2] TO aClassSc[i1, 3] FOR j2 =aClassSc[i2, 2] TO aClassSc[i2, 3] FOR j3 =aClassSc[i3, 2] TO aClassSc[i3, 3] DC_CompleteEvents();IF lCancelled;EXIT;ENDIF AADD(anGrCSKod , ++mKodGrCS) AADD(anGrCSName, ALLTRIM(STR(j1))+','+ALLTRIM(STR(j2))+','+ALLTRIM(STR(j3))) NEXT;NEXT;NEXT NEXT;NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT AddClScCl(03, aCochPar[1]) ENDIF IF aNCochCl[04,3] anGrCSKod := {};anGrCSName := {} FOR i1=1 TO n;aKodAllOS:= {};FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n FOR j1 =aClassSc[i1, 2] TO aClassSc[i1, 3] FOR j2 =aClassSc[i2, 2] TO aClassSc[i2, 3] FOR j3 =aClassSc[i3, 2] TO aClassSc[i3, 3] FOR j4 =aClassSc[i4, 2] TO aClassSc[i4, 3] DC_CompleteEvents();IF lCancelled;EXIT;ENDIF AADD(anGrCSKod , ++mKodGrCS) AADD(anGrCSName, ALLTRIM(STR(j1))+','+ALLTRIM(STR(j2))+','+ALLTRIM(STR(j3))+','+ALLTRIM(STR(j4))) NEXT;NEXT;NEXT;NEXT NEXT;NEXT;NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT AddClScCl(04, aCochPar[1]) ENDIF IF aNCochCl[05,3] anGrCSKod := {};anGrCSName := {} FOR i1=1 TO n;aKodAllOS:= {};FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n FOR j1 =aClassSc[i1, 2] TO aClassSc[i1, 3] FOR j2 =aClassSc[i2, 2] TO aClassSc[i2, 3] FOR j3 =aClassSc[i3, 2] TO aClassSc[i3, 3] FOR j4 =aClassSc[i4, 2] TO aClassSc[i4, 3] FOR j5 =aClassSc[i5, 2] TO aClassSc[i5, 3] DC_CompleteEvents();IF lCancelled;EXIT;ENDIF AADD(anGrCSKod , ++mKodGrCS) AADD(anGrCSName, ALLTRIM(STR(j1))+','+ALLTRIM(STR(j2))+','+ALLTRIM(STR(j3))+','+ALLTRIM(STR(j4))+','+ALLTRIM(STR(j5))) NEXT;NEXT;NEXT;NEXT;NEXT NEXT;NEXT;NEXT;NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT AddClScCl(05, aCochPar[1]) ENDIF IF aNCochCl[06,3] anGrCSKod := {};anGrCSName := {} FOR i1=1 TO n;aKodAllOS:= {};FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n FOR j1 =aClassSc[i1, 2] TO aClassSc[i1, 3] FOR j2 =aClassSc[i2, 2] TO aClassSc[i2, 3] FOR j3 =aClassSc[i3, 2] TO aClassSc[i3, 3] FOR j4 =aClassSc[i4, 2] TO aClassSc[i4, 3] FOR j5 =aClassSc[i5, 2] TO aClassSc[i5, 3] FOR j6 =aClassSc[i6, 2] TO aClassSc[i6, 3] DC_CompleteEvents();IF lCancelled;EXIT;ENDIF AADD(anGrCSKod , ++mKodGrCS) AADD(anGrCSName, ALLTRIM(STR(j1))+','+ALLTRIM(STR(j2))+','+ALLTRIM(STR(j3))+','+ALLTRIM(STR(j4))+','+ALLTRIM(STR(j5))+','+ALLTRIM(STR(j6))) NEXT;NEXT;NEXT;NEXT;NEXT;NEXT NEXT;NEXT;NEXT;NEXT;NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT AddClScCl(06, aCochPar[1]) ENDIF IF aNCochCl[07,3] anGrCSKod := {};anGrCSName := {} FOR i1=1 TO n;aKodAllOS:= {};FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n FOR j1 =aClassSc[i1, 2] TO aClassSc[i1, 3] FOR j2 =aClassSc[i2, 2] TO aClassSc[i2, 3] FOR j3 =aClassSc[i3, 2] TO aClassSc[i3, 3] FOR j4 =aClassSc[i4, 2] TO aClassSc[i4, 3] FOR j5 =aClassSc[i5, 2] TO aClassSc[i5, 3] FOR j6 =aClassSc[i6, 2] TO aClassSc[i6, 3] FOR j7 =aClassSc[i7, 2] TO aClassSc[i7, 3] DC_CompleteEvents();IF lCancelled;EXIT;ENDIF AADD(anGrCSKod , ++mKodGrCS) AADD(anGrCSName, ALLTRIM(STR(j1))+','+ALLTRIM(STR(j2))+','+ALLTRIM(STR(j3))+','+ALLTRIM(STR(j4))+','+ALLTRIM(STR(j5))+','+ALLTRIM(STR(j6))+','+ALLTRIM(STR(j7))) NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT AddClScCl(07, aCochPar[1]) ENDIF IF aNCochCl[08,3] anGrCSKod := {};anGrCSName := {} FOR i1=1 TO n;aKodAllOS:= {};FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n FOR j1 =aClassSc[i1, 2] TO aClassSc[i1, 3] FOR j2 =aClassSc[i2, 2] TO aClassSc[i2, 3] FOR j3 =aClassSc[i3, 2] TO aClassSc[i3, 3] FOR j4 =aClassSc[i4, 2] TO aClassSc[i4, 3] FOR j5 =aClassSc[i5, 2] TO aClassSc[i5, 3] FOR j6 =aClassSc[i6, 2] TO aClassSc[i6, 3] FOR j7 =aClassSc[i7, 2] TO aClassSc[i7, 3] FOR j8 =aClassSc[i8, 2] TO aClassSc[i8, 3] DC_CompleteEvents();IF lCancelled;EXIT;ENDIF AADD(anGrCSKod , ++mKodGrCS) AADD(anGrCSName, ALLTRIM(STR(j1))+','+ALLTRIM(STR(j2))+','+ALLTRIM(STR(j3))+','+ALLTRIM(STR(j4))+','+ALLTRIM(STR(j5))+','+ALLTRIM(STR(j6))+','+ALLTRIM(STR(j7))+','+ALLTRIM(STR(j8))) NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT AddClScCl(08, aCochPar[1]) ENDIF IF aNCochCl[09,3] anGrCSKod := {};anGrCSName := {} FOR i1=1 TO n;aKodAllOS:= {};FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n;FOR i9=i8+1 TO n FOR j1 =aClassSc[i1, 2] TO aClassSc[i1, 3] FOR j2 =aClassSc[i2, 2] TO aClassSc[i2, 3] FOR j3 =aClassSc[i3, 2] TO aClassSc[i3, 3] FOR j4 =aClassSc[i4, 2] TO aClassSc[i4, 3] FOR j5 =aClassSc[i5, 2] TO aClassSc[i5, 3] FOR j6 =aClassSc[i6, 2] TO aClassSc[i6, 3] FOR j7 =aClassSc[i7, 2] TO aClassSc[i7, 3] FOR j8 =aClassSc[i8, 2] TO aClassSc[i8, 3] FOR j9 =aClassSc[i9, 2] TO aClassSc[i9, 3] DC_CompleteEvents();IF lCancelled;EXIT;ENDIF AADD(anGrCSKod , ++mKodGrCS) AADD(anGrCSName, ALLTRIM(STR(j1))+','+ALLTRIM(STR(j2))+','+ALLTRIM(STR(j3))+','+ALLTRIM(STR(j4))+','+ALLTRIM(STR(j5))+','+ALLTRIM(STR(j6))+','+ALLTRIM(STR(j7))+','+ALLTRIM(STR(j8))+','+ALLTRIM(STR(j9))) NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT AddClScCl(09, aCochPar[1]) ENDIF IF aNCochCl[10,3] anGrCSKod := {};anGrCSName := {} FOR i1=1 TO n;aKodAllOS:= {};FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n;FOR i9=i8+1 TO n;FOR i10=i9+1 TO n FOR j1 =aClassSc[i1, 2] TO aClassSc[i1, 3] FOR j2 =aClassSc[i2, 2] TO aClassSc[i2, 3] FOR j3 =aClassSc[i3, 2] TO aClassSc[i3, 3] FOR j4 =aClassSc[i4, 2] TO aClassSc[i4, 3] FOR j5 =aClassSc[i5, 2] TO aClassSc[i5, 3] FOR j6 =aClassSc[i6, 2] TO aClassSc[i6, 3] FOR j7 =aClassSc[i7, 2] TO aClassSc[i7, 3] FOR j8 =aClassSc[i8, 2] TO aClassSc[i8, 3] FOR j9 =aClassSc[i9, 2] TO aClassSc[i9, 3] FOR j10=aClassSc[i10,2] TO aClassSc[i10,3] DC_CompleteEvents();IF lCancelled;EXIT;ENDIF AADD(anGrCSKod , ++mKodGrCS) AADD(anGrCSName, ALLTRIM(STR(j1))+','+ALLTRIM(STR(j2))+','+ALLTRIM(STR(j3))+','+ALLTRIM(STR(j4))+','+ALLTRIM(STR(j5))+','+ALLTRIM(STR(j6))+','+ALLTRIM(STR(j7))+','+ALLTRIM(STR(j8))+','+ALLTRIM(STR(j9))+','+ALLTRIM(STR(j10))) NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT AddClScCl(10, aCochPar[1]) ENDIF IF aNCochCl[11,3] anGrCSKod := {};anGrCSName := {} FOR i1=1 TO n;aKodAllOS:= {};FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n;FOR i9=i8+1 TO n;FOR i10=i9+1 TO n;FOR i11=i10+1 TO n FOR j1 =aClassSc[i1, 2] TO aClassSc[i1, 3] FOR j2 =aClassSc[i2, 2] TO aClassSc[i2, 3] FOR j3 =aClassSc[i3, 2] TO aClassSc[i3, 3] FOR j4 =aClassSc[i4, 2] TO aClassSc[i4, 3] FOR j5 =aClassSc[i5, 2] TO aClassSc[i5, 3] FOR j6 =aClassSc[i6, 2] TO aClassSc[i6, 3] FOR j7 =aClassSc[i7, 2] TO aClassSc[i7, 3] FOR j8 =aClassSc[i8, 2] TO aClassSc[i8, 3] FOR j9 =aClassSc[i9, 2] TO aClassSc[i9, 3] FOR j10=aClassSc[i10,2] TO aClassSc[i10,3] FOR j11=aClassSc[i11,2] TO aClassSc[i11,3] DC_CompleteEvents();IF lCancelled;EXIT;ENDIF AADD(anGrCSKod , ++mKodGrCS) AADD(anGrCSName, ALLTRIM(STR(j1))+','+ALLTRIM(STR(j2))+','+ALLTRIM(STR(j3))+','+ALLTRIM(STR(j4))+','+ALLTRIM(STR(j5))+','+ALLTRIM(STR(j6))+','+ALLTRIM(STR(j7))+','+ALLTRIM(STR(j8))+','+ALLTRIM(STR(j9))+','+ALLTRIM(STR(j10))+','+ALLTRIM(STR(j11))) NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT AddClScCl(11, aCochPar[1]) ENDIF IF aNCochCl[12,3] anGrCSKod := {};anGrCSName := {} FOR i1=1 TO n;aKodAllOS:= {};FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6 =i5+1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n;FOR i9=i8+1 TO n;FOR i10=i9+1 TO n;FOR i11=i10+1 TO n;FOR i12=i11+1 TO n FOR j1 =aClassSc[i1, 2] TO aClassSc[i1, 3] FOR j2 =aClassSc[i2, 2] TO aClassSc[i2, 3] FOR j3 =aClassSc[i3, 2] TO aClassSc[i3, 3] FOR j4 =aClassSc[i4, 2] TO aClassSc[i4, 3] FOR j5 =aClassSc[i5, 2] TO aClassSc[i5, 3] FOR j6 =aClassSc[i6, 2] TO aClassSc[i6, 3] FOR j7 =aClassSc[i7, 2] TO aClassSc[i7, 3] FOR j8 =aClassSc[i8, 2] TO aClassSc[i8, 3] FOR j9 =aClassSc[i9, 2] TO aClassSc[i9, 3] FOR j10=aClassSc[i10,2] TO aClassSc[i10,3] FOR j11=aClassSc[i11,2] TO aClassSc[i11,3] FOR j12=aClassSc[i12,2] TO aClassSc[i12,3] DC_CompleteEvents();IF lCancelled;EXIT;ENDIF AADD(anGrCSKod , ++mKodGrCS) AADD(anGrCSName, ALLTRIM(STR(j1))+','+ALLTRIM(STR(j2))+','+ALLTRIM(STR(j3))+','+ALLTRIM(STR(j4))+','+ALLTRIM(STR(j5))+','+ALLTRIM(STR(j6))+','+ALLTRIM(STR(j7))+','+ALLTRIM(STR(j8))+','+ALLTRIM(STR(j9))+','+ALLTRIM(STR(j10))+','+ALLTRIM(STR(j11))+','+ALLTRIM(STR(j12))) NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk);NEXT AddClScCl(12, aCochPar[1]) ENDIF ENDIF ************* Прерывание процесса по нажатию 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() ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN( Time_Progress ) ENDIF ************* Прерывание процесса по нажатию Cancel ############################################## aSay[1]:SetCaption(aSay[1]:caption+L(' - Готово ')) ****************************************************************************************** aSay[2]:SetCaption(L('2/2: Докодирование обучающей выборки')) ****** Записать в массив справочник классов SELECT Classes aCls := {} DBGOTOP() DO WHILE .NOT. EOF() AADD(aCls, ALLTRIM(Name_cls)) DBSKIP(1) ENDDO SELECT Obi_Kcl FOR i=1 TO N_ObiObj SET FILTER TO Kod_obj = i aKodCl := {} DBGOTOP() DO WHILE .NOT. EOF() FOR j=1 TO 4 mV = FIELDGET(1+j) IF mV > 0 AADD(aKodCl, mV) ENDIF NEXT DBSKIP(1) ENDDO ***** Формирование кодов сочетаний классов на основе базовых классов объекта ASORT(aKodCl) aKodClNew := {} n = LEN(aKodCl) IF aNCochCl[02,3] FOR i1=1 TO n;FOR i2=i1+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF mNameOpSc = 'ПОДСИСТЕМЫ ИЗ 2'+IF(aCochPar[1]=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' КЛАССОВ' mName = mNameOpSc+'-'+ALLTRIM(STR(aKodCl[i1]))+','+ALLTRIM(STR(aKodCl[i2])) Pos = ASCAN(aCls, mName);IF Pos > 0;AADD(aKodClNew, Pos);ENDIF NEXT;NEXT ENDIF IF aNCochCl[03,3] FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF mNameOpSc = 'ПОДСИСТЕМЫ ИЗ 3'+IF(aCochPar[1]=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' КЛАССОВ' mName = mNameOpSc+'-'+ALLTRIM(STR(aKodCl[i1]))+','+ALLTRIM(STR(aKodCl[i2]))+','+ALLTRIM(STR(aKodCl[i3])) Pos = ASCAN(aCls, mName);IF Pos > 0;AADD(aKodClNew, Pos);ENDIF NEXT;NEXT;NEXT ENDIF IF aNCochCl[04,3] FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF mNameOpSc = 'ПОДСИСТЕМЫ ИЗ 4'+IF(aCochPar[1]=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' КЛАССОВ' mName = mNameOpSc+'-'+ALLTRIM(STR(aKodCl[i1]))+','+ALLTRIM(STR(aKodCl[i2]))+','+ALLTRIM(STR(aKodCl[i3]))+','+ALLTRIM(STR(aKodCl[i4])) Pos = ASCAN(aCls, mName);IF Pos > 0;AADD(aKodClNew, Pos);ENDIF NEXT;NEXT;NEXT;NEXT ENDIF IF aNCochCl[05,3] FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF mNameOpSc = 'ПОДСИСТЕМЫ ИЗ 5'+IF(aCochPar[1]=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' КЛАССОВ' mName = mNameOpSc+'-'+ALLTRIM(STR(aKodCl[i1]))+','+ALLTRIM(STR(aKodCl[i2]))+','+ALLTRIM(STR(aKodCl[i3]))+','+ALLTRIM(STR(aKodCl[i4]))+; ','+ALLTRIM(STR(aKodCl[i5])) Pos = ASCAN(aCls, mName);IF Pos > 0;AADD(aKodClNew, Pos);ENDIF NEXT;NEXT;NEXT;NEXT;NEXT ENDIF IF aNCochCl[06,3] FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF mNameOpSc = 'ПОДСИСТЕМЫ ИЗ 6'+IF(aCochPar[1]=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' КЛАССОВ' mName = mNameOpSc+'-'+ALLTRIM(STR(aKodCl[i1]))+','+ALLTRIM(STR(aKodCl[i2]))+','+ALLTRIM(STR(aKodCl[i3]))+','+ALLTRIM(STR(aKodCl[i4]))+; ','+ALLTRIM(STR(aKodCl[i5]))+','+ALLTRIM(STR(aKodCl[i6])) Pos = ASCAN(aCls, mName);IF Pos > 0;AADD(aKodClNew, Pos);ENDIF NEXT;NEXT;NEXT;NEXT;NEXT;NEXT ENDIF IF aNCochCl[07,3] FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF mNameOpSc = 'ПОДСИСТЕМЫ ИЗ 7'+IF(aCochPar[1]=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' КЛАССОВ' mName = mNameOpSc+'-'+ALLTRIM(STR(aKodCl[i1]))+','+ALLTRIM(STR(aKodCl[i2]))+','+ALLTRIM(STR(aKodCl[i3]))+','+ALLTRIM(STR(aKodCl[i4]))+; ','+ALLTRIM(STR(aKodCl[i5]))+','+ALLTRIM(STR(aKodCl[i6]))+','+ALLTRIM(STR(aKodCl[i7])) Pos = ASCAN(aCls, mName);IF Pos > 0;AADD(aKodClNew, Pos);ENDIF NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT ENDIF IF aNCochCl[08,3] FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF mNameOpSc = 'ПОДСИСТЕМЫ ИЗ 8'+IF(aCochPar[1]=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' КЛАССОВ' mName = mNameOpSc+'-'+ALLTRIM(STR(aKodCl[i1]))+','+ALLTRIM(STR(aKodCl[i2]))+','+ALLTRIM(STR(aKodCl[i3]))+','+ALLTRIM(STR(aKodCl[i4]))+; ','+ALLTRIM(STR(aKodCl[i5]))+','+ALLTRIM(STR(aKodCl[i6]))+','+ALLTRIM(STR(aKodCl[i7]))+','+ALLTRIM(STR(aKodCl[i8])) Pos = ASCAN(aCls, mName);IF Pos > 0;AADD(aKodClNew, Pos);ENDIF NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT ENDIF IF aNCochCl[09,3] FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n;FOR i9=i8+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF mNameOpSc = 'ПОДСИСТЕМЫ ИЗ 9'+IF(aCochPar[1]=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' КЛАССОВ' mName = mNameOpSc+'-'+ALLTRIM(STR(aKodCl[i1]))+','+ALLTRIM(STR(aKodCl[i2]))+','+ALLTRIM(STR(aKodCl[i3]))+','+ALLTRIM(STR(aKodCl[i4]))+; ','+ALLTRIM(STR(aKodCl[i5]))+','+ALLTRIM(STR(aKodCl[i6]))+','+ALLTRIM(STR(aKodCl[i7]))+','+ALLTRIM(STR(aKodCl[i8]))+; ','+ALLTRIM(STR(aKodCl[i9])) Pos = ASCAN(aCls, mName);IF Pos > 0;AADD(aKodClNew, Pos);ENDIF NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT ENDIF IF aNCochCl[10,3] FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n;FOR i9=i8+1 TO n;FOR i10=i9+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF mNameOpSc = 'ПОДСИСТЕМЫ ИЗ 10'+IF(aCochPar[1]=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' КЛАССОВ' mName = mNameOpSc+'-'+ALLTRIM(STR(aKodCl[i1]))+','+ALLTRIM(STR(aKodCl[i2]))+','+ALLTRIM(STR(aKodCl[i3]))+','+ALLTRIM(STR(aKodCl[i4]))+; ','+ALLTRIM(STR(aKodCl[i5]))+','+ALLTRIM(STR(aKodCl[i6]))+','+ALLTRIM(STR(aKodCl[i7]))+','+ALLTRIM(STR(aKodCl[i8]))+; ','+ALLTRIM(STR(aKodCl[i9]))+','+ALLTRIM(STR(aKodCl[i10])) Pos = ASCAN(aCls, mName);IF Pos > 0;AADD(aKodClNew, Pos);ENDIF NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT ENDIF IF aNCochCl[11,3] FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n;FOR i9=i8+1 TO n;FOR i10=i9+1 TO n;FOR i11=i10+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF mNameOpSc = 'ПОДСИСТЕМЫ ИЗ 11'+IF(aCochPar[1]=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' КЛАССОВ' mName = mNameOpSc+'-'+ALLTRIM(STR(aKodCl[i1]))+','+ALLTRIM(STR(aKodCl[i2]))+','+ALLTRIM(STR(aKodCl[i3]))+','+ALLTRIM(STR(aKodCl[i4]))+; ','+ALLTRIM(STR(aKodCl[i5]))+','+ALLTRIM(STR(aKodCl[i6]))+','+ALLTRIM(STR(aKodCl[i7]))+','+ALLTRIM(STR(aKodCl[i8]))+; ','+ALLTRIM(STR(aKodCl[i9]))+','+ALLTRIM(STR(aKodCl[i10]))+','+ALLTRIM(STR(aKodCl[i11])) Pos = ASCAN(aCls, mName);IF Pos > 0;AADD(aKodClNew, Pos);ENDIF NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT ENDIF IF aNCochCl[12,3] FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6 =i5+1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n;FOR i9=i8+1 TO n;FOR i10=i9+1 TO n;FOR i11=i10+1 TO n;FOR i12=i11+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF mNameOpSc = 'ПОДСИСТЕМЫ ИЗ 12'+IF(aCochPar[1]=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' КЛАССОВ' mName = mNameOpSc+'-'+ALLTRIM(STR(aKodCl[i1]))+','+ALLTRIM(STR(aKodCl[i2]))+','+ALLTRIM(STR(aKodCl[i3]))+','+ALLTRIM(STR(aKodCl[i4]))+; ','+ALLTRIM(STR(aKodCl[i5]))+','+ALLTRIM(STR(aKodCl[i6]))+','+ALLTRIM(STR(aKodCl[i7]))+','+ALLTRIM(STR(aKodCl[i8]))+; ','+ALLTRIM(STR(aKodCl[i9]))+','+ALLTRIM(STR(aKodCl[i10]))+','+ALLTRIM(STR(aKodCl[i11]))+','+ALLTRIM(STR(aKodCl[i12])) Pos = ASCAN(aCls, mName);IF Pos > 0;AADD(aKodClNew, Pos);ENDIF NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT ENDIF ************* Прерывание процесса по нажатию 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() ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ************* Прерывание процесса по нажатию Cancel ############################################## ** Дозапись кодов сочетаний классов в БД Obi_Cls IF LEN(aKodClNew) > 0 SELECT Obi_Kcl APPEND BLANK REPLACE Kod_Obj WITH i k=1 FOR j=1 TO LEN(aKodClNew) IF k <= 4 FIELDPUT(1+k++,aKodClNew[j]) ELSE k=1 APPEND BLANK REPLACE Kod_Obj WITH i FIELDPUT(1+k++,aKodClNew[j]) ENDIF NEXT ENDIF lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk) NEXT aSay[2]:SetCaption(aSay[2]:caption+L(' - Готово ')) ENDIF IF aCochPar[3] = 2 ****************************************************************************************** aSay[3]:SetCaption(L('1/1: Докодирование сочетаний классов в распознаваемой выборке')) ****** Записать в массив справочник классов SELECT Classes aCls := {} DBGOTOP() DO WHILE .NOT. EOF() AADD(aCls, ALLTRIM(Name_cls)) DBSKIP(1) ENDDO SELECT Rso_Kcl FOR i=1 TO N_RsoObj SET FILTER TO Kod_obj = i aKodCl := {} DBGOTOP() DO WHILE .NOT. EOF() FOR j=1 TO 4 mV = FIELDGET(1+j) IF mV > 0 AADD(aKodCl, mV) ENDIF NEXT DBSKIP(1) ENDDO ***** Формирование кодов сочетаний классов на основе базовых классов объекта ASORT(aKodCl) aKodClNew := {} n = LEN(aKodCl) IF aNCochCl[02,3] FOR i1=1 TO n;FOR i2=i1+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF mNameOpSc = 'ПОДСИСТЕМЫ ИЗ 2'+IF(aCochPar[1]=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' КЛАССОВ' mName = mNameOpSc+'-'+ALLTRIM(STR(aKodCl[i1]))+','+ALLTRIM(STR(aKodCl[i2])) Pos = ASCAN(aCls, mName);IF Pos > 0;AADD(aKodClNew, Pos);ENDIF NEXT;NEXT ENDIF IF aNCochCl[03,3] FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF mNameOpSc = 'ПОДСИСТЕМЫ ИЗ 3'+IF(aCochPar[1]=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' КЛАССОВ' mName = mNameOpSc+'-'+ALLTRIM(STR(aKodCl[i1]))+','+ALLTRIM(STR(aKodCl[i2]))+','+ALLTRIM(STR(aKodCl[i3])) Pos = ASCAN(aCls, mName);IF Pos > 0;AADD(aKodClNew, Pos);ENDIF NEXT;NEXT;NEXT ENDIF IF aNCochCl[04,3] FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF mNameOpSc = 'ПОДСИСТЕМЫ ИЗ 4'+IF(aCochPar[1]=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' КЛАССОВ' mName = mNameOpSc+'-'+ALLTRIM(STR(aKodCl[i1]))+','+ALLTRIM(STR(aKodCl[i2]))+','+ALLTRIM(STR(aKodCl[i3]))+','+ALLTRIM(STR(aKodCl[i4])) Pos = ASCAN(aCls, mName);IF Pos > 0;AADD(aKodClNew, Pos);ENDIF NEXT;NEXT;NEXT;NEXT ENDIF IF aNCochCl[05,3] FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF mNameOpSc = 'ПОДСИСТЕМЫ ИЗ 5'+IF(aCochPar[1]=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' КЛАССОВ' mName = mNameOpSc+'-'+ALLTRIM(STR(aKodCl[i1]))+','+ALLTRIM(STR(aKodCl[i2]))+','+ALLTRIM(STR(aKodCl[i3]))+','+ALLTRIM(STR(aKodCl[i4]))+; ','+ALLTRIM(STR(aKodCl[i5])) Pos = ASCAN(aCls, mName);IF Pos > 0;AADD(aKodClNew, Pos);ENDIF NEXT;NEXT;NEXT;NEXT;NEXT ENDIF IF aNCochCl[06,3] FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF mNameOpSc = 'ПОДСИСТЕМЫ ИЗ 6'+IF(aCochPar[1]=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' КЛАССОВ' mName = mNameOpSc+'-'+ALLTRIM(STR(aKodCl[i1]))+','+ALLTRIM(STR(aKodCl[i2]))+','+ALLTRIM(STR(aKodCl[i3]))+','+ALLTRIM(STR(aKodCl[i4]))+; ','+ALLTRIM(STR(aKodCl[i5]))+','+ALLTRIM(STR(aKodCl[i6])) Pos = ASCAN(aCls, mName);IF Pos > 0;AADD(aKodClNew, Pos);ENDIF NEXT;NEXT;NEXT;NEXT;NEXT;NEXT ENDIF IF aNCochCl[07,3] FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF mNameOpSc = 'ПОДСИСТЕМЫ ИЗ 7'+IF(aCochPar[1]=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' КЛАССОВ' mName = mNameOpSc+'-'+ALLTRIM(STR(aKodCl[i1]))+','+ALLTRIM(STR(aKodCl[i2]))+','+ALLTRIM(STR(aKodCl[i3]))+','+ALLTRIM(STR(aKodCl[i4]))+; ','+ALLTRIM(STR(aKodCl[i5]))+','+ALLTRIM(STR(aKodCl[i6]))+','+ALLTRIM(STR(aKodCl[i7])) Pos = ASCAN(aCls, mName);IF Pos > 0;AADD(aKodClNew, Pos);ENDIF NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT ENDIF IF aNCochCl[08,3] FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF mNameOpSc = 'ПОДСИСТЕМЫ ИЗ 8'+IF(aCochPar[1]=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' КЛАССОВ' mName = mNameOpSc+'-'+ALLTRIM(STR(aKodCl[i1]))+','+ALLTRIM(STR(aKodCl[i2]))+','+ALLTRIM(STR(aKodCl[i3]))+','+ALLTRIM(STR(aKodCl[i4]))+; ','+ALLTRIM(STR(aKodCl[i5]))+','+ALLTRIM(STR(aKodCl[i6]))+','+ALLTRIM(STR(aKodCl[i7]))+','+ALLTRIM(STR(aKodCl[i8])) Pos = ASCAN(aCls, mName);IF Pos > 0;AADD(aKodClNew, Pos);ENDIF NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT ENDIF IF aNCochCl[09,3] FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n;FOR i9=i8+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF mNameOpSc = 'ПОДСИСТЕМЫ ИЗ 9'+IF(aCochPar[1]=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' КЛАССОВ' mName = mNameOpSc+'-'+ALLTRIM(STR(aKodCl[i1]))+','+ALLTRIM(STR(aKodCl[i2]))+','+ALLTRIM(STR(aKodCl[i3]))+','+ALLTRIM(STR(aKodCl[i4]))+; ','+ALLTRIM(STR(aKodCl[i5]))+','+ALLTRIM(STR(aKodCl[i6]))+','+ALLTRIM(STR(aKodCl[i7]))+','+ALLTRIM(STR(aKodCl[i8]))+; ','+ALLTRIM(STR(aKodCl[i9])) Pos = ASCAN(aCls, mName);IF Pos > 0;AADD(aKodClNew, Pos);ENDIF NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT ENDIF IF aNCochCl[10,3] FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n;FOR i9=i8+1 TO n;FOR i10=i9+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF mNameOpSc = 'ПОДСИСТЕМЫ ИЗ 10'+IF(aCochPar[1]=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' КЛАССОВ' mName = mNameOpSc+'-'+ALLTRIM(STR(aKodCl[i1]))+','+ALLTRIM(STR(aKodCl[i2]))+','+ALLTRIM(STR(aKodCl[i3]))+','+ALLTRIM(STR(aKodCl[i4]))+; ','+ALLTRIM(STR(aKodCl[i5]))+','+ALLTRIM(STR(aKodCl[i6]))+','+ALLTRIM(STR(aKodCl[i7]))+','+ALLTRIM(STR(aKodCl[i8]))+; ','+ALLTRIM(STR(aKodCl[i9]))+','+ALLTRIM(STR(aKodCl[i10])) Pos = ASCAN(aCls, mName);IF Pos > 0;AADD(aKodClNew, Pos);ENDIF NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT ENDIF IF aNCochCl[11,3] FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n;FOR i9=i8+1 TO n;FOR i10=i9+1 TO n;FOR i11=i10+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF mNameOpSc = 'ПОДСИСТЕМЫ ИЗ 11'+IF(aCochPar[1]=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' КЛАССОВ' mName = mNameOpSc+'-'+ALLTRIM(STR(aKodCl[i1]))+','+ALLTRIM(STR(aKodCl[i2]))+','+ALLTRIM(STR(aKodCl[i3]))+','+ALLTRIM(STR(aKodCl[i4]))+; ','+ALLTRIM(STR(aKodCl[i5]))+','+ALLTRIM(STR(aKodCl[i6]))+','+ALLTRIM(STR(aKodCl[i7]))+','+ALLTRIM(STR(aKodCl[i8]))+; ','+ALLTRIM(STR(aKodCl[i9]))+','+ALLTRIM(STR(aKodCl[i10]))+','+ALLTRIM(STR(aKodCl[i11])) Pos = ASCAN(aCls, mName);IF Pos > 0;AADD(aKodClNew, Pos);ENDIF NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT ENDIF IF aNCochCl[12,3] FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6 =i5+1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n;FOR i9=i8+1 TO n;FOR i10=i9+1 TO n;FOR i11=i10+1 TO n;FOR i12=i11+1 TO n DC_CompleteEvents();IF lCancelled;EXIT;ENDIF mNameOpSc = 'ПОДСИСТЕМЫ ИЗ 12'+IF(aCochPar[1]=1," НЕАЛЬТЕРНАТИВНЫХ"," АЛЬТЕРНАТИВНЫХ")+' КЛАССОВ' mName = mNameOpSc+'-'+ALLTRIM(STR(aKodCl[i1]))+','+ALLTRIM(STR(aKodCl[i2]))+','+ALLTRIM(STR(aKodCl[i3]))+','+ALLTRIM(STR(aKodCl[i4]))+; ','+ALLTRIM(STR(aKodCl[i5]))+','+ALLTRIM(STR(aKodCl[i6]))+','+ALLTRIM(STR(aKodCl[i7]))+','+ALLTRIM(STR(aKodCl[i8]))+; ','+ALLTRIM(STR(aKodCl[i9]))+','+ALLTRIM(STR(aKodCl[i10]))+','+ALLTRIM(STR(aKodCl[i11]))+','+ALLTRIM(STR(aKodCl[i12])) Pos = ASCAN(aCls, mName);IF Pos > 0;AADD(aKodClNew, Pos);ENDIF NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT ENDIF ************* Прерывание процесса по нажатию 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() ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ************* Прерывание процесса по нажатию Cancel ############################################## ** Дозапись кодов сочетаний классов в БД Rso_Kcl IF LEN(aKodClNew) > 0 SELECT Rso_Kcl APPEND BLANK REPLACE Kod_Obj WITH i k=1 FOR j=1 TO LEN(aKodClNew) IF k <= 4 FIELDPUT(1+k++,aKodClNew[j]) ELSE k=1 APPEND BLANK REPLACE Kod_Obj WITH i FIELDPUT(1+k++,aKodClNew[j]) ENDIF NEXT ENDIF lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk) NEXT aSay[3]:SetCaption(aSay[3]:caption+L(' - Готово ')) ENDIF ****************************************************************************************** ******** Сформировать в БД Class_Sc информацию по числу классов и начальным и конечным кодам классов в класс.шкале ClSc_Ngr() ******** Сформировать в БД Opis_Sc информацию по числу признаков и начальным и конечным кодам признаков в опис.шкале OpSc_Ngr() // Вывод информации о завершении процесса исполнения IF aCochPar[3] = 1 Mess = L("ГЕНЕРАЦИЯ СОЧЕТАНИЙ КЛАССОВ И ДОКОДИРОВАНИЕ ОБУЧАЮЩЕЙ ВЫБОРКИ ЗАВЕРШЕНО !!!") ENDIF IF aCochPar[3] = 2 Mess = L("ДОКОДИРОВАНИЕ СОЧЕТАНИЙ КЛАССОВ В РАСПОЗНАВАЕМОЙ ВЫБОРКЕ ЗАВЕРШЕНО !!!") ENDIF 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() ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN nil ******** Добавление Class_Sc и сочетаний признаков в БД Gr_ClSc и Classes FUNCTION AddClScCl(mNSoch, Alt) IF LEN(anGrCSKod) > 0 SELECT Class_Sc DBGOBOTTOM() mKodClSc = Kod_ClSc mNameClSc = L('ПОДСИСТЕМЫ ИЗ ')+ALLTRIM(STR(mNSoch))+IF(Alt=1,L(" НЕАЛЬТЕРНАТИВНЫХ"),L(" АЛЬТЕРНАТИВНЫХ"))+L(' КЛАССОВ') APPEND BLANK REPLACE Kod_ClSc WITH ++mKodClSc REPLACE Name_ClSc WITH mNameClSc SELECT Gr_ClSc FOR j=1 TO LEN(anGrCSKod) APPEND BLANK REPLACE Kod_ClSc WITH mKodClSc REPLACE Kod_GrCS WITH anGrCSKod[j] REPLACE Name_GrCS WITH anGrCSName[j] NEXT SELECT Classes FOR j=1 TO LEN(anGrCSKod) APPEND BLANK REPLACE Kod_cls WITH anGrCSKod[j] REPLACE Name_cls WITH mNameClSc+'-'+anGrCSName[j] REPLACE Kod_ClSc WITH mKodClSc REPLACE N_ChrClSc WITH LEN(mNameClSc) NEXT ENDIF RETURN nil ***************************************************************************** ******** С(n,m) = n! / (m! (n - m)!) число сочетаний альтернативных классов ***************************************************************************** FUNCTION Cc(n,m) Cc = 0 IF m=1 FOR i1=1 TO n Cc = Cc + aClassSc[i1,1] NEXT ENDIF IF m=2 FOR i1=1 TO n;FOR i2=i1+1 TO n Cc = Cc + aClassSc[i1,1] * aClassSc[i2,1] NEXT;NEXT ENDIF IF m=3 FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n Cc = Cc + aClassSc[i1,1] * aClassSc[i2,1] * aClassSc[i3,1] NEXT;NEXT;NEXT ENDIF IF m=4 FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n Cc = Cc + aClassSc[i1,1] * aClassSc[i2,1] * aClassSc[i3,1] * aClassSc[i4,1] NEXT;NEXT;NEXT;NEXT ENDIF IF m=5 FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n Cc = Cc + aClassSc[i1,1] * aClassSc[i2,1] * aClassSc[i3,1] * aClassSc[i4,1] * aClassSc[i5,1] NEXT;NEXT;NEXT;NEXT;NEXT ENDIF IF m=6 FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n Cc = Cc + aClassSc[i1,1] * aClassSc[i2,1] * aClassSc[i3,1] * aClassSc[i4,1] * aClassSc[i5,1] * aClassSc[i6,1] NEXT;NEXT;NEXT;NEXT;NEXT;NEXT ENDIF IF m=7 FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n Cc = Cc + aClassSc[i1,1] * aClassSc[i2,1] * aClassSc[i3,1] * aClassSc[i4,1] * aClassSc[i5,1] * aClassSc[i6,1] * aClassSc[i7,1] NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT ENDIF IF m=8 FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n Cc = Cc + aClassSc[i1,1] * aClassSc[i2,1] * aClassSc[i3,1] * aClassSc[i4,1] * aClassSc[i5,1] * aClassSc[i6,1] * aClassSc[i7,1] * aClassSc[i8,1] NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT ENDIF IF m=9 FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n;FOR i9=i8+1 TO n Cc = Cc + aClassSc[i1,1] * aClassSc[i2,1] * aClassSc[i3,1] * aClassSc[i4,1] * aClassSc[i5,1] * aClassSc[i6,1] * aClassSc[i7,1] * aClassSc[i8,1] * aClassSc[i9,1] NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT ENDIF IF m=10 FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n;FOR i9=i8+1 TO n;FOR i10=i9+1 TO n Cc = Cc + aClassSc[i1,1] * aClassSc[i2,1] * aClassSc[i3,1] * aClassSc[i4,1] * aClassSc[i5,1] * aClassSc[i6,1] * aClassSc[i7,1] * aClassSc[i8,1] * aClassSc[i9,1] * aClassSc[i10,1] NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT ENDIF IF m=11 FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6=i5+1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n;FOR i9=i8+1 TO n;FOR i10=i9+1 TO n;FOR i11=i10+1 TO n Cc = Cc + aClassSc[i1,1] * aClassSc[i2,1] * aClassSc[i3,1] * aClassSc[i4,1] * aClassSc[i5,1] * aClassSc[i6,1] * aClassSc[i7,1] * aClassSc[i8,1] * aClassSc[i9,1] * aClassSc[i10,1] * aClassSc[i11,1] NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT ENDIF IF m=12 FOR i1=1 TO n;FOR i2=i1+1 TO n;FOR i3=i2+1 TO n;FOR i4=i3+1 TO n;FOR i5=i4+1 TO n;FOR i6 =i5+1 TO n;FOR i7=i6+1 TO n;FOR i8=i7+1 TO n;FOR i9=i8+1 TO n;FOR i10=i9+1 TO n;FOR i11=i10+1 TO n;FOR i12=i11+1 TO n Cc = Cc + aClassSc[i1,1] * aClassSc[i2,1] * aClassSc[i3,1] * aClassSc[i4,1] * aClassSc[i5,1] * aClassSc[i6,1] * aClassSc[i7,1] * aClassSc[i8,1] * aClassSc[i9,1] * aClassSc[i10,1] * aClassSc[i11,1] * aClassSc[i12,1] NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT;NEXT ENDIF RETURN(ALLTRIM(STR(Cc))) **************************************************************************************************************** ******* 5.4. Конвер. результатов расп.для SigmaPlot ########## ******* Ковертирует результаты распознавания, т.е. БД Rasp.dbf в параметрическую форму в стиле: "X, Y, Z", ******* удобную для картографической визуализации в системе SigmaPlot. Это возможно, если предварительно ******* были выполнены режимы 3.7.7 и 3.4(3.5.) и 4.1.2.' ########## **************************************************************************************************************** FUNCTION F5_4() LOCAL GetList[0], oStatus, lContinue := .T., oProgressm, oDialogm LOCAL lOk, aSay[30], oSay9, Mess9, Mess97, Mess98, Mess99, oDialog // Массив сообщений отображаемых стадий исполнения (до 30 на экране) Running(.T.) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF IF ApplChange("5.4()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF IF .NOT. FILE("Classes.dbf") // БД градаций класс.шкал + градаций класс.шкал: Classes.dbf LB_Warning(L('Перед выполнением режима необходимо сформировать справочник классификационных шкал и градаций'),L('5.4. Конвертер результатов распознавания для системы SigmaPlot')) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF IF .NOT. FILE("Rasp.dbf") // БД результатов распознавания: Rasp.dbf LB_Warning(L('Перед выполнением режима необходимо выполнить распознавание (3.5 или 4.1.2)'),L('5.4. Конвертер результатов распознавания для системы SigmaPlot')) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** 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") * aSoftInt[17] // Количество градаций в числовой классификационной шкале * aSoftInt[18] // Количество градаций в числовой описательной шкале ELSE LB_Warning(L('Перед выполнением данного режима необходимо выполнить режим 2.3.2.2.'),L('5.4. Конвертер результатов распознавания для системы SigmaPlot')) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ****************************************************************************************************** * 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) ****************************************************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Rso_Zag EXCLUSIVE NEW;N_Obj = RECCOUNT() // Кол-во объектов расп.выборки IF N_Cls > 3375000000 Flag_map = .F. aMess := {} AADD(aMess, L('Матрицы для визуализации результатов распознавания не могут быть созданы,')) AADD(aMess, L('так как в модели # классов, что более 3375000000 !')) aMess[2] = STRTRAN(aMess, "#", ALLTRIM(STR(N_Cls))) LB_Warning(aMess, L('Создание матриц визуализации результатов распознавания')) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF nMax = N_Cls + N_Obj Mess = L('Режим 5.4. Подготовка массивов для расчетов') @ 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) SELECT Rso_Zag PRIVATE aNameObj[N_Obj] mMLNameObj = -9999999 DBGOTOP() DO WHILE .NOT. EOF() aNameObj[Kod_obj] = ALLTRIM(Name_obj) mMLNameObj = MAX(mMLNameObj, LEN(aNameObj[Kod_obj])) DC_GetProgress(oProgressm, ++nTime, nMax) DBSKIP(1) ENDDO SELECT Classes PRIVATE aKodCls [N_Cls] PRIVATE aNameCls [N_Cls] PRIVATE aMinGrInt[N_Cls] PRIVATE aMaxGrInt[N_Cls] PRIVATE aAvrGrInt[N_Cls] N_RXYZ = 0 // Число сочетаний классов по 3 mMLNameCls = -999999 DBGOTOP() DO WHILE .NOT. EOF() M_KodCls = Kod_cls aKodCls [M_KodCls] = Kod_ClSc aNameCls [M_KodCls] = DelZeroNameGr(Name_cls) mMLNameCls = MAX(mMLNameCls, LEN(aNameCls[M_KodCls])) aMinGrInt[M_KodCls] = Min_GrInt aMaxGrInt[M_KodCls] = Max_GrInt aAvrGrInt[M_KodCls] = Avr_GrInt IF Perc_fiz > 0 IF AT("ПОДСИСТЕМЫ ИЗ 3 АЛЬТЕРНАТИВНЫХ КЛАССОВ",aNameCls[M_KodCls])>0 .OR. AT("ПОДСИСТЕМЫ ИЗ 3 НЕАЛЬТЕРНАТИВНЫХ КЛАССОВ",aNameCls[M_KodCls])>0 N_RXYZ++ ENDIF ENDIF DC_GetProgress(oProgressm, ++nTime, nMax) DBSKIP(1) ENDDO *MsgBox(STR(N_RXYZ)) aSaveGenDbf := DC_DataSave() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций aStructure := { { "Kod_obj" , "N", 15, 0 }, ; { "Name_obj" , "C",mMLNameObj, 0 }, ; { "Kod_cls" , "N", 15, 0 }, ; { "Name_cls" , "C",mMLNameCls, 0 }, ; { "Kod_X" , "N", 15, 0 }, ; { "Name_X" , "C",mMLNameCls, 0 }, ; { "MinGrIntX", "N", 19, 7 }, ; { "MaxGrIntX", "N", 19, 7 }, ; { "AvrGrIntX", "N", 19, 7 }, ; { "Kod_Y" , "N", 15, 0 }, ; { "Name_Y" , "C",mMLNameCls, 0 }, ; { "MinGrIntY", "N", 19, 7 }, ; { "MaxGrIntY", "N", 19, 7 }, ; { "AvrGrIntY", "N", 19, 7 }, ; { "Kod_Z" , "N", 15, 0 }, ; { "Name_Z" , "C",mMLNameCls, 0 }, ; { "MinGrIntZ", "N", 19, 7 }, ; { "MaxGrIntZ", "N", 19, 7 }, ; { "AvrGrIntZ", "N", 19, 7 }, ; { "Korr" , "N", 19, 7 }, ; { "Sum_inf" , "N", 19, 7 }, ; { "Fakt" , "C", 1, 0 } } DbCreate( "Rasp_XYZ.dbf", aStructure ) // Исходная база данных для картографической визуализации результатов распознавания **** "Что будет" в стиле X,Y,Z для СигмаПлот DbCreate( "RspXYZpK.dbf", aStructure ) // Для каждой зоны X,Y дается значение Z с МАКСИМАЛЬНЫМ знач.интегр.критерия сходства - Korr DbCreate( "RspXYZpI.dbf", aStructure ) // Для каждой зоны X,Y дается значение Z с МАКСИМАЛЬНЫМ знач.интегр.критерия сходства - Sum_Inf **** "Чего не будет" в стиле X,Y,Z для СигмаПлот DbCreate( "RspXYZnK.dbf", aStructure ) // Для каждой зоны X,Y дается значение Z с МИНИМАЛЬНЫМ знач.интегр.критерия сходства - Korr DbCreate( "RspXYZnI.dbf", aStructure ) // Для каждой зоны X,Y дается значение Z с МИНИМАЛЬНЫМ знач.интегр.критерия сходства - Sum_Inf DC_GetProgress(oProgressm,nMax,nMax) oDialogm:Destroy() *DC_Impl(oScr) ******************************************************************************************************* CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Class_Sc EXCLUSIVE NEW;N_ClSc = RECCOUNT() USE Rso_Zag EXCLUSIVE NEW;N_Obj = RECCOUNT() // Кол-во объектов расп.выборки USE Rasp EXCLUSIVE NEW;N_Rsp = RECCOUNT() USE Rasp_XYZ EXCLUSIVE NEW USE RspXYZpK EXCLUSIVE NEW USE RspXYZpI EXCLUSIVE NEW USE RspXYZnK EXCLUSIVE NEW USE RspXYZnI EXCLUSIVE NEW ****************************************************************************************************** Wsego = 1 + N_Obj * N_RXYZ * 5 + 8 s = 1 // Отображение стадии исполнения. Будет написано прямо в окне 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 @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 1] FONT "10.Helv" // 1/7: Создается исходная БД для картографической визуализации результатов распознавания @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 2] FONT "10.Helv" // 2/7: Формирование матриц картографической визуализации результатов распознавания @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 3] FONT "10.Helv" // 3/7: Для каждой зоны карты определяется наиболее сходный класс (инт.крит.-корреляция) @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 4] FONT "10.Helv" // 4/7: Для каждой зоны карты определяется наиболее сходный класс (инт.крит.-сумма инф.) @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 5] FONT "10.Helv" // 5/7: Для каждой зоны карты определяется наиболее отличающийся класс (инт.крит.-корреляция) @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 6] FONT "10.Helv" // 6/7: Для каждой зоны карты определяется наиболее отличающийся класс (инт.крит.-сумма инф.) @s++,1 DCSAY L(" ") SAYSIZE 100 SAYOBJECT aSay[ 7] FONT "10.Helv" // 7/7: Преобразование матриц результатов распознавания в новый стандарт баз данных 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 {||lOk:=.T.} OBJECT oButton ; SIZE 7,1.5 DCREAD GUI ; TITLE L('5.4. Подготовка картографической визуализации результатов распознавания'); 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('1/7: Создается исходная БД для картографической визуализации результатов распознавания')) SELECT Rasp DBGOTOP() DO WHILE .NOT. EOF() M_KodCls = Kod_cls IF AT("ПОДСИСТЕМЫ ИЗ 3 АЛЬТЕРНАТИВНЫХ КЛАССОВ",aNameCls[M_KodCls])>0 .OR. AT("ПОДСИСТЕМЫ ИЗ 3 НЕАЛЬТЕРНАТИВНЫХ КЛАССОВ",aNameCls[M_KodCls])>0 M_KodObj = Kod_obj M_KodCls = Kod_cls M_Korr = Korr M_SumInf = Sum_inf M_Fakt = Fakt SELECT Rasp_XYZ APPEND BLANK REPLACE Kod_obj WITH M_KodObj REPLACE Name_obj WITH aNameObj[M_KodObj] REPLACE Kod_cls WITH M_KodCls REPLACE Name_cls WITH DelZeroNameGr(aNameCls[M_KodCls]) aNameCls[M_KodCls] = Name_cls Pos = AT('-', aNameCls[M_KodCls]) M_NameCls = SUBSTR(aNameCls[M_KodCls], Pos+1, LEN(aNameCls[M_KodCls])-Pos) * MsgBox(M_NameCls) M_Kod = VAL(TOKEN(M_NameCls,",",1)) REPLACE Kod_X WITH M_Kod REPLACE Name_X WITH DelZeroNameGr(aNameCls[M_Kod]) REPLACE MinGrIntX WITH aMinGrInt[M_Kod] REPLACE MaxGrIntX WITH aMaxGrInt[M_Kod] REPLACE AvrGrIntX WITH aAvrGrInt[M_Kod] M_Kod = VAL(TOKEN(M_NameCls,",",2)) REPLACE Kod_Y WITH M_Kod REPLACE Name_Y WITH DelZeroNameGr(aNameCls[M_Kod]) REPLACE MinGrIntY WITH aMinGrInt[M_Kod] REPLACE MaxGrIntY WITH aMaxGrInt[M_Kod] REPLACE AvrGrIntY WITH aAvrGrInt[M_Kod] M_Kod = VAL(TOKEN(M_NameCls,",",3)) REPLACE Kod_Z WITH M_Kod REPLACE Name_Z WITH DelZeroNameGr(aNameCls[M_Kod]) REPLACE MinGrIntZ WITH aMinGrInt[M_Kod] REPLACE MaxGrIntZ WITH aMaxGrInt[M_Kod] REPLACE AvrGrIntZ WITH aAvrGrInt[M_Kod] REPLACE Korr WITH M_Korr REPLACE Sum_inf WITH M_SumInf REPLACE Fakt WITH M_Fakt lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk) SELECT Rasp ENDIF DBSKIP(1) ENDDO aSay[1]:SetCaption(aSay[1]:caption+L(' - Готово ')) aSay[2]:SetCaption(L('2/7: Формирование матриц картографической визуализации результатов распознавания')) ***** Создание матриц для визуализации результатов распознавания ************************************** ***** вертикальная шапка - X, горизонтальная - Y, зачения полей: ***** 1. Для каждого сочетания X,Y вывести: ***** Z, для которого МАКСИМАЛЬНОЕ значение интегрального критерия: (что будет) ***** - Korr ***** - Sum_inf ***** само значение интегрального критерия: ***** - Korr ***** - Sum_inf ***** 2. Для каждого сочетания X,Y вывести: ***** Z, для которого МИНИМАЛЬНОЕ значение интегрального критерия: (чего не будет) ***** - Korr ***** - Sum_inf ***** само значение интегрального критерия: ***** - Korr ***** - Sum_inf *************** Создание матриц для визуализации результатов распознавания SELECT Rasp_XYZ SET FILTER TO;SET ORDER TO INDEX ON STR(Kod_X,15) TO XYZ_X UNIQUE aX := {} DBGOTOP() DO WHILE .NOT. EOF() AADD(aX, Kod_X) DBSKIP(1) ENDDO SET FILTER TO;SET ORDER TO INDEX ON STR(Kod_Y,15) TO XYZ_Y UNIQUE aY := {} DBGOTOP() DO WHILE .NOT. EOF() AADD(aY, Kod_Y) DBSKIP(1) ENDDO CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций aStructure := { { "Kod_cls" , "N", 15, 0 }, ; // 1 { "Name_cls", "C",mMLNameCls, 0 }, ; // 2 { "MinGrInt", "N", 19, 7 }, ; // 3 { "MaxGrInt", "N", 19, 7 }, ; // 4 { "AvrGrInt", "N", 19, 7 } } // 5 *** Здесь нужно перечислить только градации шкалы Y FOR my=1 TO LEN(aY) FieldName = "CLS"+ALLTRIM(STR(aY[my],15)) AADD(aStructure, { FieldName, "N", 19, 7 }) NEXT DbCreate( "MapXYZpK.dbf", aStructure ) // Значения Z макс. Korr DbCreate( "MapXYZpI.dbf", aStructure ) // Значения Z макс. Sum_inf DbCreate( "MapXYKpK.dbf", aStructure ) // Значения инт.крит. макс. Korr DbCreate( "MapXYKpI.dbf", aStructure ) // Значения инт.крит. макс. Sum_inf DbCreate( "MapXYZnK.dbf", aStructure ) // Значения Z мин. Korr DbCreate( "MapXYZnI.dbf", aStructure ) // Значения Z мин. Sum_inf DbCreate( "MapXYKnK.dbf", aStructure ) // Значения инт.крит. мин. Korr DbCreate( "MapXYKnI.dbf", aStructure ) // Значения инт.крит. мин. Sum_inf CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() USE Class_Sc EXCLUSIVE NEW;N_ClSc = RECCOUNT() USE Rso_Zag EXCLUSIVE NEW;N_Obj = RECCOUNT() // Кол-во объектов расп.выборки USE Rasp EXCLUSIVE NEW;N_Rsp = RECCOUNT() USE Rasp_XYZ EXCLUSIVE NEW USE RspXYZpK EXCLUSIVE NEW USE RspXYZpI EXCLUSIVE NEW USE RspXYZnK EXCLUSIVE NEW USE RspXYZnI EXCLUSIVE NEW USE MapXYZpK EXCLUSIVE NEW USE MapXYZpI EXCLUSIVE NEW USE MapXYKpK EXCLUSIVE NEW USE MapXYKpI EXCLUSIVE NEW USE MapXYZnK EXCLUSIVE NEW USE MapXYZnI EXCLUSIVE NEW USE MapXYKnK EXCLUSIVE NEW USE MapXYKnI EXCLUSIVE NEW ****** Формирование пустых матриц визуализации результатов распознавания ****** Здесь нужно перечислить только градации шкалы X FOR mx=1 TO LEN(aX) SELECT Classes DBGOTO(aX[mx]) mKodCls = Kod_cls mNameCls = Name_Cls mMinGrInt = Min_GrInt mMaxGrInt = Max_GrInt mAvrGrInt = Avr_GrInt SELECT MapXYZpK;APPEND BLANK;FIELDPUT(1,mKodCls);FIELDPUT(2,mNameCls);FIELDPUT(3,mMinGrInt);FIELDPUT(4,mMaxGrInt);FIELDPUT(5,mAvrGrInt ) SELECT MapXYZpI;APPEND BLANK;FIELDPUT(1,mKodCls);FIELDPUT(2,mNameCls);FIELDPUT(3,mMinGrInt);FIELDPUT(4,mMaxGrInt);FIELDPUT(5,mAvrGrInt ) SELECT MapXYKpK;APPEND BLANK;FIELDPUT(1,mKodCls);FIELDPUT(2,mNameCls);FIELDPUT(3,mMinGrInt);FIELDPUT(4,mMaxGrInt);FIELDPUT(5,mAvrGrInt ) SELECT MapXYKpI;APPEND BLANK;FIELDPUT(1,mKodCls);FIELDPUT(2,mNameCls);FIELDPUT(3,mMinGrInt);FIELDPUT(4,mMaxGrInt);FIELDPUT(5,mAvrGrInt ) SELECT MapXYZnK;APPEND BLANK;FIELDPUT(1,mKodCls);FIELDPUT(2,mNameCls);FIELDPUT(3,mMinGrInt);FIELDPUT(4,mMaxGrInt);FIELDPUT(5,mAvrGrInt ) SELECT MapXYZnI;APPEND BLANK;FIELDPUT(1,mKodCls);FIELDPUT(2,mNameCls);FIELDPUT(3,mMinGrInt);FIELDPUT(4,mMaxGrInt);FIELDPUT(5,mAvrGrInt ) SELECT MapXYKnK;APPEND BLANK;FIELDPUT(1,mKodCls);FIELDPUT(2,mNameCls);FIELDPUT(3,mMinGrInt);FIELDPUT(4,mMaxGrInt);FIELDPUT(5,mAvrGrInt ) SELECT MapXYKnI;APPEND BLANK;FIELDPUT(1,mKodCls);FIELDPUT(2,mNameCls);FIELDPUT(3,mMinGrInt);FIELDPUT(4,mMaxGrInt);FIELDPUT(5,mAvrGrInt ) NEXT lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk) aSay[2]:SetCaption(aSay[2]:caption+L(' - Готово ')) aSay[3]:SetCaption(L('3/7: Для каждой зоны карты определяется наиболее сходный класс (инт.крит.-корреляция)')) SELECT Rasp_XYZ SET FILTER TO;SET ORDER TO INDEX ON STR(Kod_X,19)+STR(Kod_Y,19)+STR(9999999999.9999999-Korr,19,7) TO RXYZk * 123456789012345678 DBGOTOP() mKodX = -1;mKodY = -1 DO WHILE .NOT. EOF() IF mKodX = Kod_X .AND. mKodY = Kod_Y ELSE mKodX = Kod_X;mKodY = Kod_Y aR := {} FOR i=1 TO FCOUNT() AADD(aR, FIELDGET(i)) NEXT SELECT RspXYZpK APPEND BLANK FOR i=1 TO FCOUNT() FIELDPUT(i, aR[i]) NEXT // Формирование матриц Z и Korr что будет SELECT MapXYZpK;DBGOTO(aR[5]);FIELDPUT(FIELDPOS("CLS"+ALLTRIM(STR(aR[10],15))),aR[19]) SELECT MapXYKpK;DBGOTO(aR[5]);FIELDPUT(FIELDPOS("CLS"+ALLTRIM(STR(aR[10],15))),aR[20]) ENDIF lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk) SELECT Rasp_XYZ DBSKIP(1) ENDDO aSay[3]:SetCaption(aSay[3]:caption+L(' - Готово ')) aSay[4]:SetCaption(L('4/7: Для каждой зоны карты определяется наиболее сходный класс (инт.крит.-сумма инф.)')) SELECT Rasp_XYZ SET FILTER TO;SET ORDER TO INDEX ON STR(Kod_X,19)+STR(Kod_Y,19)+STR(9999999999.9999999-Sum_inf,19,7) TO RXYZi * 123456789012345678 DBGOTOP() mKodX = -1;mKodY = -1 DO WHILE .NOT. EOF() IF mKodX = Kod_X .AND. mKodY = Kod_Y ELSE mKodX = Kod_X;mKodY = Kod_Y aR := {} FOR i=1 TO FCOUNT() AADD(aR, FIELDGET(i)) NEXT SELECT RspXYZpI APPEND BLANK FOR i=1 TO FCOUNT() FIELDPUT(i, aR[i]) NEXT // Формирование матриц Z и Sum_Inf что будет SELECT MapXYZpI;DBGOTO(aR[5]);FIELDPUT(FIELDPOS("CLS"+ALLTRIM(STR(aR[10],15))),aR[19]) SELECT MapXYKpI;DBGOTO(aR[5]);FIELDPUT(FIELDPOS("CLS"+ALLTRIM(STR(aR[10],15))),aR[21]) ENDIF lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk) SELECT Rasp_XYZ DBSKIP(1) ENDDO aSay[4]:SetCaption(aSay[4]:caption+L(' - Готово ')) aSay[5]:SetCaption(L('5/7: Для каждой зоны карты определяется наиболее отличающийся класс (инт.крит.-корреляция)')) SELECT Rasp_XYZ SET FILTER TO;SET ORDER TO INDEX ON STR(Kod_X,19)+STR(Kod_Y,19)+STR(Korr,19,7) TO RXYZk DBGOTOP() mKodX = -1;mKodY = -1 DO WHILE .NOT. EOF() IF mKodX = Kod_X .AND. mKodY = Kod_Y ELSE mKodX = Kod_X;mKodY = Kod_Y aR := {} FOR i=1 TO FCOUNT() AADD(aR, FIELDGET(i)) NEXT SELECT RspXYZnK APPEND BLANK FOR i=1 TO FCOUNT() FIELDPUT(i, aR[i]) NEXT // Формирование матриц Z и Korr чего не будет SELECT MapXYZnK;DBGOTO(aR[5]);FIELDPUT(FIELDPOS("CLS"+ALLTRIM(STR(aR[10],15))),aR[19]) SELECT MapXYKnK;DBGOTO(aR[5]);FIELDPUT(FIELDPOS("CLS"+ALLTRIM(STR(aR[10],15))),aR[20]) ENDIF lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk) SELECT Rasp_XYZ DBSKIP(1) ENDDO aSay[5]:SetCaption(aSay[5]:caption+L(' - Готово ')) aSay[6]:SetCaption(L('6/7: Для каждой зоны карты определяется наиболее отличающийся класс (инт.крит.-сумма инф.)')) SELECT Rasp_XYZ SET FILTER TO;SET ORDER TO INDEX ON STR(Kod_X,19)+STR(Kod_Y,19)+STR(Sum_inf,19,7) TO RXYZi DBGOTOP() mKodX = -1;mKodY = -1 DO WHILE .NOT. EOF() IF mKodX = Kod_X .AND. mKodY = Kod_Y ELSE mKodX = Kod_X;mKodY = Kod_Y aR := {} FOR i=1 TO FCOUNT() AADD(aR, FIELDGET(i)) NEXT SELECT RspXYZnI APPEND BLANK FOR i=1 TO FCOUNT() FIELDPUT(i, aR[i]) NEXT // Формирование матриц Z и Sum_Inf чего не будет SELECT MapXYZnI;DBGOTO(aR[5]);FIELDPUT(FIELDPOS("CLS"+ALLTRIM(STR(aR[10],15))),aR[19]) SELECT MapXYKnI;DBGOTO(aR[5]);FIELDPUT(FIELDPOS("CLS"+ALLTRIM(STR(aR[10],15))),aR[21]) ENDIF lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk) SELECT Rasp_XYZ DBSKIP(1) ENDDO aSay[6]:SetCaption(aSay[6]:caption+L(' - Готово ')) aSay[7]:SetCaption(L('7/7: Преобразование матриц результатов распознавания в новый стандарт баз данных')) * ########################################################################### ********** Структура создаваемой базы *********** aInfStruct := { { "Kod_cls" , "N", 15, 0 }, ; // 1 { "Name_cls", "C",mMLNameCls, 0 }, ; // 2 { "MinGrInt", "N", 19, 7 }, ; // 3 { "MaxGrInt", "N", 19, 7 }, ; // 4 { "AvrGrInt", "N", 19, 7 } } // 5 *** Здесь нужно перечислить только градации шкалы Y FOR my=1 TO LEN(aY) FieldName = "CLS"+ALLTRIM(STR(aY[my],15)) AADD(aInfStruct, { FieldName, "N", 19, 7 }) NEXT DC_ASave(aInfStruct, "_RaspMatr.arx") // Когда БД создается - записывать структуру, когда открывается - считывать *aInfStruct = DC_ARestore("_RaspMatr.arx") ************************************************* ***** Формирование пустой записи N_Col = LEN(aY)+5 // Число полей 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 := {"MapXYZpK",; "MapXYZpI",; "MapXYKpK",; "MapXYKpI",; "MapXYZnK",; "MapXYZnI",; "MapXYKnK",; "MapXYKnI" } PRIVATE nHandle[LEN(Ar_Model)] FOR z=1 TO LEN(Ar_Model) DB_name = Ar_Model[z]+".txt" nHandle[z] := FCreate( DB_name, FC_NORMAL ) // Создание БД (если она была, то все равно создается пустая) IF nHandle[z] = -1 MsgBox("Файл: "+DB_name+" не может быть создан. Ошибка:"+FERROR()) RETURN NIL ENDIF LC_DbCreate( DB_name, nHandle[z], Lc_buf, LEN(aX) ) // Создание БД.txt, содержащей N_Rec пустых записей ############ NEXT *nHandle := FOpen( DB_name, 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 * ########################################################################### FOR z=1 TO LEN(Ar_Model) * nHandle[z] := FOpen( Ar_Model[z]+".txt", FO_READWRITE ) // Открытие базы данных ######################################## SELECT(Ar_Model[z]) FOR i=1 TO RECCOUNT() DBGOTO(i) FOR j=1 TO N_Col mV = FIELDGET(j) IF VALTYPE(mV) = "N" mV = STR(mV, aInfStruct[j,3], aInfStruct[j,4] ) ENDIF LC_FieldPut(Ar_Model[z]+".txt", nHandle[z], i, j, mV ) NEXT NEXT lOk=Time_Progress(++Time_Progress,Wsego,oProgress,lOk) NEXT aSay[7]:SetCaption(aSay[7]:caption+L(' - Готово ')) Mess = L("БД для картографической визуализации в системе SigmaPlot и режиме 4.5 подготовлены !!!") 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() CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций 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 ************************************************************************************************** *** Эксперимент по созданию и заполнению базы данных сверхбольшой размерности собственного формата *** БД создается похожей на Abs, Prc1, Prc2, Inf1-Inf7, т.к. это нужно в первую очередь для них *** (С) Е.В.Луценко, 01.08.2013 ************************************************************************************************** FUNCTION M_a_i_n() // Это ПРИМЕРЫ обращения к функциям работы с текстовой базой данных LOCAL Getlist := {}, oProgress, oDialog DC_IconDefault(1000) **** Опрделение максимальной длины текстовой переменной для строки базы данных **mTXT = "" *DO WHILE .T. * mTXT = mTXT + REPLICATE("#",1000000) *ENDDO * Оказалось текстовая переменная может содержать до 282 млн.символов. Этого более чем достаточно CrLf = CHR(13)+CHR(10) // Конец строки (записи) N_Cls = 1000 // Число классов N_Rec = 1000 // Число признаков N_Col = N_Cls+3 // Число полей * ########################################################################### ********** Структура создаваемой базы *********** aStructure := { { "Kod_pr", "N", 15, 0},; // 1 { "Name" , "C", 15, 0} } // 2 FOR j=1 TO N_Cls FieldName = "N"+ALLTRIM(STR(j,15)) AADD(aStructure, { FieldName, "N", 19, 2 }) NEXT AADD(aStructure, { "Summa", "N", 19, 2 }) ************************************************* DC_ASave(aStructure, "_AbsStruct.arx") // Когда БД создается - записывать структуру, когда открывается - считывать *aStructure = DC_ARestore("_AbsStruct.arx") N_Col = N_Cls+3 // Число полей DB_name = "Max_DB.txt" // Имя базы данных nHandle := FCreate( DB_name, FC_NORMAL ) // Создание БД (если она была, то все равно создается пустая) ###### *nHandle := FOpen( DB_name, FO_READWRITE ) // Открытие базы данных ############################################ IF nHandle = -1 MsgBox("Файл: "+DB_name+" не может быть создан. Ошибка:"+FERROR()) RETURN NIL ENDIF ***** Формирование пустой записи CrLf = CHR(13)+CHR(10) // Конец строки (записи) Lc_buf = "" FOR j=1 TO N_Col S = IF(j=2*INT(j/2),"#","X") // Для отладки * S = " " // Для работы IF aStructure[j,4] = 0 Lc_buf = Lc_buf + REPLICATE(S, aInfStruct[j,3]) ELSE Lc_buf = Lc_buf + REPLICATE(S, aStructure[j,3]-aStructure[j,4]-1)+"."+REPLICATE(S, aStructure[j,4]) ENDIF NEXT Lc_buf = Lc_buf + CrLf Len_LcBuf = LEN(Lc_buf) LC_DbCreate( DB_name, nHandle, Lc_buf, N_Rec ) // Создание БД.txt, содержащей N_Rec пустых записей ############ *DbCreate( "Max_DB", aStructure ) // Создание пустой БД.dbf (для отладки) **** Рассчет массива начальных позиций полей в строке PRIVATE aPos[N_Col] aPos[1] = 1 FOR j=2 TO N_Col aPos[j] = aPos[j-1] + aInfStruct[j-1,3] NEXT * ########################################################################### *** Отображение начальных позиций полей (отладка) *aM := {} *FOR j=1 TO N_Col * AADD(aM, STR(j)+" "+STR(aPos[j])) *NEXT *LB_Warning(aM) *** Запись поля в БД (корректная) *********** FOR i=1 TO N_Rec FOR j=1 TO N_Col IF aStructure[j,4] = 0 String = STR(i*1000+j,aStructure[j,3]) ELSE String = STR(i*1000+j+0.12,aInfStruct[j,3],aInfStruct[j,4]) ENDIF Flag_err = LC_FieldPut( DB_name, nHandle, i, j, String ) // Запись поля в БД (корректная) ##################### IF Flag_err EXIT ENDIF NEXT NEXT *Flag_err = LC_FieldPut( DB_name, nHandle, Pos, String ) // Запись поля в БД (некорректная) *** Считывание поля в БД (корректная) *********** *** Формирование БД.dbf (для отладки) USE Max_DB EXCLUSIVE NEW;ZAP SELECT Max_DB DBGOTOP() FOR j=1 TO N_Rec APPEND BLANK NEXT FOR i=1 TO N_Rec FOR j=1 TO N_Col String = LC_FieldGet( DB_name, nHandle, i, j ) // Считывание поля из БД (корректная) ################ DO CASE CASE aStructure[j,2] = "C" DBGOTO(i);FIELDPUT(j, String ) // Для отладки CASE aStructure[j,2] = "N" DBGOTO(i);FIELDPUT(j, VAL(String) ) // Для отладки ENDCASE IF EMPTY(String) EXIT ENDIF NEXT NEXT *String = LC_FieldGet( DB_name, nHandle, Pos ) // Считывание поля из БД (некорректная) ******* Эксперимент по определению скорости обращения к базам данных TXT и DBF nTimeON := SECONDS() FOR i=1 TO N_Rec FOR j=1 TO N_Col String = LC_FieldGet( DB_name, nHandle, i, j ) // Считывание поля из БД (корректная) ################ Flag_err = LC_FieldPut( DB_name, nHandle, i, j, String ) // Запись поля в БД (корректная) ##################### NEXT NEXT nTimeOFF := SECONDS() MsgBox("Время исполнения для БД.TXT="+ALLTRIM(STR(nTimeOFF-nTimeON))+" "+"сек.") nTimeON := SECONDS() SELECT Max_DB FOR i=1 TO N_Rec FOR j=1 TO N_Col DBGOTO(i);Str = FieldGet( j ) DBGOTO(i);FIELDPUT(j, Str ) NEXT NEXT nTimeOFF := SECONDS() MsgBox("Время исполнения для БД.DBF="+ALLTRIM(STR(nTimeOFF-nTimeON))+" "+"сек.") *** Результат: обращение к на чтение и запись происходит БД.txt почти в 3 раза быстрее, чем к БД.dbf FClose( nHandle ) // Закрытие текстовой базы данных ###################################### RETURN NIL *********************************************************** ******** Создание Max_БД ******** - DB_name - имя создаваемой БД ******** - nHandle - идентификатор создаваемой БД ******** - Lc_buf - пустая запись (строка) базы данных ******** - N_Rec - количество строк (записей) *********************************************************** FUNCTION LC_DbCreate( DB_name, nHandle, Lc_buf, N_Rec ) Len_LcBuf = LEN(Lc_buf) nTimeON := SECONDS() *nMax = N_Rec *Mess = L('Создание файла: ')+DB_name *@ 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_Rec // Реальное число записей Len_rec = FWrite( nHandle, Lc_buf, Len_LcBuf ) IF Len_rec < Len_LcBuf MsgBox("Произошла ошибка записи файла: "+DB_name+". Ошибка:"+FERROR()) RETURN NIL ENDIF * DC_GetProgress(oProgr, ++nTime, nMax) NEXT *DC_GetProgress(oProgr,nMax,nMax) *FClose( nHandle ) nTimeOFF := SECONDS() *MsgBox("Время исполнения="+ALLTRIM(STR(nTimeOFF-nTimeON))+" "+"сек.") *oDial:Destroy() RETURN NIL ********************************************* ********* Запись поля в Max_БД ********************************************* *FUNCTION LC_FieldPutOld( DB_name, nHandle, mRec, mCol, String ) *Pos = (mRec-1) * Len_LcBuf + aPos[mCol] - 1 *FSEEK(nHandle, Pos, FS_SET) // Позиционирование начала поля *Len_str = LEN(String) *N_Write = FWrite( nHandle, String, Len_str ) *IF N_Write < Len_str * Mess = L('Ошибка записи поля: [строка=@, колонка=$] в БД: "#"') * Mess = STRTRAN(Mess, "#", DB_Name) * Mess = STRTRAN(Mess, "@", ALLTRIM(STR(mRec))) * Mess = STRTRAN(Mess, "$", ALLTRIM(STR(mCol))) * MsgBox(Mess) * RETURN(.T.) *ENDIF *RETURN(.F.) ********************************************* ********* Считывание поля из Max_БД ********************************************* *FUNCTION LC_FieldGetOld( DB_name, nHandle, mRec, mCol ) *Len_str = aInfStruct[mCol,3] *Pos = (mRec-1) * Len_LcBuf + aPos[mCol] - 1 *FSEEK(nHandle, Pos, FS_SET) // Позиционирование начала поля *String = SPACE(Len_str) *N_Read = FRead( nHandle, @String, Len_str ) *IF N_Read < Len_str * Mess = L('Ошибка считывания поля: [строка=@, колонка=$] БД: "#"') * Mess = STRTRAN(Mess, "#", DB_Name) * Mess = STRTRAN(Mess, "@", ALLTRIM(STR(mRec))) * Mess = STRTRAN(Mess, "$", ALLTRIM(STR(mCol))) * MsgBox(Mess) * RETURN("") *ENDIF *// Пробел в числовом поле рассматривается как "0" *IF aInfStruct[mCol,2] = "N" .AND. LEN(ALLTRIM(String)) = 0 * String = "0" *ENDIF *RETURN(String) * LC_AppendBl( DB_name, aInfStruct ) * LC_DeleteBl( DB_name ) ******************************************** ******** Запись поля в Max_БД ******************************************** FUNCTION LC_FieldPut( DB_name, nHandle, mRec, mCol, String ) Pos = (mRec-1) * Len_LcBuf + aPos[mCol] - 1 FSEEK(nHandle, Pos, FS_SET) // Позиционирование начала поля Len_str = LEN(String) N_Write = FWrite( nHandle, String, Len_str ) *IF N_Write <> Len_str * MsgBox(STR(N_Write)+STR(Len_str)+'######'+String+'######') *ENDIF *IF N_Write <> Len_str * MsgBox('######'+N_Write+'######'+String+'######') * aMess := {} * AADD(aMess, L('Ошибка записи поля: [строка=@, колонка=$] БД: "#".')) * AADD(aMess, L(' ')) * AADD(aMess, L('Это неустранимая ошибка, возникающая при попытке открытия уже открытой базы данных модели: '+DB_Name+'.')) * AADD(aMess, L('Скорее всего она возникла из-за того, что перед запуском нового режима не был закрыт предыдущий.')) * AADD(aMess, L('Работа системы будет прервана. Если после этого сразу запустить режим, в котором возникла ошибка,')) * AADD(aMess, L('то скорее всего он будет выполнен нормально.')) * aMess[1] = STRTRAN(aMess[1], "#", DB_Name) * aMess[1] = STRTRAN(aMess[1], "@", ALLTRIM(STR(mRec))) * aMess[1] = STRTRAN(aMess[1], "$", ALLTRIM(STR(mCol))) * LB_Warning(aMess) ** MsgBox(aMess) * ADS_SERVER_QUIT() * QUIT * RETURN(.T.) *ENDIF RETURN(.F.) ******************************************** ******** Считывание поля из Max_БД ******************************************** FUNCTION LC_FieldGet( DB_name, nHandle, mRec, mCol ) *MsgBox('Строка='+ALLTRIM(STR(mRec))+', Колонка='+ALLTRIM(STR(mCol))) Len_str = aInfStruct[mCol,3] *DC_DebugQout( aPos ) // <<<===################### Pos = (mRec-1) * Len_LcBuf + aPos[mCol] - 1 FSEEK(nHandle, Pos, FS_SET) // Позиционирование начала поля String = SPACE(Len_str) N_Read = FRead( nHandle, @String, Len_str ) *MsgBox(N_Read) *IF N_Read <> Len_str * MsgBox(STR(N_Read)+STR(Len_str)+'######'+String+'######') *ENDIF *IF N_Read <> Len_str * MsgBox('######'+N_Read+'######'+String+'######') * aMess := {} * AADD(aMess, L('Ошибка считывания поля: [строка=@, колонка=$] БД: "#".')) * AADD(aMess, L(' ')) * AADD(aMess, L('Это неустранимая ошибка, возникающая при попытке открытия уже открытой базы данных модели: '+DB_Name+'.')) * AADD(aMess, L('Скорее всего она возникла из-за того, что перед запуском нового режима не был закрыт предыдущий.')) * AADD(aMess, L('Работа системы будет прервана. Если после этого сразу запустить режим, в котором возникла ошибка,')) * AADD(aMess, L('то скорее всего он будет выполнен нормально.')) * aMess[1] = STRTRAN(aMess[1], "#", DB_Name) * aMess[1] = STRTRAN(aMess[1], "@", ALLTRIM(STR(mRec))) * aMess[1] = STRTRAN(aMess[1], "$", ALLTRIM(STR(mCol))) * LB_Warning(aMess) ** MsgBox(aMess) * ADS_SERVER_QUIT() * QUIT * RETURN("") *ENDIF // Пробел в числовом поле рассматривается как "0" IF aInfStruct[mCol,2] = "N" .AND. LEN(ALLTRIM(String)) = 0 String = "0" ENDIF RETURN(String) ***************************************************************************************************** ********************************* ******** Помощь по функции 4.6() ********************************* FUNCTION Help4_6() cFile = Disk_dir+"\_Help4_6.pdf" IF .NOT. FILE(cFile) Mess = L('В папке с исполнимым модулем системы нет файла: "#"') Mess = STRTRAN(Mess, "#", cFile) LB_Warning(Mess) ENDIF // Проверить контрольную сумму файла и если она не совпадает // выдать сообщение о том, что файл поврежден (чтобы было невозможно заменить графический файл). IF FILECHECK(cFile) = 6657804 * DC_PrintPreviewAcrobat( cFile, 'Help 4.6: смысл метода взвешивания наблюдений с весами, равными количеству информации в них' ) 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 RETURN NIL ************************************************************************************************************************************************************** ******** 4.2.2.4. Классическая кластеризация классов. Классическая кластеризация классов в Питоне. ******** Построение и визуализация агломеративных дендрограмм классов и графиков межкластерных расстояний в графическом виде, а также матрицы сходства классов ************************************************************************************************************************************************************** FUNCTION F4_2_2_4() LOCAL GetList[0], lOk Running(.T.) * Наименование приложения ******************* 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 IF ApplChange("4.2.2.4()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения IF FILEDATE("ClusteringClasses",16) = CTOD("//") DIRMAKE("ClusteringClasses") aMess := {} AADD(aMess, L('В папке текущего приложения: "')+ALLTRIM(M_PathAppl)+'"') AADD(aMess, L('не было директории "ClusteringClasses" для выходных форм кластеризации и она была создана!')) LB_Warning(aMess, L('4.2.2.4. Классическая кластеризация классов' )) ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения IF .NOT. FILE( "Opis_Sc.dbf" ) .OR. ; .NOT. FILE( "Gr_OpSc.dbf" ) .OR. ; .NOT. FILE( "Class_Sc.dbf") .OR. ; .NOT. FILE( "Gr_ClSc.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.2.2.4. Классическая кластеризация классов' )) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF IF FILE( "ABS.txt" ) .AND. ; FILE( "PRC1.txt" ) .AND. ; FILE( "PRC2.txt" ) .AND. ; FILE( "INF1.txt" ) .AND. ; FILE( "INF2.txt" ) .AND. ; FILE( "INF3.txt" ) .AND. ; FILE( "INF4.txt" ) .AND. ; FILE( "INF5.txt" ) .AND. ; FILE( "INF6.txt" ) .AND. ; FILE( "INF7.txt" ) * OK ELSE aMess := {} AADD(aMess, L('В папке текущего приложения: "#"')) 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')) AADD(aMess, L("Для того, чтобы их создать необходимо выполнить режим 3.5.")) aMess[1] = STRTRAN(aMess[1], "#", UPPER(ALLTRIM(M_PathAppl))) LB_Warning(aMess, L('4.2.2.4. Классическая кластеризация классов' )) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF * АЛГОРИТМ *********************************************************************************************************************************************************************************************************** * Весь диалог и выборку подматрицы в CSV СДЕЛАТЬ НА Аляске. На Питоне только само рисование одного вида когнитивной функции по ОДНОЙ подматрице. * Задать в диалоге текущую модель, вид когнитивной функции и количество градаций уровня функции. * Все базы данных, используемые программой, находятся по пути, который находится в поле PATH_APPL первой записи базы данных Appls.dbf, в которой поле: BY_DEFAULT не пустое. В этой же базе и наименование приложения. ******************************************************************************************* ****** 0. Задать текущую стат.модель или модель знаний ******************************************************************************************* * Задание и сохранение всех заданных параметров в файлах ******************** IF .NOT. FILE("_4224param.arx") aParameters := {} AADD(aParameters, 6 ) // Текущая модель для кластеризации ELSE * DC_ASave(aParameters, "_4224param.arx") aParameters := DC_ARestore("_4224param.arx") ENDIF ****** Задание параметров кластеризации ***************************************************************** s=0;d=1.0 @ 0,0 DCGROUP oGroup1 CAPTION L('Задайте статистическую или системно-когнитивную модель для кластеризации классов: ') SIZE 83,14.0 ;s=s+d @ s,3 DCRADIO aParameters[1] VALUE 1 PROMPT L('1. ABS - частный критерий: количество встреч сочетаний: "класс-признак" у объектов обуч.выборки') PARENT oGroup1;s=s+d @ s,3 DCRADIO aParameters[1] VALUE 2 PROMPT L('2. PRC1 - частный критерий: усл. вероятность i-го признака среди признаков объектов j-го класса ') PARENT oGroup1;s=s+d @ s,3 DCRADIO aParameters[1] VALUE 3 PROMPT L('3. PRC2 - частный критерий: условная вероятность i-го признака у объектов j-го класса ') PARENT oGroup1;s=s+d @ s,3 DCRADIO aParameters[1] VALUE 4 PROMPT L('4. INF1 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC-1 ') PARENT oGroup1;s=s+d @ s,3 DCRADIO aParameters[1] VALUE 5 PROMPT L('5. INF2 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC-2 ') PARENT oGroup1;s=s+d @ s,3 DCRADIO aParameters[1] VALUE 6 PROMPT L('6. INF3 - частный критерий: Xи-квадрат, разности между фактическими и ожидаемыми абс.частотами ') PARENT oGroup1;s=s+d @ s,3 DCRADIO aParameters[1] VALUE 7 PROMPT L('7. INF4 - частный критерий: ROI (Return On Investment); вероятности из PRC-1 ') PARENT oGroup1;s=s+d @ s,3 DCRADIO aParameters[1] VALUE 8 PROMPT L('8. INF5 - частный критерий: ROI (Return On Investment); вероятности из PRC-2 ') PARENT oGroup1;s=s+d @ s,3 DCRADIO aParameters[1] VALUE 9 PROMPT L('9. INF6 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC-1 ') PARENT oGroup1;s=s+d @ s,3 DCRADIO aParameters[1] VALUE 10 PROMPT L('10.INF7 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC-2 ') PARENT oGroup1;s=s+1.5*d * @ s, 3 DCPUSHBUTTON CAPTION L('Для начала кластеризации задайте модель и нажмите "OK"' ) SIZE 77, 1.5 ACTION {||DC_ReadGuiEvent(DCGUI_EXIT_OK,GetList)} FONT "10.HelvBold" PARENT oGroup7 // Просто выход из диалога с заданными папаметрами @ s, 3 DCSAY 'Для старта классической кластеризации классов задайте модель и нажмите OK' PARENT oGroup1 FONT "10.HelvBold" SAYSIZE 0 DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; ADDBUTTONS; OPTIONS GetOptions ; MODAL ; TITLE L('4.2.2.4. Классическая кластеризация классов') *********************************************************************** 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(aParameters, "_4224param.arx") * aParameters := DC_ARestore("_4224param.arx" CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() // Количество классов USE Attributes EXCLUSIVE NEW;N_Atr = RECCOUNT() // Количество признаков ***************************************************************************************************************************************************************** aClasses := {} // Массив кодов и наименований классов SELECT Classes DBGOTOP() DO WHILE .NOT. EOF() AADD(aClasses, '['+ALLTRIM(STR(Kod_cls))+']-'+ALLTRIM(Name_cls)) DBSKIP(1) ENDDO aAttributes := {} // Массив кодов и наименований признаков SELECT Attributes DBGOTOP() DO WHILE .NOT. EOF() AADD(aAttributes, '['+ALLTRIM(STR(Kod_atr))+']-'+ALLTRIM(Name_atr)) DBSKIP(1) ENDDO * Формирование файла параметров 4223Param.CSV ***************************************************** PRIVATE aModName[10] aModName := {L('1. ABS - частный критерий: количество встреч сочетаний: "класс-признак" у объектов обуч.выборки '),; L('2. PRC1 - частный критерий: условная вероятность i-го признака среди признаков объектов j-го класса'),; L('3. PRC2 - частный критерий: условная вероятность i-го признака у объектов j-го класса '),; L('4. INF1 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC-1 '),; L('5. INF2 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC-2 '),; L('6. INF3 - частный критерий: Xи-квадрат, разности между фактическими и ожидаемыми абс.частотами '),; L('7. INF4 - частный критерий: ROI (Return On Investment); вероятности из PRC-1 '),; L('8. INF5 - частный критерий: ROI (Return On Investment); вероятности из PRC-2 '),; L('9. INF6 - частный критерий: разность условной и безусловной вероятностей; вероятности из PRC-1 '),; L('10.INF7 - частный критерий: разность условной и безусловной вероятностей; вероятности из PRC-2 ') } PUBLIC Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } CrLf = CHR(13)+CHR(10) // Конец строки (записи) m4224Param = 'Наименование приложения:#' + M_NameAppl + CrLf m4224Param = m4224Param + 'Наименование модели:#' + ALLTRIM(aModName[aParameters[1]]) + CrLf m4224Param = m4224Param + 'Код модели:#' + ALLTRIM(STR(aParameters[1])) + CrLf StrFile(m4224Param, '4224Param.CSV') // Создать CSV-файл со всеми ПАРАМЕТРАМИ для программы на Питоне: наименование приложения, наименование модели, вид когнитивной функции, наименования классификационной и описательной шкал и их градаций с кодами * После формирования матрицы 4224matrix.CSV и файлов параметров запустить внешнюю программу на Питоне _4224py.exe для визуализации и записи выходных форм с результатами кластеризации для заданной модели с заданными параметрами * CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций CLOSE ALL DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы * LC_RunShell("_4224py.exe",2085426422) // Мой вариант на Питоне/C++ <<<===################# * LC_RunShellAidosPy(717400306, "_4224py") // Мой вариант на Питоне в системе __AIDOS-PY.exe LC_RunShell("__AIDOS-PY.exe", 717400306, "_4224py") // Мой вариант на Питоне в системе __AIDOS-PY.exe DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * Написать в каких моделях и какие выходные формы кластеризации созданы и в какие дирректории записаны // <<<===################### * aMess := {} * AADD(aMess, L('Генерация, визуализация и запись выходных форм кластеризации завершены успешно !!!')) * AADD(aMess, L('Выходные формы кластеризации созданы в модели:')+' '+ALLTRIM(aModName[aParameters[1]])) * AADD(aMess, L('Записаны эти выходные формы кластеризации в папку:')+' '+ALLTRIM(M_PathAppl)+'ClusteringClasses') // <<<===################### * LB_Warning(aMess, L('4.2.2.4. Классическая кластеризация классов' )) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL *************************************************************************************************************************************************************************************************************** ******** 4.3.2.4. Классическая кластеризация признаков ******** Классическая кластеризация классов в Питоне. Построение и визуализация агломеративных дендрограмм признаков и графиков межкластерных расстояний в графическом виде, а также матрицы сходства признаков *************************************************************************************************************************************************************************************************************** FUNCTION F4_3_2_4() LOCAL GetList[0], lOk Running(.T.) * Наименование приложения ******************* 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 IF ApplChange("4.3.2.4()") // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения Running(.F.) RETURN NIL ENDIF DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения IF FILEDATE("ClusteringAttributes",16) = CTOD("//") DIRMAKE("ClusteringAttributes") aMess := {} AADD(aMess, L('В папке текущего приложения: "')+ALLTRIM(M_PathAppl)+'"') AADD(aMess, L('не было директории "ClusteringAttributes" для выходных форм кластеризации и она была создана!')) LB_Warning(aMess, L('4.2.2.4. Классическая кластеризация классов' )) ENDIF CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения IF .NOT. FILE( "Opis_Sc.dbf" ) .OR. ; .NOT. FILE( "Gr_OpSc.dbf" ) .OR. ; .NOT. FILE( "Class_Sc.dbf") .OR. ; .NOT. FILE( "Gr_ClSc.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.3.2.4. Классическая кластеризация признаков' )) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF IF FILE( "ABS.txt" ) .AND. ; FILE( "PRC1.txt" ) .AND. ; FILE( "PRC2.txt" ) .AND. ; FILE( "INF1.txt" ) .AND. ; FILE( "INF2.txt" ) .AND. ; FILE( "INF3.txt" ) .AND. ; FILE( "INF4.txt" ) .AND. ; FILE( "INF5.txt" ) .AND. ; FILE( "INF6.txt" ) .AND. ; FILE( "INF7.txt" ) * OK ELSE aMess := {} AADD(aMess, L('В папке текущего приложения: "#"')) 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')) AADD(aMess, L("Для того, чтобы их создать необходимо выполнить режим 3.5.")) aMess[1] = STRTRAN(aMess[1], "#", UPPER(ALLTRIM(M_PathAppl))) LB_Warning(aMess, L('4.3.2.4. Классическая кластеризация признаков' )) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF * АЛГОРИТМ *********************************************************************************************************************************************************************************************************** * Весь диалог и выборку подматрицы в CSV СДЕЛАТЬ НА Аляске. На Питоне только само рисование одного вида когнитивной функции по ОДНОЙ подматрице. * Задать в диалоге текущую модель, вид когнитивной функции и количество градаций уровня функции. * Все базы данных, используемые программой, находятся по пути, который находится в поле PATH_APPL первой записи базы данных Appls.dbf, в которой поле: BY_DEFAULT не пустое. В этой же базе и наименование приложения. ******************************************************************************************* ****** 0. Задать текущую стат.модель или модель знаний ******************************************************************************************* * Задание и сохранение всех заданных параметров в файлах ******************** IF .NOT. FILE("_4324param.arx") aParameters := {} AADD(aParameters, 6 ) // Текущая модель для кластеризации ELSE * DC_ASave(aParameters, "_4324param.arx") aParameters := DC_ARestore("_4324param.arx") ENDIF ****** Задание параметров кластеризации ***************************************************************** s=0;d=1.0 @ 0,0 DCGROUP oGroup1 CAPTION L('Задайте статистическую или системно-когнитивную модель для кластеризации признаков: ') SIZE 83,14.0 ;s=s+d @ s,3 DCRADIO aParameters[1] VALUE 1 PROMPT L('1. ABS - частный критерий: количество встреч сочетаний: "класс-признак" у объектов обуч.выборки') PARENT oGroup1;s=s+d @ s,3 DCRADIO aParameters[1] VALUE 2 PROMPT L('2. PRC1 - частный критерий: усл. вероятность i-го признака среди признаков объектов j-го класса ') PARENT oGroup1;s=s+d @ s,3 DCRADIO aParameters[1] VALUE 3 PROMPT L('3. PRC2 - частный критерий: условная вероятность i-го признака у объектов j-го класса ') PARENT oGroup1;s=s+d @ s,3 DCRADIO aParameters[1] VALUE 4 PROMPT L('4. INF1 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC-1 ') PARENT oGroup1;s=s+d @ s,3 DCRADIO aParameters[1] VALUE 5 PROMPT L('5. INF2 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC-2 ') PARENT oGroup1;s=s+d @ s,3 DCRADIO aParameters[1] VALUE 6 PROMPT L('6. INF3 - частный критерий: Xи-квадрат, разности между фактическими и ожидаемыми абс.частотами ') PARENT oGroup1;s=s+d @ s,3 DCRADIO aParameters[1] VALUE 7 PROMPT L('7. INF4 - частный критерий: ROI (Return On Investment); вероятности из PRC-1 ') PARENT oGroup1;s=s+d @ s,3 DCRADIO aParameters[1] VALUE 8 PROMPT L('8. INF5 - частный критерий: ROI (Return On Investment); вероятности из PRC-2 ') PARENT oGroup1;s=s+d @ s,3 DCRADIO aParameters[1] VALUE 9 PROMPT L('9. INF6 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC-1 ') PARENT oGroup1;s=s+d @ s,3 DCRADIO aParameters[1] VALUE 10 PROMPT L('10.INF7 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC-2 ') PARENT oGroup1;s=s+2*d * @ s, 3 DCPUSHBUTTON CAPTION L('Для начала кластеризации задайте модель и нажмите "OK"' ) SIZE 77, 1.5 ACTION {||DC_ReadGuiEvent(DCGUI_EXIT_OK,GetList)} FONT "10.HelvBold" PARENT oGroup7 // Просто выход из диалога с заданными папаметрами @ s,1.5 DCSAY 'Для старта классической кластеризации признаков задайте модель и нажмите OK' PARENT oGroup1 FONT "10.HelvBold" SAYSIZE 0 DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; TO lExit ; FIT ; ADDBUTTONS; OPTIONS GetOptions ; MODAL ; TITLE L('4.3.2.4. Классическая кластеризация признаков') *********************************************************************** 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 *********************************************************************** * Прверка корректности заданных параметров ************************ mFlagError = .F. aMess := {} IF mFlagError * Сохранение всех заданных параметров в файлах ******************** DC_ASave(aParameters, "_4324param.arx") * aParameters := DC_ARestore("_4324param.arx" LB_Warning(aMess, L('4.3.2.4. Классическая кластеризация признаков' )) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL ENDIF ******************************************************************** * Сохранение всех заданных параметров в файлах ******************** DC_ASave(aParameters, "_4324param.arx") * aParameters := DC_ARestore("_4324param.arx" CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE Classes EXCLUSIVE NEW;N_Cls = RECCOUNT() // Количество классов USE Attributes EXCLUSIVE NEW;N_Atr = RECCOUNT() // Количество признаков ***************************************************************************************************************************************************************** aClasses := {} // Массив кодов и наименований классов SELECT Classes DBGOTOP() DO WHILE .NOT. EOF() AADD(aClasses, '['+ALLTRIM(STR(Kod_cls))+']-'+ALLTRIM(Name_cls)) DBSKIP(1) ENDDO aAttributes := {} // Массив кодов и наименований признаков SELECT Attributes DBGOTOP() DO WHILE .NOT. EOF() AADD(aAttributes, '['+ALLTRIM(STR(Kod_atr))+']-'+ALLTRIM(Name_atr)) DBSKIP(1) ENDDO * Формирование файла параметров 4223Param.CSV ***************************************************** PRIVATE aModName[10] aModName := {L('1. ABS - частный критерий: количество встреч сочетаний: "класс-признак" у объектов обуч.выборки '),; L('2. PRC1 - частный критерий: условная вероятность i-го признака среди признаков объектов j-го класса'),; L('3. PRC2 - частный критерий: условная вероятность i-го признака у объектов j-го класса '),; L('4. INF1 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC-1 '),; L('5. INF2 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC-2 '),; L('6. INF3 - частный критерий: Xи-квадрат, разности между фактическими и ожидаемыми абс.частотами '),; L('7. INF4 - частный критерий: ROI (Return On Investment); вероятности из PRC-1 '),; L('8. INF5 - частный критерий: ROI (Return On Investment); вероятности из PRC-2 '),; L('9. INF6 - частный критерий: разность условной и безусловной вероятностей; вероятности из PRC-1 '),; L('10.INF7 - частный критерий: разность условной и безусловной вероятностей; вероятности из PRC-2 ') } PUBLIC Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } CrLf = CHR(13)+CHR(10) // Конец строки (записи) m4324Param = 'Наименование приложения:#' + M_NameAppl + CrLf m4324Param = m4324Param + 'Наименование модели:#' + ALLTRIM(aModName[aParameters[1]]) + CrLf m4324Param = m4324Param + 'Код модели:#' + ALLTRIM(STR(aParameters[1])) + CrLf StrFile(m4324Param, '4324Param.CSV') // Создать CSV-файл со всеми ПАРАМЕТРАМИ для программы на Питоне: наименование приложения, наименование модели, вид когнитивной функции, наименования классификационной и описательной шкал и их градаций с кодами * После формирования матрицы 4224matrix.CSV и файлов параметров запустить внешнюю программу на Питоне _4224py.exe для визуализации и записи выходных форм с результатами кластеризации для заданной модели с заданными параметрами CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы * LC_RunShell("_4324py.exe",2053863690) // Мой вариант на Питоне/C++ <<<===################# * LC_RunShellAidosPy(717400306, "_4324py") // Мой вариант на Питоне в системе __AIDOS-PY.exe LC_RunShell("__AIDOS-PY.exe", 717400306, "_4324py") // Мой вариант на Питоне в системе __AIDOS-PY.exe DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций * Написать в каких моделях и какие выходные формы кластеризации созданы и в какие дирректории записаны // <<<===################### * aMess := {} * AADD(aMess, L('Генерация, визуализация и запись выходных форм кластеризации завершены успешно !!!')) * AADD(aMess, L('Выходные формы кластеризации созданы в модели:')+' '+ALLTRIM(aModName[aParameters[1]])) * AADD(aMess, L('Записаны эти выходные формы кластеризации в папку:')+' '+ALLTRIM(M_PathAppl)+'Clustering4.3.2.4. Классическая кластеризация признаков') // <<<===################### * LB_Warning(aMess, L('4.3.2.4. Классическая кластеризация признаков' )) ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) RETURN NIL /* *** (C) д.э.н., к.т.н., профессор Луценко Евгений Вениаминович, Россия, Краснодар. *** 11:13 10.06.2024 Конвертирование xls(x) файлов в DBF IV с любым допустимым в DBF числом полей (до 4096). *** Полный путь на xls(x) файл должен быть в файле: Converter_xlsx_to_dbf.txt, который должен быть в текущей папке работы программы. *** В результате конвертации в той же папке, в какой находится исходный файл, появляется файл с тем же именем, но с расширением DBF *** Первая строка xlsx файла рассматривается как строка с именами полей DBF файла. Типы данных в колонках те же, что в xlsx файле. */ #include "dcdir.ch" #include "natmsg.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 "dmlb.ch" #include "express.ch" #include "fileio.ch" #include "font.ch" #include "gra.ch" #include "inkey.ch" #include "memvar.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( "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("Taskbar.lib") #include "directry.ch" // 2.0 #pragma Library( "ASINet10.lib" ) // 2.0 PROCEDURE AppSys // Рабочий стол остается окном приложения RETURN ******************************************************************************** FUNCTION Main() LOCAL GetList[0], GetOptions, nColor, oMessageBox, oMenuWords, oDlg, n := 0, oPrinter DC_IconDefault(1000) PUBLIC Disk_name := DISKNAME() PUBLIC Cur_dir := CURDIR() PUBLIC Disk_dir := Disk_name+":\"+Cur_dir // Путь на папку с системой *********** Преобразование Excel-файлов в DBF **************** IF FILE('Converter_xlsx_to_dbf.txt') XlsxFileName = FileStr('Converter_xlsx_to_dbf.txt') * XlsxFileName = 'C:\AIDOS-X\AID_DATA\A0000005\System\SxodClsInf7.xlsx' // Пример ELSE LB_Warning('В текущей папке: "'+Disk_dir+'" отсутствует файл: "Converter_xlsx_to_dbf.txt" с именем xlsx-файла для конвертации в DBF-IV') RETURN NIL ENDIF mFlag = LC_Excel2WorkArea( XlsxFileName ) * XlsxFileName = 'C:\AIDOS-X\AID_DATA\A0000005\System\SxodClsInf7.xlsx' // Пример M_PathAppl = SUBSTR(XlsxFileName, 1, RAT('\', XlsxFileName)) * MsgBox(M_PathAppl) DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения ********** Структура создаваемой базы *********** Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } * XlsxFileName = 'C:\AIDOS-X\AID_DATA\A0000005\System\SxodClsInf7.xlsx' // Пример * 123456789012345678901234567890123456789012345678901 * 10 20 30 36 40 48 * 44 47 mPos1 = RAT('\', XlsxFileName)+8 mPos2 = RAT('.', XlsxFileName)-1 * MsgBox(STR(mPos1)+STR(mPos2)) M_Model = SUBSTR(XlsxFileName, mPos1, mPos2-mPos1+1) mClsAtr = SUBSTR(XlsxFileName, RAT('\', XlsxFileName)+5, 3) * MsgBox(M_Model+' '+mClsAtr) DO CASE CASE mClsAtr = 'Cls' ********************************************** *** РАСЧЕТ КЛАСТЕРОВ И КОНСТРУКТОВ КЛАССОВ *** ********************************************** ***** Создание баз кластеров и конструктов классов для разных моделей 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 ***** Отображение стадии исполнения в кратком варианте ***************************************** nMax = 2 * N_Cls ^ 2 nTime = 0 @ 4,5 DCPROGRESS oProgressm SIZE 150,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 DCREAD GUI TITLE 'Расчет кластеров и конструктов классов в модели: "'+M_Model+'"' PARENT @oDialogm FIT EXIT oDialogm:show() DC_GetProgress(oProgressm,0,nMax) ************************************************************************************************ ********** Структура создаваемой базы *********** 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 cFileName = "Klast"+mClsAtr+M_Model DbCreate( cFileName, aStructure ) 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 // Одна общая БД для всех конструктов всех моделей M_KlastCls = "KlastCls"+M_Model USE (M_KlastCls) EXCLUSIVE NEW 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" } * aSay[ 3]:SetCaption(L('3. Расчет кластеров и конструктов классов в модели:')+' '+ALLTRIM(STR(m))+'/10-'+M_Inf) M_SxodCls = "SxodCls"+M_Model USE (M_SxodCls) EXCLUSIVE NEW * MsgBox(M_SxodCls) mNumKlast = 0 // Номер кластера FOR mCls1 = 1 TO N_Cls // Цикл по классам заданного диапазона mNumKlast++ FOR mCls2 = 1 TO N_Cls // Цикл по классам заданного диапазона SELECT (M_SxodCls) DBGOTO(mCls2) mSxodstvo = FIELDGET(3+mCls1) mKodcls = n1 mKodclSc = n2 mNameCls = n3 SELECT KonstClsAll APPEND BLANK REPLACE Model WITH M_Model // Модель REPLACE Num_Klast WITH mNumKlast // Номер кластера REPLACE Kod_cls WITH mKodcls // Код класса REPLACE Kod_ClSc WITH mKodClSc // Код классификационной шкалы REPLACE Name_cls WITH mNameCls // Наименование класса REPLACE Sxodstvo WITH mSxodstvo // Сходство класса DC_GetProgress(oProgressm, ++nTime, nMax) // 1 * N_Cls ^ 2 NEXT 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"+M_Model IF FILE(M_KlastCls+'.dbf') // <<<===################# Если для расчета заданы не все модели, то некторые файлы могут быть не созданы SELECT (M_KlastCls) APPEND BLANK FOR j=1 TO LEN(Ar) FIELDPUT(j, Ar[j]) NEXT ENDIF DC_GetProgress(oProgressm, ++nTime, nMax) // 2 * N_Cls ^ 2 SELECT KonstClsAll DBSKIP(1) ENDDO ***** Копирование БД KonstClsTmp => KonstClsAll (Может быть использовать ADS_CopyFile()?) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций ERASE("KonstClsAll.dbf") COPY FILE ("KonstClsTmp.dbf") TO ("KonstClsAll.dbf") ERASE("KonstClsTmp.dbf") Name_SS = "SxodCls"+M_Model+".dbf" Name_DD = "SxodCls"+M_Model+".xls" * LB_Warning(L("Источник: "+Name_SS+", приемник: "+Name_DD) COPY FILE (Name_SS) TO (Name_DD) StrFile('', '_4221xBase.txt') // Признак, что режим _4221 на xBase++ завершился нормально CASE mClsAtr = 'Atr' ************************************************ *** РАСЧЕТ КЛАСТЕРОВ И КОНСТРУКТОВ ПРИЗНАКОВ *** ************************************************ ***** Создание баз кластеров и конструктов классов для разных моделей 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 ***** Отображение стадии исполнения в кратком варианте ***************************************** nMax = 2 * N_Atr ^ 2 nTime = 0 @ 4,5 DCPROGRESS oProgressm SIZE 150,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 DCREAD GUI TITLE 'Расчет кластеров и конструктов признаков в модели: "'+M_Model+'"' PARENT @oDialogm FIT EXIT oDialogm:show() DC_GetProgress(oProgressm,0,nMax) ************************************************************************************************ ********** Структура создаваемой базы *********** 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 cFileName = "Klast"+mClsAtr+M_Model DbCreate( cFileName, aStructure ) 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 // Одна общая БД для всех конструктов всех моделей M_KlastAtr = "KlastAtr"+M_Model USE (M_KlastAtr) EXCLUSIVE NEW SELECT Attributes aAtrKod = {} // Массив кодов всех признаков DBGOTOP() DO WHILE .NOT. EOF() AADD(aAtrKod, ALLTRIM(STR(Kod_atr))) DBSKIP(1) ENDDO **** Создать БД KonstClsAll, общую для всех кластеров и конструктов всех моделей Ar_Model := { "Abs","Prc1","Prc2","Inf1","Inf2","Inf3","Inf4","Inf5","Inf6","Inf7" } * aSay[ 3]:SetCaption(L('3. Расчет кластеров и конструктов классов в модели:')+' '+ALLTRIM(STR(m))+'/10-'+M_Inf) M_SxodAtr = "SxodAtr"+M_Model USE (M_SxodAtr) EXCLUSIVE NEW * MsgBox(M_SxodAtr) mNumKlast = 0 // Номер кластера FOR mAtr1 = 1 TO N_Atr // Цикл по классам заданного диапазона mNumKlast++ FOR mAtr2 = 1 TO N_Atr // Цикл по классам заданного диапазона SELECT (M_SxodAtr) DBGOTO(mAtr2) mSxodstvo = FIELDGET(3+mAtr1) mKodAtr = n1 mKodOpSc = n2 mNameAtr = n3 SELECT KonstAtrAll APPEND BLANK REPLACE Model WITH M_Model // Модель REPLACE Num_Klast WITH mNumKlast // Номер кластера REPLACE Kod_atr WITH mKodAtr // Код признака REPLACE Kod_OpSc WITH mKodOpSc // Код описательной шкалы REPLACE Name_atr WITH mNameAtr // Наименование признака ****************************************** ****** Обработка ошибки ****************** bError := ErrorBlock( {|e| Break(e)} ) // установить новый кодовый блок обработки ошибок BEGIN SEQUENCE // код нормального исполнения *** код нормального исполнения REPLACE Sxodstvo WITH mSxodstvo // Сходство признака RECOVER // код обработки ошибки REPLACE Sxodstvo WITH 0 // Сходство признака * EXIT ENDSEQUENCE ErrorBlock( bError ) // переустановить старый кодовый ****************************************** ****************************************** DC_GetProgress(oProgressm, ++nTime, nMax) // 1 * N_Atr ^ 2 NEXT 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_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 KonstAtrTmp APPEND BLANK FOR j=1 TO LEN(Ar) FIELDPUT(j, Ar[j]) NEXT ** Копирование записи в рассортированную БД (M_KlastCls) M_KlastAtr = "KlastAtr"+M_Model IF FILE(M_KlastAtr+'.dbf') // <<<===################# Если для расчета заданы не все модели, то некторые файлы могут быть не созданы SELECT (M_KlastAtr) APPEND BLANK FOR j=1 TO LEN(Ar) FIELDPUT(j, Ar[j]) NEXT ENDIF DC_GetProgress(oProgressm, ++nTime, nMax) // 2 * N_Cls ^ 2 SELECT KonstAtrAll DBSKIP(1) ENDDO ***** Копирование БД KonstAtrTmp => KonstAtrAll (Может быть использовать ADS_CopyFile()?) CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций ERASE("KonstAtrAll.dbf") COPY FILE ("KonstAtrTmp.dbf") TO ("KonstAtrAll.dbf") ERASE("KonstAtrTmp.dbf") Name_SS = "SxodAtr"+M_Model+".dbf" Name_DD = "SxodAtr"+M_Model+".xls" * LB_Warning(L("Источник: "+Name_SS+", приемник: "+Name_DD) COPY FILE (Name_SS) TO (Name_DD) StrFile('', '_4321xBase.txt') // Признак, что режим _4221 на xBase++ завершился нормально ENDCASE DC_GetProgress(oProgressm,nMax,nMax) oDialogm:Destroy() RETURN NIL *********************************************************************************************************************** FUNCTION LB_Warning( message, ctitle ) LOCAL aMsg := {} DEFAULT cTitle TO 'C° Система "Эйдос"' IF valtype(message) # 'A' aadd(aMsg,message) ELSE aMsg := message ENDIF IF LEN(ALLTRIM(cTitle)) > 0 DC_MsgBox(10,10,aMsg,cTitle) ELSE DC_MsgBox(10,10,aMsg,'C° Система "Эйдос"') ENDIF RETURN NIL *********************************************************************************************************************** ************************************************************************************* ******** Загрузка Excel-листа в DBF-таблицу по частям ************************************************************************************* ******************* ******** XLS => DBF ******************* FUNCTION LC_Excel2WorkArea( cExcelFile ) LOCAL lStatus := .f., oExcel, cPath, oSheet, oBook, aValues, i, j, ; aStru, xValue LOCAL oProgressm, oDialogm, lOk #if XPPVER > 1900000 // Create the "Excel.Application" object oExcel := CreateObject("Excel.Application") // Как определить, какой Excel проинсталлирован на компьютере: 2003 или 2007-2010 IF Empty( oExcel ) DC_WinAlert( "Excel is not installed" ) RETURN .f. ENDIF #else DC_WinAlert('This feature is available in Xbase++ 1.9 and later only!') RETURN .f. #endif oExcel:Visible := .f. // Load a Workbook from an .XLS file // Get path from ini file mPathFiles = SUBSTR(XlsxFileName, 1, RAT('\',XlsxFileName)) cDBaseFile = SUBSTR(XlsxFileName,RAT('\',XlsxFileName)+1, (RAT('.',XlsxFileName)-1)-(RAT('\',XlsxFileName)+1)+1) *MsgBox(mPathFiles+', '+cDBaseFile) DIRCHANGE(mPathFiles) // Папка с xlsx и dbf файлами *MsgBox(cExcelFile) IF !File(cExcelFile) LB_Warning( 'xlsx-файл: "'+ cExcelFile + '" для конвертации в DBF-IV не найден в папке: "' + Disk_dir + '"', 'Загрузка Excel-листа в DBF-таблицу' ) RETURN .F. ENDIF // Активизация чтения Excel-листа oScrn := DC_WaitOn( 'Открытие XLS-файла' ) oBook := oExcel:Workbooks:Open(cExcelFile) oSheet := oBook:activeSheet *aValues := oBook:workSheets(1):usedRange:value // Загрузка 1-го листа Excel-книги целиком // Определение количества строк и столбцов с данными в Excel-дисте без его загрузки в оперативную память oUsedRange := oSheet:usedRange N_Col := oUsedRange:Columns:Count() // Количество колонок с данными в xls-файле N_Rec := oUsedRange:Rows:Count() // Количество строк с данными в xls-файле DC_Impl(oScrn) ********* Сформировать файл Inp_name.txt // Наименования классификационных и описательных шкал // R1C1_A1() возвращает буквенные имена колонок по их номеру // чтобы сформировать текстовую переменную для обращения к Range() mLinkBlock = "A1:"+R1C1_A1(N_Col)+'1' // Традиционное буквенное обозначение столбцов xls-листа aValues := oUsedRange:Range(mLinkBlock):Value // Загрузка ДВУМЕРНОГО массива из одной строки с именами колонок 1-го листа Excel-книги PUBLIC aInp_name := aValues[1] // Присвоение массиву имен колонок aInp_name значений первой строки массива aValues // Убрать пробелы и записать массив имен колонок в виде файла FOR j=1 TO LEN(aInp_name) IF VALTYPE(aInp_name[j]) = 'C' aInp_name[j] = ALLTRIM(aInp_name[j]) ELSE Mess := {} AADD(Mess, 'Колонка "#" имеет не текстовое наименование.') AADD(Mess, 'Надо сделать правильное наименование или удалить колонку') Mess[1] = STRTRAN(Mess[1],"#",ALLTRIM(STR(j))) LB_Warning( Mess, 'Загрузка Excel-листа в DBF-таблицу' ) ENDIF NEXT * DC_ASave(aInp_name, "_ColumnNames.arx") // Запись массива наименований шкал (колонок) в виде файла * DC_ASave(aInp_name, "_Inp_name.arx") // Запись массива наименований шкал (колонок) в виде файла * aInp_name = DC_ARestore("_Inp_name.arx") // Загрузка массива наименований шкал (колонок) из файла // Проверка на то, что в 1-й строке ТЕКСТОВЫЙ тип данных (заголовки колонок), и, если нет, выдать сообщение об этом и выйти FOR j=1 TO N_Col IF VALTYPE(aInp_name[j]) <> 'C' * DC_WinAlert( 'В 1-й строке Excel-файла во всех столбцах должны быть текстовые заголовки колонок' ) Mess := {} AADD(Mess, 'В 1-й строке Excel-файла есть колонки без ТЕКСТОВЫХ заголовков, возможно правее колонок с данными') AADD(Mess, 'В 1-й строке Excel-файла ВО ВСЕХ столбцах, в т.ч. в 1-м, должны быть ТЕКСТОВЫЕ заголовки колонок') AADD(Mess, 'В 1-й строке Excel-файла не должно быть переносов слов, объединенных и пустых ячеек') AADD(Mess, 'В 1-й строке Excel-файла ДОПУСКАЮТСЯ заголовки, повернутые на 90 градусов') LB_Warning( Mess, 'Загрузка Excel-листа в DBF-таблицу' ) oBook:close() oBook:destroy() // Quit Excel oExcel:Quit() oExcel:Destroy() RETURN .F. ENDIF NEXT **** Наименования колонок со 1-й по последнюю CrLf = CHR(13)+CHR(10) // Конец строки (абзаца) (CrLf) mCol_name = "" FOR j=1 TO N_Col // 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-й по последнюю CrLf = CHR(13)+CHR(10) // Конец строки (абзаца) (CrLf) mCol_name = "" FOR j=2 TO N_Col // 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') // Добавить путь на папку Inp_data: Disk_dir+"/AID_DATA/Inp_data/" *StrFile(mCol_name, Disk_dir+'/AID_DATA/Inp_data/Inp_name.txt') *MsgBox(mCol_name) // Создание пустой dbf-таблицы для записи в нее данных из 1-го листа xls-файла ****************** // Определение структуры для dbf-таблицы по значениям всех строк (тип и формат данных в колонках) // На основе просмотра ВСЕГО xls-файла сделать массивы описания полей и для создания структуры брать MAX из каждого массива // В dbf-таблицу переносить данные, начиная со 2-й строки xls-листа // 1-ю строку с наименованиями полей использовать вместо Inp_name.txt или чтобы автоматически его делать aStructure := {} // Массив структуры dbf-таблицы PRIVATE aFieldName[N_col] // Наименования колонок для базы данных Inp_data.dbf PRIVATE aFieldType[N_Col] // Тип значений в j-й колонке (если есть хотя бы одно текстовое, то текстовое) PRIVATE aFieldSize[N_Col] // Максимальный размер значения в j-й колонке в символах (<=19 для числовых полей) PRIVATE aFieldInt [N_Col] // Максимальное количество значащих цифр до десятичной точки в значениях j-й колонки PRIVATE aFieldDeci[N_Col] // Максимальное количество значащих цифр после десятичной точки в значениях j-й колонки PRIVATE aFlag_neg [N_Col] // Флаг наличия отрицательных значений в j-й колонке AFILL(aFieldType, "X" ) AFILL(aFieldSize, 1 ) AFILL(aFieldInt , 1 ) AFILL(aFieldDeci, 0 ) AFILL(aFlag_neg , .F. ) // Если имена полей латинские оставить их, но заменить пробелы на "_" и обрезать до 12 символов // aInp_name - массив имен колонок исходного файла **** Проверить, есть ли в наименованиях колонок исходного файла символы, недопустимые в именах полей (русские, пробелы, спец.символы) Flag = .F. FOR j=1 TO LEN(aInp_name) FOR i=1 TO LEN(aInp_name[j]) s = ASC(SUBSTR(STRTRAN(ALLTRIM(aInp_name[j])," ","_"), i, 1)) IF (48 <= s .AND. s <= 57) .OR.; // Цифры (65 <= s .and. s <= 90) .OR.; // Латинские большие (97 <= s .and. s <=122) // Латинские маленькие ELSE Flag = .T. ENDIF NEXT NEXT IF Flag FOR j=1 TO N_Col aFieldName[j] = "N"+ALLTRIM(STR(j, 15)) NEXT ELSE FOR j=1 TO N_Col * aFieldName[j] = SUBSTR(ALLTRIM(STRTRAN(aInp_name[j]," ","_")), 1, 12) * aFieldName[j] = SUBSTR(ALLTRIM(STRTRAN(aInp_name[j]," ","_")), 1, 10) aFieldName[j] = "N"+ALLTRIM(STR(j, 15)) NEXT ENDIF // Здесь сделать цикл по загружаемым блокам xls-листа по N_BlockRec записей * N_Rec // Кол-во записей в исходном xls-файле * N_Col // Кол-во колонок в исходном xls-файле N_RecBlock = 65535 // Кол-во записей в блоке загрузки * N_RecBlock = 1024 // Кол-во записей в блоке загрузки N_Block = 1 + INT( N_Rec / N_RecBlock ) // Кол-во полных блоков загрузки N_RecBlockEnd = ABS( N_Rec - N_RecBlock * ( N_Block - 1 ) ) // Кол-во записей в споследнем (неполном) блоке загрузки, если он есть (число записей в нем > 0) ***** Отображение стадии исполнения в кратком варианте ***************************************** nMax = N_Col * N_Rec + N_Rec - 1 nTime = 0 @ 4,5 DCPROGRESS oProgressm SIZE 150,1.1 MAXCOUNT nMax COLOR GRA_CLR_CYAN PERCENT EVERY 100 DCREAD GUI TITLE 'Идет преобразование Excel-файла: "'+cExcelFile+'" в DBF-таблицу !!!' PARENT @oDialogm FIT EXIT oDialogm:show() DC_GetProgress(oProgressm,0,nMax) ************************************************************************************************ FOR j=1 TO N_Col // Цикл по колонкам блока загрузки FOR mNumBlock = 1 TO N_Block IF mNumBlock = 1 mRec1 = 2 + (mNumBlock - 1) * N_RecBlock // Начальная запись блока загрузки (в 1-м блоке наим.колонок здесь не загружать) ELSE mRec1 = 1 + (mNumBlock - 1) * N_RecBlock // Начальная запись блока загрузки ENDIF IF mNumBlock * N_RecBlock <= N_Rec mRec2 = mNumBlock * N_RecBlock // Конечная запись блока загрузки ELSE mRec2 = N_Rec // Конечная запись блока загрузки = конечной записи xls-листа ENDIF ********* Обработка случая, когда в файле 1 запись mFlagNRec = .T. IF mRec2 = mRec1 mRec2 = mRec1 + 1 mFlagNRec = .F. ENDIF mLinkBlock = R1C1_A1(j)+ALLTRIM(STR(mRec1,19))+":"+R1C1_A1(j)+ALLTRIM(STR(mRec2,19)) // Код обращения к j-му столбцу блока загрузки для Range() aValues := oUsedRange:Range(mLinkBlock):Value // Загрузка ДВУМЕРНОГО массива из одной строки с именами колонок 1-го листа Excel-книги * DC_DebugQout( aValues ) FOR i=1 TO mRec2 - mRec1 + IF(mFlagNRec,1,0) // Цикл по строкам блока загрузки (посчитать сколько в нем строк) * MsgBox(STR(mRec1)+STR(mRec2)+STR(i)) mFieldType = VALTYPE(aValues[i,1]) DO CASE CASE mFieldType = "C" // ************************************************************************** aFieldType[j] = "C" // Тип значений в j-й колонке (если есть хотя бы одно текстовое, то текстовое) * aFieldSize[j] = LEN(ALLTRIM(aValues[i,1])) * aFieldSize[j] = MAX(aFieldSize[j], LEN(ALLTRIM(aValues[i,1]))) * aFieldSize[j] = MAX(aFieldSize[j], LEN(ALLTRIM(aValues[i,1]))+32) // К длине текстового поля добавлять 32 символа для режима разделения классов на типичную и нетипичную части * aFieldSize[j] = IF(aFieldSize[j] <= 220, aFieldSize[j], 220 ) // <<<########################### aFieldSize[j] = 255 aFieldDeci[j] = 0 CASE mFieldType = "N" // ************************************************************************** IF aValues[i,1] < 0 aFlag_neg[j] = .T. ENDIF IF aFieldType[j] <> 'C' aFieldType[j] = 'N' ENDIF mVal = ALLTRIM(STR(aValues[i,1],15,7)) mVal = REMRIGHT(mVal,"0") // Убрать подряд идущие нули справа до 1-й значащей цифры Pos = AT('.', MVal) aFieldInt [j] = Pos - 1 // Определить число значащих цифр ДО запятой без ведущих нулей mFieldDeci = LEN(ALLTRIM(mVal)) - aFieldInt [j] - 1 * aFieldDeci[j] = MAX(aFieldDeci[j], mFieldDeci) aFieldDeci[j] = 7 // Всегда 7 знаков после запятой, в т.ч. и для целых, т.к. в шаг в Inp_sh * IF aFieldDeci[j] = 0 * aFieldDeci[j] = 1 // Целые не использовать, т.к. по ним не правильно индексируется * ELSE * aFieldDeci[j] = IF(aFieldDeci[j] <= 7, aFieldDeci[j], 7) // Ограничить точность исходных данных 7 десятичными знаками * ENDIF // Если с дробной частью, то плюс символ на точку // Если отрицательное, то символ на знак * aFieldSize[j] = MAX(aFieldSize[j], aFieldInt[j] + aFieldDeci[j] + 1 + IF(aFlag_neg[j],1,0)) * aFieldSize[j] = IF(aFieldSize[j]<=19, aFieldSize[j], 19) // В Excel числовые поля не могут больше 19 символов aFieldSize[j] = 19 // Всегда 19 знаков, т.к. в Excel числовые поля не могут больше 19 символов CASE mFieldType = "D" .OR. mFieldType = "X" // **************************************************** aFieldType[j] = "C" aFieldSize[j] = 255 aFieldDeci[j] = 0 OTHERWISE aFieldType[j] = "C" aFieldSize[j] = 255 aFieldDeci[j] = 0 ENDCASE * aFieldSize[j] = IF(aFieldSize[j]<= 250,aFieldSize[j], 250) aFieldSize[j] = IF(aFieldSize[j]<=32000,aFieldSize[j],32000) DC_GetProgress(oProgressm, ++nTime, nMax) NEXT NEXT // Ограничить точность исходных данных 7 десятичными знаками // Ограничить длину имени поля 10 знаками * AADD(aStructure, { aFieldName[j] , aFieldType[j], aFieldSize[j]+7-aFieldDeci[j], 7 }) // Добавить строку в структуру dbf-таблицы AADD(aStructure, { SUBSTR(ALLTRIM(aFieldName[j]),1,10) , aFieldType[j], aFieldSize[j] , aFieldDeci[j] }) // Добавить строку в структуру dbf-таблицы NEXT ******** Иногда невозможно создать базу данных, если она пуста, тогда возникает ошибка <<<############ *MsgBox(cDBaseFile) // Отладка *aDir := directory() // Отладка *DC_ArrayView( aStructure ) // Отладка *DC_DebugQout( aStructure ) // Отладка *LB_Warning('Stop') CLOSE ALL DbCreate( cDBaseFile, aStructure ) // Создание файла Inp_data.dbf (или другого, например, Inp_rasp.dbf) по сформированной структуре ***** Цикл переноса данных из xls-листа в dbf-таблицу CLOSE ALL USE (cDBaseFile) EXCLUSIVE NEW SELECT(cDBaseFile) *MsgBox(STR(FCOUNT())) // Сдесь сделать цикл по загружаемым блокам xls-листа по N_BlockRec записей * N_Rec // Кол-во записей в исходном xls-файле * N_Col // Кол-во колонок в исходном xls-файле * N_RecBlock = 65535 // Кол-во записей в блоке загрузки N_RecBlock = 1024 // Кол-во записей в блоке загрузки N_Block = 1 + INT( N_Rec / N_RecBlock ) // Кол-во полных блоков загрузки N_RecBlockEnd = ABS( N_Rec - N_RecBlock * ( N_Block - 1 ) ) // Кол-во записей в споследнем блоке FOR mNumBlock = 1 TO N_Block IF mNumBlock = 1 mRec1 = 2 + (mNumBlock - 1) * N_RecBlock // Начальная запись блока загрузки (в 1-м блоке наим.колонок здесь не загружать) ELSE mRec1 = 1 + (mNumBlock - 1) * N_RecBlock // Начальная запись блока загрузки ENDIF IF mNumBlock * N_RecBlock <= N_Rec mRec2 = mNumBlock * N_RecBlock // Конечная запись блока загрузки ELSE mRec2 = N_Rec // Конечная запись блока загрузки = конечной записи xls-листа ENDIF mLinkBlock = "A"+ALLTRIM(STR(mRec1,19))+":"+R1C1_A1(N_Col)+ALLTRIM(STR(mRec2,19)) // Код обращения к блоку загрузки для Range() aValues := oUsedRange:Range(mLinkBlock):Value // Загрузка ДВУМЕРНОГО массива из одной строки с именами колонок 1-го листа Excel-книги FOR i=1 TO mRec2 - mRec1 + 1 // Цикл по строкам блока загрузки (посчитать сколько в нем строк) APPEND BLANK FOR j=1 TO N_Col // Цикл по колонкам блока загрузки // Преобразовывать значения с типами числа и даты в текст, если тип поля текст DO CASE CASE VALTYPE(aValues[i,j]) = 'C' .AND. aFieldType[j] = 'C' FIELDPUT(j, SUBSTR(aValues[i,j],1,aFieldSize[j])) // Просто занести CASE VALTYPE(aValues[i,j]) = 'N' .AND. aFieldType[j] = 'N' FIELDPUT(j, VAL(STR(aValues[i,j], aFieldSize[j], aFieldDeci[j] ))) // Просто занести CASE VALTYPE(aValues[i,j]) = 'N' .AND. aFieldType[j] = 'C' FIELDPUT(j, STR(aValues[i,j], aFieldSize[j], aFieldDeci[j] )) // Преобразовать число к текстовому виду CASE VALTYPE(aValues[i,j]) = 'D' .AND. aFieldType[j] = 'C' FIELDPUT(j, DTOC(aValues[i,j])) // Преобразовать дату к текстовому виду ENDCASE NEXT DC_GetProgress(oProgressm, ++nTime, nMax) NEXT NEXT DC_GetProgress(oProgressm,nMax,nMax) oDialogm:Destroy() oBook:close() oBook:destroy() // Quit Excel oExcel:Quit() oExcel:Destroy() CLOSE ALL oSheet := nil oUsedRange := nil aValues := nil DIRCHANGE(Disk_dir) // Папка с программой конвертации RETURN .T. * ###################### Окончание программы конвертации XLS -> DBF ################# ******** Функция преобразования номера колонки в ее буквенное наименование FUNCTION R1C1_A1(mNumColumn) aLiterCol := {} ******** Однобуквенные наименования столбцов FOR j1=1 TO 26 AADD(aLiterCol, CHR(j1+64)) NEXT *DC_DebugQout( { aLiterCol } ) ******** Двухбуквенные наименования столбцов FOR j1=1 TO 26 FOR j2=1 TO 26 AADD(aLiterCol, CHR(j1+64)+CHR(j2+64)) NEXT NEXT ******** Трехбуквенные наименования столбцов FOR j1=1 TO 26 FOR j2=1 TO 26 FOR j3=1 TO 26 AADD(aLiterCol, CHR(j1+64)+CHR(j2+64)+CHR(j3+64)) NEXT NEXT NEXT RETURN(aLiterCol[mNumColumn]) ************************************** * cEnde := ZAHL2CHR(numColumns) * aExcel := oSheet:range( "A1:"+cEnde+LTRIM(STR(numRows)) ):value FUNCTION ZAHL2CHR(numColumns) LOCAL nMal LOCAL cEnde IF numColumns > 26 nMal := INT(numColumns/26) cEnde := CHR(nMal+64)+CHR((numColumns-(nMal*26))+64) ELSE cEnde := CHR(numColumns+64) ENDIF RETURN cEnde ****************************************************************************************** ****************************************************************************************** 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 ****************************************************************************************** *********************************************************************************************************** ****** Графический прогресс-бар (на основе примера XSample_14() xdemo.exe) *********************************************************************************************************** FUNCTION Time_Progress(Time_Progress, Wsego, oProgress, lOk ) LOCAL nMaxCount := Wsego xtime = Time_Progress ** Отображение занимает очень много времени, поэтому показывать прогресс не чаще чем через 0.1 секунды (как в PercTimeVisio()) * T2tp = (DOY(DATE())-1)*86400+SECONDS() // Текущее время * IF T2tp - T1tp > 0.1 .OR. xtime = Wsego // Время в секундах или 100% * aSay[mPTVnumb]:SetCaption(mPTVmess+' '+ALLTRIM(STR(mNumPP/Wsego*100,15,7))+'%') *** Индикация времени исполнения ***** Процесс может идти больше суток, поэтому для определения ***** во всех случаях вычисляется время, прошедшее с начала года * T_Mess1 = "Начало:"+" "+TIME() // Начало ***** Прошло секунд с начала процесса PUBLIC T_Mess2 := "ch:mi:se" 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 // Секунды T_Mess2 = "Прошло:"+" "+ALLTRIM(STRTRAN(T_Mess2,"ch",STR(ch2,19))) T_Mess2 = STRTRAN(T_Mess2,"mi",STRTRAN(STR(mm2,2)," ","0")) T_Mess2 = STRTRAN(T_Mess2,"se",STRTRAN(STR(cc2,2)," ","0")) *@19,2 SAY T_Mess2+" всего: "+ALLTRIM(STR(Sec_2,17))+" сек." PUBLIC T_Mess3 := "ch:mi:se" // Осталось Sec_3 = Sec_2*Wsego/xtime // Прогн.длит.исп. в секундах ch3 = INT(Sec_3/3600) // Часы mm3 = INT(Sec_3/60)-ch3*60 // Минуты cc3 = Sec_3-ch3*3600-mm3*60 // Секунды T_Mess3 = ALLTRIM(STRTRAN(T_Mess3,"ch",STR(ch3,19))) T_Mess3 = STRTRAN(T_Mess3,"mi",STRTRAN(STR(mm3,2)," ","0")) T_Mess3 = STRTRAN(T_Mess3,"se",STRTRAN(STR(cc3,2)," ","0")) *@20,2 SAY T_Mess3+" всего: "+ALLTRIM(STR(Sec_3,17))+" сек." PUBLIC T_Mess4 := "ch:mi:se" // Окончание Sec_4 = Sec_1 + Sec_3 - (DOY(DATE())-1)*86400 ch4 = INT(Sec_4/3600) // Часы mm4 = INT(Sec_4/60)-ch4*60 // Минуты cc4 = Sec_4-ch4*3600-mm4*60 // Секунды T_Mess4 = "Окончание:"+" "+ALLTRIM(STRTRAN(T_Mess4,"ch",STR(ch4,19))) T_Mess4 = STRTRAN(T_Mess4,"mi",STRTRAN(STR(mm4,2)," ","0")) T_Mess4 = STRTRAN(T_Mess4,"se",STRTRAN(STR(cc4,2)," ","0")) *@21,2 SAY T_Mess4+" всего: "+ALLTRIM(STR(Sec_4,17L())+" сек.с нач.суток") PUBLIC T_Mess5 := "Средн.время обработки 1-го объекта: ch:mi:se" Sec_5 = Sec_2/xtime ch5 = INT(Sec_5/3600) // Часы mm5 = INT(Sec_5/60)-ch5*60 // Минуты cc5 = Sec_5-ch5*3600-mm5*60 // Секунды T_Mess5 = ALLTRIM(STRTRAN(T_Mess5,"ch",STR(ch5,19))) T_Mess5 = STRTRAN(T_Mess5,"mi",STRTRAN(STR(mm5,2)," ","0")) T_Mess5 = STRTRAN(T_Mess5,"se",STRTRAN(STR(cc5,2)," ","0")) *@22,2 SAY T_Mess5+" всего: "+ALLTRIM(STR(Sec_5,17))+" сек." PUBLIC T_Mess6 := "ch:mi:se" // Осталось Sec_6 = Sec_3 - Sec_2 ch6 = INT(Sec_6/3600) // Часы mm6 = INT(Sec_6/60)-ch6*60 // Минуты cc6 = Sec_6-ch6*3600-mm6*60 // Секунды T_Mess6 = "Осталось:"+" "+ALLTRIM(STRTRAN(T_Mess6,"ch",STR(ch6,19))) T_Mess6 = STRTRAN(T_Mess6,"mi",STRTRAN(STR(mm6,2)," ","0")) T_Mess6 = STRTRAN(T_Mess6,"se",STRTRAN(STR(cc6,2)," ","0")) *@23,2 SAY T_Mess6+" всего: "+ALLTRIM(STR(Sec_6,17))+" сек." Mess98 = T_Mess1+SPACE(142-LEN(T_Mess1)-LEN(T_Mess4))+T_Mess4 // Начало, окончание (прогноз) 145 oSay98:SetCaption(Mess98);oSay98:SetCaption(oSay98:caption) // <<<===##################### ERROR после F2_3_2_2() Mess99 = T_Mess2+SPACE(144-LEN(T_Mess2)-LEN(T_Mess6))+T_Mess6 // Прошло, осталось (прогноз) 146 oSay99:SetCaption(Mess99);oSay99:SetCaption(oSay99:caption) // <<<===##################### ERROR после F2_3_2_2() DC_GetProgress( oProgress, Time_Progress, Wsego ) // Отображение графического Progress-bar * Sec_1 // Начало * Sec_4 // Окончание * Sec_2 // Прошло секунд с начала процесса * Sec_6 // Осталось секунд до окончания * mTimeProgress=ROUND(Sec_2/(Sec_2+Sec_6)*100,0) * DC_GetProgress( oProgress, mTimeProgress, 100 ) // Отображение графического Progress-bar * DC_GetProgress( oProgress, ROUND(Sec_2,0), ROUND(Sec_2+Sec_6,0) ) // Отображение графического Progress-bar * MsgBox(STR(ROUND(Sec_2,0))+STR(ROUND(Sec_2+Sec_6,0))) * MsgBox(STR(mTimeProgress)) * MILLISEC(1000) * K=100/Wsego;mTimeProgress=ROUND(K*Time_Progress,0) * DC_GetProgress( oProgress, mTimeProgress, 100 ) // Отображение графического Progress-bar DC_AppEvent( @lOk, 0, .01 ) * T1tp = T2tp * ENDIF RETURN lOk ****************************************************************************************************************************************** FUNCTION DC_GetProgress( oProgress, nCurrCount, nMaxCount, nEvery, lBar ) LOCAL nX, aSize, aAttr[ GRA_AA_COUNT], lClear, lVertical, aPoints, ; aAttrS[ GRA_AS_COUNT ], aPos, aPos2[2], nPercent, cPercent, ; nWidth, nHeight, nOldPercent IF Valtype(oProgress) # 'O' RETURN nil ELSE DEFAULT nCurrCount := 0 DEFAULT nMaxCount := oProgress:maxCount DEFAULT nEvery := oProgress:every DEFAULT lVertical := oProgress:vertical IF nEvery > 0 .AND. nCurrCount % Int(nEvery) # 0 .AND. ; Valtype(nMaxCount) = 'N' .AND. nCurrCount < nMaxCount RETURN nil ENDIF ENDIF DEFAULT lBar := .t. IF nMaxCount = 0 nPercent := 0 ELSE nPercent := nCurrCount/nMaxCount ENDIF IF nMaxCount == 0 nOldPercent := 0 ELSE nOldPercent := oProgress:currCount/nMaxCount ENDIF lClear := nCurrCount <= oProgress:currCount IF Valtype(nMaxCount) = 'N' oProgress:maxCount := nMaxCount ELSE nMaxCount := oProgress:maxCount ENDIF IF lBar IF lVertical aSize := { oProgress:currentSize()[2], oProgress:currentSize()[1] } ELSE aSize := oProgress:currentSize() ENDIF aSize[1] -= 2 aSize[2] -= 2 IF nMaxCount > 0 nX := aSize[1] * ( nCurrCount / nMaxCount ) ELSE nX := 0 ENDIF nX := Min( nX, aSize[1] ) // Calculate width for rectangle IF nX <= 0 nX := 1 ENDIF IF Valtype(oProgress:presSpace) # 'O' oProgress:presSpace := oProgress:lockPS() ENDIF IF lClear .OR. ( oProgress:percent .AND. !oProgress:dynamic ) .OR. nPercent < .1 aAttr[ GRA_AA_COLOR ] := oProgress:backColor GraSetAttrArea( oProgress:presSpace, aAttr ) GraBox( oProgress:presSpace, {1,1}, ; IIF( lVertical, {aSize[2], aSize[1]},{aSize[1], aSize[2]}), GRA_FILL ) lClear := .T. ENDIF aAttr[ GRA_AA_COLOR ] := oProgress:barColor GraSetAttrArea( oProgress:presSpace, aAttr ) IF Int(nOldPercent*100) # Int(nPercent*100) .OR. lClear GraBox( oProgress:presSpace, {1,1}, ; IIF( lVertical, {aSize[1],nX},{nX, aSize[2]} ), ; IIF( oProgress:outline,GRA_OUTLINEFILL,GRA_FILL ), ; oProgress:radius, oProgress:radius ) ENDIF ENDIF IF oProgress:percent IF lVertical aSize := { oProgress:currentSize()[2], oProgress:currentSize()[1] } ELSE aSize := oProgress:currentSize() ENDIF IF Int(nOldPercent*100) # Int(nPercent*100) .OR. lClear .OR. nCurrCount >= nMaxCount cPercent := Str(100*nPercent,10,5)+"%" aPoints := GraQueryTextBox( oProgress:presSpace, cPercent ) nWidth := aPoints[3,1] - aPoints[1,1] nHeight := aPoints[1,2] - aPoints[2,2] IF oProgress:dynamic aPos2[1] := (nX-nWidth) / 2 IF aPos2[1] < 2 aPos2[1] := 2 ENDIF ELSE aPos2[1] := ( aSize[1] - nWidth ) / 2 ENDIF aPos2[2] := (( aSize[2] - nHeight ) / 2) + 2 IF Valtype( oProgress:percentColor ) == 'N' aAttrs[ GRA_AS_COLOR ] := oProgress:percentColor ENDIF GraSetAttrString( oProgress:presSpace, aAttrS ) GraStringAt( oProgress:presSpace, aPos2, cPercent ) ENDIF ENDIF oProgress:currCount := nCurrCount RETURN .t. ************************************************************************************************************************************************************************ ******** 3.8 Оценивается достоверность (адекватность) всех моделей различных уровней ******** (#={1,2}) и способов нормализации (@), ранее созданных в режиме 3.5 с момента ******** создания приложения. Для этого используются базы данных, ранее созданные ******** режимом 3.5 при создании и верификации моделей: Dost_modCls_basic_level.dbf; ******** Dost_modCls_#nd_level_@.dbf, Dost_modClsALL.dbf, находящиеся в папке текущего приложения ****************************************************************************************************** #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 ****************************************************************************************************** ******** 3.8 Оценивается достоверность (адекватность) всех моделей различных уровней ******** (#={1,2}) и способов нормализации (@), ранее созданных в режиме 3.5 с момента ******** создания приложения. Для этого используются базы данных, ранее созданные ******** режимом 3.5 при создании и верификации моделей: Dost_modCls_basic_level.dbf; ******** Dost_modCls_#nd_level_@.dbf, Dost_modClsALL.dbf, находящиеся в папке текущего приложения ****************************************************************************************************** FUNCTION F3_8(mPar) LOCAL GetList := {}, aPres, oBrowse, oToolBar, aColors, bColor, GetOptions PUBLIC mWindow := 17 // Интервал сглаживания Running(.T.) IF M_KodAdmAppls = 0 // Выйти из системы если нет авторизации LB_Warning(L("Вы не авторизовались в системе (режим 1.1) и не можете ей пользоваться!")) Running(.F.) RETURN NIL ENDIF mRegim = IF(mPar='4.1.3.6.', 'F4.1.3.6()', 'F3.8()') mFlag = .F. IF ApplChange(mRegim) // Если не запущен режим, работающий с БД, то перейти в папку выбранного приложения mFlag = .T. ENDIF IF .NOT. FILE('Dost_modClsALL.dbf') .OR. .NOT. FILE('DostRasp.dbf') LB_Warning(L("Необходимо выполнить режим: 3.5. Синтез и верификация моделей")) mFlag = .T. ENDIF IF .NOT. FILE("Rasp.txt") LB_Warning(L("Необходимо выполнить режим: 3.5. Синтез и верификация моделей")) mFlag = .T. ELSE * StrFile("35", "Rasp.txt") // Запись текстового файла с информацией о том, что был выполнен режим 3.5 mRasp = FileStr("Rasp.txt") IF mRasp <> '35' LB_Warning(L("Необходимо выполнить режим: 3.5. Синтез и верификация моделей")) 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 *################################################################ <<<===############# Здесь был блок, который теперь в конце 3.5, если было распознавние ****** Поиск строк с максимальным значением F-меры, L1-меры и L2-меры CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE DostRasp EXCLUSIVE NEW USE Dost_modClsALL EXCLUSIVE NEW SELECT Dost_modClsALL DBGOTOP() M_MaxValF = -9999999999 DO WHILE .NOT. EOF() M_MaxValF = MAX(M_MaxValF, Dost_modClsALL->F_mera) DBSKIP(1) ENDDO DBGOTOP() M_MaxValL1 = -9999999999 DO WHILE .NOT. EOF() M_MaxValL1 = MAX(M_MaxValL1, Dost_modClsALL->L1_mera) DBSKIP(1) ENDDO DBGOTOP() M_MaxValL2 = -9999999999 DO WHILE .NOT. EOF() M_MaxValL2 = MAX(M_MaxValL2, Dost_modClsALL->L2_mera) DBSKIP(1) ENDDO DBGOTOP() /* ----- Create ToolBar ----- */ *** Задать модель ********************************** PUBLIC Ar_Model := {"Abs", "Prc1", "Prc2", "Inf1", "Inf2", "Inf3", "Inf4", "Inf5", "Inf6", "Inf7" } mMaxLen = -999999999999 SELECT Dost_modClsALL DBGOTOP() DO WHILE .NOT. EOF() mMaxLen = MAX(mMaxLen, LEN(ALLTRIM(Type_Model))) DBSKIP(1) ENDDO mMaxLen = mMaxLen * 0.5 mWindowWidth = mMaxLen + 131 mWindowHeight = 40 mLen1 = LEN(L("Помощь по мерам достоверности")) mLen2 = LEN(L("Помощь по частотным распределениям")) @ mWindowHeight+1.5, 0 DCTOOLBAR oToolBar SIZE mLen1, 1.5 DCADDBUTTON CAPTION L('Помощь по мерам достоверности') ; SIZE mLen1-2 ; ACTION {||Help4136(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Помощь по мерам достоверности') @ mWindowHeight+1.5, mLen1+1 DCTOOLBAR oToolBar SIZE mLen2, 1.5 DCADDBUTTON CAPTION L('Помощь по частотным распределениям') ; SIZE mLen2-2 ; ACTION {||Help41311(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Помощь по частотным распределениям') @ mWindowHeight+1.5, mLen1+mLen2+1 DCTOOLBAR oToolBar SIZE LEN(L("Сортировка по F-мере Ван Ризбергена"))+LEN(L("Сортировка по L1 мере проф.Е.В.Луценко"))+LEN(L("Сортировка по L2 мере проф.Е.В.Луценко"))+LEN(L("Без сортировки"))-5, 1.5 DCADDBUTTON CAPTION L('Сортировка по F-мере Ван Ризбергена') ; SIZE LEN(L("Сортировка по F-мере Ван Ризбергена"))+2 ; ACTION {||SortALL_F(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; FONT '9.Arial Bold' ; TOOLTIP L('Сортировка по F-мере Ван Ризбергена') DCADDBUTTON CAPTION L('Сортировка по L1 мере проф.Е.В.Луценко') ; SIZE LEN(L("Сортировка по L1 мере проф.Е.В.Луценко"))-4 ; ACTION {||SortALL_L1(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Сортировка по L1 мере проф.Е.В.Луценко') DCADDBUTTON CAPTION L('Сортировка по L2 мере проф.Е.В.Луценко') ; SIZE LEN(L("Сортировка по L2 мере проф.Е.В.Луценко"))-4 ; ACTION {||SortALL_L2(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Сортировка по L2 мере проф.Е.В.Луценко') DCADDBUTTON CAPTION L('Без сортировки') ; SIZE LEN(L("Без сортировки"))-0 ; ACTION {||WithoutSorting(), DC_GetRefresh(GetList)} ; PARENT oToolBar ; TOOLTIP L('Без сортировки') /* ----- Create browse ----- */ 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 *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}))) } // Клиффорд *@ .. DCBROWSE .. COLOR {||IIF(Recno()%2==0,{nil,GRA_CLR_PALEGRAY},{nil,GRA_CLR_WHITE})} // Управление фоном отображения строки от Роджера DO CASE CASE M_MaxValF <= M_MaxValL1 .AND. M_MaxValL1 <= M_MaxValL2 @ 1, 0 DCBROWSE oBrowse ALIAS 'Dost_modClsALL' SIZE mWindowWidth, mWindowHeight ; PRESENTATION LC_BrowPres() ; // Только просмотр БД Users HEADLINES 4 ; // Кол-во строк в заголовке FREEZELEFT {1,2} ; // При горизонтальной прокрутке не прокручивать первые 2 колонки COLOR {||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})))} CASE M_MaxValF <= M_MaxValL2 .AND. M_MaxValL2 <= M_MaxValL1 @ 1, 0 DCBROWSE oBrowse ALIAS 'Dost_modClsALL' SIZE mWindowWidth, mWindowHeight ; PRESENTATION LC_BrowPres() ; // Только просмотр БД Users HEADLINES 4 ; // Кол-во строк в заголовке FREEZELEFT {1,2} ; // При горизонтальной прокрутке не прокручивать первые 2 колонки COLOR {||IIF(L1_mera=M_MaxValL1, {nil,aColor[107]},IIF(L2_mera=M_MaxValL2,{nil,aColor[153]},IIF(F_mera=M_MaxValF,{nil,aColor[33]},{nil,GRA_CLR_WHITE})))} CASE M_MaxValL1 <= M_MaxValF .AND. M_MaxValF <= M_MaxValL2 @ 1, 0 DCBROWSE oBrowse ALIAS 'Dost_modClsALL' SIZE mWindowWidth, mWindowHeight ; PRESENTATION LC_BrowPres() ; // Только просмотр БД Users HEADLINES 4 ; // Кол-во строк в заголовке FREEZELEFT {1,2} ; // При горизонтальной прокрутке не прокручивать первые 2 колонки COLOR {||IIF(L2_mera=M_MaxValL2, {nil,aColor[153]},IIF(F_mera =M_MaxValF,{nil,aColor[33]},IIF(L1_mera=M_MaxValL1,{nil,aColor[107]},{nil,GRA_CLR_WHITE})))} CASE M_MaxValL1 <= M_MaxValL2 .AND. M_MaxValL2 <= M_MaxValF @ 1, 0 DCBROWSE oBrowse ALIAS 'Dost_modClsALL' SIZE mWindowWidth, mWindowHeight ; PRESENTATION LC_BrowPres() ; // Только просмотр БД Users HEADLINES 4 ; // Кол-во строк в заголовке FREEZELEFT {1,2} ; // При горизонтальной прокрутке не прокручивать первые 2 колонки COLOR {||IIF(F_mera=M_MaxValF, {nil,aColor[33]},IIF(L2_mera=M_MaxValL2,{nil,aColor[153]},IIF(L1_mera=M_MaxValL1,{nil,aColor[107]},{nil,GRA_CLR_WHITE})))} CASE M_MaxValL2 <= M_MaxValF .AND. M_MaxValF <= M_MaxValL1 @ 1, 0 DCBROWSE oBrowse ALIAS 'Dost_modClsALL' SIZE mWindowWidth, mWindowHeight ; PRESENTATION LC_BrowPres() ; // Только просмотр БД Users HEADLINES 4 ; // Кол-во строк в заголовке FREEZELEFT {1,2} ; // При горизонтальной прокрутке не прокручивать первые 2 колонки COLOR {||IIF(L1_mera=M_MaxValL1, {nil,aColor[107]},IIF(F_mera=M_MaxValF,{nil,aColor[33]},IIF(L2_mera=M_MaxValL2,{nil,aColor[153]},{nil,GRA_CLR_WHITE})))} CASE M_MaxValL2 <= M_MaxValL1 .AND. M_MaxValL1 <= M_MaxValF @ 1, 0 DCBROWSE oBrowse ALIAS 'Dost_modClsALL' SIZE mWindowWidth, mWindowHeight ; PRESENTATION LC_BrowPres() ; // Только просмотр БД Users HEADLINES 4 ; // Кол-во строк в заголовке FREEZELEFT {1,2} ; // При горизонтальной прокрутке не прокручивать первые 2 колонки COLOR {||IIF(F_mera=M_MaxValF, {nil,aColor[33]},IIF(L1_mera=M_MaxValL1,{nil,aColor[107]},IIF(L2_mera =M_MaxValL2,{nil,aColor[153]},{nil,GRA_CLR_WHITE})))} ENDCASE * Структура базы данных N°=22: Dost_modClsALL.dbf * ============================================================================ * | N | Имя поля | Тип | Ширина | Дес. | Примечание | * ============================================================================ * | 1 | TYPE_MODEL | C | 250 | 0 | * | 2 | INT_KRIT | C | 40 | 0 | * | 3 | N_LOGOBJ | N | 15 | 0 | 3. Количество логических объектов расп.выборки, фактически относящихся к классу (TP+FN) * | 4 | N_T_IDENT | N | 15 | 0 | 4. Количество верно идентифицированных объектов расп.выборки (TP) * | 5 | N_F_NIDENT | N | 15 | 0 | 5. Количество ошибочно неидентифицированных объектов расп.выборки (FN) * | 6 | N_F_IDENT | N | 15 | 0 | 6. Количество ошибочно идентифицированных объектов расп.выборки (FP) * | 7 | N_T_NIDENT | N | 15 | 0 | 7. Количество верно неидентифицированных объектов расп.выборки (TN) * | 8 | P_T_IDENT | N | 15 | 7 | 8. Вероятность верной идентификации объекта с классом с использованием модели * | 9 | P_T_NIDENT | N | 15 | 7 | 9. Вероятность верной не идентификации объекта с классом с использованием модели * | 10 | P_F_IDENT | N | 15 | 7 | 10.Вероятность ошибочной идентификации объекта с классом с использованием модели * | 11 | P_F_NIDENT | N | 15 | 7 | 11.Вероятность ошибочной не идентификации объекта с классом с использованием модели * | 12 | P_AVR_T | N | 15 | 7 | 12.Вероятность верной идентификации или неидентификации объекта с классом с использованием модели (моя мера) * | 13 | DVMOD | N | 15 | 7 | 13.M_DVMod = (NT-NF)/(NT+NF)*100 Моя мера качества модели-классификатора (в знаменателе: "всего объектов") * | 14 | PRECISION | N | 15 | 7 | 14.Precision = TP/(TP+FP) - точность * | 15 | RECALL | N | 15 | 7 | 15.Recall = TP/(TP+FN) - полнота * | 16 | F_MERA | N | 15 | 7 | 16.F-mera = 2*(Precision*Recall)/(Precision+Recall) (мультиклассовый вариант) * | 17 | S_T_IDENT | N | 15 | 7 | 17.Сумма модулей уровней сходства верно идентифицированных объектов расп.выборки (STP) * | 18 | S_F_NIDENT | N | 15 | 7 | 18.Сумма модулей уровней сходства ошибочно неидентифицированных объектов расп.выборки (SFN) * | 19 | S_F_IDENT | N | 15 | 7 | 19.Сумма модулей уровней сходства ошибочно идентифицированных объектов расп.выборки (SFP) * | 20 | S_T_NIDENT | N | 15 | 7 | 20.Сумма модулей уровней сходства верно неидентифицированных объектов расп.выборки (STN) * | 21 | SPRECISION | N | 15 | 7 | 21.SPrecision = STP/(STP+SFP) - точность с учетом уровней сходства * | 22 | SRECALL | N | 15 | 7 | 22.SRecall = STP/(STP+SFN) - полнота с учетом уровней сходства * | 23 | L1_MERA | N | 15 | 7 | 23.L1-mera = 2*(SPrecision*SRecall)/(SPrecision+SRecall) (L1-мера проф.Е.В.Луценко - нечеткое мультиклассовое обобщение * | 24 | A_T_IDENT | N | 15 | 7 | 17.Среднее модулей уровней сходства верно идентифицированных объектов расп.выборки (ATP=STP/TP) * | 25 | A_F_NIDENT | N | 15 | 7 | 18.Среднее модулей уровней сходства ошибочно неидентифицированных объектов расп.выборки (AFN=SFN/FN) * | 26 | A_F_IDENT | N | 15 | 7 | 19.Среднее модулей уровней сходства ошибочно идентифицированных объектов расп.выборки (AFP=SFP/FP) * | 27 | A_T_NIDENT | N | 15 | 7 | 20.Среднее модулей уровней сходства верно неидентифицированных объектов расп.выборки (ATN=STN/TN) * | 28 | APRECISION | N | 15 | 7 | 21.APrecision = ATP/(ATP+AFP) - точность с учетом уровней сходства * | 29 | ARECALL | N | 15 | 7 | 22.ARecall = ATP/(ATP+AFN) - полнота с учетом уровней сходства * | 30 | L2_MERA | N | 15 | 7 | 23.L2-mera = 2*(APrecision*ARecall)/(APrecision+ARecall) (L2-мера проф.Е.В.Луценко - нечеткое мультиклассовое обобщение * | 31 | DATE | C | 10 | 0 | 24. Date Дата формирования записи БД * | 32 | TIME | C | 8 | 0 | 25. Time Время формирования записи БД * ============================================================================ * В С Е Г О длина записи: 624 байтов. | * ============================================================================ * ############################################################################################################################################# * ПОСЧИТАТЬ И ОТОБРАЗИТЬ СРЕДНИЕ МОДУЛИ УРОВНИ СХОДСТВА ДЛЯ ВЕРНО И ОШИБОЧНО ИДЕНТИФИЦИРОВАННЫХ И НЕИДЕНТИФИЦРОВАННЫХ ОБЪЕКТОВ И L2-МЕРУ ИЗ НИХ * ############################################################################################################################################# *TP - истино-положительное решение; *TN - истино-отрицательное решение; *FP - ложно-положительное решение; *FN - ложно-отрицательное решение. CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций USE DostRasp EXCLUSIVE NEW USE Dost_modClsALL EXCLUSIVE NEW WNF = 10 * Цвет шрифта соотвествует строкам с максимальным значенем в нужной колонке DCBROWSECOL FIELD Dost_modClsALL->Type_Model HEADER L("Наименование модели;и частного критерия" ) PARENT oBrowse WIDTH mMaxLen DCBROWSECOL FIELD Dost_modClsALL->Int_Krit HEADER L("Интегральный критерий" ) PARENT oBrowse WIDTH 21 * DCBROWSECOL DATA FieldAnchor( 3, 9,0) HEADER L("Всего;логических;объектов;выборки" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF * DCBROWSECOL DATA FieldAnchor( 4, 9,0) HEADER L("Число истино-;положительных;решений (TP)" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF * DCBROWSECOL DATA FieldAnchor( 7, 9,0) HEADER L("Число истино-;отрицательных;решений (TN)" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF * DCBROWSECOL DATA FieldAnchor( 6, 9,0) HEADER L("Число ложно- ;положительных;решений (FP)" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF * DCBROWSECOL DATA FieldAnchor( 5, 9,0) HEADER L("Число ложно- ;отрицательных;решений (FN)" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF * DCBROWSECOL DATA FieldAnchor(14, 9,3) HEADER L("Точность;модели" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF * DCBROWSECOL DATA FieldAnchor(15, 9,3) HEADER L("Полнота ;модели" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(16, 9,3) HEADER L("F-мера ;Ван;Ризбергена" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF COLOR {||{nil,aColor[33]}} * DCBROWSECOL DATA FieldAnchor(17,10,3) HEADER L("Сумма модулей;уровней сходства;истино-положит.;решений (STP)" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF * DCBROWSECOL DATA FieldAnchor(20,10,3) HEADER L("Сумма модулей;уровней сходства;истино-отрицат.;решений (STN)" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF * DCBROWSECOL DATA FieldAnchor(19,10,3) HEADER L("Сумма модулей;уровней сходства;ложно-положит.;решений (SFP)" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF * DCBROWSECOL DATA FieldAnchor(18,10,3) HEADER L("Сумма модулей;уровней сходства;ложно-отрицат.;решений (SFN)" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF * DCBROWSECOL DATA FieldAnchor(21, 9,3) HEADER L("S-Точность;модели" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF * DCBROWSECOL DATA FieldAnchor(22, 9,3) HEADER L("S-Полнота ;модели" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(23, 9,3) HEADER L("L1-мера ;проф.;Е.В.Луценко" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF COLOR {||{nil,aColor[107]}} * DCBROWSECOL DATA FieldAnchor(24, 9,3) HEADER L("Средний модуль;уровней сходства;истино-положит.;решений;(ATP=STP/TP)") PARENT oBrowse FONT "9.Courier" WIDTH WNF * DCBROWSECOL DATA FieldAnchor(27, 9,3) HEADER L("Средний модуль;уровней сходства;истино-отрицат.;решений;(ATN=STN/TN)") PARENT oBrowse FONT "9.Courier" WIDTH WNF * DCBROWSECOL DATA FieldAnchor(26, 9,3) HEADER L("Средний модуль;уровней сходства;ложно-положит.;решений;(AFP=SFP/FP)" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF * DCBROWSECOL DATA FieldAnchor(25, 9,3) HEADER L("Средний модуль;уровней сходства;ложно-отрицат.;решений;(AFN=SFN/FN)" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF * DCBROWSECOL DATA FieldAnchor(28, 9,3) HEADER L("A-Точность;модели;APrecision;= ATP/(ATP+AFP)" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF * DCBROWSECOL DATA FieldAnchor(29, 9,3) HEADER L("A-Полнота ;модели;ARecall;= ATP/(ATP+AFN)" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL DATA FieldAnchor(30, 9,3) HEADER L("L2-мера ;проф.;Е.В.Луценко" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF COLOR {||{nil,aColor[153]}} * DCBROWSECOL DATA FieldAnchor( 8, 9,3) HEADER L("Процент;правильной;идентификации" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF * DCBROWSECOL DATA FieldAnchor( 9, 9,3) HEADER L("Процент;правильной;не идентификации" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF * DCBROWSECOL DATA FieldAnchor(10, 9,3) HEADER L("Процент;ошибочной ;идентификации" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF * DCBROWSECOL DATA FieldAnchor(11, 9,3) HEADER L("Процент;ошибочной ;не идентификации" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF * DCBROWSECOL DATA FieldAnchor(12, 9,3) HEADER L("Процент;правильных;результатов" ) PARENT oBrowse FONT "9.Courier" WIDTH WNF DCBROWSECOL FIELD Dost_modClsALL->Date HEADER L("Дата;получения;результата" ) PARENT oBrowse FONT "9.Courier" WIDTH 10 DCBROWSECOL FIELD Dost_modClsALL->Time HEADER L("Время;получения;результата" ) PARENT oBrowse FONT "9.Courier" WIDTH 8 DCGETOPTIONS TABSTOP RESIZE RESIZEDEFAULT DCGUI_RESIZE_AUTORESIZE DCREAD GUI ; OPTIONS GetOptions ; MODAL ; TITLE L('3.8. Обобщающая форма по достоверности моделей разных уровней и способов нормализации при разных интегральных критериях'); FIT ; CLEAREVENTS ************************************************************** ***** БД, открытые перед запуском главного меню ***** Восстанавливать их после выхода из функций главного меню ************************************************************** CLoseAll() // Закрытие всех баз данных с ожиданием завершения операций DIRCHANGE(Disk_dir) // Перейти в папку с исполнимым модулем системы USE PathGrAp EXCLUSIVE NEW USE Appls EXCLUSIVE NEW USE Users EXCLUSIVE NEW ************************************************************** Running(.F.) ReTURN nil ***************************************************************** ******** Сортировки *************** FUNCTION SortALL_F() INDEX ON STR(99999.9999999-F_MERA,15,7) TO SortALL_F DBGOTOP() ReTURN nil FUNCTION SortALL_L1() INDEX ON STR(99999.9999999-L1_MERA,15,7) TO SortALL_L1 DBGOTOP() ReTURN nil FUNCTION SortALL_L2() INDEX ON STR(99999.9999999-L2_MERA,15,7) TO SortALL_L2 DBGOTOP() ReTURN nil FUNCTION WithoutSorting() SET ORDER TO DBGOTOP() ReTURN nil ***************************************************************** from matplotlib.colors import LinearSegmentedColormap from scipy.interpolate import griddata from PyQt5.QtGui import QIcon, QImage, QPixmap from PyQt5.QtCore import Qt, QTimer from matplotlib.patches import Circle from scipy.interpolate import make_interp_spline from tkinter import Tk, Frame, Label, StringVar, Checkbutton, Button, ttk, messagebox import shutil import io import random import requests from googletrans import Translator import ftplib import socket from PyQt5.QtWidgets import ( QApplication, QMainWindow, QTableWidget, QTableWidgetItem, QVBoxLayout, QPushButton, QWidget, QInputDialog, QMessageBox, QScrollArea, QHBoxLayout ) import webbrowser import warnings from matplotlib.tri import Triangulation import chardet import re from PIL import Image, ImageTk from PIL import Image, ImageOps import matplotlib.pyplot as plt from scipy.cluster.hierarchy import linkage, dendrogram from PIL import Image # Assuming you're using PIL for image processing import time from tkinter import Tk, Label, messagebox from openpyxl import Workbook, load_workbook import subprocess import hashlib from openpyxl.styles import Alignment, Font from openpyxl.utils import get_column_letter import dbfread from openpyxl import Workbook import dbf from tkinter import ttk import csv import numpy as np import torch.nn as nn from dbfread import DBF from PyQt5.QtWidgets import ( QApplication, QMainWindow, QWidget, QVBoxLayout, QLabel, QPushButton, QProgressBar, QMessageBox, QCheckBox, QDialog ) from PyQt5.QtGui import QIcon from PyQt5.QtCore import Qt import os import sys import tkinter as tk from tkinter import ttk from tkinter import messagebox import pandas as pd from dbf import Table, READ_WRITE import time import threading # from tqdm import tqdm # Консольный прогресс-бар # Единственное место в программе, где определяются глобальные параметры доступа к хостингу # def upload_filtered_data_to_ftp(self, file_name): def FTP_access_to_the_Eidos_cloud(): # Эта функция аналогична FUNCTION Xb2NetKey() __AIDOS-X.exe global URL_Eidos_cloud global ftp_host global ftp_user global ftp_pass URL_Eidos_cloud = "" ftp_host = "" ftp_user = "" ftp_pass = "" # Определение функций def _4_5py(): # ######################################################################################## # _4_5py.py. (c°) проф.Е.В.Луценко. Программа построения когнитивных функций системы Эйдос # ######################################################################################## # Параметры визуализации когнитивных функций global x_labels global y_labels global x_axis_name global y_axis_name global xy_axis_kode global header_level_1 global header_level_2_app_name global header_level_2_model_info global header_level_2_cognitive_function global ConnectDotsMax global ConnectDotsMin global NumbGradLevel global NumbPixInch global duration_seconds global font_size # Список наименований статистических и системно-когнитивных моделей MODELS_NAME = { "ABS": "частный критерий: количество встреч сочетаний: класс-признак у объектов обуч.выборки", "PRC1": "частный критерий: усл. вероятность i-го признака среди признаков объектов j-го класса", "PRC2": "частный критерий: условная вероятность i-го признака у объектов j-го класса", "INF1": "частный критерий: количество знаний по А.Харкевичу; вероятности из PRC-1", "INF2": "частный критерий: количество знаний по А.Харкевичу; вероятности из PRC-2", "INF3": "частный критерий: Xи-квадрат, разности между фактическими и ожидаемыми абс.частотами", "INF4": "частный критерий: ROI (Return On Investment); вероятности из PRC-1", "INF5": "частный критерий: ROI (Return On Investment); вероятности из PRC-2", "INF6": "частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC-1", "INF7": "частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC-2" } # Список кратких наименований статистических и системно-когнитивных моделей для формирования имен файлов Models_ShortName = ["ABS", "PRC1", "PRC2", "INF1", "INF2", "INF3", "INF4", "INF5", "INF6", "INF7"] # Список наименований видов когнитивных функций COGNITIVE_FUNCTIONS = [ "1. Сетка триангуляции Делоне без цветовой заливки", "2. Сглаженные изолинии триангуляции Делоне без цветовой заливки", "3. Сетка триангуляции Делоне с цветовой заливкой", "4. Сглаженные изолинии триангуляции Делоне с цветовой заливкой", "5. Сглаженная цветовая заливка изолиний с заданным количеством градаций цвета" ] # Список англоязычных наименований видов когнитивных функций для формирования мен файлов CognFunct_EngShortName = [ "plot_triangulation_grid", "plot_smoothed_contours", "plot_colored_triangulation_grid", "plot_smoothed_colored_contours", "plot_smoothed_colored_contourf" ] # Значения [0.1, 0.48, 0.8, 0.4]являются относительными координатами, которые определяют положение и размер осей в фигуре. Вы можете настроить эти значения, чтобы контролировать размер области, в которой отображается график функции. Первые два значения ( 0.1и 0.48) представляют положение x и y нижнего левого угла осей, а последние два значения ( 0.8и 0.4) представляют ширину и высоту осей соответственно. Изменяя эти значения, вы можете управлять размером окна для отображения графика. # Например, чтобы увеличить высоту графика, вы можете изменить значение высоты с 0.4 на более высокое значение, такое как 0.6или 0.7. Это сделает график выше в окне. Поэкспериментируйте с этими значениями, чтобы добиться желаемого размера окна, отображающего график. # Массив с параметрами положения и размеров для графиков функций axes_positions = [ [0.1, 0.23, 0.792, 0.66], # Параметры для 1-го графика: Сетка триангуляции Делоне без цветовой заливки <<<===############## [0.1, 0.23, 0.792, 0.66], # Параметры для 2-го графика: Сглаженные изолинии триангуляции Делоне без цветовой заливки <<<===############## [0.1, 0.23, 0.990, 0.66], # Параметры для 3-го графика: Сетка триангуляции Делоне с цветовой заливкой [0.1, 0.23, 0.990, 0.66], # Параметры для 4-го графика: Сглаженные изолинии триангуляции Делоне с цветовой заливкой [0.1, 0.23, 0.990, 0.66], # Параметры для 5-го графика: Сглаженная цветовая заливка изолиний с заданным количеством градаций цвета ] # Функция для извлечения параметров из CSV файла def extract_params_from_csv(file_path): try: with open(file_path, 'rb') as file: data = file.read() result = chardet.detect(data) encoding = result['encoding'] decoded_data = data.decode(encoding) lines = decoded_data.splitlines() x_labels = [] y_labels = [] x_axis_name = "" y_axis_name = "" xy_axis_kode = "" header_level_1 = "" header_level_2_app_name = "" header_level_2_model_info = "" header_level_2_cognitive_function = "" ConnectDotsMax = "" ConnectDotsMin = "" NumbGradLevel = "" NumbPixInch = "" duration_seconds = "" font_size = "" for line in lines: if '#' in line: param_split = line.split('#', 1) param_name = param_split[0].strip() param_value = param_split[1].strip() # Check each param_name and assign values accordingly if 'градации оси X' in param_name: x_labels.append(param_value) if 'градации оси Y' in param_name: y_labels.append(param_value) if 'Код и наименование оси X:' in param_name: x_axis_name = param_value if 'Код и наименование оси Y:' in param_name: y_axis_name = param_value if 'Коды классификационной и описательной шкал через тире:' in param_name: xy_axis_kode = param_value if 'Название графической формы:' in param_name: header_level_1 = param_value if 'Наименование приложения:' in param_name: header_level_2_app_name = param_value if 'Код и наименование модели:' in param_name: header_level_2_model_info = param_value if 'Код и вид когнитивной функции:' in param_name: header_level_2_cognitive_function = param_value if 'Соединять точки с максимальным количеством информации линией КРАСНОГО цвета?' in param_name: ConnectDotsMax = param_value # print('ConnectDotsMax: ' + ConnectDotsMax) if 'Соединять точки с минимальным количеством информации линией СИНЕГО цвета?' in param_name: ConnectDotsMin = param_value # print('ConnectDotsMin: ' + ConnectDotsMin) if 'Количество градаций уровня (цвета и изолиний) когнитивных функций:' in param_name: NumbGradLevel = param_value # print(NumbGradLevel) if 'Количество пикселей на дюйм в изображениях когнитивных функций:' in param_name: NumbPixInch = param_value if 'Пауза в секундах между визуализациями когнитивных функций' in param_name: duration_seconds = param_value if 'Размер шрифта для наименований градаций шкал X и Y:' in param_name: font_size = param_value # Print relevant header info # print(header_level_1) # print(header_level_2_app_name) # print(header_level_2_model_info) # print(header_level_2_cognitive_function) # print(duration_seconds) # Return collected values return x_labels, y_labels, x_axis_name, y_axis_name, xy_axis_kode, header_level_1, \ header_level_2_app_name, header_level_2_model_info, header_level_2_cognitive_function, \ ConnectDotsMax, ConnectDotsMin, NumbGradLevel, NumbPixInch, duration_seconds, font_size except Exception as e: # print(f"Error: {e}") return [], [], "", "", "", "", "", "", "", "", "", "", "", "", "" # Функция для получения информации о модели def get_model_info_old(): try: current_directory = os.getcwd() with dbfread.DBF('Appls.dbf', encoding="cp866") as table: records = list(table) for record in records: if record['BY_DEFAULT'].strip(): name_appl = record['NAME_APPL'].strip() path = record['PATH_APPL'].strip() start_index = path.find("AID_DATA") model_db_path = os.path.join(current_directory, path[start_index:]) # print(f"Trying to open: {model_db_path}") return model_db_path except Exception as e: # print(f"Error: {e}") return None def get_model_info(): try: # Определяем путь к папке, в которой находится исполняемый файл (exe) # Получаем абсолютный путь к базе данных Appls.dbf file_path = os.path.abspath('Appls.dbf') # Open the DBF file and get all records from it # table = DBF(file_path, encoding='cp866') with dbfread.DBF(file_path, encoding="cp866") as table: records = list(table) for record in records: if record['BY_DEFAULT'].strip(): name_appl = record['NAME_APPL'].strip() model_db_path = record['PATH_APPL'].strip() # model_db_path = "c:\Aidos-X\AID_DATA\A0000001\System" # print(f"Trying to open: {model_db_path}") return model_db_path except Exception as e: # print(f"Error: {e}") return None # Получение информации о модели app_folder_path = get_model_info() # print(app_folder_path) csv_file_path = os.path.join(app_folder_path, 'CognFunParam.CSV') x_labels, y_labels, x_axis_name, y_axis_name, xy_axis_kode, header_level_1, \ header_level_2_app_name, header_level_2_model_info, header_level_2_cognitive_function, \ ConnectDotsMax, ConnectDotsMin, NumbGradLevel, NumbPixInch, duration_seconds, font_size = extract_params_from_csv( csv_file_path) # if len(x_labels) > 0: # print("Описательная шкала: " + x_axis_name + " X Labels:") # for label in x_labels: # print(label) # if len(y_labels) > 0: # print("Классификационная шкала: " + y_axis_name + " Y Labels:") # for label in y_labels: # print(label) # if len(x_labels) == 0 and len(y_labels) == 0: # print("No parameters found.") # Задание количества уровней цветов и контуров # num_levels = int(input("Введите количество уровней цветов и контуров: ")) # print(NumbGradLevel) try: num_levels = int(NumbGradLevel) except ValueError: print("Error: NumbGradLevel is not a valid integer.") # You might want to handle this error condition appropriately for your program # For example, you could ask the user to input a valid number again or provide a default value. exit(1) # Получение пути к файлу данных и меток model_db_path = get_model_info() sub_matrix_path = os.path.join(model_db_path, "SubMatrix.CSV") data_with_labels = np.genfromtxt(sub_matrix_path, delimiter=',', dtype=str) labels_x_axis, data_without_labels = np.hsplit(data_with_labels, [1]) labels_x_axis = labels_x_axis.flatten() data_without_labels = data_without_labels.astype(float) data_without_labels[data_without_labels == 0] = np.random.uniform(1e-7, 0.9999999, size=np.count_nonzero(data_without_labels == 0)) # Определение цветовой карты colors = [(1, 0, 0), (1, 0.65, 0), (1, 1, 0), (0, 1, 0), (0, 1, 1), (0, 0, 1), (0.5, 0, 0.5)] cmap = LinearSegmentedColormap.from_list('custom_cmap', colors, N=num_levels) cmap_reversed = cmap.reversed() # Сдвигаем данные и метки на оси X на одну позицию вправо data_without_labels_shifted = np.concatenate((np.zeros((data_without_labels.shape[0], 1)), data_without_labels), axis=1) labels_x_axis_shifted = [''] + labels_x_axis.tolist() # Сдвигаем данные и метки на оси Y на одну позицию вверх ТОЖЕ НУЖНО? <<<===############ x, y = np.meshgrid(np.arange(data_without_labels_shifted.shape[1]), np.arange(data_without_labels_shifted.shape[0])) triangulation = Triangulation(x.flatten(), y.flatten()) def truncate_label(label): if len(label) > max_allowed_length: return label[:int(max_allowed_length)] return label # Define your COGNITIVE_FUNCTIONS, axes_positions, x_labels, y_labels, x_axis_name, y_axis_name, header_level_1, header_level_2_app_name, header_level_2_model_info, etc. def plot_and_save_compressed_image_old(func_name, plot_function, cmap=None): fig = plt.figure(figsize=(19.2, 10.8)) Models_ShortName = ["ABS", "PRC1", "PRC2", "INF1", "INF2", "INF3", "INF4", "INF5", "INF6", "INF7"] # Размер шрифта для наименований градаций шкал X и Y x_fontsize = int(font_size) y_fontsize = int(font_size) func_index = COGNITIVE_FUNCTIONS.index(func_name) position = axes_positions[func_index] ax_plot = fig.add_axes(position) if cmap is None: plot_function() else: plot_function(cmap) current_cognitive_function = COGNITIVE_FUNCTIONS[func_index] title = f"\nПриложение: '{header_level_2_app_name}'\nМодель: '{header_level_2_model_info}'\nФункция: '{current_cognitive_function}'" plt.figtext(0.5, 0.98, header_level_1, ha='center', va='center', multialignment='center', fontweight='bold', fontsize=16) plt.figtext(0.5, 0.945, title, ha='center', va='center', multialignment='center', fontsize=14) plt.xticks(rotation=90, fontsize=x_fontsize, ha='center') plt.yticks(fontsize=y_fontsize) # Устанавливаем метки на осях X и Y plt.xticks(np.arange(len(x_labels)), x_labels, fontsize=x_fontsize, ha='center') plt.yticks(np.arange(len(y_labels)), y_labels, fontsize=y_fontsize, va='center') plt.gca().grid(True, linestyle='--', linewidth=0.5, alpha=0.7) x_max_allowed_length = 270 / x_fontsize # Максимально допустимая длина наименования градации по оси X y_max_allowed_length = 200 / y_fontsize # Максимально допустимая длина наименования градации по оси Y # Обрезаем длинные наименования для осей X и Y x_labels_trimmed = [label[:int(x_max_allowed_length)] if len(label) > x_max_allowed_length else label for label in x_labels] y_labels_trimmed = [label[:int(y_max_allowed_length)] if len(label) > y_max_allowed_length else label for label in y_labels] plt.xticks(range(len(x_labels)), x_labels_trimmed, fontsize=x_fontsize, ha='center') plt.yticks(range(len(y_labels)), y_labels_trimmed, fontsize=x_fontsize, va='center') plt.xlabel(x_axis_name, fontsize=12, ha='center') plt.ylabel(y_axis_name, fontsize=12, rotation=90, va='center') # Создаем матрицу данных matrix[y,x] на основе data_with_labels ConnectDotsMax = "Yes" if ConnectDotsMax == "Yes": matrix = np.array(data_with_labels, dtype=float) # Создаем массив aMaxY[x] для координат Y точек с максимальными значениями matrix[y,x] в зависимости от X aMaxY = np.zeros(matrix.shape[1], dtype=int) # Определяем максимальное значение Y и соответствующую координату Y для каждого X for x in range(matrix.shape[1]): mMaxY = -9999999999 for y in range(matrix.shape[0]): if matrix[y, x] > mMaxY: mMaxY = matrix[y, x] aMaxY[x] = y # Отрисовываем опорные точки for x, y in enumerate(aMaxY): # Создаем окружность с оранжевой заливкой и красной окантовкой circle = Circle((x, y), radius=0.03, edgecolor='red', facecolor='orange') ax_plot.add_patch(circle) # Соединяем опорные точки линиями ax_plot.plot(range(1, len(aMaxY)), aMaxY[1:], color='red', linewidth=3) # Красная линия save_dir = os.path.join(app_folder_path, "CognitiveFunctions") if not os.path.exists(save_dir): os.makedirs(save_dir) model_short_name = None for model_name in Models_ShortName: if model_name in header_level_2_model_info: model_short_name = model_name break if model_short_name is None: raise ValueError("Краткое наименование модели не найдено в header_level_2_model_info") cogn_funct_eng_short_name = CognFunct_EngShortName[func_index] output_file_name = f"{model_short_name}-{xy_axis_kode}-{cogn_funct_eng_short_name}.jpg" output_file_path = os.path.join(save_dir, output_file_name) plt.savefig(output_file_path, dpi=int(NumbPixInch)) # После сохранения изображения вызывайте функцию для его отображения в GUI image_path = output_file_path # Используйте правильный путь к сохраненному изображению cognitive_function_name = COGNITIVE_FUNCTIONS[func_index] # Замените func_index на фактический индекс display_image_in_gui(image_path, output_file_path, duration_seconds) def plot_and_save_compressed_image(func_name, plot_function, cmap=None): fig = plt.figure(figsize=(19.2, 10.8)) # print(func_name) # Вид когнитивной функции Models_ShortName = ["ABS", "PRC1", "PRC2", "INF1", "INF2", "INF3", "INF4", "INF5", "INF6", "INF7"] # Размер шрифта для наименований градаций шкал X и Y x_fontsize = int(font_size) y_fontsize = int(font_size) func_index = COGNITIVE_FUNCTIONS.index(func_name) position = axes_positions[func_index] ax_plot = fig.add_axes(position) if cmap is None: plot_function() else: plot_function(cmap) current_cognitive_function = COGNITIVE_FUNCTIONS[func_index] title = f"\nПриложение: '{header_level_2_app_name}'\nМодель: '{header_level_2_model_info}'\nФункция: '{current_cognitive_function}'" plt.figtext(0.5, 0.98, header_level_1, ha='center', va='center', multialignment='center', fontweight='bold', fontsize=16) plt.figtext(0.5, 0.945, title, ha='center', va='center', multialignment='center', fontsize=14) plt.xticks(rotation=90, fontsize=x_fontsize, ha='center') plt.yticks(fontsize=y_fontsize) plt.xticks(np.arange(len(x_labels)), x_labels, fontsize=x_fontsize, ha='center') plt.yticks(np.arange(len(y_labels)), y_labels, fontsize=y_fontsize, va='center') plt.gca().grid(True, linestyle='--', linewidth=0.5, alpha=0.7) x_max_allowed_length = 270 / x_fontsize y_max_allowed_length = 200 / y_fontsize x_labels_trimmed = [label[:int(x_max_allowed_length)] if len(label) > x_max_allowed_length else label for label in x_labels] y_labels_trimmed = [label[:int(y_max_allowed_length)] if len(label) > y_max_allowed_length else label for label in y_labels] plt.xticks(range(len(x_labels)), x_labels_trimmed, fontsize=x_fontsize, ha='center') plt.yticks(range(len(y_labels)), y_labels_trimmed, fontsize=x_fontsize, va='center') plt.xlabel(x_axis_name, fontsize=12, ha='center') plt.ylabel(y_axis_name, fontsize=12, rotation=90, va='center') # Рисование позитивных и негативных редуцированных когнитивных функций aMaxY = None aMinY = None # print('ConnectDotsMax: ' + ConnectDotsMax) # print('ConnectDotsMin: ' + ConnectDotsMin) # ConnectDotsMax = "Yes" if ConnectDotsMax == "Yes": matrix = np.array(data_with_labels, dtype=float) # print(matrix) aMaxY = np.zeros(matrix.shape[1], dtype=int) for x in range(matrix.shape[1]): mMaxY = -9999999999 for y in range(matrix.shape[0]): if matrix[y, x] > mMaxY: mMaxY = matrix[y, x] aMaxY[x] = y # Создаем массив для интерполяции x_interp = np.arange(0, len(aMaxY)) y_interp = aMaxY # Создаем сплайн для сглаживания try: spline = make_interp_spline(x_interp, y_interp, k=3) # Генерируем точки для сглаженной кривой x_smooth = np.linspace(0, len(aMaxY) - 1, 300) y_smooth = spline(x_smooth) # Отрисовываем сглаженную кривую и опорные точки ax_plot.plot(x_smooth, y_smooth, color='red', linewidth=3) # Красная линия # Опорные точки for x, y in enumerate(aMaxY): circle = Circle((x, y), radius=0.04, edgecolor='red', facecolor='orange') ax_plot.add_patch(circle) except ValueError: # Если сглаживание невозможно, рисуем опрные точки и ломаную линию # Опорные точки for x, y in enumerate(aMaxY): circle = Circle((x, y), radius=0.04, edgecolor='red', facecolor='orange') ax_plot.add_patch(circle) ax_plot.plot(range(len(aMaxY)), aMaxY, color='red', linewidth=3) # Простое соединение точек if aMaxY is not None and len(np.unique(aMaxY)) > 1: ax_plot.set_ylim(0, max(aMaxY)) # ConnectDotsMin = "Yes" if ConnectDotsMin == "Yes": matrix = np.array(data_with_labels, dtype=float) # print(matrix) aMinY = np.zeros(matrix.shape[1], dtype=int) # Минимальные Y для каждого X for x in range(matrix.shape[1]): mMinY = 9999999999 for y in range(matrix.shape[0]): if matrix[y, x] < mMinY: mMinY = matrix[y, x] aMinY[x] = y # print(aMinY) # Создаем массив для интерполяции x_interp = np.arange(0, len(aMinY)) y_interp = aMinY # Создаем сплайн для сглаживания try: spline = make_interp_spline(x_interp, y_interp, k=3) # Генерируем точки для сглаженной кривой x_smooth = np.linspace(0, len(aMinY) - 1, 300) y_smooth = spline(x_smooth) # Отрисовываем сглаженную кривую и опорные точки ax_plot.plot(x_smooth, y_smooth, color='blue', linewidth=3) # Синяя линия # Опорные точки for x, y in enumerate(aMinY): circle = Circle((x, y), radius=0.04, edgecolor='blue', facecolor='lightblue') ax_plot.add_patch(circle) except ValueError: # Если сглаживание невозможно, рисуем опорные ломаную линию # Опорные точки for x, y in enumerate(aMinY): circle = Circle((x, y), radius=0.04, edgecolor='blue', facecolor='lightblue') ax_plot.add_patch(circle) ax_plot.plot(range(len(aMinY)), aMinY, color='blue', linewidth=3) # Простое соединение точек if aMinY is not None and len(np.unique(aMinY)) > 1: ax_plot.set_ylim(0, max(aMinY)) # Остальная часть вашего кода # Сохраняем изображение save_dir = os.path.join(app_folder_path, "CognitiveFunctions") if not os.path.exists(save_dir): os.makedirs(save_dir) model_short_name = None print(header_level_2_model_info) for model_name in Models_ShortName: if model_name in header_level_2_model_info: model_short_name = model_name break if model_short_name is None: raise ValueError("Краткое наименование модели не найдено в header_level_2_model_info") cogn_funct_eng_short_name = CognFunct_EngShortName[func_index] output_file_name = f"{model_short_name}-{xy_axis_kode}-{cogn_funct_eng_short_name}.jpg" output_file_path = os.path.join(save_dir, output_file_name) plt.savefig(output_file_path, dpi=int(NumbPixInch)) # После сохранения изображения вызывайте функцию для его отображения в GUI image_path = output_file_path # Используйте правильный путь к сохраненному изображению cognitive_function_name = COGNITIVE_FUNCTIONS[func_index] # Замените func_index на фактический индекс display_image_in_gui(image_path, output_file_path, duration_seconds) def display_image_in_gui(image_path, window_title, duration_seconds): app = QApplication([]) desktop = app.primaryScreen() available_screen_size = desktop.availableGeometry().size() panel_height = desktop.availableGeometry().height() - available_screen_size.height() window = QWidget() window.setWindowState(Qt.WindowMaximized) # Максимизация окна image = QImage(image_path) scaled_image = image.scaled(available_screen_size, Qt.KeepAspectRatio, Qt.SmoothTransformation) label = QLabel() # Сжатие вертикально немного сильнее aspect_ratio = image.width() / image.height() new_height = int(available_screen_size.height() * 0.9) new_width = int(new_height * aspect_ratio) scaled_image = image.scaled(new_width, new_height, Qt.KeepAspectRatio, Qt.SmoothTransformation) label.setAlignment(Qt.AlignCenter) label.setPixmap(QPixmap.fromImage(scaled_image)) layout = QVBoxLayout() layout.addWidget(label) window.setLayout(layout) window.setWindowTitle(window_title) icon_path = os.path.join(os.path.abspath(os.path.dirname(__file__)), '_Aidos.ico') window.setWindowIcon(QIcon(icon_path)) def close_window(): window.close() timer = QTimer() timer.timeout.connect(close_window) timer.start(int(float(duration_seconds) * 1000)) # Перевод в миллисекунды with app: window.show() app.exec_() # Пример использования: # image_path = "path/to/your/image.jpg" # window_title = "Image Viewer" # duration_seconds = 6.5 # display_image_in_gui(image_path, window_title, duration_seconds) # Остальные функции для построения графиков def plot_triangulation_grid(): plt.triplot(triangulation, 'k-', linewidth=1.0) plt.grid(True, linestyle='--', linewidth=0.5, alpha=0.7) plt.xticks(rotation=90, ha='center') plt.yticks(ha='right') plt.xlabel("") plt.ylabel("") plt.gca().set_xticks(np.arange(len(x_labels))) plt.gca().set_yticks(np.arange(len(y_labels))) plt.gca().set_xticklabels(x_labels, fontsize=8) plt.gca().set_yticklabels(y_labels, fontsize=8, ha='right') def plot_smoothed_contours(cmap): xi, yi = np.meshgrid(np.linspace(x.min(), x.max(), 100), np.linspace(y.min(), y.max(), 100)) zi = griddata((x.flatten(), y.flatten()), data_without_labels_shifted.flatten(), (xi, yi), method='cubic') contour = plt.contour(xi, yi, zi, levels=num_levels, colors='k', linewidths=0.5) plt.gca().set_rasterized(True) plt.setp(contour.collections, linewidth=0.5) def plot_colored_triangulation_grid(cmap): plt.tripcolor(triangulation, data_without_labels_shifted.flatten(), shading='gouraud', cmap=cmap.reversed()) plt.colorbar(label='Значение цвета') def plot_smoothed_colored_contours(cmap): contour_filled = plt.tricontourf(x.flatten(), y.flatten(), data_without_labels_shifted.flatten(), levels=num_levels, cmap=cmap) plt.colorbar(contour_filled, label='Значение цвета') def plot_smoothed_colored_contourf(cmap): xi, yi = np.meshgrid(np.linspace(x.min(), x.max(), 100), np.linspace(y.min(), y.max(), 100)) zi = griddata((x.flatten(), y.flatten()), data_without_labels_shifted.flatten(), (xi, yi), method='cubic') contour_filled_smooth = plt.contourf(xi, yi, zi, levels=num_levels, cmap=cmap) plt.colorbar(contour_filled_smooth, label='Значение цвета') # Использование функции plot_and_save_image для построения и сохранения графиков # x_labels, y_labels, x_axis_name, y_axis_name, xy_axis_kode, header_level_1, \ # header_level_2_app_name, header_level_2_model_info, header_level_2_cognitive_function, \ # ConnectDotsMax, ConnectDotsMin, NumbGradLevel, NumbPixInch, duration_seconds, font_size = extract_params_from_csv( # csv_file_path) # Виды когнитивных функций и соответствующие названия форм cognitive_functions = [ ("1. Сетка триангуляции Делоне без цветовой заливки", plot_triangulation_grid), ("2. Сглаженные изолинии триангуляции Делоне без цветовой заливки", lambda: plot_smoothed_contours(cmap)), ("3. Сетка триангуляции Делоне с цветовой заливкой", lambda: plot_colored_triangulation_grid(cmap)), ("4. Сглаженные изолинии триангуляции Делоне с цветовой заливкой", lambda: plot_smoothed_colored_contours(cmap_reversed)), ("5. Сглаженная цветовая заливка изолиний с заданным количеством градаций цвета", lambda: plot_smoothed_colored_contourf(cmap_reversed)) ] # for func_name, plot_function in cognitive_functions: # plot_and_save_compressed_image(func_name, plot_function) # Находим функцию и её имя по заданному наименованию в массиве cognitive_functions selected_function = None selected_function_name = None for name, func in cognitive_functions: if name == header_level_2_cognitive_function: selected_function = func selected_function_name = name break # Проверяем, нашлась ли функция и, если нашлась, запускаем на исполнение if selected_function is not None: plot_and_save_compressed_image(selected_function_name, selected_function) else: print("Функция с указанным наименованием не найдена в массиве cognitive_functions.") def _4224py(): ###################################################################################################################### # _4224py.py. 4.2.2.4. Классическая кластеризация классов. Классическая кластеризация классов в Питоне. # Построение и визуализация агломеративных дендрограмм классов и графиков межкластерных расстояний в графическом виде, # а также матрицы сходства классов ###################################################################################################################### # Функция для создания папки, если она не существует def create_folder_if_not_exists(folder_path): if not os.path.exists(folder_path): os.makedirs(folder_path) # Функция для конвертации DBF в XLSX def convert_db_to_xlsx(model_name, progress_bar): file_path = os.path.abspath('Appls.dbf') with DBF(file_path, encoding='cp866') as table: name_appl = None dbf_folder = None for record in table: if record.get('BY_DEFAULT').strip(): dbf_folder = record.get('PATH_APPL').strip() name_appl = record.get('NAME_APPL').strip() break if dbf_folder: model_name = None model_code = None param_file_path = os.path.join(dbf_folder, '4224Param.CSV') with open(param_file_path, 'r', encoding='cp866') as param_file: param_file_content = param_file.readlines() for line in param_file_content: if 'Код модели' in line: model_code = line.split('#')[1].strip() break Ar_Model = { "1": "Abs", "2": "Prс1", "3": "Prс2", "4": "Inf1", "5": "Inf2", "6": "Inf3", "7": "Inf4", "8": "Inf5", "9": "Inf6", "10": "Inf7" } model_name = Ar_Model.get(model_code) if model_name: wb = Workbook() ws = wb.active ws.title = model_name attributes_dbf_path = os.path.join(dbf_folder, 'Attributes.dbf') with DBF(attributes_dbf_path, encoding='cp866') as attributes_table: kod_pr_name_values = [] max_kod_pr_name = 0 for record in attributes_table: kod_atr = str(record['KOD_ATR']).strip() name_atr = record['NAME_ATR'].strip() kod_pr_name = f"{kod_atr}-{name_atr}" max_kod_pr_name = max(max_kod_pr_name, len(kod_pr_name) - 1) kod_pr_name_values.append(kod_pr_name) N_Atr = len(kod_pr_name_values) classes_dbf_path = os.path.join(dbf_folder, 'Classes.dbf') with DBF(classes_dbf_path, encoding='cp866') as classes_table: N_Cls = sum(1 for _ in classes_table) field_names = ['Kod_pr-Name'] field_names.extend([f"{record['KOD_CLS']}-{record['NAME_CLS']}" for record in classes_table]) ws.append(field_names) for col in ws.iter_cols(max_col=len(field_names)): for cell in col: cell.alignment = Alignment(horizontal='center', vertical='bottom', text_rotation=90) aInfStruct = [[kod_pr_name_values[0], "C", max_kod_pr_name, 0]] for j in range(1, N_Cls + 1): FieldName = f"N{j}" aInfStruct.append([FieldName, "N", 19, 7]) excel_file_path = os.path.join(dbf_folder, f'{model_name}.xlsx') model_txt_file_path = os.path.join(dbf_folder, f'{model_name}.txt') with open(model_txt_file_path, 'r', encoding='cp866') as model_txt_file: lines = model_txt_file.read().splitlines()[:-4] for row_idx, line in enumerate(lines, start=2): values = [kod_pr_name_values[row_idx - 2]] start_pos = 15 + max_kod_pr_name for field_info in aInfStruct[1:]: field_length = field_info[2] field_value = line[start_pos:start_pos + field_length].strip() if field_info[0] != 'Kod_pr-Name': if field_info[1] == 'N': try: field_value = float(field_value.replace(' ', '0').replace(',', '.')) except ValueError: field_value = 0 values.append(field_value) start_pos += field_length for col_idx, value in enumerate(values, start=1): ws.cell(row=row_idx, column=col_idx).value = value progress_bar['value'] = (row_idx - 1) / (len(lines) - 1) * 100 progress_bar.update() if 'Sheet' in wb.sheetnames: sheet = wb['Sheet'] wb.remove(sheet) try: wb.save(excel_file_path) except PermissionError: messagebox.showerror("Ошибка", "Файл Excel используется другой программой.") return True return False # Функция для создания GUI для кластеризации def create_gui(model_name): root = Tk() root.title(f"Преобразование БД модели {model_name} из txt файла в xlsx") root.geometry("550x100") root.iconbitmap("_Aidos.ico") label = Label(root, text=f"Преобразование БД модели {model_name} из txt файла в xlsx") label.pack(pady=10) progress_bar = ttk.Progressbar(root, orient='horizontal', length=500, mode='determinate') progress_bar.pack(pady=10) if convert_db_to_xlsx(model_name, progress_bar): label.config(text="Преобразование завершено успешно") else: messagebox.showerror("Ошибка", "Не удалось найти базу данных") root.after(3000, root.destroy) root.mainloop() # Получить абсолютный путь к базе данных DBF Appls.dbf file_path = os.path.abspath('Appls.dbf') # Открыть файл DBF и получить все записи из него with DBF(file_path, encoding='cp866') as table: name_appl = None dbf_folder = None for record in table: if record.get('BY_DEFAULT').strip(): dbf_folder = record.get('PATH_APPL').strip() name_appl = record.get('NAME_APPL').strip() break # Проверить, найден ли путь к базе данных if dbf_folder: param_file_path = os.path.join(dbf_folder, '4224Param.CSV') with open(param_file_path, 'r', encoding='cp866') as param_file: param_file_content = param_file.readlines() model_code = None for line in param_file_content: if 'Наименование модели:' in line: full_model_name = line.split('#')[1].strip() if 'Код модели:' in line: model_code = line.split('#')[1].strip() break Ar_Model = { "1": "Abs", "2": "Prс1", "3": "Prс2", "4": "Inf1", "5": "Inf2", "6": "Inf3", "7": "Inf4", "8": "Inf5", "9": "Inf6", "10": "Inf7" } model_name = Ar_Model.get(model_code) if model_name is None: print("Model name not found for code:", model_code) else: create_gui(model_name) # Вызов функции создания GUI здесь attributes_dbf_path = os.path.join(dbf_folder, 'Attributes.dbf') with DBF(attributes_dbf_path, encoding='cp866') as attributes_table: kod_pr_name_values = [] max_kod_pr_name = 0 for record in attributes_table: kod_atr = str(record['KOD_ATR']).strip() name_atr = record['NAME_ATR'].strip() kod_pr_name = f"{kod_atr}-{name_atr}" max_kod_pr_name = max(max_kod_pr_name, len(kod_pr_name) - 1) kod_pr_name_values.append(kod_pr_name) N_Atr = len(kod_pr_name_values) classes_dbf_path = os.path.join(dbf_folder, 'Classes.dbf') with DBF(classes_dbf_path, encoding='cp866') as classes_table: N_Cls = sum(1 for _ in classes_table) wb = Workbook() ws = wb.active ws.title = model_name field_names = ['Kod_pr-Name'] field_names.extend([f"{record['KOD_CLS']}-{record['NAME_CLS']}" for record in classes_table]) ws.append(field_names) for col in ws.iter_cols(max_col=len(field_names)): for cell in col: cell.alignment = Alignment(horizontal='center', vertical='bottom', text_rotation=90) aInfStruct = [[kod_pr_name_values[0], "C", max_kod_pr_name, 0]] for j in range(1, N_Cls + 1): FieldName = f"N{j}" aInfStruct.append([FieldName, "N", 19, 7]) excel_file_path = os.path.join(dbf_folder, f'{model_name}.xlsx') model_txt_file_path = os.path.join(dbf_folder, f'{model_name}.txt') with open(model_txt_file_path, 'r', encoding='cp866') as model_txt_file: lines = model_txt_file.read().splitlines()[:-4] for row_idx, line in enumerate(lines, start=2): values = [kod_pr_name_values[row_idx - 2]] start_pos = 15 + max_kod_pr_name for field_info in aInfStruct[1:]: field_length = field_info[2] field_value = line[start_pos:start_pos + field_length].strip() if field_info[0] != 'Kod_pr-Name': if field_info[1] == 'N': try: field_value = float(field_value.replace(' ', '0').replace(',', '.')) except ValueError: field_value = 0 values.append(field_value) start_pos += field_length for col_idx, value in enumerate(values, start=1): ws.cell(row=row_idx, column=col_idx).value = value if 'Sheet' in wb.sheetnames: sheet = wb['Sheet'] wb.remove(sheet) try: wb.save(excel_file_path) except PermissionError: messagebox.showerror("Ошибка", "Файл Excel используется другой программой.") else: messagebox.showerror("Ошибка", "Путь к базе данных не найден.") # ФОРМАТИРОВАНИЕ XLSX ФАЙЛА МОДЕЛИ def align_columns(file_path): # Открытие существующего файла Excel wb = load_workbook(file_path) ws = wb.active # Выравнивание первой колонки max_length_first_col = max(len(str(cell.value)) for cell in ws['A']) for cell in ws['A']: cell.alignment = Alignment(horizontal='left', vertical='bottom') ws.column_dimensions[cell.column_letter].width = max_length_first_col + 1 # Выравнивание остальных колонок for col in range(2, ws.max_column + 1): max_length = max( len(str(cell.value)) for row in ws.iter_rows(min_row=2, max_row=ws.max_row, min_col=col, max_col=col) for cell in row) ws.column_dimensions[ws.cell(row=1, column=col).column_letter].width = max_length # Сохранение изменений wb.save(file_path) # Пример вызова функции align_columns(excel_file_path) # КЛАСТЕРИЗАЦИЯ КЛАССОВ # Определить папку для результатов кластеризации clustering_classes_folder = os.path.join(dbf_folder, 'ClusteringClasses') create_folder_if_not_exists(clustering_classes_folder) def show_help(): help_text = """Кластеризация - это процесс группировки объектов данных на основе их сходства. Каждый из методов кластеризации имеет свои особенности: 1. Single linkage (одиночная связь): Этот метод определяет расстояние между двумя кластерами как минимальное расстояние между их членами. Объекты кластеризуются по принципу "ближайшего соседа". 2. Complete linkage (полная связь): В этом методе расстояние между кластерами определяется как максимальное расстояние между их членами. Объекты кластеризуются по принципу "самого дальнего соседа". 3. Average linkage (средняя связь): Расстояние между кластерами определяется как среднее расстояние между всеми парами их членов. 4. Weighted linkage (взвешенная связь): Этот метод похож на среднюю связь, но с использованием весов, чтобы учитывать различную значимость объектов. 5. Centroid linkage (центроидная связь): Расстояние между кластерами определяется как расстояние между их центроидами (средними значениями объектов). 6. Median linkage (медианная связь): Здесь расстояние между кластерами вычисляется как расстояние между их медианными объектами. 7. Ward linkage (метод Уорда): Этот метод стремится минимизировать дисперсию внутри кластеров, объединяя кластеры, которые минимизируют увеличение общей дисперсии после объединения.""" messagebox.showinfo("Помощь", help_text) # Переместить или скопировать файл Excel модели в папку для результатов кластеризации def move_excel_file_to_clustering_results_folder(excel_file_path, clustering_results_folder): try: shutil.copy(excel_file_path, clustering_results_folder) # Копировать файл # shutil.move(excel_file_path, clustering_results_folder) # Переместить файл (если нужно переместить) # messagebox.showinfo("Успех", "Excel файл успешно скопирован в папку для результатов кластеризации.") except FileNotFoundError: messagebox.showerror("Ошибка", "Файл Excel модели не найден.") except Exception as e: messagebox.showerror("Ошибка", f"Произошла ошибка при копировании Excel файла: {e}") # Вызов функции для перемещения или копирования файла Excel модели в папку для результатов кластеризации move_excel_file_to_clustering_results_folder(excel_file_path, clustering_classes_folder) # Расчет и запись xlsx матрицы сходства классов # Загрузка данных из файла Excel data = pd.read_excel(excel_file_path) # Исключаем первую строку (наименования объектов кластеризации) и первый столбец (наименования признаков) data = data.iloc[1:, 1:] # Вычисление корреляции Пирсона между колонками correlation_matrix = data.corr() # Создание нового файла Excel с матрицей сходства output_file_path = os.path.join(clustering_classes_folder, 'Classes_similarity_matrix.xlsx') try: # Запись данных в Excel с использованием openpyxl для форматирования with pd.ExcelWriter(output_file_path, engine='openpyxl') as writer: correlation_matrix.to_excel(writer, index=True, sheet_name='Correlation') # Получаем объект книги Excel wb = writer.book ws = wb['Correlation'] # Устанавливаем выравнивание для наименований колонок for cell in ws[1]: cell.alignment = Alignment(horizontal='center', vertical='bottom') cell.font = Font(bold=True) # Устанавливаем обычный шрифт для всех ячеек for row in ws.iter_rows(): for cell in row: cell.font = Font(name='Arial', size=10) # Создаем новый лист ws_new = wb.create_sheet(title='Summary') # Вставляем текст заголовка в новый лист title_text = ( f"МАТРИЦА СХОДСТВА КЛАССОВ\n" f"(С°) Персональная интеллектуальная on-line среда 'Эйдос'\n" f"Приложение: {name_appl}\n" f"Модель: {full_model_name}\n" f"Дата и время создания формы: {pd.Timestamp.now()}\n" ) for i, line in enumerate(title_text.split('\n')): cell = ws_new.cell(row=i + 1, column=1, value=line) cell.font = Font(bold=True) # Переносим наименования строк и столбцов с форматированием for col_idx, col_name in enumerate(correlation_matrix.columns): cell = ws_new.cell(row=6, column=col_idx + 2, value=col_name) cell.alignment = Alignment(horizontal='center', vertical='bottom', text_rotation=90) for row_idx, row_name in enumerate(correlation_matrix.index): cell = ws_new.cell(row=row_idx + 7, column=1, value=row_name) cell.alignment = Alignment(horizontal='left', vertical='bottom') # Переносим матрицу сходства на новый лист со смещением вниз на 6 строк for row_idx, row in enumerate(correlation_matrix.values): for col_idx, value in enumerate(row): ws_new.cell(row=row_idx + 7, column=col_idx + 2, value=value) # Размеры первой колонки max_length = max(len(str(cell.value)) for row in ws_new.iter_rows(min_row=7, max_row=ws_new.max_row, min_col=1, max_col=1) for cell in row) ws_new.column_dimensions['A'].width = max_length + 8 # Увеличиваем ширину на 8 символов для запаса # Удаляем старый лист del wb['Correlation'] # Сохраняем изменения wb.save(output_file_path) except PermissionError: # Если файл занят другим приложением, выводим сообщение об ошибке в GUI окне root = tk.Tk() root.withdraw() # Скрыть основное окно messagebox.showerror("Ошибка", "Файл Classes_similarity_matrix.xlsx занят другим приложением. Закройте его и повторите попытку.") root.destroy() # Закрыть GUI окно после закрытия сообщения об ошибке # КРУГОВАЯ КОГНИТИВНАЯ ДИАГРАММА СХОДСТВА КЛАССОВ # Function to get user preferences for the circular diagram def get_user_preferences_circle(mTitle): global percentage_value, response_value, x_pixels, y_pixels, dpi, line_thickness root = tk.Tk() root.title(mTitle) # Устанавливаем иконку root.iconbitmap("_Aidos.ico") frame = tk.Frame(root) frame.pack(padx=10, pady=10) fields = [ ("Показывать связи по модулю не менее (%) :", "0"), ("Показывать классы без таких связей?", "Y"), ("Размер изображения по X (pixel):", "1080"), ("Размер изображения по Y (pixel):", "1080"), ("Максимальная толщина линий связи (pixel):", "5"), ("Разрешение (DPI):", "100") ] entries = [] for i, (label_text, default_value) in enumerate(fields): label = tk.Label(frame, text=label_text) label.grid(row=i, column=0, sticky="w", padx=(0, 10), pady=5) var = tk.StringVar(value=default_value) entry = tk.Entry(frame, textvariable=var, width=6) entry.grid(row=i, column=1, sticky="w", pady=5) entries.append(entry) entries[0].bind("", lambda event: validate_and_close()) entries[1].bind("", lambda event: validate_and_close()) # Initialize variables with default values percentage_value = 0 response_value = True x_pixels = 1080 y_pixels = 1080 line_thickness = 5 dpi = 100 show_classes = True # Default value def validate_and_close(): try: global percentage_value, response_value, x_pixels, y_pixels, dpi, line_thickness, show_classes percentage = float(entries[0].get()) if 0 <= percentage <= 100: response = entries[1].get().upper() == "Y" x_pixels = int(entries[2].get()) y_pixels = int(entries[3].get()) line_thickness = int(entries[4].get()) # Adjusted index to match line thickness entry dpi = int(entries[5].get()) # Adjusted to ensure DPI is within valid range root.destroy() percentage_value = percentage response_value = response show_classes = response else: percentage_value = 0 except ValueError: messagebox.showerror("Ошибка", "Пожалуйста, введите числовое значение для числового поля") return root.quit() def cancel_and_close(): global percentage_value, response_value, x_pixels, y_pixels, dpi, line_thickness root.destroy() percentage_value = 0 response_value = True x_pixels = 1080 y_pixels = 1080 line_thickness = 5 # Adjusted to match the default value in the fields list dpi = 100 root.quit() root.protocol("WM_DELETE_WINDOW", cancel_and_close) button_frame = tk.Frame(root) button_frame.pack(pady=(10, 0)) ok_button = tk.Button(button_frame, text="OK", command=validate_and_close) ok_button.pack(side=tk.LEFT, padx=(0, 10)) cancel_button = tk.Button(button_frame, text="Cancel", command=cancel_and_close) cancel_button.pack(side=tk.LEFT) root.geometry("380x270") # Increased height to accommodate the new field root.mainloop() return percentage_value, response_value, x_pixels, y_pixels, line_thickness, dpi, show_classes # Function to plot the circular diagram def plot_similarity_circle(correlation_matrix, classes, output_path): try: min_similarity_percentage, show_classes, x_pixels, y_pixels, line_thickness, target_dpi, show_classes = get_user_preferences_circle( "Параметры круговой диаграммы классов") print("Параметры круговой диаграммы классов") print("Percentage value:", min_similarity_percentage) print("Response value:", show_classes) print("X pixels:", x_pixels) print("Y pixels:", y_pixels) print("Line thickness:", line_thickness) print("DPI:", target_dpi) except Exception as e: print(f"Error: {e}") similarities = correlation_matrix.values num_classes = correlation_matrix.shape[0] # Find classes to display based on user preferences if not show_classes: classes_to_display = [] for i in range(num_classes): if any(abs(similarity) >= min_similarity_percentage * 0.01 for j, similarity in enumerate(correlation_matrix.iloc[i]) if i != j): classes_to_display.append(i) classes = [classes[i] for i in classes_to_display] correlation_matrix = correlation_matrix.iloc[classes_to_display, :].iloc[:, classes_to_display] num_classes = len(classes) if not classes_to_display: messagebox.showinfo("Классы не найдены", "При заданных условиях фильтрации классов для визуализации не найдено!") return # Stop the execution of the function angles = np.linspace(0, 2 * np.pi, num_classes, endpoint=False) radius = 1.0 class_name_widths = [] class_name_heights = [] fig_tmp = plt.figure() resolution = target_dpi fig_tmp.set_dpi(resolution) canvas = fig_tmp.canvas for class_name in classes: fig_tmp.clear() t = fig_tmp.text(0.5, 0.5, class_name, fontsize=8, ha='center', va='center') bbox = t.get_window_extent(canvas.get_renderer()) w, h = bbox.width, bbox.height class_name_widths.append(w) class_name_heights.append(h) plt.close(fig_tmp) max_class_name_width = max(class_name_widths) max_class_name_height = max(class_name_heights) diameter = 2 * radius + max(max_class_name_width, max_class_name_height) + 40 # target_dpi = mDPI target_width_inches = x_pixels / target_dpi target_height_inches = y_pixels / target_dpi figure_size_inches = max(diameter / resolution, target_width_inches, target_height_inches) fig, ax = plt.subplots(figsize=(target_width_inches, target_height_inches), dpi=target_dpi) ax.set_xticks([]) ax.set_yticks([]) ax.set_xlim(-1.5, 1.5) ax.set_ylim(-1.5, 1.5) ax.axis('off') for i in range(num_classes): for j in range(num_classes): if i != j and (show_classes or correlation_matrix.iloc[i, j] != 0): similarity = correlation_matrix.iloc[i, j] if min_similarity_percentage * 0.01 < abs(similarity): color = 'red' if similarity > 0 else 'blue' width = abs(similarity) * line_thickness x1 = np.cos(angles[i]) * radius y1 = np.sin(angles[i]) * radius x2 = np.cos(angles[j]) * radius y2 = np.sin(angles[j]) * radius ax.plot([x1, x2], [y1, y2], color=color, linewidth=width) # Add labels for classes for i, class_name in enumerate(classes): x = np.cos(angles[i]) * radius y = np.sin(angles[i]) * radius ax.plot(x, y, 'o', markersize=10, color='black') x_text = np.cos(angles[i]) * radius * 1.06 y_text = np.sin(angles[i]) * radius * 1.06 ax.text(x_text, y_text, str(class_name), fontsize=8, ha='left', va='center', rotation=angles[i] * 180 / np.pi, rotation_mode='anchor', transform=ax.transData) # Add title and bottom text title_text = ( f"\n" f"КРУГОВАЯ КОГНИТИВНАЯ ДИАГРАММА СХОДСТВА КЛАССОВ\n\n" f"(С°) Персональная интеллектуальная on-line среда 'Эйдос'\n" f"Приложение: {name_appl}\n" f"Модель: {full_model_name}\n" f"Дата и время создания диаграммы: {pd.Timestamp.now()}\n" ) bbox_props = dict(boxstyle="square", pad=0, fc="white", lw=0) ax.text(0.5, 1.0, title_text, transform=ax.transAxes, fontsize=11, fontweight='bold', ha='center', va='baseline', bbox=bbox_props) # print(min_similarity_percentage, show_classes) if show_classes: mClasses = "все классы." else: mClasses = "только классы с такими связями." bottom_text = ( f"Линии связи между классами отображают степень сходства / различия классов по системе их детерминации,\n" f"т.е. по системе обуславливающих их значений факторов. Красный цет означает сходство, синий - различие.\n" f"Толщина линий соответствует степени сходства / различия классов по системе их детерминации.\n" f"Показаны только линии связи по модулю силы не менее {min_similarity_percentage}% и {mClasses}\n" ) bbox_props_bottom = dict(boxstyle="square,pad=0", facecolor="white", edgecolor="none", alpha=1.0) ax.text(0.5, -0.1, bottom_text, transform=ax.transAxes, fontsize=10, fontweight='bold', ha='center', va='center', bbox=bbox_props_bottom) fig.savefig(output_path, dpi=target_dpi) plt.close(fig) # Вызов функции рисования круговой когнитивной диаграммы output_file_path = os.path.join(clustering_classes_folder, "Classes_similarity_matrix.png") # print(output_file_path) classes_dbf_path = os.path.join(dbf_folder, 'Classes.dbf') field_names = [] with DBF(classes_dbf_path, encoding='cp866') as classes_table: N_Cls = sum(1 for _ in classes_table) field_names.extend([f"{record['KOD_CLS']}-{record['NAME_CLS']}" for record in classes_table]) # print(field_names) plot_similarity_circle(correlation_matrix, field_names, output_file_path) # ДЕНДРОГРАММА АГЛОМЕРАТИВНОЙ КЛАСТЕРИЗАЦИИ КЛАССОВ def get_user_preferences_dendrogram(mTitle): global x_pixels, y_pixels, line_thickness, font_size_title, font_size_object, target_dpi root = tk.Tk() root.title(mTitle) # Устанавливаем иконку root.iconbitmap("_Aidos.ico") frame = tk.Frame(root) frame.pack(padx=10, pady=10) fields = [ ("Размер изображения по X (pixel):", "1080"), ("Размер изображения по Y (pixel):", "1080"), ("Толщина линий дендрограммы (pixel):", "5"), ("Размер шрифта заголовка:", "14"), ("Размер шрифта наименований объектов:", "8"), ("Разрешение (DPI):", "100") ] entries = [] for i, (label_text, default_value) in enumerate(fields): label = tk.Label(frame, text=label_text) label.grid(row=i, column=0, sticky="w", padx=(0, 10), pady=5) var = tk.StringVar(value=default_value) entry = tk.Entry(frame, textvariable=var, width=6) entry.grid(row=i, column=1, sticky="w", pady=5) entries.append(entry) entries[0].bind("", lambda event: validate_and_close()) entries[1].bind("", lambda event: validate_and_close()) def validate_and_close(): global x_pixels, y_pixels, line_thickness, font_size_title, font_size_object, target_dpi try: x_pixels = int(entries[0].get()) y_pixels = int(entries[1].get()) line_thickness = int(entries[2].get()) # Adjusted index to match line thickness entry font_size_title = int(entries[3].get()) # Define font_size from the input font_size_object = int(entries[4].get()) # Define font_size_object from the input target_dpi = int(entries[5].get()) # Adjusted to ensure DPI is within valid range root.destroy() # Close the GUI window immediately after exiting except ValueError: messagebox.showerror("Ошибка", "Пожалуйста, введите числовое значение для числового поля") def cancel_and_close(): root.destroy() root.protocol("WM_DELETE_WINDOW", cancel_and_close) button_frame = tk.Frame(root) button_frame.pack(pady=(10, 0)) ok_button = tk.Button(button_frame, text="OK", command=validate_and_close) ok_button.pack(side=tk.LEFT, padx=(0, 10)) cancel_button = tk.Button(button_frame, text="Cancel", command=cancel_and_close) cancel_button.pack(side=tk.LEFT) root.geometry("380x270") # Increased height to accommodate the new field root.mainloop() return x_pixels, y_pixels, line_thickness, font_size_title, font_size_object, target_dpi # Example usage: x_pixels, y_pixels, line_thickness, font_size_title, font_size_object, target_dpi = get_user_preferences_dendrogram( "Параметры дендрограммы классов") print("Параметры дендрограммы классов") print("X pixels:", x_pixels) print("Y pixels:", y_pixels) print("Line thickness:", line_thickness) print("font_size_title:", font_size_title) print("font_size_object:", font_size_object) print("DPI:", target_dpi) def perform_cluster_analysis(method, x_pixels, y_pixels, line_thickness, font_size_title, font_size_object, target_dpi): import matplotlib matplotlib.rcParams['lines.linewidth'] = line_thickness # Assuming excel_file_path, clustering_classes_folder, name_appl, and full_model_name are defined elsewhere df = pd.read_excel(excel_file_path, header=0, index_col=0) if "Kod_pr-Name" in df.index: df.drop("Kod_pr-Name", axis=0, inplace=True) linkage_matrix = linkage(df.transpose(), method=method) dendrogram_file_path = os.path.join(clustering_classes_folder, f'dendrogram-{method}.png') fig, ax = plt.subplots(figsize=(x_pixels / target_dpi, y_pixels / target_dpi), dpi=target_dpi) plt.xlabel("Расстояние", fontsize=font_size_title, labelpad=10) plt.ylabel("Объекты", fontsize=font_size_title, labelpad=10) dendrogram(linkage_matrix, labels=df.columns, leaf_rotation=0, orientation='right', leaf_font_size=font_size_object) plt.savefig(dendrogram_file_path, format='png', bbox_inches='tight', pad_inches=0.1, dpi=target_dpi) plt.close() img = plt.imread(dendrogram_file_path) dendrogram_width_pixels = img.shape[1] title_text = ( f"ДЕНДРОГРАММА АГЛОМЕРАТИВНОЙ КЛАСТЕРИЗАЦИИ КЛАССОВ\n\n" f"(С°) Персональная интеллектуальная on-line среда 'Эйдос'\n" f"Приложение: {name_appl}\n" f"Модель: {full_model_name}\n" f"Метод кластеризации: {method}\n" f"Дата и время создания дендрограммы: {pd.Timestamp.now()}\n" ) title_lines = title_text.split('\n') title_height = len(title_lines) * font_size_title * 1.2 fig_height = title_height / target_dpi fig, ax = plt.subplots(figsize=(dendrogram_width_pixels / target_dpi, fig_height), dpi=target_dpi) ax.axis('off') ax.text(0.5, 1.0, s=title_text, fontsize=font_size_title, fontweight='bold', ha='center', va='top', color='black') title_with_dendrogram_file_path = os.path.join(clustering_classes_folder, f'dendrogram-{method}_with_title.png') plt.savefig(title_with_dendrogram_file_path, format='png', bbox_inches='tight', pad_inches=0.1, dpi=target_dpi) plt.close() title_with_dendrogram_img = Image.open(title_with_dendrogram_file_path) title_with_dendrogram_img = title_with_dendrogram_img.resize( (dendrogram_width_pixels, title_with_dendrogram_img.height)) # Assuming combine_titles_with_dendrograms function is defined elsewhere combine_titles_with_dendrograms(method, clustering_classes_folder, linkage_matrix, dendrogram_width_pixels, title_with_dendrogram_img) os.remove(dendrogram_file_path) os.remove(title_with_dendrogram_file_path) combined_file_path = os.path.join(clustering_classes_folder, f'dendrogram-{method}_ALL.png') print(f"Combined image saved: {combined_file_path}. Temporary files removed.") def crop_empty_space(img): # Convert the image to grayscale gray_img = ImageOps.grayscale(img) # Apply a threshold value to find the title text threshold = 100 # Threshold value for the title text gray_img = gray_img.point(lambda p: p < threshold and 255) # Convert text pixels to white color # Find the bottom edge of the title bottom_edge = gray_img.size[1] - 1 while bottom_edge > 0 and gray_img.getpixel((0, bottom_edge)) == 255: # 255 represents white color bottom_edge -= 1 # Crop the image if bottom_edge < gray_img.size[1] - 1: img = img.crop((0, 0, img.width, bottom_edge)) return img def combine_titles_with_dendrograms(method, clustering_classes_folder, linkage_matrix, dendrogram_width_pixels, title_with_dendrogram_img): # Get paths to the title and dendrogram files dendrogram_file_path = os.path.join(clustering_classes_folder, f'dendrogram-{method}.png') # Open the dendrogram file dendrogram_img = Image.open(dendrogram_file_path) # Compute the combined height without any additional spacing combined_height = title_with_dendrogram_img.height + dendrogram_img.height # Create a new image for the combined title and dendrogram combined_img = Image.new('RGB', (dendrogram_img.width, combined_height)) combined_img.paste(title_with_dendrogram_img, (0, 0)) combined_img.paste(dendrogram_img, (0, title_with_dendrogram_img.height)) # without spacing # Save the resulting image combined_file_path = os.path.join(clustering_classes_folder, f'dendrogram-{method}_ALL.png') combined_img.save(combined_file_path) print(f"Combined image saved: {combined_file_path}") # ЗАВИСИМОСТЬ МЕЖКЛАСТЕРНЫХ РАССТОЯНИЙ ОТ УРОВНЯ ИЕРАРХИИ ДЕНДРОГРАММЫ КЛАССОВ # Generating a plot of inter-cluster distances as a function of the hierarchy level of the dendrogram plt.figure() plt.plot(linkage_matrix[:, 2], color='blue') # Plotting distances plt.xlabel('Уровень иерархии') plt.ylabel('Расстояние между кластерами') # Create a title without the first line of the dendrogram title title_lines = title_text.split('\n') modified_title_text = '\n'.join(title_lines[1:]) # Concatenate lines starting from the second one plt.title( "ЗАВИСИМОСТЬ МЕЖКЛАСТЕРНЫХ РАССТОЯНИЙ ОТ УРОВНЯ ИЕРАРХИИ ДЕНДРОГРАММЫ КЛАССОВ\n\n" + modified_title_text, fontsize=7, fontweight='bold') # Use the same title as the dendrogram distance_plot_file_path = os.path.join(clustering_classes_folder, f'dendrogram_distances-{method}.png') plt.savefig(distance_plot_file_path, format='png', bbox_inches='tight', pad_inches=0.1, dpi=300) plt.close() def on_cluster_analysis(): selected_methods = [method for method, var in method_vars.items() if var.get() == "1"] if not selected_methods: messagebox.showwarning("Ошибка", "Выберите метод кластеризации!") return progress_bar["maximum"] = len(selected_methods) for i, method in enumerate(selected_methods, start=1): progress_bar["value"] = i root.update_idletasks() perform_cluster_analysis(method, x_pixels, y_pixels, line_thickness, font_size_title, font_size_object, target_dpi) # corrected variable name # Закрыть окно после завершения кластеризации root.destroy() # Create a custom toplevel window for the success message success_window = Tk() success_window.title("Успешное завершение") success_window.geometry("410x120") success_window.iconbitmap('_Aidos.ico') # Setting the icon for the success window # Add a label with success message and path on a new line success_message = f"\nКластеризация завершена успешно.\nРезультаты находятся в папке:\n{clustering_classes_folder}." Label(success_window, text=success_message).pack() # Function to close the success window def close_success_window(): success_window.destroy() sys.exit() # Add an "OK" button to close the success window ok_button = Button(success_window, text="OK", command=close_success_window) ok_button.pack() # Ensure the success window is active before starting the event loop success_window.grab_set() success_window.mainloop() def toggle_all_checkboxes(): select_all_state = select_all_var.get() for var in method_vars.values(): var.set(select_all_state) root = Tk() root.title("Выбор метода кластеризации") # Установка минимальных размеров окна root.minsize(350, 380) # Получение размеров экрана screen_width = root.winfo_screenwidth() screen_height = root.winfo_screenheight() # Расчет координат для размещения окна по центру экрана x_coordinate = (screen_width - 350) // 2 y_coordinate = (screen_height - 380) // 2 # Установка координат и размеров окна root.geometry(f"350x380+{x_coordinate}+{y_coordinate}") root.iconbitmap('_Aidos.ico') # Установка иконки для главного окна Label(root, text="").pack() # Пустая метка для создания отступа Label(root, text="Выберите методы кластеризации:").pack() # Надпись "Выберите методы кластеризации:" frame = Frame(root) # Создаем фрейм для размещения флажков и наименований методов frame.pack() # Add the "Select All" checkbox with the new label in the same frame as method checkboxes select_all_var = StringVar(root) Checkbutton(frame, text="Все методы", variable=select_all_var, command=toggle_all_checkboxes).pack(anchor='w') # Добавляем пустую метку для создания отступа empty_label = Label(frame, text="") empty_label.pack() method_vars = {} methods = ["single", "complete", "average", "weighted", "centroid", "median", "ward"] for method in methods: var = StringVar(root, value="1") method_vars[method] = var Checkbutton(frame, text=method, variable=var).pack(anchor='w') # Выравниваем по левому краю фрейма progress_bar = ttk.Progressbar(root, orient="horizontal", length=320, mode="determinate") progress_bar.pack(pady=10) # Add Help button Button(root, text="Помощь", command=show_help, width=10).pack(side="left", padx=15, pady=10) Button(root, text="Выполнить кластеризацию", command=on_cluster_analysis, width=30).pack(side="left", padx=5, pady=10) # Добавляем еще одну пустую метку для создания отступа перед кнопкой Label(root, text="").pack() root.mainloop() def _4324py(): ###################################################################################################################### # _4324py.py. 4.3.2.4. Классическая кластеризация признаков. Классическая кластеризация признаков в Питоне. Построение # и визуализация агломеративных дендрограмм признаков и графиков межкластерных расстояний в графическом виде, а также # матрицы сходства признаков ###################################################################################################################### # Функция для создания папки, если она не существует def create_folder_if_not_exists(folder_path): if not os.path.exists(folder_path): os.makedirs(folder_path) # Функция для конвертации DBF в XLSX def convert_db_to_xlsx(model_name, progress_bar): file_path = os.path.abspath('Appls.dbf') with DBF(file_path, encoding='cp866') as table: name_appl = None dbf_folder = None for record in table: if record.get('BY_DEFAULT').strip(): dbf_folder = record.get('PATH_APPL').strip() name_appl = record.get('NAME_APPL').strip() break if dbf_folder: model_name = None model_code = None param_file_path = os.path.join(dbf_folder, '4324Param.CSV') with open(param_file_path, 'r', encoding='cp866') as param_file: param_file_content = param_file.readlines() for line in param_file_content: if 'Код модели' in line: model_code = line.split('#')[1].strip() break Ar_Model = { "1": "Abs", "2": "Prс1", "3": "Prс2", "4": "Inf1", "5": "Inf2", "6": "Inf3", "7": "Inf4", "8": "Inf5", "9": "Inf6", "10": "Inf7" } model_name = Ar_Model.get(model_code) if model_name: wb = Workbook() ws = wb.active ws.title = model_name attributes_dbf_path = os.path.join(dbf_folder, 'Attributes.dbf') with DBF(attributes_dbf_path, encoding='cp866') as attributes_table: kod_pr_name_values = [] max_kod_pr_name = 0 for record in attributes_table: kod_atr = str(record['KOD_ATR']).strip() name_atr = record['NAME_ATR'].strip() kod_pr_name = f"{kod_atr}-{name_atr}" max_kod_pr_name = max(max_kod_pr_name, len(kod_pr_name) - 1) kod_pr_name_values.append(kod_pr_name) N_Atr = len(kod_pr_name_values) classes_dbf_path = os.path.join(dbf_folder, 'Classes.dbf') with DBF(classes_dbf_path, encoding='cp866') as classes_table: N_Cls = sum(1 for _ in classes_table) field_names = ['Kod_pr-Name'] field_names.extend([f"{record['KOD_CLS']}-{record['NAME_CLS']}" for record in classes_table]) ws.append(field_names) for col in ws.iter_cols(max_col=len(field_names)): for cell in col: cell.alignment = Alignment(horizontal='center', vertical='bottom', text_rotation=90) aInfStruct = [[kod_pr_name_values[0], "C", max_kod_pr_name, 0]] for j in range(1, N_Cls + 1): FieldName = f"N{j}" aInfStruct.append([FieldName, "N", 19, 7]) excel_file_path = os.path.join(dbf_folder, f'{model_name}.xlsx') model_txt_file_path = os.path.join(dbf_folder, f'{model_name}.txt') with open(model_txt_file_path, 'r', encoding='cp866') as model_txt_file: lines = model_txt_file.read().splitlines()[:-4] for row_idx, line in enumerate(lines, start=2): values = [kod_pr_name_values[row_idx - 2]] start_pos = 15 + max_kod_pr_name for field_info in aInfStruct[1:]: field_length = field_info[2] field_value = line[start_pos:start_pos + field_length].strip() if field_info[0] != 'Kod_pr-Name': if field_info[1] == 'N': try: field_value = float(field_value.replace(' ', '0').replace(',', '.')) except ValueError: field_value = 0 values.append(field_value) start_pos += field_length for col_idx, value in enumerate(values, start=1): ws.cell(row=row_idx, column=col_idx).value = value progress_bar['value'] = (row_idx - 1) / (len(lines) - 1) * 100 progress_bar.update() if 'Sheet' in wb.sheetnames: sheet = wb['Sheet'] wb.remove(sheet) try: wb.save(excel_file_path) except PermissionError: messagebox.showerror("Ошибка", "Файл Excel используется другой программой.") return True return False # Функция для создания GUI для кластеризации def create_gui(model_name): root = Tk() root.title(f"Преобразование БД модели {model_name} из txt файла в xlsx") root.geometry("550x100") root.iconbitmap("_Aidos.ico") label = Label(root, text=f"Преобразование БД модели {model_name} из txt файла в xlsx") label.pack(pady=10) progress_bar = ttk.Progressbar(root, orient='horizontal', length=500, mode='determinate') progress_bar.pack(pady=10) if convert_db_to_xlsx(model_name, progress_bar): label.config(text="Преобразование завершено успешно") else: messagebox.showerror("Ошибка", "Не удалось найти базу данных") root.after(3000, root.destroy) root.mainloop() # Получить абсолютный путь к базе данных DBF Appls.dbf file_path = os.path.abspath('Appls.dbf') # Открыть файл DBF и получить все записи из него with DBF(file_path, encoding='cp866') as table: name_appl = None dbf_folder = None for record in table: if record.get('BY_DEFAULT').strip(): dbf_folder = record.get('PATH_APPL').strip() name_appl = record.get('NAME_APPL').strip() break # Проверить, найден ли путь к базе данных if dbf_folder: param_file_path = os.path.join(dbf_folder, '4324Param.CSV') with open(param_file_path, 'r', encoding='cp866') as param_file: param_file_content = param_file.readlines() model_code = None for line in param_file_content: if 'Наименование модели:' in line: full_model_name = line.split('#')[1].strip() if 'Код модели:' in line: model_code = line.split('#')[1].strip() break Ar_Model = { "1": "Abs", "2": "Prс1", "3": "Prс2", "4": "Inf1", "5": "Inf2", "6": "Inf3", "7": "Inf4", "8": "Inf5", "9": "Inf6", "10": "Inf7" } model_name = Ar_Model.get(model_code) if model_name is None: print("Model name not found for code:", model_code) else: create_gui(model_name) # Вызов функции создания GUI здесь attributes_dbf_path = os.path.join(dbf_folder, 'Attributes.dbf') with DBF(attributes_dbf_path, encoding='cp866') as attributes_table: kod_pr_name_values = [] max_kod_pr_name = 0 for record in attributes_table: kod_atr = str(record['KOD_ATR']).strip() name_atr = record['NAME_ATR'].strip() kod_pr_name = f"{kod_atr}-{name_atr}" max_kod_pr_name = max(max_kod_pr_name, len(kod_pr_name) - 1) kod_pr_name_values.append(kod_pr_name) N_Atr = len(kod_pr_name_values) classes_dbf_path = os.path.join(dbf_folder, 'Classes.dbf') with DBF(classes_dbf_path, encoding='cp866') as classes_table: N_Cls = sum(1 for _ in classes_table) wb = Workbook() ws = wb.active ws.title = model_name field_names = ['Kod_pr-Name'] field_names.extend([f"{record['KOD_CLS']}-{record['NAME_CLS']}" for record in classes_table]) ws.append(field_names) for col in ws.iter_cols(max_col=len(field_names)): for cell in col: cell.alignment = Alignment(horizontal='center', vertical='bottom', text_rotation=90) aInfStruct = [[kod_pr_name_values[0], "C", max_kod_pr_name, 0]] for j in range(1, N_Cls + 1): FieldName = f"N{j}" aInfStruct.append([FieldName, "N", 19, 7]) excel_file_path = os.path.join(dbf_folder, f'{model_name}.xlsx') model_txt_file_path = os.path.join(dbf_folder, f'{model_name}.txt') with open(model_txt_file_path, 'r', encoding='cp866') as model_txt_file: lines = model_txt_file.read().splitlines()[:-4] for row_idx, line in enumerate(lines, start=2): values = [kod_pr_name_values[row_idx - 2]] start_pos = 15 + max_kod_pr_name for field_info in aInfStruct[1:]: field_length = field_info[2] field_value = line[start_pos:start_pos + field_length].strip() if field_info[0] != 'Kod_pr-Name': if field_info[1] == 'N': try: field_value = float(field_value.replace(' ', '0').replace(',', '.')) except ValueError: field_value = 0 values.append(field_value) start_pos += field_length for col_idx, value in enumerate(values, start=1): ws.cell(row=row_idx, column=col_idx).value = value if 'Sheet' in wb.sheetnames: sheet = wb['Sheet'] wb.remove(sheet) try: wb.save(excel_file_path) except PermissionError: messagebox.showerror("Ошибка", "Файл Excel используется другой программой.") else: messagebox.showerror("Ошибка", "Путь к базе данных не найден.") # ФОРМАТИРОВАНИЕ XLSX ФАЙЛА МОДЕЛИ def align_columns(file_path): # Открытие существующего файла Excel wb = load_workbook(file_path) ws = wb.active # Выравнивание первой колонки max_length_first_col = max(len(str(cell.value)) for cell in ws['A']) for cell in ws['A']: cell.alignment = Alignment(horizontal='left', vertical='bottom') ws.column_dimensions[cell.column_letter].width = max_length_first_col + 1 # Выравнивание остальных колонок for col in range(2, ws.max_column + 1): max_length = max( len(str(cell.value)) for row in ws.iter_rows(min_row=2, max_row=ws.max_row, min_col=col, max_col=col) for cell in row) ws.column_dimensions[ws.cell(row=1, column=col).column_letter].width = max_length # Сохранение изменений wb.save(file_path) # Пример вызова функции форматирования xlsx-файла # print(excel_file_path) align_columns(excel_file_path) # КОПИРОВАНИЕ XLSX ФАЙЛА МОДЕЛИ С СУФФИКСОМ "original" # Разделяем путь на директорию и имя файла directory, filename_orig = os.path.split(excel_file_path) # Разделяем имя файла и расширение name_orig, extension = os.path.splitext(filename_orig) # Создаем новое имя файла с добавленным суффиксом new_filename_orig = f"{name_orig}_{'original'}{extension}" # Формируем новый путь для скопированного файла new_excel_file_path_orig = os.path.join(directory, new_filename_orig) # Копируем файл shutil.copy2(excel_file_path, new_excel_file_path_orig) # ТРАНСПОНИРОВАНИЕ XLSX ФАЙЛА МОДЕЛИ def transpose_excel(file_name): # Получение абсолютного пути к файлу Excel file_path = os.path.abspath(file_name) # Чтение файла Excel wb = load_workbook(file_path) sheet = wb.active # Создание нового листа для транспонированных данных transposed_sheet = wb.create_sheet(title="Transposed") # Транспонирование данных for row in zip(*sheet.iter_rows()): transposed_sheet.append([cell.value for cell in row]) # Удаление изначального листа, если это необходимо if len(wb.sheetnames) > 1: del wb[sheet.title] # Форматирование наименований колонок for cell in transposed_sheet.iter_cols(min_row=1, max_row=1): cell[0].alignment = Alignment(horizontal='center', vertical='bottom', text_rotation=90) # Форматирование наименований строк for cell in transposed_sheet.iter_rows(min_col=1, max_col=1): cell[0].alignment = Alignment(horizontal='left', vertical='bottom') # Выравнивание колонок по ширине, начиная со второй колонки for col_idx, col in enumerate(transposed_sheet.columns, start=1): if col_idx == 1: # Пропускаем первую колонку с наименованиями строк continue max_length = max(len(str(cell.value)) for cell in col if cell.row != 1) # Пропускаем первую строку с наименованиями столбцов transposed_sheet.column_dimensions[col[0].column_letter].width = max_length # Увеличение ширины первой колонки на 10 символов max_length_first_col = max(len(str(cell.value)) for cell in transposed_sheet['A'][1:]) # Пропускаем первую ячейку с наименованием столбца transposed_sheet.column_dimensions['A'].width = max_length_first_col + 10 # Сохранение результата в исходном файле wb.save(file_path) # Имя файла Excel file_path = os.path.join(excel_file_path) # Вызов функции для транспонирования transpose_excel(file_path) # Переместить или скопировать транспонированный файл Excel модели в папку для результатов кластеризации def move_excel_file_to_clustering_results_folder(new_filename, clustering_attributes_folder): try: shutil.copy(new_filename, clustering_attributes_folder) # Копировать файл # shutil.move(excel_file_path, clustering_results_folder) # Переместить файл (если нужно переместить) # messagebox.showinfo("Успех", "Excel файл успешно скопирован в папку для результатов кластеризации.") except FileNotFoundError: messagebox.showerror("Ошибка", "Файл Excel модели не найден.") except Exception as e: messagebox.showerror("Ошибка", f"Произошла ошибка при копировании Excel файла: {e}") # КОПИРОВАНИЕ XLSX ФАЙЛА МОДЕЛИ С СУФФИКСОМ "transposed" # Разделяем путь на директорию и имя файла directory, filename_trans = os.path.split(excel_file_path) # Разделяем имя файла и расширение name_trans, extension = os.path.splitext(filename_trans) # Создаем новое имя файла с добавленным суффиксом new_filename_trans = f"{name_trans}_{'transposed'}{extension}" # Формируем новый путь для скопированного файла new_excel_file_path_trans = os.path.join(directory, new_filename_trans) # Копируем файл shutil.copy2(excel_file_path, new_excel_file_path_trans) # КЛАСТЕРИЗАЦИЯ ПРИЗНАКОВ # Определить папку для результатов кластеризации clustering_attributes_folder = os.path.join(dbf_folder, 'ClusteringAttributes') create_folder_if_not_exists(clustering_attributes_folder) # Вызов функции для перемещения или копирования файла Excel модели в папку для результатов кластеризации move_excel_file_to_clustering_results_folder(new_excel_file_path_trans, clustering_attributes_folder) def show_help(): help_text = """Кластеризация - это процесс группировки объектов данных на основе их сходства. Каждый из методов кластеризации имеет свои особенности: 1. Single linkage (одиночная связь): Этот метод определяет расстояние между двумя кластерами как минимальное расстояние между их членами. Объекты кластеризуются по принципу "ближайшего соседа". 2. Complete linkage (полная связь): В этом методе расстояние между кластерами определяется как максимальное расстояние между их членами. Объекты кластеризуются по принципу "самого дальнего соседа". 3. Average linkage (средняя связь): Расстояние между кластерами определяется как среднее расстояние между всеми парами их членов. 4. Weighted linkage (взвешенная связь): Этот метод похож на среднюю связь, но с использованием весов, чтобы учитывать различную значимость объектов. 5. Centroid linkage (центроидная связь): Расстояние между кластерами определяется как расстояние между их центроидами (средними значениями объектов). 6. Median linkage (медианная связь): Здесь расстояние между кластерами вычисляется как расстояние между их медианными объектами. 7. Ward linkage (метод Уорда): Этот метод стремится минимизировать дисперсию внутри кластеров, объединяя кластеры, которые минимизируют увеличение общей дисперсии после объединения.""" messagebox.showinfo("Помощь", help_text) # РАСЧЕТ И ЗАПИСЬ МАТРИЦЫ СХОДСТВА ПРИЗНАКОВ # Загрузка данных из файла Excel data = pd.read_excel(excel_file_path) # Исключаем первую строку (наименования объектов кластеризации) и первый столбец (наименования признаков) data = data.iloc[1:, 1:] # Вычисление корреляции Пирсона между колонками correlation_matrix = data.corr() # Создание нового файла Excel с матрицей сходства output_file_path = os.path.join(clustering_attributes_folder, 'Attributes_similarity_matrix.xlsx') try: # Запись данных в Excel с использованием openpyxl для форматирования with pd.ExcelWriter(output_file_path, engine='openpyxl') as writer: correlation_matrix.to_excel(writer, index=True, sheet_name='Correlation') # Получаем объект книги Excel wb = writer.book ws = wb['Correlation'] # Устанавливаем выравнивание для наименований колонок for cell in ws[1]: cell.alignment = Alignment(horizontal='center', vertical='bottom') cell.font = Font(bold=True) # Устанавливаем обычный шрифт для всех ячеек for row in ws.iter_rows(): for cell in row: cell.font = Font(name='Arial', size=10) # Создаем новый лист ws_new = wb.create_sheet(title='Summary') # Вставляем текст заголовка в новый лист title_text = ( f"МАТРИЦА СХОДСТВА ПРИЗНАКОВ\n" f"(С°) Персональная интеллектуальная on-line среда 'Эйдос'\n" f"Приложение: {name_appl}\n" f"Модель: {full_model_name}\n" f"Дата и время создания формы: {pd.Timestamp.now()}\n" ) for i, line in enumerate(title_text.split('\n')): cell = ws_new.cell(row=i + 1, column=1, value=line) cell.font = Font(bold=True) # Переносим наименования строк и столбцов с форматированием for col_idx, col_name in enumerate(correlation_matrix.columns): cell = ws_new.cell(row=6, column=col_idx + 2, value=col_name) cell.alignment = Alignment(horizontal='center', vertical='bottom', text_rotation=90) for row_idx, row_name in enumerate(correlation_matrix.index): cell = ws_new.cell(row=row_idx + 7, column=1, value=row_name) cell.alignment = Alignment(horizontal='left', vertical='bottom') # Переносим матрицу сходства на новый лист со смещением вниз на 6 строк for row_idx, row in enumerate(correlation_matrix.values): for col_idx, value in enumerate(row): ws_new.cell(row=row_idx + 7, column=col_idx + 2, value=value) # Размеры первой колонки max_length = max(len(str(cell.value)) for row in ws_new.iter_rows(min_row=7, max_row=ws_new.max_row, min_col=1, max_col=1) for cell in row) ws_new.column_dimensions['A'].width = max_length + 8 # Увеличиваем ширину на 8 символов для запаса # Удаляем старый лист del wb['Correlation'] # Сохраняем изменения wb.save(output_file_path) except PermissionError: # Если файл занят другим приложением, выводим сообщение об ошибке в GUI окне root = tk.Tk() root.withdraw() # Скрыть основное окно messagebox.showerror("Ошибка", "Файл Attributes_similarity_matrix.xlsx занят другим приложением. Закройте его и повторите попытку.") root.destroy() # Закрыть GUI окно после закрытия сообщения об ошибке # КРУГОВАЯ КОГНИТИВНАЯ ДИАГРАММА СХОДСТВА ПРИЗНАКОВ def get_user_preferences_circle(mTitle): global percentage_value, response_value, x_pixels, y_pixels, dpi, line_thickness, show_classes root = tk.Tk() root.title(mTitle) # Устанавливаем иконку root.iconbitmap("_Aidos.ico") frame = tk.Frame(root) frame.pack(padx=10, pady=10) fields = [ ("Показывать связи по модулю не менее (%) :", "0"), ("Показывать признаки без таких связей?", "Y"), ("Размер изображения по X (pixel):", "1080"), ("Размер изображения по Y (pixel):", "1080"), ("Максимальная толщина линий связи (pixel):", "5"), ("Разрешение (DPI):", "100") ] entries = [] for i, (label_text, default_value) in enumerate(fields): label = tk.Label(frame, text=label_text) label.grid(row=i, column=0, sticky="w", padx=(0, 10), pady=5) var = tk.StringVar(value=default_value) entry = tk.Entry(frame, textvariable=var, width=6) entry.grid(row=i, column=1, sticky="w", pady=5) entries.append(entry) entries[0].bind("", lambda event: validate_and_close()) entries[1].bind("", lambda event: validate_and_close()) # Default values percentage_value = 0 response_value = True x_pixels = 1080 y_pixels = 1080 line_thickness = 5 dpi = 100 show_classes = True def validate_and_close(): try: global percentage_value, response_value, x_pixels, y_pixels, dpi, line_thickness, show_classes percentage = float(entries[0].get()) if 0 <= percentage <= 100: response = entries[1].get().upper() == "Y" x_pixels = int(entries[2].get()) y_pixels = int(entries[3].get()) line_thickness = int(entries[4].get()) dpi = int(entries[5].get()) root.destroy() percentage_value = percentage response_value = response show_classes = response else: percentage_value = 0 except ValueError: messagebox.showerror("Ошибка", "Пожалуйста, введите числовое значение для числового поля") return root.quit() def cancel_and_close(): global percentage_value, response_value, x_pixels, y_pixels, dpi, line_thickness root.destroy() percentage_value = 0 response_value = True x_pixels = 1080 y_pixels = 1080 line_thickness = 5 dpi = 100 root.quit() root.protocol("WM_DELETE_WINDOW", cancel_and_close) button_frame = tk.Frame(root) button_frame.pack(pady=(10, 0)) ok_button = tk.Button(button_frame, text="OK", command=validate_and_close) ok_button.pack(side=tk.LEFT, padx=(0, 10)) cancel_button = tk.Button(button_frame, text="Cancel", command=cancel_and_close) cancel_button.pack(side=tk.LEFT) root.geometry("380x270") root.mainloop() return percentage_value, response_value, x_pixels, y_pixels, line_thickness, dpi, show_classes # Function to plot the circular diagram def plot_similarity_circle(correlation_matrix, classes, output_path): try: min_similarity_percentage, show_classes, x_pixels, y_pixels, line_thickness, target_dpi, show_classes = get_user_preferences_circle( "Параметры круговой диаграммы признаков") print("Параметры круговой диаграммы признаков") print("Percentage value:", min_similarity_percentage) print("Response value:", show_classes) print("X pixels:", x_pixels) print("Y pixels:", y_pixels) print("Line thickness:", line_thickness) print("DPI:", target_dpi) except Exception as e: print(f"Error: {e}") similarities = correlation_matrix.values num_classes = correlation_matrix.shape[0] # Find classes to display based on user preferences if not show_classes: classes_to_display = [] for i in range(num_classes): if any(abs(similarity) >= min_similarity_percentage * 0.01 for j, similarity in enumerate(correlation_matrix.iloc[i]) if i != j): classes_to_display.append(i) classes = [classes[i] for i in classes_to_display] correlation_matrix = correlation_matrix.iloc[classes_to_display, :].iloc[:, classes_to_display] num_classes = len(classes) if not classes_to_display: messagebox.showinfo("Классы не найдены", "При заданных условиях фильтрации признаков для визуализации не найдено!") return # Stop the execution of the function angles = np.linspace(0, 2 * np.pi, num_classes, endpoint=False) radius = 1.0 class_name_widths = [] class_name_heights = [] fig_tmp = plt.figure() resolution = target_dpi fig_tmp.set_dpi(resolution) canvas = fig_tmp.canvas for class_name in classes: fig_tmp.clear() t = fig_tmp.text(0.5, 0.5, class_name, fontsize=8, ha='center', va='center') bbox = t.get_window_extent(canvas.get_renderer()) w, h = bbox.width, bbox.height class_name_widths.append(w) class_name_heights.append(h) plt.close(fig_tmp) max_class_name_width = max(class_name_widths) max_class_name_height = max(class_name_heights) diameter = 2 * radius + max(max_class_name_width, max_class_name_height) + 40 # target_dpi = mDPI target_width_inches = x_pixels / target_dpi target_height_inches = y_pixels / target_dpi figure_size_inches = max(diameter / resolution, target_width_inches, target_height_inches) fig, ax = plt.subplots(figsize=(target_width_inches, target_height_inches), dpi=target_dpi) ax.set_xticks([]) ax.set_yticks([]) ax.set_xlim(-1.5, 1.5) ax.set_ylim(-1.5, 1.5) ax.axis('off') for i in range(num_classes): for j in range(num_classes): if i != j and (show_classes or correlation_matrix.iloc[i, j] != 0): similarity = correlation_matrix.iloc[i, j] if min_similarity_percentage * 0.01 < abs(similarity): color = 'red' if similarity > 0 else 'blue' width = abs(similarity) * line_thickness x1 = np.cos(angles[i]) * radius y1 = np.sin(angles[i]) * radius x2 = np.cos(angles[j]) * radius y2 = np.sin(angles[j]) * radius ax.plot([x1, x2], [y1, y2], color=color, linewidth=width) # Add labels for classes for i, class_name in enumerate(classes): x = np.cos(angles[i]) * radius y = np.sin(angles[i]) * radius ax.plot(x, y, 'o', markersize=10, color='black') x_text = np.cos(angles[i]) * radius * 1.06 y_text = np.sin(angles[i]) * radius * 1.06 ax.text(x_text, y_text, str(class_name), fontsize=8, ha='left', va='center', rotation=angles[i] * 180 / np.pi, rotation_mode='anchor', transform=ax.transData) # Add title and bottom text title_text = ( f"\n" f"КРУГОВАЯ КОГНИТИВНАЯ ДИАГРАММА СХОДСТВА ПРИЗНАКОВ\n\n" f"(С°) Персональная интеллектуальная on-line среда 'Эйдос'\n" f"Приложение: {name_appl}\n" f"Модель: {full_model_name}\n" f"Дата и время создания диаграммы: {pd.Timestamp.now()}\n" ) bbox_props = dict(boxstyle="square", pad=0, fc="white", lw=0) ax.text(0.5, 1.0, title_text, transform=ax.transAxes, fontsize=11, fontweight='bold', ha='center', va='baseline', bbox=bbox_props) # print(min_similarity_percentage, show_classes) if show_classes: mClasses = "все классы." else: mClasses = "только классы с такими связями." bottom_text = ( f"Линии связи между признаками отображают степень их сходства / различия по смыслу, \n" f"т.е. по их влиянию на переходы объекта моделирования в будущие состояния, соответствующие классам.\n" f"Красный цет означает сходство, синий - различие, толщина линий отражает степень сходства / различия.\n" f"Показаны только линии связи по модулю силы не менее {min_similarity_percentage}% и {mClasses}\n" ) bbox_props_bottom = dict(boxstyle="square,pad=0", facecolor="white", edgecolor="none", alpha=1.0) ax.text(0.5, -0.1, bottom_text, transform=ax.transAxes, fontsize=10, fontweight='bold', ha='center', va='center', bbox=bbox_props_bottom) fig.savefig(output_path, dpi=target_dpi) plt.close(fig) # Вызов функции рисования круговой когнитивной диаграммы output_file_path = os.path.join(clustering_attributes_folder, "Attributes_similarity_matrix.png") # print(output_file_path) classes_dbf_path = os.path.join(dbf_folder, 'Attributes.dbf') field_names = [] with DBF(classes_dbf_path, encoding='cp866') as classes_table: N_Cls = sum(1 for _ in classes_table) field_names.extend([f"{record['KOD_ATR']}-{record['NAME_ATR']}" for record in classes_table]) # print(field_names) plot_similarity_circle(correlation_matrix, field_names, output_file_path) # ДЕНДРОГРАММА АГЛОМЕРАТИВНОЙ КЛАСТЕРИЗАЦИИ ПРИЗНАКОВ def get_user_preferences_dendrogram(mTitle): global x_pixels, y_pixels, line_thickness, font_size_title, font_size_object, target_dpi root = tk.Tk() root.title(mTitle) # Устанавливаем иконку root.iconbitmap("_Aidos.ico") # Устанавливаем иконку root.iconbitmap("_Aidos.ico") frame = tk.Frame(root) frame.pack(padx=10, pady=10) fields = [ ("Размер изображения по X (pixel):", "1080"), ("Размер изображения по Y (pixel):", "1080"), ("Толщина линий дендрограммы (pixel):", "5"), ("Размер шрифта заголовка:", "14"), ("Размер шрифта наименований объектов:", "8"), ("Разрешение (DPI):", "100") ] entries = [] for i, (label_text, default_value) in enumerate(fields): label = tk.Label(frame, text=label_text) label.grid(row=i, column=0, sticky="w", padx=(0, 10), pady=5) var = tk.StringVar(value=default_value) entry = tk.Entry(frame, textvariable=var, width=6) entry.grid(row=i, column=1, sticky="w", pady=5) entries.append(entry) entries[0].bind("", lambda event: validate_and_close()) entries[1].bind("", lambda event: validate_and_close()) def validate_and_close(): global x_pixels, y_pixels, line_thickness, font_size_title, font_size_object, target_dpi try: x_pixels = int(entries[0].get()) y_pixels = int(entries[1].get()) line_thickness = int(entries[2].get()) # Adjusted index to match line thickness entry font_size_title = int(entries[3].get()) # Define font_size from the input font_size_object = int(entries[4].get()) # Define font_size_object from the input target_dpi = int(entries[5].get()) # Adjusted to ensure DPI is within valid range root.destroy() # Close the GUI window immediately after exiting except ValueError: messagebox.showerror("Ошибка", "Пожалуйста, введите числовое значение для числового поля") def cancel_and_close(): root.destroy() root.protocol("WM_DELETE_WINDOW", cancel_and_close) button_frame = tk.Frame(root) button_frame.pack(pady=(10, 0)) ok_button = tk.Button(button_frame, text="OK", command=validate_and_close) ok_button.pack(side=tk.LEFT, padx=(0, 10)) cancel_button = tk.Button(button_frame, text="Cancel", command=cancel_and_close) cancel_button.pack(side=tk.LEFT) root.geometry("380x270") # Increased height to accommodate the new field root.mainloop() return x_pixels, y_pixels, line_thickness, font_size_title, font_size_object, target_dpi # Example usage: x_pixels, y_pixels, line_thickness, font_size_title, font_size_object, target_dpi = get_user_preferences_dendrogram( "Параметры дендрограммы признаков") print("Параметры дендрограммы признаков") print("X pixels:", x_pixels) print("Y pixels:", y_pixels) print("Line thickness:", line_thickness) print("font_size_title:", font_size_title) print("font_size_object:", font_size_object) print("DPI:", target_dpi) def perform_cluster_analysis(method, x_pixels, y_pixels, line_thickness, font_size_title, font_size_object, target_dpi): import matplotlib matplotlib.rcParams['lines.linewidth'] = line_thickness # Assuming excel_file_path, clustering_classes_folder, name_appl, and full_model_name are defined elsewhere df = pd.read_excel(excel_file_path, header=0, index_col=0) if "Kod_pr-Name" in df.index: df.drop("Kod_pr-Name", axis=0, inplace=True) linkage_matrix = linkage(df.transpose(), method=method) dendrogram_file_path = os.path.join(clustering_attributes_folder, f'dendrogram-{method}.png') fig, ax = plt.subplots(figsize=(x_pixels / target_dpi, y_pixels / target_dpi), dpi=target_dpi) plt.xlabel("Расстояние", fontsize=font_size_title, labelpad=10) plt.ylabel("Объекты", fontsize=font_size_title, labelpad=10) dendrogram(linkage_matrix, labels=df.columns, leaf_rotation=0, orientation='right', leaf_font_size=font_size_object) plt.savefig(dendrogram_file_path, format='png', bbox_inches='tight', pad_inches=0.1, dpi=target_dpi) plt.close() img = plt.imread(dendrogram_file_path) dendrogram_width_pixels = img.shape[1] title_text = ( f"ДЕНДРОГРАММА АГЛОМЕРАТИВНОЙ КЛАСТЕРИЗАЦИИ ПРИЗНАКОВ\n\n" f"(С°) Персональная интеллектуальная on-line среда 'Эйдос'\n" f"Приложение: {name_appl}\n" f"Модель: {full_model_name}\n" f"Метод кластеризации: {method}\n" f"Дата и время создания дендрограммы: {pd.Timestamp.now()}\n" ) title_lines = title_text.split('\n') title_height = len(title_lines) * font_size_title * 1.2 fig_height = title_height / target_dpi fig, ax = plt.subplots(figsize=(dendrogram_width_pixels / target_dpi, fig_height), dpi=target_dpi) ax.axis('off') ax.text(0.5, 1.0, s=title_text, fontsize=font_size_title, fontweight='bold', ha='center', va='top', color='black') title_with_dendrogram_file_path = os.path.join(clustering_attributes_folder, f'dendrogram-{method}_with_title.png') plt.savefig(title_with_dendrogram_file_path, format='png', bbox_inches='tight', pad_inches=0.1, dpi=target_dpi) plt.close() title_with_dendrogram_img = Image.open(title_with_dendrogram_file_path) title_with_dendrogram_img = title_with_dendrogram_img.resize( (dendrogram_width_pixels, title_with_dendrogram_img.height)) # Assuming combine_titles_with_dendrograms function is defined elsewhere combine_titles_with_dendrograms(method, clustering_attributes_folder, linkage_matrix, dendrogram_width_pixels, title_with_dendrogram_img) os.remove(dendrogram_file_path) os.remove(title_with_dendrogram_file_path) combined_file_path = os.path.join(clustering_attributes_folder, f'dendrogram-{method}_ALL.png') print(f"Combined image saved: {combined_file_path}. Temporary files removed.") def crop_empty_space(img): # Convert the image to grayscale gray_img = ImageOps.grayscale(img) # Apply a threshold value to find the title text threshold = 100 # Threshold value for the title text gray_img = gray_img.point(lambda p: p < threshold and 255) # Convert text pixels to white color # Find the bottom edge of the title bottom_edge = gray_img.size[1] - 1 while bottom_edge > 0 and gray_img.getpixel((0, bottom_edge)) == 255: # 255 represents white color bottom_edge -= 1 # Crop the image if bottom_edge < gray_img.size[1] - 1: img = img.crop((0, 0, img.width, bottom_edge)) return img def combine_titles_with_dendrograms(method, clustering_attributes_folder, linkage_matrix, dendrogram_width_pixels, title_with_dendrogram_img): # Get paths to the title and dendrogram files dendrogram_file_path = os.path.join(clustering_attributes_folder, f'dendrogram-{method}.png') # Open the dendrogram file dendrogram_img = Image.open(dendrogram_file_path) # Compute the combined height without any additional spacing combined_height = title_with_dendrogram_img.height + dendrogram_img.height # Create a new image for the combined title and dendrogram combined_img = Image.new('RGB', (dendrogram_img.width, combined_height)) combined_img.paste(title_with_dendrogram_img, (0, 0)) combined_img.paste(dendrogram_img, (0, title_with_dendrogram_img.height)) # without spacing # Save the resulting image combined_file_path = os.path.join(clustering_attributes_folder, f'dendrogram-{method}_ALL.png') combined_img.save(combined_file_path) print(f"Combined image saved: {combined_file_path}") # ЗАВИСИМОСТЬ МЕЖКЛАСТЕРНЫХ РАССТОЯНИЙ ОТ УРОВНЯ ИЕРАРХИИ ДЕНДРОГРАММЫ КЛАССОВ # Generating a plot of inter-cluster distances as a function of the hierarchy level of the dendrogram plt.figure() plt.plot(linkage_matrix[:, 2], color='blue') # Plotting distances plt.xlabel('Уровень иерархии') plt.ylabel('Расстояние между кластерами') # Create a title without the first line of the dendrogram title title_lines = title_text.split('\n') modified_title_text = '\n'.join(title_lines[1:]) # Concatenate lines starting from the second one plt.title( "ЗАВИСИМОСТЬ МЕЖКЛАСТЕРНЫХ РАССТОЯНИЙ ОТ УРОВНЯ ИЕРАРХИИ ДЕНДРОГРАММЫ ПРИЗНАКОВ\n\n" + modified_title_text, fontsize=7, fontweight='bold') # Use the same title as the dendrogram distance_plot_file_path = os.path.join(clustering_attributes_folder, f'dendrogram_distances-{method}.png') plt.savefig(distance_plot_file_path, format='png', bbox_inches='tight', pad_inches=0.1, dpi=300) plt.close() def on_cluster_analysis(): selected_methods = [method for method, var in method_vars.items() if var.get() == "1"] if not selected_methods: messagebox.showwarning("Ошибка", "Выберите метод кластеризации!") return progress_bar["maximum"] = len(selected_methods) for i, method in enumerate(selected_methods, start=1): progress_bar["value"] = i root.update_idletasks() perform_cluster_analysis(method, x_pixels, y_pixels, line_thickness, font_size_title, font_size_object, target_dpi) # corrected variable name # КОПИРОВАНИЕ XLSX ФАЙЛА МОДЕЛИ С СУФФИКСОМ "original" БЕЗ СУФФИКСА # Разделяем путь на директорию и имя файла directory, filename_orig = os.path.split(new_excel_file_path_orig) # Удаляем суффикс "_original" из имени файла name_orig = filename_orig.replace("_original", "") # Формируем новый путь для папки без суффикса "_original" new_directory_orig = os.path.join(directory, name_orig) # Копируем файл shutil.copy2(new_excel_file_path_orig, new_directory_orig) # Закрыть окно после завершения кластеризации root.destroy() # Create a custom toplevel window for the success message success_window = Tk() success_window.title("Успешное завершение") success_window.geometry("410x120") success_window.iconbitmap('_Aidos.ico') # Setting the icon for the success window # Add a label with success message and path on a new line success_message = f"\nКластеризация завершена успешно.\nРезультаты находятся в папке:\n{clustering_attributes_folder}." Label(success_window, text=success_message).pack() # Function to close the success window def close_success_window(): success_window.destroy() sys.exit() # Add an "OK" button to close the success window ok_button = Button(success_window, text="OK", command=close_success_window) ok_button.pack() # Ensure the success window is active before starting the event loop success_window.grab_set() success_window.mainloop() def toggle_all_checkboxes(): select_all_state = select_all_var.get() for var in method_vars.values(): var.set(select_all_state) root = Tk() root.title("Выбор метода кластеризации") # Установка минимальных размеров окна root.minsize(350, 380) # Получение размеров экрана screen_width = root.winfo_screenwidth() screen_height = root.winfo_screenheight() # Расчет координат для размещения окна по центру экрана x_coordinate = (screen_width - 350) // 2 y_coordinate = (screen_height - 380) // 2 # Установка координат и размеров окна root.geometry(f"350x380+{x_coordinate}+{y_coordinate}") root.iconbitmap('_Aidos.ico') # Установка иконки для главного окна Label(root, text="").pack() # Пустая метка для создания отступа Label(root, text="Выберите методы кластеризации:").pack() # Надпись "Выберите методы кластеризации:" frame = Frame(root) # Создаем фрейм для размещения флажков и наименований методов frame.pack() # Add the "Select All" checkbox with the new label in the same frame as method checkboxes select_all_var = StringVar(root) Checkbutton(frame, text="Все методы", variable=select_all_var, command=toggle_all_checkboxes).pack(anchor='w') # Добавляем пустую метку для создания отступа empty_label = Label(frame, text="") empty_label.pack() method_vars = {} methods = ["single", "complete", "average", "weighted", "centroid", "median", "ward"] for method in methods: var = StringVar(root, value="1") method_vars[method] = var Checkbutton(frame, text=method, variable=var).pack(anchor='w') # Выравниваем по левому краю фрейма progress_bar = ttk.Progressbar(root, orient="horizontal", length=320, mode="determinate") progress_bar.pack(pady=10) # Add Help button Button(root, text="Помощь", command=show_help, width=10).pack(side="left", padx=15, pady=10) Button(root, text="Выполнить кластеризацию", command=on_cluster_analysis, width=30).pack(side="left", padx=5, pady=10) # Добавляем еще одну пустую метку для создания отступа перед кнопкой Label(root, text="").pack() root.mainloop() def _5_11py_testing(): # ################################################################################################ # _5_11py_testing.py. (c°) проф.Е.В.Луценко. Программа тестирования по АСК-анализу и системе Эйдос # ################################################################################################ URL_Eidos_cloud = "http://lc.kubagro.ru" # Адрес Эйдос-облака в Internet FTP_access_to_the_Eidos_cloud() student_name = '' test_data = {} # ########################################################################################################################################################### Test_number = 0 # Здесь укажите номер теста, например, 1, 2, 3, 4 или 0, если все тесты вместе student_name = "" # Переменная для хранения ФИО учащегося questions = [] # Массив вопросов и ответов # Массив вопросов и ответов questions_all = [ ["Основные положения информационно-функциональной теории развития техники.", "Информационно-функциональная теория развития техники исследует взаимосвязь между информацией и развитием техники, утверждая, что информация играет ключевую роль в этом процессе.", "Эта теория исследует влияние развития техники на информацию.", "Основное положение этой теории - техника не зависит от информации.", "Техника развивается независимо от информации."], ["Процессы труда и познания, как информационные процессы снятия неопределенности.", "Процессы труда и познания рассматриваются как информационные процессы, которые помогают снимать неопределенность и получать знания.", "Эти процессы не имеют ничего общего с информацией и неопределенностью.", "Процессы труда и познания сводятся к обработке случайных данных.", "Процессы труда и познания не имеют информационной природы."], ["Организм человека и средства труда как информационные системы.", "Организм человека и средства труда рассматриваются как информационные системы, взаимодействующие для достижения определенных целей.", "Организм человека не имеет ничего общего с информационными системами.", "Средства труда - это только инструменты, не связанные с информацией.", "Организм человека и средства труда не являются информационными системами."], ["Законы развития техники.", "Законы развития техники описывают определенные закономерности в её развитии, включая рост сложности и интеграции информационных технологий.", "Законы развития техники не существуют.", "Законы развития техники описывают только материальные процессы.", "Развитие техники не подчиняется никаким законам."], ["Детерминация формы сознания человека функциональным уровнем средств труда.", "Форма сознания человека может быть определена функциональным уровнем используемых средств труда согласно этой теории.", "Сознание человека не зависит от средств труда.", "Эта теория не рассматривает влияние средств труда на сознание.", "Сознание человека формируется только средствами труда."], ["Неизбежность возникновения компьютеров, информационных систем и систем искусственного интеллекта.", "Теория предсказывает неизбежность возникновения компьютеров, информационных систем и систем искусственного интеллекта в результате развития информационных технологий.", "Эта теория утверждает, что компьютеры и системы искусственного интеллекта не будут развиваться.", "Неизбежность возникновения таких систем не связана с информационной теорией стоимости.", "Развитие информационных технологий не влияет на возникновение компьютеров и систем искусственного интеллекта."], ["Информационная теория стоимости.", "Информационная теория стоимости исследует, как информация влияет на стоимость товаров и услуг.", "Эта теория оценивает стоимость информации, но не связана с товарами и услугами.", "Информационная теория стоимости определяет только потребительскую стоимость информации.", "Стоимость товаров и услуг зависит только от информации."], ["Связь количества и качества информации с меновой и потребительной стоимостью.", "Эта теория утверждает, что как количество, так и качество информации могут влиять на её меновую и потребительскую стоимость.", "Количество информации не имеет значения для её стоимости.", "Качество информации никак не связано со стоимостью.", "Информация всегда имеет одинаковую стоимость независимо от количества и качества."], [ "Информация, как сырье и как товар: абсолютная, относительная и аналитическая информация. Данные, информация, знания.", "Эта теория различает информацию как сырье и как товар, разделяя её на абсолютную, относительную и аналитическая информацию, а также на данные и знания.", "Информация всегда является товаром.", "Знания и данные это одно и то же.", "Информация не имеет разных форм и всегда одинакова."], ["Стоимость и амортизация систем искусственного интеллекта и баз знаний.", "Эта теория рассматривает стоимость и процесс амортизации систем искусственного интеллекта и баз знаний с точки зрения информационной теории стоимости.", "Системы искусственного интеллекта не имеют стоимости.", "Амортизация не применима к системам искусственного интеллекта.", "Стоимость и амортизация систем искусственного интеллекта и баз знаний не имеют значения."], [ "Источники экономической эффективности систем искусственного интеллекта и интеллектуальной обработки данных с позиций информационной теории стоимости (повышение уровня системности и 'охлаждение' объекта управления).", "Источники экономической эффективности систем искусственного интеллекта включают повышение уровня системности и 'охлаждение' объекта управления, как утверждает теория стоимости информации.", "Экономическая эффективность не связана с информационной теорией.", "Источники экономической эффективности систем искусственного интеллекта неизвестны.", "Экономическая эффективность систем искусственного интеллекта зависит от цвета их корпуса."], ["Интеллектуализация - генеральное направление и развития информационных технологий.", "Интеллектуализация считается главным направлением развития информационных технологий, как предсказывает теория.", "Интеллектуализация не имеет значения для информационных технологий.", "Главным направлением развития - автоматизация.", "Интеллектуализация означает создание технологий для обучения домашних животных."], ["От электронных вычислительных машин к компьютерам. Функциональное определение компьютера.", "Теория описывает развитие от электронных вычислительных машин к компьютерам и дает функциональное определение компьютера.", "Электронные вычислительные машины и компьютеры - одно и то же.", "Компьютеры не имеют функционального определения.", "Компьютеры - это машины для приготовления кофе."], ["Эволюция понятия: 'Обработка информации' от информационного сырья к информационному продукту.", "Теория исследует эволюцию понятия 'обработка информации' от первоначальной фазы информационного сырья к конечному информационному продукту.", "Понятие 'обработка информации' не имеет эволюции.", "Обработка информации всегда оставалась одинаковой.", "Эволюция понятия 'обработка информации' связана с изменением месяца."], ["Эволюция технологий создания и поддержки информационных систем: автоматизация функций посредников.", "Теория описывает эволюцию технологий создания и поддержки информационных систем, включая автоматизацию функций посредников.", "Технологии информационных систем не изменялись со временем.", "Автоматизация функций посредников никак не связана с информационными системами.", "Эволюция технологий информационных систем началась с изобретения желтых ботинок."], [ "Перспективы информационных технологий: интеллектуализация, создание самообучающихся, саморазвивающихся (эволюционирующих) и самовоспроизводящихся систем.", "Теория предсказывает перспективы информационных технологий, включая интеллектуализацию и создание самообучающихся, саморазвивающихся и самовоспроизводящихся систем.", "Информационные технологии не имеют перспектив.", "Интеллектуализация не связана с информационными технологиями.", "Перспективы информационных технологий включают использование человеческих деревьев для обработки данных."], ["Данные, информация, знания. Системно-когнитивный анализ как развитие концепции смысла Шенка-Абельсона.", "Теория разделяет данные, информацию и знания, и использует системно-когнитивный анализ для развития концепции смысла Шенка-Абельсона.", "Данные, информация и знания - одно и то же.", "Системно-когнитивный анализ не связан с концепцией смысла.", "Данные - это информация, а информация - это знания."], ["Когнитивная концепция АСК-анализа и синтеза когнитивного конфигуратора.", "Когнитивная концепция включает АСК-анализ и синтез когнитивного конфигуратора как метод анализа и синтеза информации.", "Когнитивная концепция не имеет отношения к АСК-анализу.", "АСК-анализ и когнитивный конфигуратор - это два разных подхода.", "Когнитивный конфигуратор - это прибор для магических исследований."], [ "Мышление как вычисление смысла и реализация операций со смыслом в инструментарии АСК-анализа - системе 'Эйдос'.", "Когнитивная концепция утверждает, что мышление сводится к вычислению смысла и операциям со смыслом с использованием АСК-анализа и системы 'Эйдос'.", "Мышление не имеет отношения к смыслу и операциям.", "АСК-анализ и система 'Эйдос' не связаны с мышлением.", "Мышление - это просто случайное событие."], ["Понятие: 'Система искусственного интеллекта', место СИИ в классификации информационных систем.", "Теория определяет понятие 'Система искусственного интеллекта' и размещает её в классификации информационных систем.", "Система искусственного интеллекта не имеет определения.", "Системы искусственного интеллекта не являются информационными системами.", "Системы искусственного интеллекта - это магические артефакты."], ["Определение и классификация систем искусственного интеллекта, цели и пути их создания.", "Теория предоставляет определение и классификацию систем искусственного интеллекта, а также обсуждает их цели и способы создания.", "Системы искусственного интеллекта не имеют классификации.", "Создание систем искусственного интеллекта не требует обсуждения целей и путей.", "Системы искусственного интеллекта создаются при помощи магии."], [ "Тест Тьюринга и критерии 'интеллектуальности' информационных систем. Может ли машина мыслить? Может ли искусственный интеллект превзойти своего создателя?", "Теория обсуждает Тест Тьюринга и критерии интеллектуальности информационных систем, а также вопросы о способности машин мыслить и о превосходстве искусственного интеллекта над человеком.", "Тест Тьюринга не имеет значения для искусственного интеллекта.", "Машины не могут думать и быть интеллектуальными.", "Машины думают лучше, чем человек, всегда и во всем."], ["Классификация систем искусственного интеллекта.", "Теория предоставляет классификацию систем искусственного интеллекта, основанную на их функциях и возможностях.", "Системы искусственного интеллекта не могут быть классифицированы.", "Классификация не имеет значения для систем искусственного интеллекта.", "Системы искусственного интеллекта - это недифференцированный хаос."], [ "Особенности технологии создания систем искусственного интеллекта (обучение, 'социализация', как технологический этап).", "Теория описывает особенности технологии создания систем искусственного интеллекта, включая этапы обучения и 'социализации'.", "Технология создания систем искусственного интеллекта не имеет этапов.", "'Социализация' не имеет значения для технологии.", "Создание систем искусственного интеллекта - это случайный процесс."], ["Информационная модель деятельности специалиста и место систем искусственного интеллекта в этой деятельности.", "Теория предоставляет информационную модель деятельности специалиста и определяет место систем искусственного интеллекта в этой деятельности.", "Информационная модель специалиста не имеет значения.", "Системы искусственного интеллекта не могут использоваться в деятельности специалиста.", "Системы искусственного интеллекта могут заменить всех специалистов."], ["Жизненный цикл системы искусственного интеллекта и критерии перехода между этапами этого цикла.", "Теория описывает жизненный цикл системы искусственного интеллекта и устанавливает критерии перехода между его этапами.", "Системы искусственного интеллекта не имеют жизненного цикла.", "Критерии перехода не важны для этапов цикла.", "Системы искусственного интеллекта рождаются и умирают сразу."], ["Проблемы и пути повышения качества создаваемых систем искусственного интеллекта.", "Теория обсуждает проблемы и методы улучшения качества систем искусственного интеллекта.", "Качество систем искусственного интеллекта не может быть улучшено.", "Проблемы не связаны с созданием систем искусственного интеллекта.", "Системы искусственного интеллекта сами улучшают свое качество."], ["Обобщенные характеристики и свойства информации как экономического объекта.", "Теория обобщает характеристики и свойства информации как экономического объекта, включая её стоимость и роль в экономике.", "Информация не имеет экономической ценности.", "Характеристики информации не могут быть обобщены.", "Информация - это бесполезная абстракция."], ["Понятие экономической информации и её структура.", "Теория определяет понятие экономической информации и анализирует её структуру.", "Экономическая информация не имеет определения.", "Структура информации не важна для экономики.", "Экономическая информация - это пустой звук."], ["Понятие информационного рынка, его структура, функции и развитие.", "Теория описывает понятие информационного рынка, его структуру, функции и тенденции развития.", "Информационный рынок не имеет значения.", "Структура и функции не связаны с информационным рынком.", "Информационный рынок - это миф."], ["Обобщенная схема системного анализа, ориентированного на интеграцию с когнитивными технологиями.", "Теория представляет обобщенную схему системного анализа, учитывающую интеграцию с когнитивными технологиями, что позволяет более глубоко анализировать и понимать сложные системы.", "Системный анализ не может инегрироваться с когнитивными технологиями.", "Обобщенная схема системного анализа не имеет связи с когнитивными технологиями.", "Интеграция с когнитивными технологиями - это пустой разговор."], ["Когнитивная концепция и синтез когнитивного конфигуратора.", "Теория описывает когнитивную концепцию и процесс синтеза когнитивного конфигуратора, который используется для анализа информации и принятия решений.", "Когнитивная концепция не имеет отношения к системному анализу.", "Синтез когнитивного конфигуратора не имеет значения для анализа.", "Когнитивная концепция - это бессмысленная абстракция."], [ "Понятие когнитивного конфигуратора и необходимость естественно-научной (формализуемой) когнитивной концепции.", "Теория объясняет понятие когнитивного конфигуратора и показывает, почему необходима естественно-научная (формализуемая) когнитивная концепция для его разработки.", "Когнитивный конфигуратор не имеет определения.", "Формализация когнитивной концепции не важна.", "Когнитивный конфигуратор - это бессмысленная игрушка."], ["Формализуемая когнитивная концепция.", "Теория описывает формализованную когнитивную концепцию, которая представляет собой стройную систему понятий и методов для анализа когнитивных процессов.", "Когнитивная концепция не может быть формализованной.", "Формализация не важна для когнитивной концепции.", "Формализованная когнитивная концепция - это бессмысленное занятие."], ["Когнитивный конфигуратор и базовые когнитивные операции системного анализа.", "Теория объясняет, как когнитивный конфигуратор использует базовые когнитивные операции системного анализа для обработки информации и принятия решений.", "Когнитивный конфигуратор не имеет отношения к системному анализу.", "Базовые когнитивные операции не используются в анализе.", "Когнитивный конфигуратор - это пустой звук."], ["Задачи формализации базовых когнитивных операций системного анализа.", "Теория определяет задачи формализации базовых когнитивных операций, что позволяет создать более точные методы анализа информации.", "Формализация базовых когнитивных операций не имеет смысла.", "Задачи формализации не важны для анализа.", "Формализация операций - это бессмысленная затея."], ["СК-анализ, как системный анализ, структурированный до уровня базовых когнитивных операций.", "Теория представляет СК-анализ как метод системного анализа, структурированный до уровня базовых когнитивных операций, что позволяет более глубоко анализировать системы.", "СК-анализ не связан с когнитивными операциями.", "Структурирование до уровня базовых операций не важно.", "СК-анализ - это бессмысленная процедура."], ["Место и роль АСК-анализа в структуре управления.", "Теория объясняет место и роль АСК-анализа в структуре управления системами, позволяя более эффективно управлять ими.", "АСК-анализ не имеет места в управлении системами.", "Роль АСК-анализа не важна.", "АСК-анализ - это астрология."], ["Структура типовой АСУ.", "Теория описывает структуру типовой АСУ (автоматизированной системы управления), что помогает понять её организацию и функциональность.", "Структура АСУ не имеет значения.", "Типовая АСУ не существует.", "Структура АСУ - это сказка."], ["Параметрическая модель адаптивной АСУ сложными системами.", "Теория объясняет параметрическую модель адаптивной АСУ, которая используется для управления сложными системами, учитывая их изменчивость.", "Параметрическая модель не применима в управлении сложными системами.", "Адаптивная АСУ не нуждается в моделировании.", "Параметрическая модель - это басня."], ["Модель рефлексивной АСУ активными объектами и понятие мета-управления.", "Теория объясняет модель рефлексивной АСУ, которая учитывает активные объекты и концепцию мета-управления, что позволяет системе более гибко реагировать на изменения.", "Рефлексивная АСУ не имеет активных объектов.", "Понятие мета-управления не важно для АСУ.", "Модель рефлексивной АСУ - это бессмысленное изобретение."], ["Двухконтурная модель РАСУ в АПК.", "Теория представляет двухконтурную модель регулирования автоматизированными системами управления в агропромышленном комплексе, что позволяет учитывать разные аспекты управления.", "Регулирование в АПК не требует двухконтурной модели.", "Модель РАСУ не применима в АПК.", "Двухконтурная модель РАСУ - это миф."], ["Предпосылки и теоретические основы системной теории информации.", "Теория объясняет предпосылки и теоретические основы системной теории информации, что помогает понять её основные принципы.", "Системная теория информации не имеет предпосылок и основ.", "Теория информации не имеет теоретических основ.", "Системная теория информации - это сказка."], ["Требования к математической модели и численной мере СТИ.", "Теория описывает требования к математической модели и численной мере системной теории информации, что позволяет разрабатывать более точные методы анализа.", "Математическая модель и численная мера не имеют значения для системной теории информации.", "Требования не важны для анализа информации.", "Требования - это чистая формальность."], ["Выбор базовой численной меры СТИ.", "Теория объясняет выбор базовой численной меры системной теории информации, что определяет способ измерения информации.", "Выбор численной меры не имеет значения.", "Базовая численная мера не существует.", "Выбор численной меры - это произвол."], ["Конструирование системной численной меры на основе базовой в СТИ.", "Теория описывает процесс конструирования системной численной меры на основе базовой меры системной теории информации.", "Конструирование не влияет на измерение информации.", "Системная численная мера не может быть создана.", "Конструирование численной меры - это бессмысленное занятие."], ["Семантическая информационная модель АСК-анализа.", "Теория представляет семантическую информационную модель АСК-анализа, что помогает понимать структуру и смысл анализируемой информации.", "Семантическая модель не имеет отношения к АСК-анализу.", "Модель не важна для анализа.", "Семантическая информационная модель - это бессмысленная абстракция."], [ "Формализм динамики взаимодействующих семантических информационных пространств. Двухвекторное представление данных.", "Теория объясняет формализм динамики взаимодействующих семантических информационных пространств и концепцию двухвекторного представления данных, что позволяет более точно описывать процессы в информационных системах.", "Формализм динамики не применим к информационным пространствам.", "Двухвекторное представление данных не имеет значения.", "Формализм динамики - это хаос."], ["Применение классической теории информации К.Шеннона для расчета весовых коэффициентов и мер сходства.", "Теория объясняет применение классической теории информации К.Шеннона для расчета весовых коэффициентов и мер сходства в информационных системах.", "Классическая теория информации не применима в информационных системах.", "Весовые коэффициенты и меры сходства не могут быть рассчитаны.", "Классическая теория информации - это утопия."], [ "Математическая модель метода распознавания образов и принятия решений, основанного на системной теории информации.", "Теория представляет математическую модель метода распознавания образов и принятия решений, использующего системную теорию информации, что позволяет более эффективно анализировать данные и принимать решения.", "Математическая модель не применима для анализа данных.", "Метод распознавания образов не зависит от информации.", "Математическая модель - это магия."], ["Некоторые свойства математической модели АСК-анализ а (сходимость, адекватность, устойчивость и др.).", "Свойства математической модели АСК-анализа включают сходимость, адекватность, устойчивость и другие характеристики.", "Свойства модели не имеют значения.", "Математическая модель не обладает свойствами.", "Свойства - это придуманные понятия."], [ "Непараметричность модели. Робастные процедуры и фильтры для исключения артефактов в математической модели АСК-анализ а.", "Теория объясняет непараметричность модели и методы для исключения артефактов, используя робастные процедуры и фильтры.", "Модель всегда параметрическая.", "Робастные процедуры не влияют на модель.", "Непараметричность - это излишество."], ["Зависимость информативностей факторов от объема обучающей выборки.", "Теория описывает зависимость информативности факторов от объема обучающей выборки.", "Информативность факторов не зависит от объема выборки.", "Обучающая выборка не влияет на информативность факторов.", "Информативность - это случайность."], [ "Зависимость адекватности семантической информационной модели от объема обучающей выборки (адекватность при малых и больших выборках).", "Теория объясняет зависимость адекватности семантической информационной модели от объема обучающей выборки, включая адекватность при малых и больших выборках.", "Семантическая информационная модель всегда адекватна.", "Обучающая выборка не влияет на адекватность модели.", "Адекватность - это само собой разумеющееся."], ["Семантическая устойчивость модели АСК-анализ а.", "Теория объясняет семантическую устойчивость модели АСК-анализа.", "Семантическая устойчивость не имеет значения.", "Модель не может быть устойчивой.", "Устойчивость - это миф."], ["Зависимость некоторых параметров модели АСК-анализ а от ее ортонормированности.", "Теория объясняет зависимость некоторых параметров модели АСК-анализа от ее ортонормированности.", "Ортонормированность не влияет на параметры модели.", "Параметры модели всегда остаются неизменными.", "Ортонормированность - это бессмысленная фраза."], ["Взаимосвязь математической модели АСК-анализ а с другими моделями.", "Теория объясняет взаимосвязь математической модели АСК-анализа с другими моделями.", "Математическая модель не связана с другими моделями.", "Другие модели не могут быть использованы с АСК-анализом.", "Модели - это изолят."], [ "Взаимосвязь системной меры целесообразности информации со статистикой Х2 и новая мера уровня системности предметной области.", "Теория объясняет взаимосвязь системной меры целесообразности информации со статистикой Х2 и новой мерой уровня системности предметной области.", "Системная мера целесообразности не связана со статистикой.", "Статистика Х2 не имеет значения для системной меры.", "Меры - это пустые слова."], [ "Сравнение, идентификация и прогнозирование как разложение векторов объектов в ряд по векторам классов (объектный анализ).", "Теория объясняет сравнение, идентификацию и прогнозирование как разложение векторов объектов в ряд по векторам классов, что представляет объектный анализ.", "Сравнение и идентификация не имеют отношения к прогнозированию.", "Прогнозирование не связано с векторами классов.", "Анализ - это греческая буква."], ["Системно-когнитивный и факторный анализ. АСК-анализ , как метод вариабельных контрольных групп.", "Теория объясняет системно-когнитивный и факторный анализ, а также использование АСК-анализа как метода вариабельных контрольных групп.", "АСК-анализ не применим к контрольным группам.", "Факторный анализ не связан с системно-когнитивным.", "Группы - это абстрактное понятие."], ["Семантическая мера целесообразности информации и эластичность.", "Теория объясняет семантическую меру целесообразности информации и ее связь с эластичностью.", "Семантическая мера не зависит от эластичности.", "Эластичность не имеет значения для семантической меры.", "Целесообразность - это абстракция."], ["Связь семантической информационной модели с нейронными сетями.", "Теория объясняет связь семантической информационной модели с нейронными сетями.", "Семантическая модель не связана с нейронными сетями.", "Нейронные сети не могут использовать семантическую информационную модель.", "Связь - это вымысел."], [ "Математический метод АСК-анализ а в свете идей интервальной бутстрепной робастной статистики объектов нечисловой природы.", "Теория объясняет математический метод АСК-анализа с использованием интервальной бутстрепной робастной статистики для объектов нечисловой природы.", "АСК-анализ не может быть применен к нечисловым данным.", "Интервальная бутстрепная статистика не влияет на метод АСК-анализа.", "Метод - это загадка."], ["Принципы формализации предметной области и подготовки эмпирических данных.", "Теория объясняет принципы формализации предметной области и подготовки эмпирических данных.", "Формализация не имеет значения в анализе данных.", "Подготовка данных не важна в анализе.", "Принципы - это чистая абстракция."], ["Иерархическая структура данных и последовательность численных расчетов в АСК-анализе", "Теория описывает иерархическую структуру данных и последовательность численных расчетов в АСК-анализе.", "Структура данных не влияет на расчеты.", "Расчеты не связаны с последовательностью данных.", "Структура - это пустой звук."], ["Обобщенное описание алгоритмов АСК-анализа", "Теория представляет обобщенное описание алгоритмов АСК-анализа.", "Алгоритмы не имеют значения в анализе.", "АСК-анализ не использует алгоритмы.", "Описание алгоритмов - это пустая формальность."], ["БКОСА-2.1. 'Восприятие и запоминание исходной обучающей информации'.", "Теория объясняет этап 'Восприятие и запоминание исходной обучающей информации' в рамках БКОСА-2.1.", "Восприятие и запоминание не являются этапами обучения.", "БКОСА-2.1 не имеет значения.", "Обучение не связано с информацией."], ["БКОСА-2.2. 'Репрезентация. Сопоставление индивидуального опыта с коллективным (общественным)'.", "Теория объясняет этап 'Репрезентация. Сопоставление индивидуального опыта с коллективным (общественным)' в рамках БКОСА-2.2.", "Репрезентация не связана с индивидуальным опытом.", "БКОСА-2.2 не имеет значения.", "Репрезентация - это пустое слово."], ["БКОСА-3.1.1. 'Обобщение (синтез, индукция). Накопление первичных данных'.", "Теория объясняет этап 'Обобщение (синтез, индукция). Накопление первичных данных' в рамках БКОСА-3.1.1.", "Обобщение не связано с накоплением данных.", "БКОСА-3.1.1 не важна в анализе данных.", "Накопление данных - это бессмысленная задача."], ["БКОСА-3.1.2. 'Обобщение (синтез, индукция). Исключение артефактов'.", "Теория объясняет этап 'Обобщение (синтез, индукция). Исключение артефактов' в рамках БКОСА-3.1.2.", "Исключение артефактов не влияет на обобщение.", "БКОСА-3.1.2 не имеет значения.", "Исключение артефактов - это лишний шаг."], [ "БКОСА-3.1.3. 'Обобщение (синтез, индукция). Расчет степени истинности содержательных смысловых связей между предпосылками и результатами (обобщенных таблиц решений)'", "Теория объясняет этап 'Обобщение (синтез, индукция). Расчет степени истинности содержательных смысловых связей между предпосылками и результатами (обобщенных таблиц решений)' в рамках БКОСА-3.1.3.", "Расчет степени истинности не имеет значения для обобщения.", "БКОСА-3.1.3 не важна в анализе данных.", "Расчеты - это бессмысленные числа."], ["Как определить значимость шкал и градаций факторов и уровней Мерлина?", "Определение значимости шкал и градаций факторов и уровней Мерлина осуществляется на основе статистического анализа и экспертных оценок.", "Значимость шкал и градаций факторов и уровней Мерлина не имеет значения.", "Значимость шкал и градаций факторов и уровней Мерлина определяется исключительно экспертами.", "Определение значимости - это произвольный выбор."], ["Как определить значимость шкал и градаций классов и уровней Мерлина?", "Значимость шкал и градаций классов и уровней Мерлина определяется путем анализа их влияния на конечные результаты исследований.", "Значимость шкал и градаций классов и уровней Мерлина не имеет значения.", "Значимость шкал и градаций классов и уровней Мерлина устанавливается случайным образом.", "Определение значимости - это бессмысленное занятие."], ["Что означает абстрагирование факторов в контексте семантического пространства факторов?", "Абстрагирование факторов в семантическом пространстве факторов представляет собой процесс уменьшения размерности этого пространства с целью выделения наиболее важных характеристик.", "Абстрагирование факторов не имеет отношения к семантическому пространству факторов.", "Абстрагирование факторов в семантическом пространстве факторов означает создание дополнительных характеристик.", "Абстрагирование - это пустой звук."], ["Что означает абстрагирование классов в контексте семантического пространства классов?", "Абстрагирование классов в семантическом пространстве классов представляет собой процесс уменьшения размерности этого пространства с целью выделения наиболее важных классов.", "Абстрагирование классов не имеет отношения к семантическому пространству классов.", "Абстрагирование классов в семантическом пространстве классов означает создание дополнительных классов.", "Абстрагирование - это бессмысленное занятие."], ["Как проводится оценка адекватности информационной модели предметной области?", "Оценка адекватности информационной модели предметной области осуществляется сравнением результатов моделирования с реальными данными и экспертными оценками.", "Оценка адекватности информационной модели не требуется.", "Оценка адекватности информационной модели проводится только на основе теоретических вычислений.", "Оценка адекватности - это формальность."], ["Что включает в себя процесс сравнения, идентификации и прогнозирования в рамках объектного анализа?", "Процесс сравнения, идентификации и прогнозирования включает в себя сопоставление объектов, определение их идентификации и прогнозирование будущих состояний.", "Этот процесс не имеет конкретных шагов.", "Процесс сравнения, идентификации и прогнозирования включает только сравнение объектов.", "Процесс - это бессмысленное слово."], ["Что означает дедукция и абдукция классов в семантическом анализе обобщенных образов классов?", "Дедукция классов означает вывод классов из обобщенных образов, а абдукция классов - наоборот, выведение обобщенных образов из классов.", "Дедукция и абдукция классов не имеют отношения к семантическому анализу обобщенных образов.", "Дедукция и абдукция классов означают одно и то же действие.", "Дедукция классов означает создание классических собак, а абдукция классов - встречу пришельцев из другой галактики."], ["Что означает дедукция и абдукция факторов в семантическом анализе факторов?", "Дедукция факторов означает вывод факторов из имеющихся данных, а абдукция факторов - наоборот, выведение данных из факторов.", "Дедукция и абдукция факторов не имеют отношения к семантическому анализу факторов.", "Дедукция и абдукция факторов означают одно и то же действие.", "Дедукция факторов - это процесс создания новых видов мороженого, а абдукция факторов - умение летать на вертолете."], ["Как осуществляется классификация обобщенных образов классов?", "Классификация обобщенных образов классов происходит на основе их характеристик и признаков.", "Классификация обобщенных образов классов не требуется.", "Классификация обобщенных образов классов проводится случайным образом.", "Классификация обобщенных образов классов базируется на гадании на кофейной гуще."], ["Что включает в себя процесс формирования бинарных конструктов классов?", "Процесс формирования бинарных конструктов классов включает в себя создание парных сравнений и связей между классами.", "Процесс формирования бинарных конструктов классов не имеет определенных шагов.", "Процесс формирования бинарных конструктов классов ограничивается только выбором одного класса.", "Процесс формирования бинарных конструктов классов включает в себя использование фокусов и карт с тайнами."], ["Что подразумевается под визуализацией семантических сетей классов?", "Визуализация семантических сетей классов представляет собой отображение взаимосвязей и структуры между классами в графическом виде.", "Визуализация семантических сетей классов не имеет смысла.", "Визуализация семантических сетей классов ограничивается только текстовым описанием.", "Визуализация семантических сетей классов подразумевает использование телепатии для передачи информации."], ["Как проводится классификация факторов в данном контексте?", "Классификация факторов осуществляется на основе их характеристик и свойств.", "Классификация факторов не требуется в данном контексте.", "Классификация факторов проводится исключительно случайным образом.", "Классификация факторов производится по цвету глаз их владельцев."], ["Что включает в себя процесс формирования бинарных конструктов факторов?", "Процесс формирования бинарных конструктов факторов включает в себя создание парных сравнений и связей между факторами.", "Процесс формирования бинарных конструктов факторов не имеет определенных шагов.", "Процесс формирования бинарных конструктов факторов ограничивается только выбором одного фактора.", "Процесс формирования бинарных конструктов факторов включает в себя использование магии и колдовства."], ["Что подразумевается под визуализацией семантических сетей факторов?", "Визуализация семантических сетей факторов представляет собой отображение взаимосвязей и структуры между факторами в графическом виде.", "Визуализация семантических сетей факторов не имеет смысла.", "Визуализация семантических сетей факторов ограничивается только текстовым описанием.", "Визуализация семантических сетей факторов осуществляется при помощи гипноза и гадания на рунах."], ["Что включает в себя содержательное сравнение классов?", "Содержательное сравнение классов включает в себя анализ и сопоставление характеристик и признаков классов с целью выявления сходств и различий.", "Содержательное сравнение классов не представляет интереса.", "Содержательное сравнение классов ограничивается только назначением классов.", "Содержательное сравнение классов включает в себя медитацию и чтение гороскопов."], [ "Что включает в себя расчет и отображение многомногозначных когнитивных диаграмм, включая диаграммы Вольфа Мерлина?", "Расчет и отображение многомногозначных когнитивных диаграмм включает в себя создание графических представлений множественных значений и связей между ними, включая диаграммы Вольфа Мерлина.", "Расчет и отображение многомногозначных когнитивных диаграмм не имеет смысла.", "Расчет и отображение многомногозначных когнитивных диаграмм ограничивается только текстовым описанием.", "Расчет и отображение многомногозначных когнитивных диаграмм включает в себя использование магических заклинаний и талисманов."], ["Что включает в себя содержательное сравнение факторов?", "Содержательное сравнение факторов включает в себя анализ и сопоставление характеристик и свойств факторов с целью выявления сходств и различий.", "Содержательное сравнение факторов не представляет интереса.", "Содержательное сравнение факторов ограничивается только выбором одного фактора.", "Содержательное сравнение факторов включает в себя чтение гаданий и обращение к магическим шаром."], [ "Что включает в себя расчет и отображение многомногозначных когнитивных диаграмм, включая инвертированные диаграммы Мерлина?", "Расчет и отображение многомногозначных когнитивных диаграмм включает в себя создание графических представлений множественных значений и связей между ними, включая инвертированные диаграммы Мерлина.", "Расчет и отображение многомногозначных когнитивных диаграмм не имеет смысла.", "Расчет и отображение многомногозначных когнитивных диаграмм ограничивается только текстовым описанием.", "Расчет и отображение многомногозначных когнитивных диаграмм включает в себя использование волшебных палочек и зелья."], [ "Как осуществляется многовариантное планирование и принятие решения о применении системы управляющих факторов?", "Многовариантное планирование и принятие решения о применении системы управляющих факторов включает в себя анализ различных сценариев и выбор наилучшего варианта на основе заданных критериев.", "Многовариантное планирование и принятие решения не требует анализа различных вариантов.", "Многовариантное планирование и принятие решения ограничивается выбором первого доступного варианта.", "Многовариантное планирование и принятие решения сводится к бросанию монетки для принятия решения."], ["Какие детальные алгоритмы включает в себя АСК-анализ?", "АСК-анализ включает в себя ряд детальных алгоритмов, таких как анализ структуры и свойств классов, вычисление показателей значимости и др.", "АСК-анализ не включает в себя детальных алгоритмов.", "АСК-анализ ограничивается только общими принципами.", "АСК-анализ включает в себя изучение астрологии и предсказание будущего по звездам."], ["Каково назначение и состав системы 'Эйдос'?", "Система 'Эйдос' предназначена для анализа, моделирования и оптимизации информационных процессов и включает в себя подсистемы для сбора данных, анализа, прогнозирования и многого другого.", "Система 'Эйдос' не имеет определенного назначения.", "Система 'Эйдос' состоит только из одной подсистемы.", "Система 'Эйдос' служит только для гадания на кофейной гуще."], ["Какие цели и основные функции у системы 'Эйдос'?", "Система 'Эйдос' имеет цели, включающие в себя анализ и оптимизацию информационных процессов, а ее функции включают сбор данных, анализ, прогнозирование, адаптацию и многие другие.", "Система 'Эйдос' не имеет определенных целей и функций.", "Цели и функции системы 'Эйдос' ограничиваются только сбором данных.", "Система 'Эйдос' предназначена для приготовления кофе и чая."], ["Какова обобщенная структура системы 'Эйдос'?", "Обобщенная структура системы 'Эйдос' включает в себя модули для сбора, обработки, анализа и управления информацией, а также интерфейс для пользователей.", "Система 'Эйдос' не имеет определенной структуры.", "Обобщенная структура системы 'Эйдос' включает только один модуль.", "Структура системы 'Эйдос' основана на использовании магических кристаллов."], ["Какими характеристиками обладает пользовательский интерфейс в системе 'Эйдос'?", "Пользовательский интерфейс системы 'Эйдос' обладает возможностью визуализации данных, взаимодействия с пользователем и предоставления доступа к функциональным возможностям системы.", "Пользовательский интерфейс системы 'Эйдос' не имеет характеристик.", "Пользовательский интерфейс системы 'Эйдос' ограничивается только текстовыми данными.", "Пользовательский интерфейс системы 'Эйдос' работает только с помощью мысли."], ["Что включает в себя начальный этап синтеза модели в подсистеме 'Словари'?", "Начальный этап синтеза модели в подсистеме 'Словари' включает в себя когнитивную структуризацию и формализацию предметной области, а также подготовку исходных данных.", "Начальный этап синтеза модели в подсистеме 'Словари' не имеет конкретных этапов.", "Начальный этап синтеза модели включает только подготовку исходных данных.", "Начальный этап синтеза модели в подсистеме 'Словари' включает в себя магические ритуалы."], ["Что включает в себя синтез модели в подсистеме 'Обучение'?", "Синтез модели в подсистеме 'Обучение' включает в себя пакетное обучение системы распознавания на основе доступных данных и обучающих выборок.", "Синтез модели в подсистеме 'Обучение' не требует обучения системы.", "Синтез модели в подсистеме 'Обучение' ограничивается только чтением данных.", "Синтез модели в подсистеме 'Обучение' осуществляется с помощью магических заклинаний."], ["Как проводится оптимизация модели в подсистеме 'Оптимизация'?", "Оптимизация модели в подсистеме 'Оптимизация' осуществляется путем нахождения оптимальных параметров и настроек модели для достижения наилучших результатов.", "Оптимизация модели не проводится в системе.", "Оптимизация модели включает только изменение ее названия.", "Оптимизация модели в подсистеме 'Оптимизация' выполняется с помощью магического кристалла."], ["Как проводится верификация модели и оценка ее адекватности?", "Верификация модели и оценка ее адекватности проводится сравнением результатов моделирования с реальными данными и экспертными оценками для проверки соответствия модели реальным явлениям.", "Верификация модели не проводится.", "Верификация модели ограничивается только теоретическим анализом.", "Верификация модели осуществляется при помощи волшебных палочек."], ["Как осуществляется эксплуатация приложения в режиме адаптации и периодического синтеза модели?", "Эксплуатация приложения в режиме адаптации и периодического синтеза модели включает в себя постоянное обновление и адаптацию модели на основе новых данных и условий эксплуатации.", "Эксплуатация приложения не требует обновления модели.", "Эксплуатация приложения ограничивается только ее запуском.", "Эксплуатация приложения осуществляется с помощью магических зелий."], ["Технические характеристики и обеспечение эксплуатации системы 'ЭЙДОС' (версии 12.5).", "Система 'ЭЙДОС' версии 12.5 предоставляет модульный дизайн для легкости настройки, поддерживает множество операционных систем и масштабируется для разных типов организаций.", "Система 'ЭЙДОС' не имеет технических характеристик и обеспечения эксплуатации.", "Технические характеристики и обеспечение эксплуатации системы 'ЭЙДОС' версии 12.5 недоступны.", "Система 'ЭЙДОС' версии 12.5 работает только в нирване."], ["Состав системы 'Эйдос': Базовая система, системы окружения и программные интерфейсы импорта данных.", "Состав системы 'Эйдос' включает базовую систему, системы окружения и программные интерфейсы импорта данных.", "Состав системы 'Эйдос' ограничивается только базовой системой без дополнительных компонентов.", "Состав системы 'Эйдос' включает только программные интерфейсы без базовой системы и систем окружения.", "Состав системы 'Эйдос' включает в себя магическую сферу и дракона."], ["Отличия системы 'Эйдос' от аналогов: экспертных и статистических систем.", "Система 'Эйдос' отличается от аналогов как экспертных, так и статистических систем.", "Система 'Эйдос' не отличается от аналогов, она идентична им.", "Система 'Эйдос' отличается только от статистических систем, но не от экспертных.", "Система 'Эйдос' отличается от аналогов благодаря своей волшебной силе."], ["Некоторые количественные характеристики системы 'Эйдос'.", "Некоторые количественные характеристики системы 'Эйдос' могут включать в себя данные о производительности, скорости обработки и объеме хранилища.", "Система 'Эйдос' не имеет количественных характеристик.", "Количественные характеристики системы 'Эйдос' ограничиваются только версией.", "Система 'Эйдос' имеет бесконечную производительность."], ["Обеспечение эксплуатации системы 'Эйдос'.", "Обеспечение эксплуатации системы 'Эйдос' включает методы поддержки и обслуживания системы, обучение пользователей и обновление программного обеспечения.", "Система 'Эйдос' не предоставляет обеспечение для эксплуатации.", "Обеспечение эксплуатации системы 'Эйдос' ограничивается только технической документацией.", "Обеспечение эксплуатации системы 'Эйдос' выполняется при помощи магических заклинаний."], ["АСК-анализ, как технология синтеза и эксплуатации рефлексивных АСУ активными объектами.", "АСК-анализ - это технология, позволяющая синтезировать и эксплуатировать рефлексивные автоматизированные системы управления активными объектами.", "АСК-анализ не имеет отношения к рефлексивным АСУ.", "Рефлексивные АСУ не используют технологию АСК-анализа.", "АСК-анализ осуществляется с помощью волшебных артефактов."], ["Интеллектуальные интерфейсы. Использование биометрической информации о пользователе в управлении системами.", "Интеллектуальные интерфейсы могут использовать биометрическую информацию о пользователе для управления системами.", "Интеллектуальные интерфейсы не могут использовать биометрическую информацию.", "Биометрическая информация не имеет отношения к управлению системами.", "Интеллектуальные интерфейсы используют магические биометрические данные."], ["Идентификация и аутентификация личности по почерку. Понятие клавиатурного почерка.", "Идентификация и аутентификация личности по почерку - это процессы, включающие понятие клавиатурного почерка.", "Понятие клавиатурного почерка не связано с идентификацией личности.", "Идентификация и аутентификация личности осуществляются только по биометрическим данным.", "Идентификация и аутентификация личности по голосу."], ["Соотношение психографологии и атрибуции текстов.", "Соотношение психографологии и атрибуции текстов может включать в себя анализ психологических характеристик автора текста.", "Соотношение психографологии и атрибуции текстов основано на семантическом анализе текста.", "Психографология не имеет отношения к атрибуции текстов.", "Соотношение астрологии и атрибуции текстов."], ["Идентификация и аутентификация личности пользователя компьютера по клавиатурному почерку.", "Идентификация и аутентификация личности пользователя компьютера может быть осуществлена с использованием клавиатурного почерка.", "Идентификация пользователя компьютера не требует учета клавиатурного почерка.", "Клавиатурный почерк не может быть использован для идентификации пользователей компьютера.", "Идентификация и аутентификация личности пользователя компьютера по лицу."], ["Прогнозирование ошибок оператора по изменениям в его электроэнцефалограмме.", "Прогнозирование ошибок оператора может быть основано на изменениях в его электроэнцефалограмме.", "Электроэнцефалограмма не связана с работой операторов и ошибками.", "Прогнозирование ошибок оператора не зависит от физиологических данных.", "Прогнозирование ошибок оператора по скорости его пульса."], ["Системы с биологической обратной связью (БОС).", "Системы с биологической обратной связью используют биологические сигналы для управления процессами.", "Системы с биологической обратной связью не используют биологические данные.", "Биологическая обратная связь не имеет отношения к автоматизации.", "Системы с биологической обратной связью используют солнечные данные."], ["Мониторинг состояния сотрудников сборочного конвейера с целью обеспечения высокого качества продукции.", "Мониторинг состояния сотрудников сборочного конвейера может помочь обеспечить высокое качество продукции.", "Мониторинг состояния сотрудников не влияет на качество продукции.", "Сборочный конвейер не требует мониторинга состояния сотрудников.", "Мониторинг состояния клиентов в ресторане с целью обеспечения высокого качества обслуживания."], ["Компьютерные тренажеры, основанные на БОС, для обучения больных навыкам управления своим состоянием.", "Компьютерные тренажеры на основе БОС могут помочь больным развивать навыки управления своим состоянием.", "БОС не может быть использована для обучения навыкам управления состоянием.", "Больные не могут использовать компьютерные тренажеры.", "Компьютерные тренажеры для обучения физической активности больных."], ["Компьютерные игры с БОС.", "Компьютерные игры с БОС могут предоставлять более интерактивный игровой опыт.", "БОС не может быть использована в компьютерных играх.", "Компьютерные игры с БОС ограничены функциональностью обычных игр.", "Компьютерные игры с БОС, улучшающие физическую активность."], [ "Системы с семантическим резонансом. Компьютерные (пси-технологии и интеллектуальный подсознательный интерфейс.", "Системы с семантическим резонансом могут включать в себя пси-технологии и интеллектуальный подсознательный интерфейс.", "Системы с семантическим резонансом не имеют ничего общего с компьютерными технологиями.", "Пси-технологии и интеллектуальный подсознательный интерфейс не связаны с семантическим резонансом.", "Системы с семантическим резонансом и магическими артефактами."], [ "Системы виртуальной реальности и критерии реальности. Эффекты присутствия, деперсонализации и модификация сознания пользователя.", "Системы виртуальной реальности могут вызывать эффекты присутствия, деперсонализации и модификации сознания пользователя.", "Системы виртуальной реальности не могут влиять на сознание пользователя.", "Эффекты присутствия, деперсонализации и модификации сознания не имеют отношения к виртуальной реальности.", "Системы виртуальной реальности и их влияние на погодные явления."], ["Классическое определение системы виртуальной реальности.", "Классическое определение системы виртуальной реальности включает в себя создание иммерсивной среды и взаимодействие пользователя с этой средой.", "Виртуальная реальность не имеет классического определения.", "Система виртуальной реальности ограничивается только визуальными эффектами.", "Классическое определение системы космической реальности."], ["'Эффект присутствия' в виртуальной реальности.", "Эффект присутствия в виртуальной реальности описывает ощущение полного погружения пользователя в виртуальную среду.", "Виртуальная реальность не может вызывать эффект присутствия.", "Эффект присутствия в виртуальной реальности ограничивается только аудиоэффектами.", "Эффект присутствия в реальной жизни."], ["Применения систем виртуальной реальности.", "Системы виртуальной реальности могут применяться в области образования, медицины, развлечений и тренингов.", "Системы виртуальной реальности не имеют практических применений.", "Применения систем виртуальной реальности ограничиваются только играми.", "Применения систем виртуальной реальности в космических исследованиях."], ["Модификация сознания и самосознания пользователя в виртуальной реальности.", "Виртуальная реальность может модифицировать сознание и самосознание пользователя через создание различных визуальных и аудиоэффектов.", "Виртуальная реальность не влияет на сознание пользователя.", "Модификация сознания возможна только с помощью химических веществ.", "Модификация сознания пользователя в реальной жизни."], ["Авторское определение системы виртуальной реальности.", "Авторское определение системы виртуальной реальности может включать в себя уникальные аспекты и характеристики данной системы.", "Система виртуальной реальности не имеет авторского определения.", "Авторское определение системы виртуальной реальности ограничивается общепринятыми определениями.", "Авторское определение системы магической реальности."], ["Критерии реальности при различных формах сознания и их применение в виртуальной реальности.", "Критерии реальности могут изменяться в зависимости от формы сознания пользователя и применяться в виртуальной реальности для создания более реалистичного опыта.", "Критерии реальности не зависят от формы сознания пользователя и не могут применяться в виртуальной реальности.", "Виртуальная реальность не учитывает критерии реальности.", "Критерии реальности в магических мирах."], ["Принципы эквивалентности (относительности) Галилея и Эйнштейна и критерии виртуальной реальности.", "Принципы эквивалентности (относительности) Галилея и Эйнштейна могут быть использованы в критериях виртуальной реальности для оценки ее реалистичности.", "Принципы эквивалентности не имеют отношения к виртуальной реальности.", "Критерии виртуальной реальности не могут быть оценены с использованием принципов эквивалентности.", "Принципы эквивалентности Галилея и Эйнштейна применимы к физическим законам, но не имеют отношения к виртуальной реальности."], ["Системы с дистанционным телекинетическим интерфейсом.", "Системы с дистанционным телекинетическим интерфейсом позволяют управлять объектами с расстояния с помощью мыслей.", "Дистанционный телекинетический интерфейс не имеет практического применения.", "Телекинез не может быть использован для управления объектами.", "Системы с дистанционным телекинетическим интерфейсом исследуют возможность управления объектами с помощью мыслей."], ["Основные понятия и определения, связанные с системами распознавания образов.", "Основные понятия и определения в системах распознавания образов включают в себя признаки, образы, и обобщенные образы классов.", "Системы распознавания образов не используют понятия и определения.", "Распознавание образов ограничивается только визуальным анализом.", "Системы распознавания образов включают в себя такие понятия, как признаки, образы и классы."], ["Признаки и образы конкретных объектов, метафора фазового пространства.", "Признаки и образы конкретных объектов могут быть ассоциированы с метафорой фазового пространства в системах распознавания образов.", "Метафора фазового пространства не имеет отношения к признакам объектов.", "Признаки объектов не могут быть ассоциированы с метафорой.", "В системах распознавания образов признаки объектов могут быть связаны с метафорой фазового пространства."], ["Признаки и обобщенные образы классов.", "Признаки и обобщенные образы классов используются в системах распознавания образов для классификации объектов.", "Системы распознавания образов не используют признаки и обобщенные образы классов.", "Признаки объектов никак не связаны с классификацией.", "Классификация объектов в системах распознавания образов включает в себя использование признаков и обобщенных образов классов."], [ "Обучающая выборка и ее репрезентативность по отношению к генеральной совокупности. Ремонт (взвешивание) данных.", "Обучающая выборка должна быть репрезентативной по отношению к генеральной совокупности для точного обучения системы распознавания образов, иногда требуется ремонт (взвешивание) данных для коррекции выборки.", "Обучающая выборка не имеет отношения к генеральной совокупности и ремонту данных.", "Генеральная совокупность не влияет на обучающую выборку.", "Обучающая выборка в системах распознавания образов должна быть репрезентативной по отношению к генеральной совокупности, и иногда требуется ремонт данных для коррекции выборки."], ["Основные операции: обобщение и распознавание.", "Основные операции в системах распознавания образов включают в себя обобщение и распознавание объектов на основе их признаков.", "Системы распознавания образов не выполняют основных операций.", "Обобщение и распознавание не имеют значения в распознавании образов.", "Основные операции в системах распознавания образов включают в себя обобщение, который помогает выявить общие черты объектов, и распознавание, при котором объекты идентифицируются на основе их признаков."], ["Обучение с учителем (экспертом) и самообучение (кластерный анализ).", "Обучение с учителем подразумевает наличие учителя или эксперта, который предоставляет правильные ответы для обучения. Самообучение, с другой стороны, предполагает, что система обучается без учителя и может использовать методы, такие как кластерный анализ, для нахождения закономерностей в данных.", "Самообучение требует наличие учителя.", "Кластерный анализ применяется только в обучении с учителем.", "Обучение с учителем предполагает наличие учителя или эксперта, который предоставляет правильные ответы для обучения, в то время как самообучение позволяет системе обучаться без внешнего учителя и использовать методы, такие как кластерный анализ."], ["Верификация, адаптация и синтез модели.", "Верификация относится к проверке правильности модели. Адаптация - это процесс настройки модели на конкретные условия. Синтез модели включает в себя создание новой модели.", "Адаптация и верификация - одно и то же.", "Синтез модели не связан с проверкой и адаптацией.", "Верификация включает в себя проверку правильности модели, адаптация - настройку модели на конкретные условия, и синтез - создание новой модели."], ["Проблема распознавания образов.", "Проблема распознавания образов заключается в определении объектов или образов на основе их признаков.", "Распознавание образов означает создание новых образов.", "Распознавание образов - это идентификация объектов только по их внешнему виду.", "Проблема распознавания образов заключается в определении объектов или образов на основе имеющихся признаков."], ["Классификация методов распознавания образов.", "Методы распознавания образов могут быть классифицированы на несколько типов в зависимости от их подходов и алгоритмов.", "Все методы распознавания образов идентичны и не имеют различий.", "Классификация методов не имеет значения в распознавании образов.", "Методы распознавания образов могут быть классифицированы на разные типы в зависимости от применяемых подходов и алгоритмов."], [ "Применение распознавания образов для идентификации и прогнозирования. Сходство и различие в содержании понятий 'идентификация' и 'прогнозирование'.", "Распознавание образов может использоваться для идентификации объектов и предсказания их будущих состояний. Идентификация - это процесс определения, к какому классу или объекту принадлежит образ. Прогнозирование - это предсказание будущих значений или состояний на основе имеющейся информации.", "Идентификация и прогнозирование - синонимы и имеют одинаковое значение.", "Распознавание образов не может использоваться для прогнозирования.", "Распознавание образов может быть применено для идентификации объектов и предсказания их будущих состояний, причем идентификация и прогнозирование имеют разные значения."], ["Роль и место распознавания образов в автоматизации управления сложными системами.", "Распознавание образов играет важную роль в автоматизации управления сложными системами, так как оно позволяет системе анализировать окружающую среду и принимать решения на основе этого анализа.", "Распознавание образов не имеет значения в автоматизации.", "Автоматизация управления не зависит от распознавания образов.", "Распознавание образов важно для автоматизации управления сложными системами, так как оно позволяет системе анализировать окружающую среду и принимать решения на основе этого анализа."], ["Обобщенная структура системы управления.", "Обобщенная структура системы управления включает в себя входные данные, процесс управления и выходные данные.", "Системы управления не имеют структуры.", "Структура системы управления ограничивается только входными данными.", "Обобщенная структура системы управления включает в себя входные данные, процесс управления и выходные данные, и это структура системы управления."], ["Место системы идентификации в системе управления.", "Система идентификации является частью системы управления и используется для определения параметров или состояний объектов, которые управляются.", "Система идентификации не имеет отношения к системе управления.", "Система управления не нуждается в идентификации объектов.", "Система идентификации входит в состав системы управления и используется для определения параметров или состояний объектов, подлежащих управлению."], ["Управление как задача, обратная прогнозированию.", "Управление - это задача, обратная прогнозированию, так при прогнозировании по факторам определяется будущее состояние, а при кправлении наоброт, по целвому будущему состоянию определяются обуславдливающие его факторы.", "Управление не связано с идентификацией и прогнозированием.", "Идентификация и прогнозирование - это задачи, обратные управлению.", "Управление - это задача, обратная идентификации и прогнозированию, так как оно включает в себя принятие решений и управление объектами на основе их идентификации и прогнозирования."], ["Методы кластерного анализ.", "Методы кластерного анализа используются для разделения данных на кластеры или группы на основе их сходства.", "Кластерный анализ не имеет методов.", "Методы кластерного анализа используются только в идентификации.", "Методы кластерного анализа используются для разделения данных на кластеры или группы на основе их сходства."], ["Метод кластеризации: 'Древовидная кластеризация'.", "Древовидная кластеризация - это метод кластерного анализа, который строит дерево кластеров, начиная с одного общего кластера и разделяя его на подкластеры.", "Древовидная кластеризация не имеет отношения к методам кластерного анализа.", "Древовидная кластеризация используется только в синтезе модели.", "Древовидная кластеризация - это метод кластерного анализа, который строит дерево кластеров, начиная с одного общего кластера и разделяя его на подкластеры."], ["Метод кластеризации: 'Двувходовое объединение'.", "Двувходовое объединение - это метод кластерного анализа, который объединяет близкие кластеры в один.", "Двувходовое объединение не имеет отношения к методам кластерного анализа.", "Двувходовое объединение используется только в верификации модели.", "Двувходовое объединение - это метод кластерного анализа, который объединяет близкие кластеры в один."], ["Метод кластеризации: 'Метод K средних'.", "Метод K средних - это метод кластерного анализа, который разделяет данные на K кластеров, минимизируя сумму квадратов расстояний между точками и их центрами кластеров.", "Метод K средних не является методом кластерного анализа.", "Метод K средних используется только в прогнозировании.", "Метод K средних - это метод кластерного анализа, который разделяет данные на K кластеров, минимизируя сумму квадратов расстояний между точками и их центрами кластеров."], ["Многообразие задач принятия решений.", "Задачи принятия решений могут быть разнообразными и включать в себя выбор наилучшей альтернативы, определение стратегии, оптимизацию и другие аспекты.", "Задачи принятия решений всегда имеют одинаковую структуру.", "Принятие решений ограничивается только выбором наилучшей альтернативы.", "Задачи принятия решений могут быть разнообразными и включать в себя выбор наилучшей альтернативы, определение стратегии, оптимизацию и другие аспекты."], ["Принятие решений, как реализация цели.", "Принятие решений является способом достижения поставленных целей или реализации стратегии.", "Принятие решений не имеет отношения к достижению целей.", "Цели не имеют значения в принятии решений.", "Принятие решений является способом достижения поставленных целей или реализации стратегии."], ["Принятие решений, как снятие неопределенности (информационный подход).", "Принятие решений может снимать неопределенность, предоставляя информацию и оценивая риски.", "Принятие решений не связано с информацией и неопределенностью.", "Информация не имеет значения в принятии решений.", "Принятие решений может снимать неопределенность, предоставляя информацию и оценивая риски."], ["Связь принятия решений и распознавания образов.", "Принятие решений может зависеть от результатов распознавания образов, так как оно может предоставлять информацию для принятия оптимальных решений.", "Принятие решений не имеет отношения к распознаванию образов.", "Распознавание образов не влияет на принятие решений.", "Принятие решений может зависеть от результатов распознавания образов, так как оно может предоставлять информацию для принятия оптимальных решений."], ["Классификация задач принятия решений.", "Задачи принятия решений могут быть классифицированы на разные типы в зависимости от их характеристик и структуры.", "Все задачи принятия решений имеют одинаковую классификацию.", "Классификация задач принятия решений не имеет значения.", "Задачи принятия решений могут быть классифицированы на разные типы в зависимости от их характеристик и структуры."], ["Языки описания методов принятия решений.", "Существуют различные языки и формализмы для описания методов принятия решений, которые могут быть использованы для анализа и моделирования процессов принятия решений.", "Языки описания методов принятия решений не существуют.", "Процессы принятия решений не могут быть описаны языками.", "Существуют различные языки и формализмы для описания методов принятия решений, которые могут быть использованы для анализа и моделирования процессов принятия решений."], ["Критериальный язык.", "Критериальный язык используется для определения критериев, по которым принимаются решения, и оценки альтернативных вариантов.", "Критериальный язык не имеет отношения к принятию решений.", "Принятие решений не зависит от критериального языка.", "Критериальный язык используется для определения критериев, по которым принимаются решения, и оценки альтернативных вариантов."], ["Язык последовательного бинарного выбора.", "Язык последовательного бинарного выбора используется для пошагового выбора между двумя альтернативами.", "Язык последовательного бинарного выбора не имеет отношения к принятию решений.", "Принятие решений не включает в себя выбор между двумя альтернативами.", "Язык последовательного бинарного выбора используется для пошагового выбора между двумя альтернативами."], ["Обобщенный язык функций выбора.", "Обобщенный язык функций выбора используется для определения функций, которые применяются к альтернативам при принятии решений.", "Функции выбора не имеют значения в принятии решений.", "Принятие решений не связано с функциями выбора.", "Обобщенный язык функций выбора используется для определения функций, которые применяются к альтернативам при принятии решений."], ["Групповой выбор.", "Групповой выбор предполагает принятие решений не одним лицом, а группой людей или экспертов.", "Принятие решений всегда осуществляется только одним лицом.", "Групповой выбор не имеет значения в принятии решений.", "Групповой выбор предполагает принятие решений не одним лицом, а группой людей или экспертов."], ["Выбор в условиях неопределенности.", "Выбор в условиях неопределенности означает, что информация о возможных исходах ограничена или не полностью известна, и решение принимается на основе вероятностных оценок.", "Все решения всегда принимаются в условиях полной ясности и определенности.", "Условия неопределенности не влияют на принятие решений.", "Выбор в условиях неопределенности означает, что информация о возможных исходах ограничена или не полностью известна, и решение принимается на основе вероятностных оценок."], ["Информационная (статистическая) неопределенность в исходных данных.", "Это неопределенность, связанная с недостаточностью или неточностью статистических данных.", "Это неопределенность, вызванная экспертным мнением.", "Это неопределенность, связанная с невозможностью принятия решения.", "Это неопределенность, связанная с случайными факторами."], ["Неопределенность последствий.", "Это неопределенность, связанная с неизвестными последствиями принимаемых решений.", "Это неопределенность, связанная с точным прогнозированием будущих событий.", "Это неопределенность, связанная с известными последствиями решений.", "Это неопределенность, связанная с переменными параметрами."], ["Расплывчатая неопределенность.", "Это неопределенность, характеризующаяся нечеткими границами исходных данных.", "Это неопределенность, характеризующаяся абсолютной ясностью исходных данных.", "Это неопределенность, характеризующаяся стабильностью исходных данных.", "Это неопределенность, характеризующаяся дополнительными данными."], ["Решение как компромисс и баланс различных интересов. О некоторых ограничениях оптимизационного подхода.", "Решение, учитывающее различные интересы и находящее компромиссное решение.", "Решение, исключающее все компромиссы и учитывающее только один интерес.", "Решение, не учитывающее интересы вообще.", "Решение, основанное на случайном выборе."], ["Экспертные методы выбора.", "Методы, основанные на мнениях и опыте экспертов для принятия решений.", "Методы, основанные исключительно на статистических данных.", "Методы, основанные на случайных выборках.", "Методы, основанные на математических моделях."], ["Юридическая ответственность за решения, принятые с применением систем поддержки принятия решений.", "Ответственность перед законом за решения, принимаемые с использованием DSS.", "Ответственность перед обществом за решения, принимаемые с применением систем поддержки принятия решений.", "Ответственность перед компанией за решения, принятые с использованием DSS.", "Ответственность перед семьей за решения, принятые с использованием DSS."], ["Условия корректности использования систем поддержки принятия решений.", "Условия, при которых системы DSS могут быть применены правильно и эффективно.", "Условия, которые ограничивают использование систем поддержки принятия решений.", "Условия, при которых системы DSS никогда не работают.", "Условия, определяемые случайным образом."], ["Хранилища данных для принятия решений.", "Места, где хранятся данные, необходимые для принятия решений в системах DSS.", "Места, где хранятся только резервные копии данных.", "Места, где хранятся только архивные данные.", "Места, где хранятся случайные данные."], ["Экспертные системы, базовые понятия.", "Основные концепции и термины, связанные с экспертными системами.", "Основные концепции и термины, связанные с медицинской диагностикой.", "Основные концепции и термины, связанные с финансовым анализом.", "Основные концепции и термины, связанные с космической исследовательской деятельностью."], ["Экспертные системы, методика построения.", "Процесс разработки экспертных систем и методы, используемые при этом.", "Методы обучения нейронных сетей.", "Процесс разработки мобильных приложений.", "Процесс разработки кулинарных рецептов."], ["Этап-1 синтеза ЭС: 'Идентификация'.", "Первый этап создания экспертной системы, на котором определяются ее цели и задачи.", "Первый этап создания экспертной системы, на котором разрабатывается искусственный интеллект.", "Последний этап создания экспертной системы, на котором проводится тестирование.", "Средний этап создания экспертной системы, на котором происходит обучение экспертов."], ["Этап-2 синтеза ЭС: 'Концептуализация'.", "Этап, на котором формируется общая концепция экспертной системы и ее структура.", "Этап, на котором проводится экспериментальная эксплуатация экспертной системы.", "Этап, на котором разрабатывается интерфейс пользователя.", "Этап, на котором создаются рекламные материалы."], ["Этап-3 синтеза ЭС: 'Формализация'.", "Этап, на котором знания экспертов формализуются в виде правил и базы данных.", "Этап, на котором проводится маркетинговый анализ.", "Этап, на котором проводится разработка дизайна экспертной системы.", "Этап, на котором проводится реорганизация компании."], ["Этап-4 синтеза ЭС: 'Разработка прототипа'.", "Этап, на котором создается рабочий прототип экспертной системы для тестирования.", "Этап, на котором создаются резервные копии данных.", "Этап, на котором проводится экспериментальное исследование.", "Этап, на котором разрабатываются учебные материалы."], ["Этап-5 синтеза ЭС: 'Экспериментальная эксплуатация'.", "Этап, на котором система тестируется на реальных задачах и ситуациях.", "Этап, на котором проводится тестирование только на симуляторах.", "Этап, на котором система используется только в лабораторных условиях.", "Этап, на котором система просто хранится в архиве."], ["Этап-6 синтеза ЭС: 'Разработка продукта'.", "Этап, на котором создается финальная версия экспертной системы для коммерческого использования.", "Этап, на котором проводится исследование рынка.", "Этап, на котором система дорабатывается только для себя.", "Этап, на котором система утилизируется."], ["Этап-7 синтеза ЭС: 'Промышленная эксплуатация'.", "Этап, на котором экспертная система внедряется в реальное производство и используется на постоянной основе.", "Этап, на котором система хранится в архиве и не используется.", "Этап, на котором система продается другим компаниям.", "Этап, на котором проводится экспериментальное исследование."], ["Биологический нейрон и формальная модель нейрона Маккалоки и Питтса.", "Биологический нейрон и абстрактная модель нейрона, предложенная Маккалоки и Питтсом.", "Биологический нейрон и модель космического аппарата.", "Биологический нейрон и модель животного.", "Биологический нейрон и математическая модель нейрона."], ["Возможность решения простых задач классификации непосредственно одним нейроном.", "Одиночный нейрон может решить простые задачи классификации.", "Одиночный нейрон не может решить ни одной задачи классификации.", "Одиночный нейрон может решить любую сложную задачу классификации.", "Одиночный нейрон всегда дает неверные ответы."], ["Однослойная нейронная сеть и персептрон Розенблата.", "Однослойная нейронная сеть - это персептрон Розенблата.", "Однослойная нейронная сеть и персептрон Розенблата - это разные вещи.", "Однослойная нейронная сеть - это название биологического нейрона.", "Однослойная нейронная сеть - это модель космического аппарата."], ["Линейная разделимость и персептронная представляемость.", "Персептрон может представить линейно разделимые данные.", "Персептрон не может представить никакие данные.", "Линейная разделимость не имеет значения в нейронных сетях.", "Персептрон всегда превосходит другие модели."], ["Многослойные нейронные сети.", "Сети, состоящие из нескольких слоев нейронов, включая входной и выходной.", "Сети, состоящие только из одного слоя нейронов.", "Сети, состоящие из биологических нейронов.", "Сети, состоящие из случайных нейронов."], ["Многослойный персептрон.", "Нейронная сеть, состоящая из нескольких слоев нейронов, включая скрытые слои.", "Нейронная сеть, состоящая из одного слоя нейронов.", "Нейронная сеть, состоящая только из двух нейронов.", "Нейронная сеть, состоящая только из входных нейронов."], ["Модель Хопфилда.", "Модель нейронной сети с ассоциативной памятью, предложенная Хопфилдом.", "Модель космического аппарата.", "Модель животного.", "Модель, предложенная Хопфилдом для анализа погоды."], ["Когнитрон и неокогнитрон Фукушимы.", "Модели, предложенные Фукушимой для распознавания образов.", "Модели, используемые в астрономии.", "Модели, применяемые в геологии.", "Модели, применяемые в исследовании океанов."], ["Проблемы и перспективы нейронных сетей.", "Текущие проблемы и будущие направления развития нейронных сетей.", "Текущие проблемы и решения, которые не имеют будущих перспектив.", "Нейронные сети не имеют ни проблем, ни перспектив.", "Проблемы и перспективы нейронных сетей никак не влияют на их развитие."], ["Модель нелокального нейрона и нелокальные интерпретируемые нейронные сети прямого счета.", "Модель нейрона, которая учитывает взаимодействие с окружающими нейронами, и нейронные сети, основанные на этой модели.", "Модель нейрона, которая игнорирует все внешние воздействия, и нейронные сети, основанные на этой модели.", "Модель нейрона, которая существует только в теории, и нейронные сети, не имеющие ничего общего с этой моделью.", "Модель нелокального нейрона и нелокальные интерпретируемые нейронные сети прямого счета - это одно и то же."], ["Метафора нейросетевого представления семантической информационной модели.", "Аналогия, используемая для объяснения того, как нейронные сети могут представлять семантическую информацию.", "Метафора для описания космических явлений.", "Метафора для описания химических реакций.", "Метафора нейросетевого представления семантической информационной модели - это пустой звук."], ["Соответствие основных терминов и понятий.", "Соответствие между терминами и понятиями в контексте нейронных сетей.", "Соответствие между терминами и понятиями в медицине.", "Соответствие между терминами и понятиями в астрономии.", "Соответствие основных терминов и понятий - это бессмысленное занятие."], ["Гипотеза о нелокальности нейрона и информационная нейросетевая парадигма.", "Идея о том, что нейроны взаимодействуют не только локально, и парадигма, основанная на этой гипотезе.", "Идея о том, что нейроны не взаимодействуют вообще, и парадигма, не имеющая отношения к нейронным сетям.", "Идея о том, что нейроны взаимодействуют только локально, и парадигма, не имеющая гипотезы о нелокальности.", "Гипотеза о нелокальности нейрона и информационная нейросетевая парадигма - это чистая выдумка."], [ "Решение проблемы интерпретируемости весовых коэффициентов (семантическая мера целесообразности информации и закон Фехнера).", "Использование семантической меры целесообразности информации и закона Фехнера для улучшения интерпретируемости весовых коэффициентов.", "Использование физических законов для расчета весовых коэффициентов.", "Применение случайных чисел для вычисления весовых коэффициентов.", "Решение проблемы интерпретируемости весовых коэффициентов - это бессмысленная задача."], ["Семантическая информационная модель, как нелокальная нейронная сеть.", "Семантическая информационная модель рассматривается как нелокальная нейронная сеть.", "Семантическая информационная модель не имеет отношения к нейронным сетям.", "Семантическая информационная модель рассматривается как локальная нейронная сеть.", "Семантическая информационная модель - это абстрактное понятие, не связанное с нейронными сетями."], ["Гипотеза о физической природе нелокального взаимодействия нейронов в нелокальной нейронной сети.", "Гипотеза о том, что нелокальное взаимодействие нейронов в нелокальной нейронной сети имеет физическую природу.", "Гипотеза о том, что нелокальное взаимодействие нейронов в нелокальной нейронной сети не имеет физической природы.", "Гипотеза о том, что нейроны не взаимодействуют в нелокальной нейронной сети.", "Гипотеза о физической природе нелокального взаимодействия нейронов - это вымысел."], ["Решение проблемы интерпретируемости передаточной функции.", "Использование методов для деления передаточной функции на более простые и интерпретируемые части.", "Использование передаточной функции без изменений.", "Передаточная функция - это фикция и никакой проблемы нет.", "Использование передаточной функции без интерпретации."], ["Решение проблемы размерности.", "Разработка методов для снижения размерности данных и улучшения их обработки.", "Игнорирование размерности данных.", "Размерность данных снижать нецелесообразно, т.к. это приводит к необратимой петере информации.", "Увеличение размерности данных без особых преимуществ."], ["Решение проблемы линейной разделимости.", "Разработка методов и алгоритмов, позволяющих разделять данные линейно.", "Использование только неразделимых данных.", "Применение методов, которые не учитывают линейную разделимость.", "Использование случайных данных без анализа."], ["Моделирование причинно-следственных цепочек в нейронных сетях и семантической информационной модели.", "Использование нейронных сетей и семантической информационной модели для моделирования причинно-следственных связей.", "Моделирование причинно-следственных цепочек без использования нейронных сетей и семантической информационной модели.", "Нейронные сети и семантическая информационная модель не могут моделировать причинно-следственные связи.", "Использование случайных данных без анализа."], ["Моделирование иерархических структур обработки информации.", "Использование методов моделирования для создания иерархических структур обработки информации.", "Отсутствие моделирования иерархических структур обработки информации.", "Использование только линейных структур обработки информации.", "Использование случайных данных без анализа."], ["Нейронные сети и АСК-анализ.", "Использование нейронных сетей и АСК-анализа в анализе данных и принятии решений.", "Нейронные сети и АСК-анализ - совершенно независимые методы.", "Использование только нейронных сетей без учета АСК-анализа.", "Использование случайных данных без анализа."], [ "Графическое отображение нейронов, Паррето-подмножеств нелокальной нейронной сети, семантических сетей, когнитивных карт и диаграмм в системе 'Эйдос'.", "Использование системы 'Эйдос' для графического отображения различных элементов нейронных сетей и семантических моделей.", "Графическое отображение не имеет значения в анализе данных.", "Использование только текстового описания элементов нейронных сетей и семантических моделей.", "Использование случайных данных без анализа."], ["Основные понятия, принципы и предпосылки генетических алгоритмов.", "Основные понятия, принципы и предпосылки генетических алгоритмов в области оптимизации.", "Основные понятия, принципы и предпосылки генетических алгоритмов в области медицины.", "Основные понятия, принципы и предпосылки генетических алгоритмов в области астрономии.", "Использование случайных данных без анализа."], ["Пример работы простого генетического алгоритма.", "Простой генетический алгоритм может использоваться для оптимизации задачи, например, для поиска оптимального значения функции.", "Простой генетический алгоритм не применим в оптимизации.", "Простой генетический алгоритм используется только в медицине.", "Использование случайных данных без анализа."], ["Достоинства и недостатки генетических алгоритмов.", "Генетические алгоритмы обладают высокой способностью к глобальной оптимизации, но могут требовать большого количества вычислений.", "Генетические алгоритмы не имеют недостатков.", "Генетические алгоритмы не применимы в оптимизации.", "Использование случайных данных без анализа."], ["Примеры применения генетических алгоритмов.", "Генетические алгоритмы могут применяться в задачах оптимизации, планирования и обучения машинного обучения.", "Генетические алгоритмы не могут использоваться в различных областях.", "Генетические алгоритмы применимы только в медицине.", "Использование случайных данных без анализа."], [ "Определение основных понятий: 'Когнитивное моделировие' и 'Классическая когнитивная карта', их связь с когнитивной психологией и гносеологией.", "Когнитивное моделирование и классическая когнитивная карта - это ключевые понятия в когнитивной психологии и гносеологии.", "Когнитивное моделирование и классическая когнитивная карта не имеют отношения к когнитивной психологии и гносеологии.", "Когнитивное моделирование и классическая когнитивная карта - это только математические понятия.", "Использование случайных данных без анализа."], [ "Когнитивная (познавательно-целевая) структуризация знаний об исследуемом объекте и внешней для него среды на основе PEST-анализа и SWOT-анализа.", "Когнитивная структуризация знаний о объекте и его среде с использованием PEST-анализа и SWOT-анализа помогает в понимании и принятии решений.", "PEST-анализ и SWOT-анализ не могут использоваться для когнитивной структуризации знаний.", "PEST-анализ и SWOT-анализ применимы только в медицине.", "Использование случайных данных без анализа."], [ "Разработка программы реализации стратегии развития исследуемого объекта на основе динамического имитационного моделирования (при поддержке программного пакета Ithink).", "Разработка программы на основе динамического имитационного моделирования с использованием программного пакета Ithink помогает в реализации стратегии развития объекта.", "Динамическое имитационное моделирование не может быть использовано для разработки программы реализации стратегии.", "Программный пакет Ithink не имеет отношения к имитационному моделированию.", "Использование случайных данных без анализа."], ["Интеллектуальный анализ данных (data mining).", "Интеллектуальный анализ данных - это процесс извлечения полезной информации из больших объемов данных.", "Интеллектуальный анализ данных - это просто обработка данных без извлечения информации.", "Интеллектуальный анализ данных применяется только в финансовой сфере.", "Использование случайных данных без анализа."], [ "Типы выявляемых закономерностей data mining: ассоциация, последовательность, классификация, кластеризация, прогнозирование.", "Data mining может выявлять различные типы закономерностей, такие как ассоциации, последовательности, классификации, кластеризации и прогнозирования.", "Data mining может выявлять только один тип закономерностей - ассоциации.", "Data mining не способен выявлять закономерности.", "Использование случайных данных без анализа."], ["Математический аппарат data mining: деревья решений, регрессионный анализ, нейронные сети, временные ряды.", "Математический аппарат data mining включает в себя деревья решений, регрессионный анализ, нейронные сети и анализ временных рядов.", "Математический аппарат data mining ограничивается только деревьями решений.", "Математический аппарат data mining не имеет отношения к анализу временных рядов.", "Математический аппарат data mining включает в себя только математические уравнения."], [ "Области применения технологий интеллектуального анализа данных: розничная торговля, банковская деятельность, страховой бизнес, производство, автоматизированные системы для интеллектуального анализа данных.", "Технологии интеллектуального анализа данных применяются в различных областях, включая розничную торговлю, банковскую деятельность, страховой бизнес, производство и автоматизированные системы для анализа данных.", "Технологии интеллектуального анализа данных применяются только в медицине.", "Технологии интеллектуального анализа данных не имеют областей применения.", "Технологии интеллектуального анализа данных применяются только в транспортной отрасли."], ["Обзор опыта применения АСК-анализа для управления и исследования социально-экономических систем.", "АСК-анализ применяется для управления и исследования социально-экономических систем с целью оптимизации и анализа процессов в них.", "АСК-анализ не применяется для управления и исследования социально-экономических систем.", "АСК-анализ применяется только в медицине.", "АСК-анализ применяется только в сельском хозяйстве."], ["Применение СИИ для синтеза и решения задач управления качеством подготовки специалистов.", "Системы искусственного интеллекта применяются для синтеза и решения задач управления качеством подготовки специалистов.", "Системы искусственного интеллекта не могут использоваться для управления качеством подготовки специалистов.", "Системы искусственного интеллекта применяются только в производстве.", "Системы искусственного интеллекта применяются только в искусстве."], ["Применение СИИ в экономических исследованиях.", "Системы искусственного интеллекта применяются в экономических исследованиях для анализа данных и прогнозирования.", "Системы искусственного интеллекта не имеют отношения к экономическим исследованиям.", "Системы искусственного интеллекта применяются только в медицине.", "Системы искусственного интеллекта применяются только в археологии."], ["Применение СИИ в социологических и политологических исследованиях.", "Системы искусственного интеллекта применяются в социологических и политологических исследованиях для анализа данных и прогнозирования.", "Системы искусственного интеллекта не могут использоваться в социологических и политологических исследованиях.", "Системы искусственного интеллекта применяются только в технических областях.", "Системы искусственного интеллекта применяются только в спорте."], ["Поддержка принятия решений по выбору агротехнологий, культур и пунктов выращивания.", "Системы искусственного интеллекта могут поддерживать принятие решений по выбору агротехнологий, культур и пунктов выращивания на основе анализа данных.", "Системы искусственного интеллекта не могут использоваться для принятия решений в сельском хозяйстве.", "Принятие решений в сельском хозяйстве не требует использования систем искусственного интеллекта.", "Системы искусственного интеллекта применяются только для выбора рецептов кулинарных блюд."], ["Поддержка принятия решений по выбору агротехнологий.", "Системы искусственного интеллекта могут поддерживать принятие решений по выбору агротехнологий на основе анализа данных.", "Принятие решений по выбору агротехнологий не требует использования систем искусственного интеллекта.", "Системы искусственного интеллекта не могут применяться в сельском хозяйстве.", "Системы искусственного интеллекта применяются только для выбора цветовой палитры в дизайне."], ["Поддержка принятия решений по выбору культур и пунктов выращивания.", "Системы искусственного интеллекта могут поддерживать принятие решений по выбору культур и пунктов выращивания на основе анализа данных.", "Принятие решений по выбору культур и пунктов выращивания не требует использования систем искусственного интеллекта.", "Системы искусственного интеллекта не могут применяться в сельском хозяйстве.", "Системы искусственного интеллекта применяются только для выбора музыкальных инструментов в оркестре."], ["Применение СИИ для прогнозирования динамики сегмента рынка.", "Системы искусственного интеллекта могут использоваться для прогнозирования динамики сегмента рынка на основе анализа данных.", "Системы искусственного интеллекта не могут использоваться для прогнозирования динамики рынка.", "Прогнозирование динамики рынка не требует использования систем искусственного интеллекта.", "Системы искусственного интеллекта применяются только для создания художественных произведений."], ["Применение СИИ для анализа рыночной конъюнктуры.", "Системы искусственного интеллекта могут использоваться для анализа рыночной конъюнктуры на основе данных и предсказания тенденций.", "Системы искусственного интеллекта не могут использоваться для анализа рыночной конъюнктуры.", "Анализ рыночной конъюнктуры не требует использования систем искусственного интеллекта.", "Системы искусственного интеллекта применяются только для создания спортивных стратегий."], ["Применение СИИ для прогнозирования тенденций развития рынка.", "Системы искусственного интеллекта могут использоваться для прогнозирования тенденций развития рынка на основе анализа данных.", "Системы искусственного интеллекта не могут использоваться для прогнозирования тенденций развития рынка.", "Прогнозирование тенденций развития рынка не требует использования систем искусственного интеллекта.", "Системы искусственного интеллекта применяются только для создания кулинарных рецептов."], ["Применение СИИ для прогнозирования тенденций развития социума.", "Системы искусственного интеллекта могут использоваться для прогнозирования тенденций развития социума на основе анализа данных.", "Системы искусственного интеллекта не могут использоваться для прогнозирования тенденций развития социума.", "Прогнозирование тенденций развития социума не требует использования систем искусственного интеллекта.", "Системы искусственного интеллекта применяются только для создания космических ракет."], ["Применение СИИ для анализа и прогнозирования экономических процессов.", "Системы искусственного интеллекта могут использоваться для анализа и прогнозирования экономических процессов на основе данных и моделей.", "Системы искусственного интеллекта не могут использоваться для анализа и прогнозирования экономических процессов.", "Анализ и прогнозирование экономических процессов не требует использования систем искусственного интеллекта.", "Системы искусственного интеллекта применяются только для создания музыкальных композиций."], ["Применение СИИ для анализа и прогнозирования политических процессов.", "Системы искусственного интеллекта могут использоваться для анализа и прогнозирования политических процессов на основе данных и моделей.", "Системы искусственного интеллекта не могут использоваться для анализа и прогнозирования политических процессов.", "Анализ и прогнозирование политических процессов не требует использования систем искусственного интеллекта.", "СИИ применяется только для музыкальных процессов."], ["Применение СИИ для анализа и прогнозирования социальных процессов.", "Системы искусственного интеллекта могут использоваться для анализа и прогнозирования социальных процессов на основе данных и моделей.", "Системы искусственного интеллекта не могут использоваться для анализа и прогнозирования социальных процессов.", "Анализ и прогнозирование социальных процессов не требует использования систем искусственного интеллекта.", "СИИ применяется только для обработки фотографий."], ["Применение СИИ для анализа и прогнозирования экологических процессов.", "Системы искусственного интеллекта могут использоваться для анализа и прогнозирования экологических процессов на основе данных и моделей.", "Системы искусственного интеллекта не могут использоваться для анализа и прогнозирования экологических процессов.", "Анализ и прогнозирование экологических процессов не требует использования систем искусственного интеллекта.", "СИИ применяется только для создания музыки."], ["Применение СИИ для анализа и прогнозирования технологических процессов.", "Системы искусственного интеллекта могут использоваться для анализа и прогнозирования технологических процессов на основе данных и моделей.", "Системы искусственного интеллекта не могут использоваться для анализа и прогнозирования технологических процессов.", "Анализ и прогнозирование технологических процессов не требует использования систем искусственного интеллекта.", "СИИ применяется только для рисования."], ["Применение СИИ для анализа и прогнозирования технологических процессов в производстве.", "Системы искусственного интеллекта могут использоваться для анализа и прогнозирования технологических процессов в производстве на основе данных и моделей.", "Системы искусственного интеллекта не могут использоваться для анализа и прогнозирования технологических процессов в производстве.", "Анализ и прогнозирование технологических процессов в производстве не требует использования систем искусственного интеллекта.", "СИИ применяется только для создания видеоигр."], ["Применение СИИ для анализа и прогнозирования технологических процессов в сельском хозяйстве.", "Системы искусственного интеллекта могут использоваться для анализа и прогнозирования технологических процессов в сельском хозяйстве на основе данных и моделей.", "Системы искусственного интеллекта не могут использоваться для анализа и прогнозирования технологических процессов в сельском хозяйстве.", "Анализ и прогнозирование технологических процессов в сельском хозяйстве не требует использования систем искусственного интеллекта.", "СИИ применяется только для написания стихов."], ["Применение СИИ для анализа и прогнозирования технологических процессов в медицине.", "Системы искусственного интеллекта могут использоваться для анализа и прогнозирования технологических процессов в медицине на основе данных и моделей.", "Системы искусственного интеллекта не могут использоваться для анализа и прогнозирования технологических процессов в медицине.", "Анализ и прогнозирование технологических процессов в медицине требует использования систем искусственного интеллекта.", "СИИ применяется только для путешествий в космосе."], ["Какие существуют виды шкал?", "Номинальные, порядковые, интервальные и относительные шкалы", "Дискретные и непрерывные шкалы", "Абсолютные и относительные шкалы", "Шкалы цветов и вкусов."], ["Как шкалы связаны с конструктами и с познанием?", "Шкалы используются для измерения конструктов и влияют на наше восприятие и понимание мира", "Шкалы определяются конструктами, но не влияют на познание", "Конструкты не связаны со шкалами", "Шкалы влияют только на цвет конструктов."], [ "Чем обусловлена возможность текстового описания объектов обучающей и распознаваемой выборки на естественном языке?", "Возможность текстового описания обусловлена наличием семантических шкал и лексической семантики", "Текстовое описание не связано с выборкой", "Текстовое описание зависит от размера выборки", "Текстовое описание возможно только для математических объектов."], ["Что понимается под формализацией задачи?", "Под формализацией задачи понимается ее математическое описание и определение правил решения", "Формализация задачи означает ее усложнение и неопределенность", "Формализация задачи относится только к программированию", "Формализация задачи означает создание гипотезы о ее решении."], ["Как создать классификационные и описательные шкалы в системе 'Эйдос'?", "Классификационные и описательные шкалы создаются в системе 'Эйдос' при помощи определенных функций и параметров", "Шкалы создаются вручную в текстовом редакторе", "Создание шкал требует дополнительных инструментов", "Шкалы создаются только с помощью физических измерений."], ["Как собрать исходную фактографическую информацию и ввести в систему обучающую выборку?", "Исходная информация собирается из различных источников и вводится в систему 'Эйдос' через специальные модули и интерфейсы", "Информацию можно вводить только вручную без автоматизации", "Собирать информацию не обязательно для создания выборки", "Исходная информация генерируется автоматически системой 'Эйдос'."], ["Как осуществить синтез и верификацию модели?", "Синтез и верификация модели выполняются в системе 'Эйдос' с помощью встроенных инструментов и алгоритмов", "Синтез и верификация модели требуют специальных программ", "Модель создается вручную без синтеза и верификации", "Синтез и верификация модели происходят только внутри головы программиста."], [ "Как оценить ценность признаков для прогнозирования и выделить признаки, наиболее существенные для решения поставленной задачи?", "Оценку ценности признаков и выделение наиболее существенных признаков можно провести с помощью статистических методов и анализа данных", "Ценность признаков не может быть оценена", "Признаки выбираются случайным образом", "Оценку ценности признаков проводит исключительно гадалка."], ["Как провести анализ модели, чтобы ответить на следующие вопросы:", "Для анализа модели используются методы машинного обучения и статистического анализа данных", "Анализ модели не требуется для ответа на поставленные вопросы", "Анализ модели делается вручную без использования инструментов", "Анализ модели осуществляется с помощью магических способов."], ["как посещаемость занятий по системам искусственного интеллекта влияет на успеваемость по этой дисциплине?", "Для определения влияния посещаемости на успеваемость проводится статистический анализ данных", "Влияние посещаемости определяется только на основе предположений", "Посещаемость не влияет на успеваемость", "Влияние посещаемости оценивается при помощи экстрасенсорных способностей."], ["как сказывается пол на посещаемости?", "Влияние пола на посещаемость может быть определено с помощью статистического анализа данных", "Пол не оказывает влияния на посещаемость", "Влияние пола определяется только на основе предположений", "Пол влияет на посещаемость благодаря магии."], ["как выглядят конструкты 'Пол', 'Город-деревня', 'Учебная группа', 'Успеваемость', 'Посещаемость'?", "Конструкты представляют собой абстрактные понятия, описывающие характеристики студентов и учебного процесса", "Конструкты имеют конкретные визуальные образы", "Конструкты не имеют определения и визуального вида", "Конструкты представлены в виде символов и живут в фэнтези мире."], [ "какие студенты являются 'типичными представителями' для своих учебных групп, а какие обладают своеобразием и выраженной индивидуальностью;", "Определение 'типичных представителей' и студентов с индивидуальностью может быть проведено с помощью статистического анализа данных и анализа конструктов", "Все студенты являются типичными представителями своих групп", "Определение типичных студентов зависит от случайных факторов", "Типичные студенты выбираются путем бросания монетки."], [ "Как отобразить результаты анализа в графической форме нелокальных нейронов и семантических сетей признаков. На их основе построить классические когнитивные карты для хорошо и плохо успевающих студентов.", "Результаты анализа можно отобразить в графической форме с использованием специализированных инструментов и программ", "Отображение результатов анализа невозможно", "Для отображения результатов анализа используются только текстовые описания", "Результаты анализа отображаются на картах сокровищ, которые не существуют."], ["Какие работы выполняются на этапе формализации задачи?", "На этапе формализации задачи выполняется математическое описание задачи и определение методов решения", "Формализация задачи не требует выполнения работ", "Формализация задачи включает только составление текстового описания задачи", "Задачи формализации решаются с помощью волшебства."], [ "Как в системе 'Эйдос' ввести классификационные шкалы и градации, выбрав в качестве классов - различные уровни учебных достижений по различным дисциплинам, перечень которых взять из зачетной книжки?", "Классификационные шкалы и градации могут быть введены в системе 'Эйдос' с использованием специальных инструментов и параметров", "Введение шкал требует создания новых программ", "Шкалы могут быть введены только вручную", "Шкалы создаются при помощи магии."], ["Как в системе 'Эйдос' ввести описательные шкалы и градации, использовав характеристики подчерка?", "Описательные шкалы и градации могут быть созданы в системе 'Эйдос' с использованием характеристик подчерка и специальных функций", "Описательные шкалы создаются без учета характеристик подчерка", "Характеристики подчерка не могут быть использованы для создания шкал", "Описательные шкалы создаются с помощью волшебства."], ["Каким образом подготовить и ввести в систему 'Эйдос' обучающую выборку?", "Обучающая выборка подготавливается путем сбора и структурирования данных, затем вводится в систему 'Эйдос' через специальные интерфейсы", "Обучающая выборка готовится автоматически без необходимости структурирования данных", "Обучающую выборку не требуется вводить в систему", "Обучающая выборка создается при помощи магии."], [ "Как осуществить синтез и верификацию (измерение адекватности) семантической информационной модели в системе 'Эйдос'?", "Синтез и верификация модели проводятся в системе 'Эйдос' с использованием специальных алгоритмов и методов измерения адекватности", "Синтез и верификация модели не требуются", "Модель создается без использования синтеза и верификации", "Синтез и верификация модели выполняются с помощью магии."], ["Что включает системно-когнитивный анализ модели?", "Системно-когнитивный анализ модели включает в себя анализ структуры, связей и конструктов модели, а также их взаимодействия", "Системно-когнитивный анализ модели ограничивается только анализом структуры", "Анализ модели не включает системно-когнитивный подход", "Анализ модели осуществляется с помощью магии."], ["Как решаются задачи идентификации и прогнозирования в системе 'Эйдос'?", "Задачи идентификации и прогнозирования решаются с помощью алгоритмов и методов машинного обучения, встроенных в систему 'Эйдос'", "Задачи идентификации и прогнозирования не решаются в системе 'Эйдос'", "Решение задач идентификации и прогнозирования требует дополнительных инструментов", "Задачи идентификации и прогнозирования решаются с помощью магии."], [ "В каких подсистемах и режимах системы 'Эйдос' генерируются информационные портреты классов и факторов и отображаются в графической форме двухмерных и трехмерных профилей классов и факторов)?", "Информационные портреты генерируются в подсистемах системы 'Эйдос', используя режимы для визуализации двухмерных и трехмерных профилей классов и факторов", "Информационные портреты не генерируются в системе 'Эйдос'", "Информационные портреты генерируются только вручную", "Информационные портреты создаются при помощи магии."], [ "Каким образом в системе 'Эйдос' провести кластерно-конструктивный анализ классов и факторов и отобразить его в форме семантических сетей классов и факторов?", "Кластерно-конструктивный анализ проводится с использованием специальных алгоритмов и затем отображается в форме семантических сетей", "Кластерно-конструктивный анализ не проводится в системе 'Эйдос'", "Анализ не может быть отображен в форме семантических сетей", "Кластерно-конструктивный анализ выполняется с помощью магии."], [ "Как в системе 'Эйдос' осуществить содержательное сравнение классов и факторов и отобразить результаты в форме когнитивных диаграмм классов и факторов?", "Сравнение классов и факторов выполняется с помощью специальных алгоритмов и результаты отображаются в форме когнитивных диаграмм", "Сравнение классов и факторов не поддерживается в системе 'Эйдос'", "Сравнение требует дополнительных инструментов", "Сравнение классов и факторов выполняется с помощью магии."], ["Как в системе 'Эйдос' построить нелокальные нейроны и интерпретируемые нейронные сети?", "Построение нелокальных нейронов и интерпретируемых нейронных сетей осуществляется с использованием специальных функций и методов в системе 'Эйдос'", "Построение нейронов и сетей требует программирования", "Нейроны и сети не могут быть построены в системе 'Эйдос'", "Для создания нейронов и сетей в 'Эйдос' необходимо провести ритуальное обрядовое действие."], ["Как в системе 'Эйдос' построить классические когнитивные модели и отобразить их в форме когнитивных карт?", "Построение классических когнитивных моделей и отображение их в форме когнитивных карт выполняется с использованием встроенных инструментов", "Построение моделей и карт требует специальных программ", "Когнитивные модели не могут быть созданы в системе 'Эйдос'", "Для создания классических когнитивных моделей в 'Эйдос' необходимо предварительно научиться медитации."], [ "Как в системе 'Эйдос' построить интегральные когнитивные модели и отобразить в форме интегральных когнитивных карт?", "Построение интегральных когнитивных моделей и отображение их в форме интегральных когнитивных карт выполняется с помощью специализированных функций и методов", "Интегральные модели не поддерживаются в системе 'Эйдос'", "Интегральные карты невозможно создать в системе 'Эйдос'", "Для создания интегральных когнитивных моделей в 'Эйдос' следует прочитать все книги по философии."], ["Как в системе 'Эйдос' построить нелокальные нейроны и интерпретируемые нейронные сети?", "Используя интегрированные инструменты системы 'Эйдос', вы можете создавать нелокальные нейроны и интерпретируемые нейронные сети.", "Для создания нелокальных нейронов в 'Эйдос' необходимо установить сторонние библиотеки.", "Для построения интерпретируемых нейронных сетей следует использовать другой программный пакет.", "Для создания нейронов и сетей в 'Эйдос' нужно попросить совет у волшебника."], ["Как в системе 'Эйдос' построить классические когнитивные модели и отобразить их в форме когнитивных карт?", "В 'Эйдос' можно создавать классические когнитивные модели и представлять их в виде когнитивных карт.", "Классические когнитивные модели не поддерживаются в системе 'Эйдос'.", "Когнитивные карты создаются только для нестандартных моделей.", "Для создания классических когнитивных моделей в 'Эйдос' необходимо обратиться к гадалке."], [ "Как в системе 'Эйдос' построить интегральные когнитивные модели и отобразить в форме интегральных когнитивных карт?", "Система 'Эйдос' предоставляет возможность создавать интегральные когнитивные модели и представлять их в виде интегральных когнитивных карт.", "Интегральные когнитивные модели не могут быть созданы в системе 'Эйдос'.", "Интегральные когнитивные карты не поддерживаются в 'Эйдос'.", "Для создания интегральных когнитивных моделей в 'Эйдос' нужно сначала пройти курс по магии."], ["Кто такой 'респондент'?", "Респондент - это лицо, участвующее в исследовании или опросе и предоставляющее ответы на вопросы.", "Респондент - это термин, используемый в информационных системах, и не имеет отношения к исследованиям.", "Респондент - это субъект исследования, который проводит эксперимент.", "Респондент - это существо из параллельной вселенной, которое помогает в решении задач исследования."], ["Что понимается под 'социальным статусом' респондента?", "Социальный статус респондента - это положение и роль данного человека в обществе, определяющие его социальное положение и влияющие на его ответы в исследовании.", "Социальный статус респондента связан исключительно с его материальным состоянием.", "Социальный статус респондента означает его уровень образования.", "Социальный статус респондента определяется количеством друзей в социальных сетях."], ["Каким образом провести анализ устойчивости модели к неполноте информации и наличию шума?", "Для анализа устойчивости модели в 'Эйдос' можно использовать методы статистической обработки данных и моделирования вариаций.", "Анализ устойчивости модели выполняется только вручную без использования инструментов 'Эйдос'.", "Устойчивость модели не имеет значения в исследованиях.", "Для анализа устойчивости модели в 'Эйдос' нужно просто попросить у модели вежливо."], [ "Каким образом можно проверить способность модели правильно идентифицировать классы, один из которых является подмножеством другого?", "Для проверки способности модели идентифицировать классы можно использовать тестовые наборы данных, в которых присутствуют классы и их подмножества.", "Способность модели идентифицировать классы не может быть проверена в системе 'Эйдос'.", "Модель всегда правильно идентифицирует классы, даже если они подмножества друг друга.", "Для проверки способности модели идентифицировать классы следует посоветоваться с кроликом-магом."], [ "Как оценить ценность букв для идентификации слов. Сравнить суммарную ценность для этой цели гласных и согласных букв?", "Ценность букв для идентификации слов может быть оценена с помощью статистических методов и анализа текстов. Сравнивая суммарную ценность гласных и согласных букв, можно выявить их вклад в идентификацию слов.", "Оценка ценности букв для идентификации слов выполняется только научными экспертами и не поддерживается 'Эйдос'.", "Ценность букв для идентификации слов невозможно оценить.", "Для оценки ценности букв для идентификации слов нужно провести специальное ритуальное испытание."], ["Что такое атрибуция текстов?", "Атрибуция текстов - это процесс определения авторства текста или его происхождения.", "Атрибуция текстов - это процесс шифрования текста для его защиты.", "Атрибуция текстов - это процесс создания новых текстов на основе существующих.", "Атрибуция текстов - это процесс связывания текстов с астральными сущностями."], ["Каким образом выполняется когнитивная структуризация предметной области?", "Когнитивная структуризация предметной области в 'Эйдос' осуществляется путем создания когнитивных моделей, анализа связей и взаимодействий между элементами предметной области.", "Когнитивная структуризация предметной области выполняется исключительно вручную без использования системы 'Эйдос'.", "Когнитивная структуризация предметной области не имеет значения в исследованиях.", "Для когнитивной структуризации предметной области нужно провести специальный ритуал с использованием камней."], ["В чем состоит формализацию предметной области и как ее осуществить в системе 'Эйдос'?", "Формализация предметной области включает в себя описание элементов, связей и правил в виде формальных моделей. В 'Эйдос' формализация осуществляется с использованием встроенных инструментов.", "Формализация предметной области не требуется в системе 'Эйдос'.", "Формализация предметной области сводится к созданию текстовых описаний и не поддерживается 'Эйдос'.", "Формализация предметной области выполняется путем призыва духов и применения магических символов."], [ "Какие средства формирования обучающей выборки используются в системе 'Эйдос' при решении задач атрибуции текстов?", "В системе 'Эйдос' для формирования обучающей выборки при решении задач атрибуции текстов используются методы анализа текстов и выделения характерных признаков.", "Обучающая выборка не имеет значения при решении задач атрибуции текстов в 'Эйдос'.", "Система 'Эйдос' не поддерживает создание обучающей выборки для таких задач.", "В системе 'Эйдос' для формирования обучающей выборки при решении задач атрибуции текстов используется случайный выбор текстов из интернета."], [ "В какой подсистеме и в каком режиме системы 'Эйдос' осуществляется синтез семантической информационной модели и в чем он состоит?", "Синтез семантической информационной модели в 'Эйдос' производится в подсистеме анализа данных и может осуществляться в автоматическом режиме на основе обработки текстовых и числовых данных. Он заключается в выявлении связей и структуры информации.", "Синтез семантической информационной модели не поддерживается в системе 'Эйдос'.", "Синтез семантической информационной модели в 'Эйдос' осуществляется вручную без использования компьютерных методов.", "Синтез семантической информационной модели в 'Эйдос' производится на кухне с помощью поваренной книги."], [ "В чем заключается оптимизация семантической информационной модели и как она осуществляется в системе 'Эйдос'?", "Оптимизация семантической информационной модели в 'Эйдос' заключается в улучшении структуры модели и ее адекватности. Это может включать в себя устранение лишних данных или добавление новых при необходимости.", "Оптимизация семантической информационной модели не проводится в системе 'Эйдос'.", "Оптимизация семантической информационной модели в 'Эйдос' сводится к простой фильтрации данных.", "Оптимизация семантической информационной модели в 'Эйдос' осуществляется путем массового удаления данных."], ["Как семантическая информационная модель проверяется на адекватность?", "Семантическая информационная модель в 'Эйдос' может быть проверена на адекватность путем анализа ее способности предсказывать реальные данные и сравнения ее результатов с наблюдениями.", "Семантическая информационная модель не может быть проверена на адекватность в системе 'Эйдос'.", "Адекватность модели не имеет значения в исследованиях.", "Семантическая информационная модель проверяется на адекватность путем сравнения ее результатов с прогнозами погоды."], ["Как связана адекватность модели с внутренней и внешней, дифференциальной и интегральной валидностью?", "Адекватность модели влияет на внутреннюю и внешнюю валидность. Внутренняя валидность связана с точностью предсказаний модели, а внешняя валидность - с ее применимостью к реальным данным. Дифференциальная и интегральная валидность - это аспекты валидности, которые также зависят от адекватности модели.", "Адекватность модели не влияет на внутреннюю и внешнюю валидность. Дифференциальная и интегральная валидность не имеют отношения к адекватности модели.", "Внутренняя и внешняя валидность не зависят от адекватности модели. Дифференциальная и интегральная валидность - это разные понятия.", "Адекватность модели влияет только на внутреннюю валидность и не имеет отношения к внешней и интегральной валидности."], ["Каким образом можно в системе 'Эйдос' выполнить адаптацию модели и измерить, как изменилась ее адекватность?", "В системе 'Эйдос' адаптация модели может быть выполнена путем внесения изменений в параметры модели на основе новых данных. Адекватность можно измерить сравнением результатов новой модели с реальными данными до и после адаптации.", "Адаптация модели в системе 'Эйдос' невозможна. Адекватность модели не изменяется.", "Адаптация модели в системе 'Эйдос' производится только вручную без использования вычислительных методов.", "Адаптация модели в системе 'Эйдос' включает в себя создание новой модели с нуля."], ["Как в системе 'Эйдос' осуществить пересинтез модели и измерить, как изменилась ее адекватность?", "Для пересинтеза модели в 'Эйдос' можно использовать актуальные данные и методы синтеза. Изменение адекватности модели оценивается сравнением результатов новой модели с предыдущими.", "Пересинтез модели не предусмотрен в системе 'Эйдос'. Адекватность модели не изменяется.", "Пересинтез модели в системе 'Эйдос' возможен только при полной переработке всей модели.", "Пересинтез модели в 'Эйдос' производится путем копирования старой модели без изменений."], ["Чем отличается адаптация модели от пересинтеза в системе 'Эйдос'?", "Адаптация модели в 'Эйдос' включает в себя внесение изменений в существующую модель на основе новых данных без полной переработки. Пересинтез, наоборот, предполагает создание новой модели с использованием актуальных данных с нуля.", "Адаптация и пересинтез модели - это синонимы в системе 'Эйдос'.", "Адаптация и пересинтез модели в 'Эйдос' абсолютно идентичны.", "Адаптация модели в 'Эйдос' означает создание новой модели на основе старой с полной переработкой."], ["В каких подсистемах и в каких режимах системы 'Эйдос' можно вывести информационные портреты?", "Информационные портреты можно создавать в подсистеме анализа данных в 'Эйдос' в различных режимах, включая автоматический и интерактивный.", "Создание информационных портретов невозможно в системе 'Эйдос'.", "Информационные портреты могут быть созданы только вручную без использования компьютерных инструментов.", "Информационные портреты создаются в системе 'Эйдос' только в режиме автоматической генерации."], ["В каких подсистемах и режимах системы 'Эйдос' можно выполнить кластерно-конструктивный анализ модели?", "Кластерно-конструктивный анализ модели можно выполнить в подсистеме анализа данных в режиме интерактивного анализа в 'Эйдос'.", "Кластерно-конструктивный анализ модели не поддерживается в системе 'Эйдос'.", "Кластерно-конструктивный анализ модели может быть выполнен только вручную без использования системы 'Эйдос'.", "Кластерно-конструктивный анализ модели доступен только в режиме автоматического анализа в 'Эйдос'."], ["Какие свойства натуральных чисел мы рассматривали в качестве их признаков?", "Свойства натуральных чисел, такие как простота, делители, четность/нечетность и др., могут рассматриваться как признаки в анализе натуральных чисел.", "Свойства натуральных чисел не имеют значения и не могут быть рассмотрены как признаки.", "Анализ натуральных чисел не предусмотрен в системе 'Эйдос'.", "В анализе натуральных чисел используются только цвета чисел."], ["Какие образом выполняется когнитивная структуризация предметной области?", "Когнитивная структуризация предметной области в 'Эйдос' осуществляется путем создания когнитивных моделей и анализа связей и взаимодействий между элементами предметной области.", "Когнитивная структуризация предметной области не имеет значения и не проводится в системе 'Эйдос'.", "Когнитивная структуризация предметной области может быть выполнена только вручную без использования системы 'Эйдос'.", "Когнитивная структуризация предметной области в 'Эйдос' осуществляется путем случайного выбора элементов."], [ "В чем состоит формализацию предметной области и как ее осуществить в системе 'Эйдос' при изучении свойств натуральных чисел?", "Формализация предметной области при изучении свойств натуральных чисел включает описание математических моделей и правил в виде формальных конструкций. В 'Эйдос' это может быть выполнено с использованием инструментов анализа и моделирования.", "Формализация предметной области не имеет значения при изучении свойств натуральных чисел в системе 'Эйдос'.", "Формализация предметной области при изучении свойств натуральных чисел проводится только на бумаге без использования 'Эйдос'.", "Формализация предметной области в 'Эйдос' осуществляется путем создания художественных картин."], [ "Какие средства формирования обучающей выборки используются в системе 'Эйдос' при изучении свойств натуральных чисел?", "В системе 'Эйдос' для формирования обучающей выборки при изучении свойств натуральных чисел можно использовать различные математические методы и анализ числовых данных.", "Формирование обучающей выборки не применимо к изучению свойств натуральных чисел в системе 'Эйдос'.", "Система 'Эйдос' не поддерживает создание обучающей выборки для изучения свойств натуральных чисел.", "Для формирования обучающей выборки в 'Эйдос' используются исключительно фотографии животных."], [ "Каким образом можно в системе 'Эйдос' провести анализ устойчивости модели при изучении свойств натуральных чисел?", "Для анализа устойчивости модели при изучении свойств натуральных чисел в 'Эйдос' можно использовать методы статистической обработки данных и моделирования вариаций.", "Анализ устойчивости модели не поддерживается в системе 'Эйдос' при изучении свойств натуральных чисел.", "Устойчивость модели не имеет значения при изучении свойств натуральных чисел в 'Эйдос'.", "Анализ устойчивости модели в 'Эйдос' осуществляется путем изучения погодных условий."], ["Каким образом можно проверить способность модели правильно идентифицировать свойства натуральных чисел?", "Для проверки способности модели идентифицировать свойства натуральных чисел в системе 'Эйдос' можно использовать тестовые наборы данных с известными свойствами и сравнить результаты модели с этими данными.", "Способность модели идентифицировать свойства натуральных чисел не может быть проверена в системе 'Эйдос'.", "Модель всегда правильно идентифицирует свойства натуральных чисел, даже без тестовых данных.", "Для проверки способности модели идентифицировать свойства натуральных чисел в 'Эйдос' нужно провести эксперимент с космическими кораблями."], ["Как оценить ценность различных свойств натуральных чисел для их идентификации?", "Оценка ценности различных свойств натуральных чисел для их идентификации может быть проведена с помощью статистических методов и анализа данных, чтобы выявить, какие свойства являются наиболее информативными для идентификации.", "Оценка ценности свойств натуральных чисел не проводится в системе 'Эйдос'.", "Ценность свойств натуральных чисел невозможно оценить.", "Оценка ценности свойств натуральных чисел для их идентификации осуществляется путем изучения звездных созвездий."], ["1. Администрирование", "Подсистема администрирования", "Администрирование системы", "Управление приложениями", "Работа с пользователями"], ["1.1. Авторизация", "Авторизация сисадмина, администратора приложения или пользователя", "Регистрация приложения", "Удаление приложения", "Настройка интерфейса"], ["1.2. Регистрация администратора приложения", "Регистрация и удаление регистрации администраторов приложений и задание паролей пользователей. Этот режим доступен только системному администратору и администраторам приложений.", "Авторизация администратора", "Создание приложений", "Удаление пользователей"], ["1.3. Диспетчер приложений", "Это подсистема администрирования приложений. Она предназначена для создания новых приложений, как пустых, так и на основе учебных примеров (лабораторных работ), имеющихся в системе, а также для выбора приложения для работы из уже имеющихся и удаления приложения. Выбор приложения для работы осуществляется путем отметки его любым символом. Удалять любые приложения разрешается только сисадмину, а Администратору приложений - только те, которые он сам создал.", "Работа с приложениями", "Создание новых приложений", "Удаление данных приложений"], ["1.4. Multi-language support", "Данный режим обеспечивает: 1) задание текущего языка интерфейса (по умолчанию - русский); 2) корректировку локальной языковой базы данных по текущему языку (улучшение перевода); 3) объединение локальных и облачных языковых баз данных", "Поддержка многих языков", "Управление интерфейсом", "Языковая настройка"], ["1.5. Задание путей на папки с группами приложений", "Папки с различными группами приложениями могут быть на локальном компьютере, в локальной сети или в Internet. Пути на них задаются сисадмином при инсталляции системы и могут быть изменены им когда угодно. Один из этих путей, а именно первый из отмеченный специальных символов, считается текущим и используется при СОЗДАНИИ приложений в диспетчере приложений 1.3, а в последующем при запуске приложений на исполнение пути берутся уже из БД диспетчера приложений", "Управление путями", "Создание групп приложений", "Перенос данных приложений"], ["1.6. Задание цветовой схемы главного меню", "Задается по умолчанию если в папке с системой нет файла: ColorSch.arx при инсталляции системы, но может быть изменена когда угодно сисадмином", "Выбор цветовой схемы", "Изменение дизайна", "Настройка интерфейса"], ["1.7. Задание размера главного окна в пикселях", "Задается по умолчанию 1024 x 769 если в папке с системой нет файла: _MainWind.arx при инсталляции системы, но может быть изменена когда угодно сисадмином", "Размер главного окна", "Изменение окна", "Настройка интерфейса"], ["1.8. Задание градиентных фонов главного окна", "Градиентные фоны главного окна задаются по умолчанию при инсталляции системы, но могут быть изменены когда угодно сисадмином", "Фон главного окна", "Изменение фона", "Дизайн интерфейса"], ["1.9. Прописывание путей по фактическому положению", "Доступно только сисадмину. Определяет фактическое месторасположение системы и приложений и прописывает пути на них в БД: PathGrAp.DBF и Appls.dbf, а также восстанавливает имена приложений в Appls.dbf на данные им при их создании", "Настройка путей", "Путь к приложениям", "Изменение расположения приложений"], ["1.10. Экспериментальная графика Роджера", "Графика Роджера. Операции с графикой на основе манипулирования массивами. Определение характеристик пикселей.", "Работа с графикой", "Экспериментальная графика", "Графические операции"], ["1.11. Локализация и инициализация (сброс) системы", "Доступно только сисадмину. Прописывает все пути по фактическому месторасположению системы, пересоздает общесистемные базы данных, удаляет все приложения и всех пользователей. Определяет фактическое месторасположение системы и приложений, удаляет все директории приложений с поддиректориями и всеми файлами в них, а затем прописывает все пути на них по фактическому месторасположению, т.е. пересоздает и переиндексирует БД: PathGrAp.DBF, Appls.dbf и Users.dbf", "Сброс системы", "Переустановка системы", "Удаление приложений"], ["1.12. Режим специального назначения", "Комментарий: 'Без комментариев'", "Особый режим", "Специальное назначение", "Работа в режиме комментария"], ["2. Формализация предметной области", "Разработка классификационных и описательных шкал и градаций и формирование обучающей выборки", "Обработка предметной области", "Создание шкал и градаций", "Сбор данных"], ["2.1. Классификационные шкалы и градации", "Ручной ввод-корректировка классификационных шкал и градаций", "Корректировка классификации", "Создание шкал", "Обработка градаций"], ["2.2. Описательные шкалы и градации", "Ручной ввод-корректировка описательных шкал и градаций", "Корректировка описания", "Создание описательных шкал", "Описательные градации"], ["2.3. Ввод обучающей выборки", "Просмотр, ввод и корректировка обучающей выборки", "Создание обучающей выборки", "Заполнение обучающих данных", "Подготовка данных для обучения"], ["2.3.1. Ручной ввод-корректировка обучающей выборки", "", "Коррекция обучающей выборки", "Изменение данных для обучения", "Работа с обучающими данными"], ["2.4. Просмотр эвентологических баз данных", "Просмотр эвентологических баз данных (баз событий), в которых исходные данные закодированы с помощью классификационных и описательных шкал и градаций и представлены в форме кодов событий, между которыми существуют причинно-следственные связи", "Просмотр базы данных", "Анализ событий", "Просмотр событий"], ["2.3.2. Программные интерфейсы с внешними базами данных", "Автоматизированная формализация предметной области", "Работа с внешними базами данных", "Интеграция данных", "Формализация предметной области"], ["2.3.2.1. Импорт данных из текстовых файлов", "Универсальный программный интерфейс ввода данных из TXT, DOC и Internet (HTML) файлов неограниченного объема. Атрибуция текстов, АСК-анализ мемов", "Импорт текстовых данных", "Чтение файлов", "Анализ текстовых данных"], ["2.3.2.2. Универсальный программный интерфейс импорта данных в систему", "Режим представляет собой УНИВЕРСАЛЬНЫЙ ПРОГРАММНЫЙ ИНТЕРФЕЙС ФОРМАЛИЗАЦИИ ПРЕДМЕТНОЙ ОБЛАСТИ И ИМПОРТА ДАННЫХ В СИСТЕМУ 'ЭЙДОС-Х'. Данный программный интерфейс обеспечивает автоматическое формирование классификационных и описательных шкал и градаций и обучающей выборки на основе XLS, XLSX или DBF-файла с исходными данными стандарта, описанного в Help режима. Кроме того он обеспечивает автоматический ввод распознаваемой выборки из внешней базы данных. В этом режиме может быть до 1000000 объектов обучающей выборки до 1500 шкал.", "Импорт данных в систему", "Формализация данных", "Автоматический ввод данных"], ["2.3.2.3. Импорт данных из транспонированных внешних баз данных", "ПРОГРАММНЫЙ ИНТЕРФЕЙС ФОРМАЛИЗАЦИИ ПРЕДМЕТНОЙ ОБЛАСТИ И ИМПОРТА ДАННЫХ В СИСТЕМУ 'ЭЙДОС-Х'.", "Автоматическая классификация данных из внешних баз", "Импорт данных из внутренних баз", "Ручное формирование данных"], ["2.3.2.4. Оцифровка изображений по внешним контурам", "Кодирование и ввод в систему 'Эйдос' изображений по их внешним контурам.", "Оцифровка изображений по внутренним контурам", "Преобразование изображений в текстовый формат", "Сжатие изображений без потерь"], ["2.3.2.5. Оцифровка изображений по всем пикселям и спектру", "Кодирование и ввод изображений по всем пикселям и спектру в систему 'Эйдос'.", "Оцифровка изображений по внешним контурам", "Обработка изображений в оттенках серого", "Импорт изображений в формате PNG"], ["2.3.2.6. Сценарный АСК-анализ символьных и числовых рядов", "Импорт данных из DOS-TXT-рядов чисел и слов для анализа временных рядов.", "Статистический анализ текстовых данных", "Кодирование изображений с использованием шаблонов", "Генерация случайных чисел для анализа"], ["2.3.2.7. Транспонирование файлов исходных данных", "Переворачивание и запись базы данных Inp_data.xls в файл Out_transp.xls.", "Импорт данных из внешних источников", "Создание резервной копии данных", "Сжатие данных для экономии места"], ["2.3.2.8. Объединение нескольких файлов исходных данных в один", "Объединение файлов одинаковой структуры в один файл Add_data.xls.", "Разделение файла на несколько частей", "Кодирование файлов для безопасности", "Импорт данных из CSV-файлов"], ["2.3.2.9. Разбиение TXT-файла на файлы-абзацы", "Обнаружение абзацев в TXT-файлах и запись каждого абзаца в отдельный файл.", "Создание резервной копии текстовых файлов", "Импорт текстовых файлов в базу данных", "Автоматическая аннотация текстовых данных"], ["2.3.2.10. CSV => DBF конвертер системы 'Эйдос'", "Преобразование CSV-файла Inp_data.csv в DBF-файл Inp_data.dbf, открываемый в MS Excel.", "Экспорт DBF-файлов в CSV-формат", "Импорт данных из DBF-файлов", "Конвертация изображений в CSV-формат"], ["2.3.2.11. Прогноз событий по астропараметрам по Н.А.Чередниченко", "Создание БД Inp_data.dbf из файлов Input1.xls и Input2.xls и модели для прогнозирования событий по астропараметрам.", "Анализ звездных карт", "Импорт данных из космических обсерваторий", "Прогноз погоды на основе астропараметров"], ["2.3.2.12. Прогнозирование землетрясений методом Н.А.Чередниченко", "Создание БД Inp_data.dbf из файлов Input1.xls и Input2.xls и модели для прогнозирования землетрясений.", "Исследование подземных процессов", "Анализ сейсмических данных", "Создание модели геологических явлений"], ["2.3.2.13. Чемпионат RAIF-Challenge 2017-API-bank", "Создание БД Inp_data.dbf из файлов t1.xlsx, t2.xlsx, t3.xlsx, t4.xlsx", "Участие в банковском чемпионате", "Работа с API банков", "Анализ данных финансовых институтов"], ["2.3.2.14. Чемпионат RAIF-Challenge 2017-API-retail", "Создание БД Inp_data.dbf и файла Inp_name.txt из файлов jet_raif_challenge.csv и description.csv", "Участие в розничном чемпионате", "Анализ данных розничных продаж", "Работа с API розничных компаний"], ["2.3.2.15. Вставка промежуточных строк в файл исходных данных", "Вставка строк с интерполяцией значений соседних строк в числовых шкалах и объединением значений в текстовых шкалах", "Редактирование текстовых файлов", "Сжатие числовых данных", "Удаление строк из файла"], ["2.3.3.4. Распределение объектов обуч. выборки по классам", "Формирование отчета о распределении объектов обучающей выборки по классам", "Создание классификационной модели", "Анализ структуры обучающей выборки", "Разметка данных для обучения"], ["2.3.3.5. Объединение объектов обуч.выборки с одинаковыми классами", "Формирование новой обучающей выборки, в которой объединены признаки объектов с одинаковыми классами и у объектов уникальные сочетания классов", "Разделение объектов обучающей выборки", "Извлечение статистических характеристик", "Автоматическое формирование отчетов"], ["3. Синтез, верификация и улучшение модели", "Создание модели, повышение ее качества и оценка достоверности", "Анализ производительности модели", "Тестирование модели на реальных данных", "Оптимизация модели"], ["3.1. Ускоренный синтез всех моделей", "Ускоренный синтез всех статистических и системно-когнитивных моделей: {Abs, Prc1, Prc2, Inf1, Inf2, Inf3, Inf4, Inf5, Inf6, Inf7}", "Создание моделей для разных целей", "Интеграция моделей", "Анализ производительности моделей"], ["3.2. Верификация всех моделей на GPU", "Верификация всех статистических и системно-когнитивных моделей: {Abs, Prc1, Prc2, Inf1, Inf2, Inf3, Inf4, Inf5, Inf6, Inf7} на графическом процессоре (GPU) с использованием параллельных вычислений", "Тестирование на разных аппаратных платформах", "Анализ эффективности GPU", "Оптимизация вычислений на GPU"], ["3.3. Синтез и верификация всех моделей на GPU", "Ускоренный синтез и верификация всех статистических и системно-когнитивных моделей: {Abs, Prc1, Prc2, Inf1, Inf2, Inf3, Inf4, Inf5, Inf6, Inf7} на графическом процессоре (GPU) с использованием параллельных вычислений", "Быстрое создание моделей без использования GPU", "Создание моделей с анализом данных на CPU", "Создание моделей на GPU без параллельных вычислений"], ["3.4. Анализ достоверности моделей с двумя инт.критериями", "Оценивается достоверность (адекватность) заданных стат.моделей и моделей знаний. Для этого осуществляется синтез заданных моделей, обучающая выборка копируется в распознаваемую и в каждой заданной модели проводится распознавание с использованием двух интегральных критериев, подсчитывается количество верно идентифицированных и не идентифицированных, ошибочно идентифицированных и не идентифицированных объектов (ошибки 1-го и 2-го рода)", "Анализ данных с одним интегральным критерием", "Анализ моделей без обучающей выборки", "Оценка моделей без использования критериев"], ["3.5. Синтез и верификация заданных из 10 моделей", "Оценивается достоверность (адекватность) заданных стат.моделей и моделей знаний. Для этого осуществляется синтез заданных моделей, обучающая выборка копируется в распознаваемую и в каждой заданной модели проводится распознавание с использованием двух интегральных критериев, подсчитывается количество верно идентифицированных и не идентифицированных, ошибочно идентифицированных и не идентифицированных объектов (ошибки 1-го и 2-го рода)", "Создание 10 моделей без верификации", "Создание моделей без обучающей выборки", "Оценка моделей без использования критериев"], ["3.6. Обнаружение, удаление и типизация артефактов", "Объекты обучающей выборки сравниваются с теми классами, к которым они относятся, и, если уровень сходства объекта с классом оказывается ниже заданного в диалоге порога, т.е. объект является нетипичным для данного класса или артефактом, то в справочнике классов создается новый класс с тем же наименованием, что у исходного класса, но с префиксом и объект обучающей выборки перекодируется на принадлежность к нему. Для этого создается новое приложение", "Обнаружение и удаление артефактов не связано с классами", "Создание новых классов без анализа сходства объектов", "Обнаружение артефактов без учета обучающей выборки"], ["3.7.1. Поиск и удаление артефактов (робастная процедура)", "Строится частотное распределение абсолютных частот встреч признаков в классах по матрице сопряженности Abs.dbf и пользователю предоставляется возможность удалить редко встречающиеся факты (сочетания), как случайные выбросы или артефакты. Для работы профессиональной графики нужна MS Windows 7 или выше", "Удаление артефактов без анализа распределения признаков", "Анализ артефактов без использования матрицы сопряженности", "Удаление случайных выбросов без возможности пользовательского вмешательства"], ["3.7.2. Значимость классификационных шкал", "В данном режиме классификационные шкалы ранжируются в порядке убывания значимости, т.е. средней значимости их градаций (степени детерминированности классов). Детерминированность класса - это вариабельность значений частных критериев статистических баз и баз знаний", "Ранжирование классификационных шкал по алфавиту", "Создание новых классификационных шкал без ранжирования", "Анализ классов без учета их значимости"], ["3.7.3. Степень детерминированности классов (град.клас.шкал)", "В данном режиме все градации классификационных шкал (классы) ранжируются в порядке убывания степени детерминированности, т.е. вариабельности значений частных критериев статистических и системно-когнитивных моделей", "Создание новых градаций классификационных шкал без ранжирования", "Ранжирование классификационных шкал по алфавиту", "Анализ классов без учета их степени детерминированности"], ["3.7.4. Значимость описательных шкал", "В данном режиме описательные шкалы ранжируются в порядке убывания значимости, т.е. средней значимости их градаций, т.е. признаков", "Создание новых описательных шкал без ранжирования", "Ранжирование описательных шкал по алфавиту", "Анализ описательных шкал без учета их значимости"], ["3.7.5. Значимость градаций описательных шкал и абстрагирование", "В данном режиме все градации описательных шкал (признаки) ранжируются в порядке убывания значимости, т.е. вариабельности значений частных критериев статистических и системно-когнитивных моделей. Модели оцениваются по степени различия значимости наиболее и наименее значимых признаков. Реализована возможность абстрагирования, т.е. удаления из модели наименее значимых признаков.", "Ранжирование градаций описательных шкал по алфавиту", "Удаление градаций описательных шкал без анализа их значимости", "Анализ градаций описательных шкал без учета значимости признаков"], ["3.7.6. Разделение классов на типичную и нетипичную части", "Из файла исходных данных 'Inp_data.dbf' стандарта программного интерфейса 2.3.2.2 либо удаляются объекты обучающей выборки, которые привели к ошибкам неидентификации или ложной идентификации, либо для таких объектов создаются новые классы. В данном режиме используются результаты распознавания.", "Удаление объектов обучающей выборки без анализа ошибок идентификации", "Создание новых классов без связи с ошибками распознавания", "Разделение классов без использования результатов распознавания"], ["3.7.7. Генерация подсистем классов и докод.об.и расп.выб.", "На основе сочетания классов по 2, 3, N формируются подсистемы классов, которые добавляются в качестве градаций в классификационные шкалы подсистем классов и в объекты обучающей и распознаваемой выборки", "Генерация подсистем классов без использования сочетания классов", "Добавление подсистем классов без связи с классификационными шкалами", "Генерация подсистем классов без добавления в выборки"], ["3.7.8. Генерация подсистем признаков и докод.об.и расп.выб.", "На основе сочетания признаков по 2, 3, N формируются подсистемы признаков, которые добавляются в качестве градаций в описательные шкалы подсистем признаков и в объекты обучающей и распознаваемой выборки", "Генерация подсистем признаков без использования сочетания признаков", "Добавление подсистем признаков без связи с описательными шкалами", "Генерация подсистем признаков без добавления в выборки"], ["3.7.9. Корректировка экспертных оценок: объект => класс", "В данном итерационном режиме обучающая выборка корректируется на основе результатов распознавания: КОРРЕКТИРУЕТСЯ принадлежность объекта к классу с экспертной оценки на полученную с помощью модели. Затем проводится синтез моделей и распознавание. Это повторяется, пока все положительные решения не станут истинными или результат перестает улучшаться", "Корректировка экспертных оценок без использования результатов распознавания", "Синтез моделей и распознавание без корректировки экспертных оценок", "Итерационная корректировка без улучшения результатов распознавания"], ["4. Решение задач с применением модели", "Применение модели для решения задач идентификации (распознавания), прогнозирования и поддержки принятия решений (обратная задача прогнозирования), а также для исследования моделируемой предметной области путем исследования ее модели", "Применение модели для решения задач идентификации и прогнозирования в узком контексте", "Применение модели для решения задач исследования предметной области без прогнозирования", "Применение модели для решения задач управления и оптимизации без исследования"], ["4.1. Идентификация и прогнозирование", "Применение модели для идентификации и прогнозирования", "Применение модели для идентификации и прогнозирования с использованием искусственного интеллекта", "Использование модели для анализа и оптимизации данных без прогнозирования", "Использование модели для статистического анализа данных без идентификации"], ["4.1.1. Ручной ввод-корректировка распознаваемой выборки", "", "Автоматизированный ввод-корректировка распознаваемой выборки", "Пакетное распознавание в ручном режиме", "Удаленный ввод-корректировка распознаваемой выборки"], ["4.1.2. Пакетное распознавание в текущей модели", "Распознаются по очереди все объекты распознаваемой выборки в стат.модели или базе знаний, заданной текущей в режиме 3.3 или 5.6.", "Распознавание объектов происходит параллельно в текущей модели", "Распознавание объектов происходит последовательно в текущей модели", "Распознавание объектов происходит случайным образом в текущей модели"], ["4.1.3. Вывод результатов распознавания", "", "Результаты выводятся в виде графиков и диаграмм", "Результаты выводятся в текстовом формате без дополнительных иллюстраций", "Результаты выводятся в виде аудио-сообщений"], ["4.1.3.1. Подробно наглядно: 'Объект - классы'", "Визуализация результатов распознавания в подробной наглядной форме в отношении: 'Один объект - много классов' с двумя интегральными критериями сходства между конкретным образом распознаваемого объекта и обобщенными образами классов: 'Семантический резонанс знаний' и 'Сумма знаний'", "Визуализация результатов распознавания в текстовом формате для каждого объекта и класса", "Подробная табличная форма вывода результатов распознавания", "Графическое представление среднего уровня сходства объектов с классами"], ["4.1.3.2. Подробно наглядно: 'Класс - объекты'", "Визуализация результатов распознавания в подробной наглядной форме в отношении: 'Один класс - много объектов' с двумя интегральными критериями сходства между конкретным образом распознаваемого объекта и обобщенными образами классов: 'Семантический резонанс знаний' и 'Сумма знаний'", "Графическое представление среднего уровня сходства классов с объектами", "Текстовое представление соответствий между классами и объектами", "Подробный отчет по каждому классу с указанием объектов"], ["4.1.3.3. Итоги наглядно: 'Объект - класс'", "Отображение итоговых результатов распознавания в наглядной форме: отображаются пары: 'Объект-класс' у которых наибольшее сходство по двум интегральным критериям сходства: 'Семантический резонанс знаний' и 'Сумма знаний'. Приводится информация о фактической принадлежности объекта к классу.", "Отображение итогов распознавания в числовом формате", "Отображение итогов распознавания в виде текстового отчета", "Отображение итогов распознавания в виде графического представления"], ["4.1.3.4. Итоги наглядно: 'Класс - объект'", "Отображение итоговых результатов распознавания в наглядной форме: отображаются пары: 'Класс-объект' у которых наибольшее сходство по двум интегральным критериям сходства: 'Семантический резонанс знаний' и 'Сумма знаний'. Приводится информация о фактической принадлежности объекта к классу.", "Отображение итогов распознавания в числовом формате для каждого класса", "Отображение итогов распознавания в виде столбчатых диаграмм", "Табличное представление итогов распознавания для каждого класса"], ["4.1.3.5. Подробно сжато: 'Объекты - классы'", "В подробной сжатой (числовой) форме приводится информация об уровне сходства всех объектов со всеми классами по двум интегральным критериям сходства: 'Семантический резонанс знаний' и 'Сумма знаний', а также о фактической принадлежности объекта к классу.", "Подробная табличная форма с числовыми данными по уровню сходства объектов с классами", "Графическое представление сжатых данных по уровню сходства", "Отображение сжатой информации в виде графиков"], ["4.1.3.6. Обобщ.форма по достов.моделей при разных интегральных крит.", "Отображаются обобщенные результаты измерения достоверности идентификации по всем моделям и интегральным критериям из БД: Dost_mod.DBF. 'Отображаются частотные распределения уровней сходства верно и ошибочно идентифицированных и неидентифицированных объектов при разных моделях и интегральных критериях", "Отображаются обобщенные результаты измерения достоверности идентификации только для одной модели и одного интегрального критерия", "Отображаются обобщенные результаты измерения достоверности идентификации в текстовом формате", "Отображаются обобщенные результаты без учета частотных распределений"], ["4.1.3.7. Обобщ.стат.анализ результатов идент. по моделям и инт.крит.", "Отображаются результаты обобщенного стат.анализа достоверности идентификации по всем моделям и интегральным критериям из БД: VerModClsIT.dbf. 'Отображаются частотные распределения уровней сходства верно и ошибочно идентифицированных и неидентифицированных объектов при разных моделях и интегральных критериях", "Отображаются результаты обобщенного статистического анализа только для одной модели и интегрального критерия", "Отображаются обобщенные результаты без учета частотных распределений в текстовом формате", "Отображаются обобщенные результаты стат.анализа в виде графиков"], ["4.1.3.8. Стат.анализ результ. идент. по классам, моделям и инт.крит.", "Отображаются результаты стат.анализа достоверности идентификации по всем классам, моделям и интегральным критериям из БД: VerModCls.dbf", "Отображаются результаты стат.анализа только по одному классу, модели и интегральному критерию", "Статистический анализ результатов только для одной модели и одного интегрального критерия", "Отображаются результаты статистического анализа в виде текстовых отчетов"], ["4.1.3.9. Достоверность идент.объектов при разных моделях и инт.крит.", "Отображается достоверность идентификации объектов по классам (F-мера Ван Ризбергена) в разрезе по объектам при разных моделях (т.е. разных частных критериях) и при разных интегральных критериях из БД: Dost_clsF.dbf. Позволяет удалять из обучающей выборки плохо распознаваемые объекты.", "Отображается достоверность идентификации только для одного объекта", "Достоверность идентификации объектов выводится в текстовом формате", "Отображается только достоверность идентификации для одной модели и одного интегрального критерия"], ["4.1.3.10. Достоверность идент.классов при разных моделях и инт.крит.", "Отображается достоверность идентификации объектов по классам (F-мера Ван Ризбергена) в разрезе по классам при разных моделях (т.е. разных частных критериях) и при разных интегральных критериях из БД: Dost_clsF.dbf", "Отображается достоверность идентификации только для одного класса", "Достоверность идентификации классов выводится в виде таблицы", "Отображается только достоверность идентификации для одной модели и одного интегрального критерия"], ["4.1.3.11. Объединение в одной БД строк по самым достоверным моделям", "Объединение в одной БД 'AddData.dbf' строк по наиболее достоверным моделям из Dost_modCls, формиремых в режиме 4.1.3.6.", "Объединение строк только для одной модели", "Объединение строк производится в текстовом формате", "Объединение строк не учитывает достоверность идентификации"], ["4.1.3.12. Вывод результатов распознавания в стиле: 'Inp_data.xlsx'", "Вывод результатов распознавания в формате 'Inp_data.xlsx' в файлах: 'RecognResults_####_#_####.xls' для разных моделей: {'Abs','Prc1','Prc2','Inf1','Inf2','Inf3','Inf4','Inf5','Inf6','Inf7'}, интегральных критериев: {'i','k'} и в кодах или наименованиях классов и признаков: {'Kod','Name'}", "Вывод результатов распознавания только для одной модели и интегрального критерия", "Результаты выводятся в формате, отличном от 'Inp_data.xlsx'", "Отображается только результат для одной модели и одного интегрального критерия"], ["4.1.3.13. Частотное распределение наблюдений по классам", "Частотное распределения объектов обучающей выборки по классам формируется на основе выходной формы режима: 4.1.3.3. Итоги наглядно: 'Объект - класс'", "Частотное распределение только для одного класса", "Частотное распределение выводится в текстовом формате", "Частотное распределение не учитывает различные интегральные критерии и модели"], ["4.1.3.14. Распределение уровней сходства наблюдений по всем классам", "Распределение уровней сходства объектов распознаваемой выборки по классам формируется на основе выходной формы режима: 4.1.3.1. Подробно наглядно: 'Объект - классы'. При расчетах учитываются все классы, на которые данное наблюдение похоже: к сумматору каждого класса суммируется сходство данного наблюдения с этим классом", "Распределение уровней сходства только для одного класса", "Распределение выводится в текстовом формате", "Распределение не учитывает различные интегральные критерии и модели"], ["4.1.4. Пакетное распознавание в заданной группе моделей", "Распознаются по очереди все объекты распознаваемой выборки в стат.модели или базе знаний, заданной текущей, во всех моделях заданной группы моделей", "Модели распознают объекты одновременно во всех моделях", "Распознаются объекты в случайном порядке", "Модели распознают объекты параллельно"], ["4.1.5. Докодирование сочетаний признаков в распознаваемой выборке", "Не предоставлен верный ответ", "Извлечение скрытой информации из объектов", "Создание новых признаков на основе текущих", "Определение конфликтов между признаками"], ["4.1.6. Рациональное назначение объектов на классы (задача о ранце)", "Управление персоналом на основе АСК-анализа и функционально-стоимостного анализа (задача о назначениях)", "Определение оптимального распределения объектов по классам для максимизации выгоды", "Прогнозирование спроса на продукцию", "Анализ структуры рынка"], ["4.1.7. Интерактивная идентификация - последовательный анализ Вальда", "Не предоставлен верный ответ", "Интерактивная идентификация объектов с использованием метода Вальда", "Последовательная идентификация всех объектов одновременно", "Интерактивная идентификация объектов с использованием метода Монте-Карло"], ["4.1.8. Мультираспознавание (пакетное распознавание во всех моделях)", "При идентификации объекта распознаваемой выборки с каждым классом он сравнивается в той модели, в которой этот класс распознается наиболее достоверно, как в системе 'Эйдос-астра'", "Мультираспознавание позволяет одновременно распознавать объекты во всех моделях", "Объекты распознаются только в одной модели", "Мультираспознавание не использует модели для идентификации"], ["4.1.9. Подготовка результатов распознавания для http://kaggle.com", "Подготовка результатов распознавания в форме CSV-файлов в стандарте http://kaggle.com. Данный режим предполагает, что: 1) в модели 2 класса; 2) результаты распознавания во всех моделях уже получены в режиме 3.5", "Подготовка результатов распознавания в форме Excel-файлов", "Подготовка результатов распознавания в текстовом формате", "Подготовка результатов распознавания в формате JSON"], ["4.2.1. Информационные портреты классов", "Решение обратной задачи прогнозирования: выработка управляющих решений. Если при прогнозировании на основе значений факторов оценивается в какое будущее состояние перейдет объект управления, то при решении обратной задачи, наоборот, по заданному целевому будущему состоянию объекта управления определяется такая система значений факторов, которая в наибольшей степени обуславливает переход в это состояние", "Анализ статистических данных о классах", "Оценка структуры рынка", "Прогнозирование изменения цен на продукцию"], ["4.2.2. Кластерный и конструктивный анализ классов", "Не предоставлен верный ответ", "Анализ классов на основе их структуры", "Анализ изменений классов во времени", "Идентификация типов классов"], ["4.2.2.1. Расчет матриц сходства, кластеров и конструктов", "Не предоставлен верный ответ", "Расчет статистических характеристик классов", "Расчет коэффициентов корреляции признаков", "Расчет матриц для генетического анализа классов"], ["4.2.2.2. Результаты кластерно-конструктивного анализа", "Состояния, соответствующие классам, расположенные около одного полюса конструкта, достижимы одновременно, т.к. имеют сходную систему детерминации, а находящиеся около противоположных полюсов конструкта являются альтернативными, т.е. одновременно недостижимы.", "Сравнительный анализ классов с разными числами объектов", "Сравнение классов на основе числа признаков", "Построение структуры классов"], ["4.2.2.3. Агломеративная древовидная кластеризация классов", "Когнитивная кластеризация, путем объединения пар классов в матрице абсолютных частот и пересчет матриц условных и безусловных процентных распределений и системно-когнитивных моделей. Построение и визуализация древовидных диаграмм объединения классов (дендрограмм) в графическом виде", "Дендрограммы анализа структуры классов", "Исследование структуры данных", "Идентификация деревьев в классах"], ["4.2.2.4. Дивизивная древовидная кластеризация классов", "Кластеризация, путем разделения классов на типичную и нетипичную части пока релизоавна в упрощенной форме (по сравнению с DOS-весрией системы 'Эйдос'. Из файла исходных данных 'Inp_data.dbf' стандарта программного интерфейса 2.3.2.2 либо удаляются объекты обучающей выборки, которые привели к ошибкам неидентификации или ложной идентификации, либо для таких объектов создаются новые классы. В данном режиме используются результаты распознавания.", "Дивизивная древовидная кластеризация данных", "Анализ древовидных структур данных", "Идентификация границ классов"], ["4.2.3. Когнитивные диаграммы классов", "Данный режим показывает в наглядной графической форме какими признаками сходны и какими отличаются друг от друга заданные классы", "Анализ текстовых данных", "Создание структуры диаграмм", "Визуализация кластеров и конструктов"], ["4.3.1. Информационные портреты признаков", "Семантический (смысловой) портрет признака или значения фактора, т.е. количественная характеристика силы и направления его влияния на поведение объекта управления", "Графическое описание признаков", "Оценка распределения признаков в выборке", "Анализ связей между признаками"], ["4.3.2. Кластерный и конструктивный анализ признаков", "Не предоставлен верный ответ", "Анализ признаков на основе их взаимосвязей", "Исследование влияния признаков на объекты управления", "Определение областей значений признаков"], ["4.3.2.1. Расчет матриц сходства, кластеров и конструктов", "Не предоставлен верный ответ", "Расчет статистических характеристик признаков", "Расчет коэффициентов корреляции между признаками", "Создание матриц сходства для признаков"], ["4.3.2.2. Результаты кластерно-конструктивного анализа", "Признаки или градации факторов, расположенные около одного полюса конструкта, оказывают сходное влияние на объект управления, т.е. на его принадлежность к классам или его переход в состояния, соответствующие классам и могут быть заменены одни другими, а находящиеся около противоположных полюсов конструкта оказывают сильно отличающееся влияние на объект управления и не могут быть заменены одни другими.", "Сравнение признаков с использованием графических методов", "Расчет весовых коэффициентов для признаков", "Создание инфографики для признаков"], ["4.3.2.3. Агломеративная древовидная кластеризация признаков", "Когнитивная кластеризация, путем объединения пар признаков в матрице абсолютных частот и пересчет матриц условных и безусловных процентных распределений и системно-когнитивных моделей. Построение и визуализация древовидных диаграмм объединения признаков (дендрограмм) в графическом виде", "Создание диаграмм для признаков", "Анализ структуры признаков", "Идентификация групп признаков"], ["4.3.3. Когнитивные диаграммы признаков", "Данный режим показывает в наглядной графической форме какими классами сходны и какими отличаются друг от друга заданные признаки", "Этот режим отображает результаты исследования предметной области", "В этом режиме происходит оценка достоверности обучающей выборки", "Здесь проводится измерение адекватности 3 стат.моделей и 7 моделей знаний"], ["4.4.1. Оценка достоверности обучающей выборки", "Выявление объектов с нарушенными корреляциями между классами и признаками. Выявление очень сходных друг с другом объектов обучающей выборки", "Здесь происходит измерение независимости классов и признаков", "В этом режиме строится SWOT-матрица для заданного класса", "Этот режим обеспечивает восстановление значений функций по признакам аргумента"], ["4.4.9. Количественный SWOT-анализ факторов средствами АСК-анализа", "АСК-анализ обеспечивает построение количественной SWOT-матрицы (модели) для заданного значения фактора с указанием степени, в которой он способствует или препятствует переходу объекта управления в различные будущие состояния, соответствующие классам (обратная задача SWOT-анализа)", "Этот режим отображает Паретто-подмножества нелокальной нейронной сети", "Здесь осуществляется АСК-анализ изображений по пикселям, спектрам и контурам", "В данном режиме осуществляется визуализация и запись когнитивных функций, созданных в текущем приложении на основе различных стат.моделей и моделей знаний"], ["4.4.12. Классические и интегральные когнитивные карты", "Это нелокальная нейронная сеть с указанием не только связей между значениями факторов и классов (как в режиме 4.4.11), но и с корреляциями между классами (как в режиме 4.2.2), и корреляциями между значениями факторов (как в режиме 4.3.2)", "Данный режим обеспечивает пакетный ввод и оконтуривание изображений и формирование соответствующих файлов", "Здесь проводится измерение сходимости и устойчивости 10 моделей", "АСК-анализ обеспечивает построение SWOT-матрицы (модели) для заданного класса с указанием силы влияния способствующих и препятствующих факторов непосредственно на основе эмпирических данных"], ["4.5. Визуализация когнитивных функций: текущее приложение, разные модели", "В данном режиме осуществляется визуализация и запись когнитивных функций, созданных в текущем приложении на основе различных стат.моделей и моделей знаний", "Этот режим обеспечивает АСК-анализ изображений по пикселям, спектрам и контурам", "Здесь осуществляется визуализация и запись когнитивных функций, созданных в текущем приложении", "Данный режим готовит базы данных для визуализации в MS Excel прямых и обратных, позитивных и негативных точечных и средневзвешенных редуцированных когнитивных функций, созданных на основе различных стат.моделей и моделей знаний"], ["4.7. АСК-анализ изображений по пикселям, спектрам и контурам", "Данный режим обеспечивает АСК-анализ изображений, как сгенерированных в учебных целях, так и внешних для системы 'Эйдос-Х++', относящихся к какой-либо предметной области", "Этот режим показывает в наглядной графической форме какими классами сходны и какими отличаются друг от друга заданные признаки", "Здесь происходит измерение адекватности 3 стат.моделей и 7 моделей знаний", "Этот режим обеспечивает пакетный ввод и оконтуривание изображений и формирование соответствующих файлов"], ["4.8. Геокогнитивная подсистема", "Обеспечивает восстановление значений функций по признакам аргумента. Преобразует 2D Excel-таблицу с именем 'Inp_map.xls' в файл исходных данных 'Inp_data.dbf', содержащий координаты X,Y,Z точек и их признаки", "В данном режиме осуществляется визуализация и запись когнитивных функций, созданных в текущем приложении на основе различных стат.моделей и моделей знаний", "Этот режим отображает Паретто-подмножества нелокальной нейронной сети", "Здесь осуществляется АСК-анализ изображений по пикселям, спектрам и контурам"], ["5.1. Конвертер моделей Abs,Prc#,Inf# => CSV", "Преобразование статистических Abs, Prc1, Prc2 и системно когнитивных моделей Inf1, Inf2, Inf3, Inf4, Inf5, Inf6, Inf7 из стандарта TXT в стандарт CSV. Особенно это может пригодиться для кластеризации в системе IBM SPSS Statistics 27.0.1 IF026. Преобразование происходит без ограничений на размерность модели (количество классов и количество признаков), т.е. для Big Data", "Конвертирование моделей в другие форматы", "Импорт моделей из CSV в систему", "Преобразование моделей в JSON"], ["5.2. Создание классов на основе кластеров", "Данный режим обеспечивает создание в файле 'Inp_data.csv', аналогичном 'Inp_data.xls(x)' новых классификационных шкал, соответствующих уровням иерархии дерева агломеративной кластеризации классов (режим 2.3.2.1), и новых классов, соответствующих кластерам. При вводе данных из файла 'Inp_data.csv' в систему 'Эйдос' в API-2.3.2.2 могут быть созданы модели многослойных нейронных сетей.", "Создание новых объектов", "Удаление классов из системы", "Изменение иерархии классов в системе"], ["5.3. Конвертер всех PCX (BMP) в GIF", "Функционал для конвертации изображений", "Конвертер изображений в различные форматы", "Импорт изображений из Интернета", "Редактор изображений"], ["5.4. Конвер. результатов расп.для SigmaPlot", "Конвертирует результаты распознавания, т.е. БД Rasp.dbf в параметрическую форму в стиле: 'X, Y, Z', удобную для картографической визуализации в системе SigmaPlot. Это возможно, если предварительно были выполнены режимы 3.7.7 и 3.4(3.5.) и 4.1.2.", "Конвертер результатов для других программ", "Экспорт данных в формате графика", "Создание новых графиков и диаграмм"], ["5.5. Просмотр основных БД всех моделей", "Обеспечивает просмотр и экспорт в Excel основных баз данных всех статистических моделей: Abs, Prc1, Prc2 и моделей знаний: Inf1~Prc1, Inf2~Prc2, Inf3-хи-квадрат, Inf4-roi~Prc1, Inf5-roi~Prc2, Inf6-Dp~Prc1, Inf7-Dp~Prc2", "Удаление баз данных моделей", "Редактирование баз данных моделей", "Создание новых баз данных моделей"], ["5.6. Выбрать модель и сделать ее текущей", "Данная функция позволяет выбрать среди ранее рассчитанных в 3-й подсистеме статистических баз Abs, Prc1, Prc2 и моделей знаний INF#, текущую модель для решения в 4-й подсистеме задач идентификации, прогнозирования, приятия решений и исследования предметной области путем исследования ее модели", "Переход к другой системе", "Сохранение текущего состояния модели", "Создание новой модели"], ["5.7. Переиндексация всех баз данных", "Заново создаются все необходимые для работы системы индексные массивы общесистемных баз данных (находящихся в папке с исполнимым модулем системы), а также баз данных текущего приложения, необходимые для работы с ним", "Очистка баз данных от старых записей", "Создание резервной копии баз данных", "Увеличение скорости работы системы"], ["5.10.Выгрузка исходных данных в 'Inp_data'", "Данный режим выполняет функцию, обратную универсальному программному интерфейсу с внешними базами данных 2.3.2.2(), т.е. не вводит исходные данные в систему, а наоборот, формирует на основе исходных данных файлы: Inp_data.dbf и Inp_data.txt, на основе которых в режиме 2.3.2.2() можно сформировать эту же модель", "Сохранение результатов работы", "Экспорт данных в другие программы", "Удаление данных из системы"], ["5.11. Внешнее управление системой 'Эйдос'", "Данный режим обеспечивает управление системой 'Эйдос' в реальном времени со стороны внешней программы путем задания ею последовательности функций системы 'Эйдос' для исполнения (по сути программы, написанной на языке 'Эйдос') в специальной базе данных: 'ExternalControl.dbf' и программного контроля их исполнения", "Удаление внешних программ", "Настройка параметров системы", "Создание скриптов для внешнего управления"], ["5.12. Печать структур всех баз данных", "Распечатка структур (даталогических моделей) всех баз данных текущего приложения", "Печать содержимого баз данных", "Редактирование структуры баз данных", "Создание отчетов и документации"], ["5.13. Редактирование БД лемматизации", "Ввод-корректировка базы данных лемматизации: 'Lemma.dbf'", "Удаление лемм из базы данных", "Создание новых лемм", "Экспорт лемм в другие форматы"], ["5.14. On-line HELP по лабораторным работам", "On-line описания лабораторных работ (статьи и с сайта автора: http://lc.kubagro.ru/), а также пояснения по смыслу частных и интегральных критериев", "Просмотр инструкций по эксплуатации системы", "Справочные материалы для обучения", "Поддержка пользователей и консультации"], ["5.15. Локальные HELP по режимам системы", "Локальные пояснения по режимам системы 'Эйдос', входящие в ее исполнимый модуль", "Просмотр справки по текущему режиму", "Инструкции по использованию системы", "Советы по оптимизации работы системы"], ["5.16. Минимизация инсталляции системы", "Удаление из текущей инсталляции системы локальных лабораторных работ, базы лемматизации, всех языковых баз, кроме текущей, а также SygWin, обеспечивающей on-line генерацию языковых баз. В результате минимизации системы rar-архив папки с системой получается уже не более 220Мб, а около 40Мб. Ранее установленные приложения не затрагиваются. Для удаления приложений служит режим 1.11.", "Обновление системы", "Установка дополнительных компонентов", "Оптимизация использования ресурсов компьютера"], ["6.2. Ссылки на патенты, документацию и текущую версию системы", "Ссылки на патенты, документацию и текущую версию системы", "Internet-ссылки на научные статьи", "Ссылки на образовательные материалы", "Ссылки на кулинарные рецепты"], ["6.4. Порядок преобразования данных в информацию, а ее в знания", "Этапы АСК-анализа", "Процесс сжатия данных", "Как приготовить пиццу", "Исследование космических объектов"], ["6.6. Roger Donnay, Professional Developer, Developer eXPress++", "Roger Donnay, Professional Developer, Developer eXPress++", "Professional Developer, Developer eXPress++", "Professional Baker, Baker eXPress++", "Professional Designer, Designer eXPress++"], ["6.9. География пользователей системы 'Эйдос-Х++'", "География пользователей системы 'Эйдос-Х++', определенная по IP", "Определение города по фамилии", "Прогноз погоды", "Геолокация мобильных устройств"], ["7. Выход", "Выход из системы 'Эйдос'", "Завершить сессию", "Отправить почту", "Покинуть чат"], ["Что такое АСК-анализ?", "Автоматизированный системно-когнитивный анализ (АСК-анализ) представляет собой системный анализ, структурированный по базовым когнитивным операциям (БКО), благодаря чему удалось разработать для него математическую модель, методику численных расчетов (структуры данных и алгоритмы их обработки), а также реализующую их программную систему - систему Эйдос", "Это анализ вопросов", "Это автоматизация строительных компаний (АСК) путем их анализа", "АСК-анализ - это сравнительный анализ основных и побочных эффектов различных форм ацетилсалициловой кислоты (АСК)"], ["Что включает АСК-анализ?", "Автоматизированный системно-когнитивный анализ включает: формализуемую когнитивную концепцию, математическую модель, методику численных расчетов и реализующий их программный инструментарий, в качестве которого в настоящее время выступает постоянно совершенствуемая автором универсальная когнитивная аналитическая система Эйдос", "АСК-анализ включает в себя различные этапы синтеза и анализа", "АСК-анализ включает анализ прошлого, настоящего и будущего", "АСК-анализ включает анализ фактического состояния объекта моделирования, его целевого состояния и пути перехода из первого во второе"], ["Каковы компоненты АСК-анализа?", "формализуемая когнитивная концепция и следующий из нее когнитивный конфигуратор; теоретические основы, методология, технология и методика АСК-анализа; обобщенная и частные математические модели АСК-анализа, основанная на системном обобщении теории информации; методика численных расчетов, в универсальной форме реализующая математическую модель АСК-анализа на компьютерах, включающая иерархическую структуру данных и 24 детальных алгоритма 10 БКОСА; специальное инструментальное программное обеспечение, реализующее математическую модель и численный метод АСК-анализа - Универсальная когнитивная аналитическая система Эйдос", "АСК-анализ включает в себя активные и пассивные компоненты", "Компоненты АСК-анализа меняются в зависимости от решаемых задач", "У АСК-аналаиза те же самые компоненты, что и обычного системного анализа"], ["Каковы этапы АСК-анализа?", "1) когнитивно-целевая структуризация предметной области (определение объекта моделирования, влияющих на него факторов и результатов их влияния); 2) формализация предметной области (конструирование классификационных и описательных шкал и градаций и подготовка обучающей выборки); синтез и верификация 3 статистических и 7 системно-когнитивных моделей; решение задач идентификации, прогнозирования, принятия решений и исследования объекта моделирования путем исследования его модели", "У АСК-анализа те же самые этапы, что и обычного системного анализа", "Этапы АСК-анализа меняются в зависимости от решаемых задач", "Различные этапы АСК-анализа представлены в виде различных IDEF0 диаграмм"], ["Кто разработал Автоматизированный системно-когнитивный анализ (АСК-анализ) и интеллектуальную систему Эйдос?", "АСК-анализ и интеллектуальную систему Эйдос разработал проф.Е.В.Луценко (Россия)", "АСК-анализ и интеллектуальную систему Эйдос разработали английские ученые", "АСК-анализ и интеллектуальную систему Эйдос разработали в фирме OpenAI Илона Маска", "АСК-анализ и интеллектуальную систему Эйдос разработал Анукен"], ] # ########################################################################################################################################################### def center_window(win, width, height): screen_width = win.winfo_screenwidth() screen_height = win.winfo_screenheight() x = (screen_width / 2) - (width / 2) y = (screen_height / 2) - (height / 2) win.geometry(f'{int(width)}x{int(height)}+{int(x)}+{int(y)}') # Функция для очистки окна def clear_window(): for widget in root.winfo_children(): widget.grid_remove() def end_test(student_name): end_time = time.time() duration_seconds = round(end_time - test_data["start_time"], 2) # Calculate hours, minutes, and seconds hours = int(duration_seconds // 3600) minutes = int((duration_seconds % 3600) // 60) seconds = int(duration_seconds % 60) # Calculate average time per question average_time_per_question = duration_seconds / len(questions) correct_percentage = (test_data["correct_answers"] / len(questions)) * 100 grade = "" if 0 <= correct_percentage <= 25: grade = "2 (Неудовлетворительно)" grade_color = "black" elif 25 < correct_percentage <= 50: grade = "3 (Удовлетворительно)" grade_color = "brown" elif 50 < correct_percentage <= 75: grade = "4 (Хорошо)" grade_color = "blue" elif 75 < correct_percentage <= 100: grade = "5 (Отлично)" grade_color = "red" clear_window() result_label.config(text="Результаты тестирования:", font=("Arial", 16, "bold"), fg="green") result_label.grid(row=0, column=0, pady=(20, 10), columnspan=2) result_info = f"ФИО учащегося: {student_name}\n\n" result_info += f"Дата и время начала тестирования: {time.ctime(test_data['start_time'])}\n" result_info += f"Дата и время окончания тестирования: {time.ctime(end_time)}\n" result_info += f"Продолжительность тестирования: {hours} часов {minutes} минут {seconds} секунд\n" result_info += f"Среднее время на один вопрос: {average_time_per_question:.3f} секунд\n\n" result_info += f"% верных ответов: {correct_percentage:.2f}%\n" result_info += f"Оценка: {grade}\n" result_label.config(text=result_info, font=("Arial", 18, "bold"), fg="green") result_label.grid(row=1, column=0, pady=(20, 0), columnspan=2) result_label.config(fg=get_grade_color(correct_percentage)) # Настроим расширение колонки для кнопок с вариантами ответов root.grid_columnconfigure(0, weight=1) root.grid_columnconfigure(1, weight=1) # Добавим кнопку "Записать результаты в Эйдос-облако и выйти" write_and_exit_button = tk.Button( root, text="Записать результаты тестирования в Эйдос-облако и выйти", font=("Arial", 16), # Уменьшил размер шрифта command=lambda: on_exit_button_click(student_name, grade), bg="lightgreen" ) write_and_exit_button.grid(row=i + 2, column=0, pady=(50, 5)) # Уменьшил верхний отступ и уменьшил нижний отступ # Добавим кнопку "Выйти без записи" и переместили её правее предыдущей кнопки exit_without_writing_button = tk.Button( root, text="Выйти без записи", font=("Arial", 16), # Уменьшил размер шрифта command=lambda: exit_without_writing(student_name), bg="lightgreen" ) exit_without_writing_button.grid(row=i + 2, column=1, pady=(50, 5)) # Уменьшил верхний отступ и уменьшил нижний отступ def exit_without_writing(student_name): # Закрыть программу с восстановлением среды исполнения sys.exit() root.destroy() # Назначаем обработчик события закрытия окна root.protocol("WM_DELETE_WINDOW", lambda: exit_without_writing(root, student_name)) def on_exit_button_click(student_name, grade): # Ваш существующий код для записи результатов # Закрываем фрейм с кнопкой # exit_frame.grid_forget() # Удалим кнопку "Записать результаты тестирования в Эйдос-облако и выйти" write_and_exit_button.destroy() # Удалим кнопку "Выйти без записи" exit_without_writing_button.destroy() # Создаем фрейм для вывода информации о стадии процесса записи progress_frame = ttk.Frame(root) progress_frame.grid(row=12, column=0, columnspan=2, pady=50) # Опускаем на 3 строки вниз # Метка для вывода информации с полужирным шрифтом progress_label = ttk.Label(progress_frame, text="Запись результатов тестирования в Эйдос-облако...\nПожалуйста, подождите.", font=("Arial", 18, "bold"), # Шрифт полужирный foreground="indigo", # Цвет текста: индиго ) progress_label.grid(row=0, column=0) # Обновляем окно root.update() local_result_file = "test_results_5_11.txt" with open(local_result_file, "w", newline="") as csvfile: csv_writer = csv.writer(csvfile) csv_writer.writerow(["Результаты тестирования"]) csv_writer.writerow([result_info]) result_data = [ student_name.replace(',', ' '), # Заменяем запятые на пробелы в student_name time.ctime(test_data['start_time']), time.ctime(end_time), f"{hours} часов {minutes} минут {seconds} секунд", f"{average_time_per_question:.3f} секунд", f"{correct_percentage:.2f}%", grade ] csv_string = ",".join(map(str, result_data)) external_ip = get_external_ip() info = get_ip_info(external_ip) log_info = create_log(info) # print("Внешний IP-адрес компьютера: " + external_ip) # print("Информация в формате лога:") combined_string = log_info + csv_string # print(combined_string) # 1. Заменить запятые на пробелы в ФИО тестируемого student_name # 2. Определить язык student_name # 3. Если student_name не на английском языке, перевести его на английский # 4. Заменить 7-е поле CSV-строки combined_string на student_name+оценка # 1. Заменить запятые на пробелы и подряд идущие пробелы на один пробел в ФИО тестируемого student_name student_name = student_name.replace(',', ' ') student_name = re.sub(r'\s+', ' ', student_name) # 2. Определить язык student_name или grade def detect_language(text): translator = Translator() detected_lang = translator.detect(text) return detected_lang.lang # 3. Если student_name не на английском языке, перевести его на английский student_name_language = detect_language(student_name) grade_language = detect_language(grade) if student_name_language != 'en': translator = Translator() student_name = translator.translate(student_name, src=student_name_language, dest='en').text grade = translator.translate(grade, src=grade_language, dest='en').text # 4. Заменить 7-е поле CSV-строки combined_string на student_name + оценка fields = combined_string.split(',') fields[6] = student_name + ': ' + grade combined_string = ','.join(fields) # Вывести результат # print(combined_string) # Make sure 'content' is defined before the try block content = combined_string try: while True: content_bytes = content.encode("utf-8") with ftplib.FTP(ftp_host, timeout=1) as ftp: ftp.set_pasv(True) ftp.login(user=ftp_user, passwd=ftp_pass) ftp.storbinary("STOR public_html/test_results_5_11.txt", io.BytesIO(content_bytes)) update_message("Запись результатов тестирования в Эйдос-облаке") # print("Файл test_results_5_11 успешно записан на FTP-сервер.") break except ftplib.error_perm as e_perm: update_message("Произошла ошибка при работе с FTP") # print(f"Произошла ошибка при работе с FTP (permission error): {e_perm}") except ftplib.all_errors as e_all: update_message("Произошла ошибка при работе с FTP") # print(f"Произошла ошибка при работе с FTP (all errors): {e_all}") except Exception as e: update_message("Произошла ошибка при работе с FTP") # print(f"Другая ошибка: {e}") url = "http://lc.kubagro.ru/index_5_11.php" # Добавляет результат тестирования 'test_results_5_11' к базе данных 'test_strings_5_11' и удаляет флаг запрета FTP-доступа 'Flag_5_11.txt' webbrowser.open(url) root.quit() # Ответ на кнопку "Прервать тестирование и записать результаты в Эйдос-облако def finish_test(student_name): clear_window() end_test(student_name) def check_internet_connection(): global Flag_Internet try: # Попытка выполнить HTTP-запрос к Эйдос-облаку response = requests.get(URL_Eidos_cloud) response.raise_for_status() except requests.exceptions.RequestException: Flag_Internet = False messagebox.showerror("Ошибка Internet-соединения", "Интернет-соединение с Эйдос-облаком ОТСУТСТВУЕТ. Прохождение теста НЕВОЗМОЖНО") # Завершить программу sys.exit() else: Flag_Internet = True def check_ftp_connection(): global Flag_FTP info_window = tk.Toplevel(root) info_window.title("Информация о процессе") info_window.iconbitmap(icon_path) info_label = tk.Label(info_window, text="Идет проверка FTP-соединения. Пожалуйста, подождите...") info_label.pack() root.update_idletasks() # Обновить интерфейс без блокировки # Увеличим размер окна по ширине info_window.geometry("600x150") # Поместим окно по центру экрана center_window(info_window, 600, 150) def close_info_window(): info_window.withdraw() info_window.destroy() try: # Подключение к FTP-серверу ftp = ftplib.FTP(ftp_host) ftp.login(ftp_user, ftp_pass) except ftplib.error_perm as e: Flag_FTP = False close_info_window() # Закрыть окно с сообщением messagebox.showerror("Ошибка FTP доступа", f"FTP-соединение с {ftp_host} ОТСУТСТВУЕТ. Прохождение теста НЕВОЗМОЖНО") # Завершить программу sys.exit() except ftplib.error_temp as e: Flag_FTP = False close_info_window() # Закрыть окно с сообщением messagebox.showerror("Ошибка FTP доступа", "Ошибка времени ожидания при подключении к FTP-серверу") # Завершить программу sys.exit() except ftplib.all_errors as e: Flag_FTP = False close_info_window() # Закрыть окно с сообщением messagebox.showerror("Ошибка FTP доступа", f"Ошибка FTP доступа: {str(e)}") # Завершить программу sys.exit() else: # FTP-соединение успешно установлено Flag_FTP = True close_info_window() # Путь к иконке icon_path = "_Aidos.ico" root = tk.Tk() root.iconbitmap(icon_path) root.withdraw() # Проверка интернет-соединения check_internet_connection() # Проверка FTP-соединения check_ftp_connection() # Проверяем значение Test_number if Test_number == 0: # Если Test_number равен 0, присваиваем все элементы questions_all элементам questions questions = questions_all else: # В противном случае выбираем соответствующую четверть вопросов и ответов start_index = (Test_number - 1) * len(questions_all) // 4 end_index = min(start_index + len(questions_all) // 4, len(questions_all)) questions = questions_all[start_index:end_index] def get_external_ip(): try: # Используем сторонний веб-сервис для определения внешнего IP response = requests.get('https://ipinfo.io') data = response.json() external_ip = data['ip'] return external_ip except Exception as e: return "Не удалось определить внешний IP: " + str(e) def get_ip_info(ip): try: # Используем API сервиса ipinfo.io для получения информации по IP-адресу response = requests.get(f'https://ipinfo.io/{ip}/json') data = response.json() return data except Exception as e: return {'Ошибка': str(e)} # Получение информации геолокации и формирование строки БД запусков системы Эйдос в мире на компьютерах, подключенных к Internet: test_strings.txt: # 08.11.2023,2:13:42 ,95.25.145.97,RU,Russia,KDA,Krasnodar Krai,Krasnodar,350000,Europe/Moscow,45.036,38.9746,,CORBINA-BROADBAND,,,AS3216 PJSC "Vimpelcom",,,,, # точно такой же, как формирует сервис: http://ip-api.com/php/: # $log = $logdate."," //дата и время посещения # .$query["query"].',' //ip # .$query["countryCode"].',' //код страны # .$query["country"].',' //страна # .$query["region"].',' //код региона # .$query["regionName"].',' //регион # .$query["city"].',' //город # .$query["zip"].',' //индекс # .$query["timezone"].',' //часовой пояс # .$query["lat"].',' //широта # .$query["lon"].',' //долгота # .$query['offset'].',' # .$query['isp'].',' # .$query['org'].',' # .$query['currency'].',' # .$query['as'].',' # .$query['asname'].',' # .$query['mobile'].',' # .$query['proxy'].',' # .$query['hosting'].','; def create_log(query): dvdr = "," logdate = time.strftime("%d.%m.%Y,%H:%M:%S") client = os.environ.get('HTTP_CLIENT_IP', '') forward = os.environ.get('HTTP_X_FORWARDED_FOR', '') remote = os.environ.get('REMOTE_ADDR', '') if client: ip = client elif forward: ip = forward else: ip = remote response = requests.get(f'http://ip-api.com/json/{ip}?lang=en') query = response.json() if query and query['status'] == 'success': log = f"{logdate},{query.get('query', '')},{query.get('countryCode', '')},{query.get('country', '')},{query.get('region', '')},{query.get('regionName', '')},{query.get('city', '')},{query.get('zip', '')},{query.get('timezone', '')},{query.get('lat', '')},{query.get('lon', '')},{query.get('offset', '')},{query.get('isp', '')},{query.get('org', '')},{query.get('currency', '')},{query.get('as', '')},{query.get('asname', '')},{query.get('mobile', '')},{query.get('proxy', '')},{query.get('hosting', '')}" with open("test_strings_5_11.txt", "a+") as f: f.write(f"{log}\n") else: log = f"{logdate},{ip}" with open("ip_error_5_11.txt", "a+") as f: f.write(f"{log}\n") return log # Function to get the text color based on the percentage def get_grade_color(percentage): if 0 <= percentage <= 25: return "black" elif 25 < percentage <= 50: return "brown" elif 50 < percentage <= 75: return "blue" elif 75 < percentage <= 100: return "red" # Функция для начала тестирования def start_test(): global student_name student_name = fio_entry.get().strip() if not student_name: result_label.config(text="Обязательно введите ФИО и № группы тестируемого!", fg="red") return # Очистка окна clear_window() # Начало тестирования start_time = time.time() test_data["start_time"] = start_time test_data["current_question"] = 0 test_data["correct_answers"] = 0 test_data["questions"] = random.sample(questions, len(questions)) # Перемешиваем вопросы display_question() # Функция для отображения текущего вопроса def display_question(): if test_data["current_question"] < len(test_data["questions"]): current_question = test_data["questions"][test_data["current_question"]] random.shuffle(current_question[1:]) # Перемешиваем варианты ответов # Создаем текст вопроса с указанием порядкового номера и общего количества вопросов question_number = test_data["current_question"] + 1 total_questions = len(test_data["questions"]) question_text = f"Вопрос №{question_number}/{total_questions}: {current_question[0]}" # Создаем метку для отображения текста вопроса без желтого фона question_label = tk.Label(root, text=question_text, font=("Arial", 16, "bold"), justify="left", anchor="w", wraplength=750, padx=20) question_label.grid(row=0, column=0, pady=(20, 0), columnspan=2, sticky="w") # Расположение по центру по ширине # Добавляем пустую строку после вопроса empty_label = tk.Label(root, text="", font=("Arial", 14), pady=10) empty_label.grid(row=1, column=0, columnspan=2) # Создаем список с вариантами ответов в случайном порядке answers = current_question[1:] random.shuffle(answers) for i, answer in enumerate(answers, start=2): answer_text = answer.replace('\n', ' ') # Заменяем переносы вариантов ответов на пробелы answer_button = tk.Button(root, text=answer_text, font=("Arial", 14), command=lambda ans=answer: check_answer(ans), bg="lightyellow") # Устанавливаем максимальную ширину кнопки (wraplength) для переноса текста, если он слишком длинный answer_button["wraplength"] = 750 # Установите желаемую максимальную ширину answer_button.grid(row=i, column=0, padx=20, pady=5, sticky="ew", columnspan=2) # Расположение по центру по ширине # Настроим расширение колонки для кнопок с вариантами ответов root.grid_columnconfigure(0, weight=1) root.grid_columnconfigure(1, weight=1) # Добавим кнопку "Прервать тестирование, записать результаты в Эйдос-облако и выйти" finish_button = tk.Button( root, text="Прервать тестирование", font=("Arial", 16), command=lambda: finish_test(student_name), bg="lightgreen" ) finish_button.grid(row=i + 1, column=0, pady=(20, 0), columnspan=2) # Расположение по центру по ширине else: end_test(student_name) # Функция для проверки ответов def check_answer(selected_answer): current_question = test_data["questions"][test_data["current_question"]] correct_answer = current_question[1] if selected_answer == correct_answer: test_data["correct_answers"] += 1 test_data["current_question"] += 1 clear_window() display_question() # Создание основного окна root = tk.Tk() # Создайте переменную для хранения соответствующего заголовка окна window_title = f"(C°) проф.Е.В.Луценко. {'Тест' if Test_number == 0 else f'Test-{Test_number}'} по АСК-анализу и системе 'Эйдос'. V-03.12.2023" # Установите заголовок окна root.title(window_title) # Остальной код без изменений root.geometry("900x800") # Загрузка иконки root.iconbitmap("_Aidos.ico") # Определите message_label после создания основного окна message_label = tk.Label(root, text="", font=("Arial", 14), wraplength=400, justify="center", bg="lightyellow") message_label.grid(row=7, column=0, columnspan=2, pady=10) def update_message(new_message): message_label.config(text=new_message) for i, question in enumerate(questions_all): if len(question) != 5: print(f"Строка {i + 1} содержит не 5 элементов: {question}") # Label for ФИО and № группы учащегося fio_label = tk.Label(root, text="ФИО, № группы тестируемого и вуз:", font=("Arial", 16)) fio_label.grid(row=0, column=0, padx=20, pady=20, sticky="w") # Создайте виджет Entry для ввода ФИО fio_entry = tk.Entry(root, font=("Arial", 14), width=37) # Настройте ширину по необходимости fio_entry.grid(row=0, column=1, padx=20, pady=20) # Кнопка "Начать тестирование" с желтым фоном start_button = tk.Button(root, text="Начать тестирование", font=("Arial", 16), command=start_test, bg="lightyellow") start_button.grid(row=1, column=1, columnspan=2, pady=20) # Изменяем значение column на 1 # Переменные для хранения данных теста test_data = { "current_question": 0, "correct_answers": 0, "start_time": 0, "questions": [] } # Метка для вывода результатов result_label = tk.Label(root) root.mainloop() def _5_12py(): # ########################################################################################################################################## # _5_12py.py. (C°) проф.Е.В.Луценко. Программа создания сайта для получения свидетельства РосПатента на базы данных приложения системы Эйдос # ########################################################################################################################################## # Создаем главное окно приложения window = tk.Tk() window.title('(C°) Система "Эйдос", режим: "5.12. Печать структур всех БД, => xlsx, html') window.geometry("700x320") # Загрузите изображение и создайте объект PhotoImage # Получаем путь к директории с _Aidos.ico icon_path = os.path.abspath('_Aidos.ico') # Абсолютный путь к иконке icon_image = ImageTk.PhotoImage(Image.open(icon_path)) # Установите иконку для окна window.iconphoto(True, icon_image) # Создаем метку с текстом перед прогресс-баром label_text = tk.Label(window, text="Создание сайта для получения свидетельства Роспатента на базу данных", font=("Arial", 14)) label_text.pack(pady=10) # Создаем стиль ttk.Style и задаем цвет полоски прогресса style = ttk.Style() style.theme_use("default") style = ttk.Style() # Задание яркого лазурного цвета style.configure("Custom.Horizontal.TProgressbar", troughcolor='white', background='#00FFFF') # Шестнадцатеричное значение # Задание золотистого цвета # style.configure("Custom.Horizontal.TProgressbar", # troughcolor='white', # background='goldenrod') # Название цвета # Создаем прогресс-бар с кастомным стилем progress_bar = ttk.Progressbar(window, style="Custom.Horizontal.TProgressbar", length=600, mode='determinate') progress_bar.pack(pady=10) # Создаем метку для отображения процента выполнения percent_label = tk.Label(window, text="0.000%", font=("Arial", 14)) percent_label.pack(pady=10) def replace(symbol, count): return symbol * count def update_progress(current_progress): # Обновляем прогресс-бар progress_bar['value'] = current_progress # Обновляем процент выполнения percent_label['text'] = '{:.3f}%'.format(current_progress) window.update_idletasks() def show_completion_message(): # Выводим сообщение о завершении процесса label1 = tk.Label(window, text="Процесс успешно завершен !!!", font=("Arial", 14)) label2 = tk.Label(window, text=replace("-", 131), font=("Arial", 12)) label3 = tk.Label(window, text="Для создания сайта необходимо скопировать на хостинг все html-файлы и поддиректории", font=("Arial", 12)) label4 = tk.Label(window, text="из папки: " + dbf_folder, font=("Arial", 12)) # Размещаем надписи с помощью pack label1.pack(pady=10) label2.pack(pady=5) label3.pack(pady=5) label4.pack(pady=5) # Получить абсолютный путь к базе данных DBF Appls.dbf file_path = os.path.abspath('Appls.dbf') # Открыть файл DBF и получить все записи из него with DBF(file_path, encoding='cp866') as table: name_appl = None dbf_folder = None for record in table: if record.get('BY_DEFAULT').strip(): dbf_folder = record.get('PATH_APPL').strip() name_appl = record.get('NAME_APPL').strip() break if name_appl: # Проверяем, что переменная name_appl определена with open('output.txt', 'w', encoding='cp866') as file: file.write('\n"' + name_appl + '"

\n') else: print("Переменная name_appl не была определена.") # Получаем список всех файлов и папок в указанной директории file_list = os.listdir(dbf_folder) # Общий прогресс для прогресс-бара total_progress = 0 # Проходимся по каждому файлу в списке и удаляем все html, xls, xlsx файлы for file_name in file_list: # Проверяем, является ли текущий элемент файлом с расширением .html if file_name.endswith('.html'): # Формируем полный путь к файлу file_path = os.path.join(dbf_folder, file_name) # Удаляем файл os.remove(file_path) # Проверяем, является ли текущий элемент файлом с расширением .xls if file_name.endswith('.xls'): # Формируем полный путь к файлу file_path = os.path.join(dbf_folder, file_name) # Удаляем файл os.remove(file_path) # Проверяем, является ли текущий элемент файлом с расширением .xls if file_name.endswith('.xlsx'): # Формируем полный путь к файлу file_path = os.path.join(dbf_folder, file_name) # Удаляем файл os.remove(file_path) # Создаем файл index.html в папке с DBF-файлами index_file_path = os.path.join(dbf_folder, 'index.html') with open(os.path.join(dbf_folder, 'index.html'), 'w', encoding='cp866') as file: file.write('

Графические выходные формы и базы данных интеллектуального Эйдос-приложения:') file.write('\n"' + name_appl + '"

\n') # Добавляем заголовок перед ссылками на html-файлы баз данных. with open(os.path.join(dbf_folder, 'index.html'), 'a', encoding='cp866') as index_file: index_file.write('

Альбомы графических выходных форм

\n') # Получаем список всех поддиректорий из указанной папки, содержащих графические файлы. subdirectories = [os.path.join(dbf_folder, d) for d in os.listdir(dbf_folder) if os.path.isdir(os.path.join(dbf_folder, d))] # Общее количество поддиректорий total_subdirectories = len(subdirectories) # Получаем список всех DBF-файлов из указанной папки dbf_files = [os.path.join(dbf_folder, f) for f in os.listdir(dbf_folder) if os.path.isfile(os.path.join(dbf_folder, f)) and f.lower().endswith('.dbf')] # Общее количество DBF-файлов total_dbf_files = len(dbf_files) # Максимальное значение прогресс-бар max_progress = total_subdirectories + 2 * total_dbf_files # total_dbf_files умножаем на 2, т.к. каждый dbf файл преобразуется в html и в xlsx # Проходимся по всем найденным поддиректориям и создаем ссылку на альбом графических форм этой директории. for subdirectory in subdirectories: try: # Создаем имя файла для выходного html файла. filename_html = '{}.html'.format(subdirectory) with open(filename_html, 'w', encoding='cp866') as f: # Создаем заголовок страницы с названием директории. f.write('

{}

\n'.format(os.path.basename(subdirectory))) # Получаем список всех графических файлов из текущей поддиректории. image_files = [os.path.join(subdirectory, f) for f in os.listdir(subdirectory) if os.path.isfile(os.path.join(subdirectory, f)) and (f.lower().endswith('.jpg') or f.lower().endswith('.png'))] # Если нет графических файлов в текущей поддиректории, выводим сообщение. if not image_files: f.write('

No image files found.

\n') # Создаем галерею из графических файлов. for image_file in image_files: # Получаем относительный путь к изображению относительно dbf_folder relative_path = os.path.relpath(image_file, dbf_folder) # Записываем тег с относительным путем f.write('{}\n'.format(relative_path, os.path.basename(image_file))) # Сохраняем путь к выходному файлу для создания гиперссылки. output_path = filename_html except Exception as e: # Если возникла ошибка при создании альбома, пропускаем текущую поддиректорию. print('Error:', e) continue finally: # Добавляем ссылку на каждый созданный альбом в список ссылок (выполняется после успешного создания или ошибки). link_text = os.path.basename(output_path) with open(os.path.join(dbf_folder, 'index.html'), 'a', encoding='cp866') as index_file: index_file.write('

{}

\n'.format(link_text, link_text)) # Обновляем прогресс и прогресс-бар total_progress += 1 current_progress = total_progress / max_progress * 100 update_progress(current_progress) # Добавляем заголовок перед ссылками на html-файлы баз данных. with open(os.path.join(dbf_folder, 'index.html'), 'a', encoding='cp866') as index_file: index_file.write('

Ссылки на таблицы баз данных

\n') # Создаем переменную для хранения ссылок на файлы links = [] # Проходимся по всем найденным файлам и конвертируем их в HTML форматы. for db_file in dbf_files: try: # Читаем данные из файла используя cp866 encoding для чтения кириллических символов. table = DBF(db_file, encoding='cp866') # Создаем имя файла для выходного html файла. filename_html = '{}.html'.format(os.path.splitext(db_file)[0]) with open(filename_html, 'w', encoding='cp866') as f: # Создаем таблицу html из dbf данных. field_names = list(table.field_names) header_row = '' + ''.join(['{}'.format(name) for name in field_names]) + '\n' rows = [] for record in table: row_data = ''.join(['{}'.format(value) for value in record.values()]) rows.append('{}\n'.format(row_data)) html_table = '\n{}{}\n
'.format(header_row, ''.join(rows)) # Записываем таблицу в файл. f.write(html_table) # Сохраняем путь к выходному файлу для создания гиперссылки. output_path = filename_html except Exception as e: # В случае ошибки выводим сообщение и переходим к следующему файлу. print('Error:', e) continue finally: # Добавляем ссылку на каждый созданный файл в список ссылок link_text = os.path.basename(output_path) links.append('{}'.format(link_text, link_text)) # Обновляем прогресс и прогресс-бар total_progress += 1 current_progress = total_progress / max_progress * 100 update_progress(current_progress) # Создаем строку со всеми ссылками через запятую links_string = ', '.join(links) # Путь к индексному HTML-файлу index_file_path = os.path.join(dbf_folder, 'index.html') # Записываем ссылки в индексный файл with open(index_file_path, 'a', encoding='cp866') as index_file: index_file.write('

{}

\n'.format(links_string)) # Добавляем заголовок перед ссылками на html-файлы баз данных. with open(os.path.join(dbf_folder, 'index.html'), 'a', encoding='cp866') as index_file: index_file.write('

Даталогические модели баз данных

\n') # Формируем полный путь к файлу "Structure_All_DataBases.txt" txt_file_path = os.path.join(dbf_folder, 'Structure_All_DataBases.txt') # Открываем файл и читаем его содержимое в переменную txt_content with open(txt_file_path, 'r', encoding='cp866') as txt_file: txt_content = txt_file.read() # Удаление BOM-маркеров ('\ufeff') txt_content = txt_content.replace('\ufeff', '') # Добавляем содержимое файла перед ссылками на html-файлы баз данных. with open(os.path.join(dbf_folder, 'index.html'), 'a', encoding='cp866') as index_file: # Вставляем содержимое файла в шрифте Courier index_file.write('
{}
\n'.format(txt_content)) # Создаем директорию для XLSX файлов # xlsx_folder = os.path.join(dbf_folder, 'xlsx_files') # os.makedirs(xlsx_folder, exist_ok=True) # Проходимся по всем DBF-файлам и создаем XLSX файлы for dbf_file in dbf_files: try: # Создаем имя XLSX файла xlsx_file = os.path.splitext(dbf_file)[0] + '.xlsx' # Читаем данные из DBF файла table = DBF(dbf_file, encoding='cp866') records = list(table) # Создаем новую книгу Excel wb = Workbook() # Создаем новый лист в книге ws = wb.active # Записываем заголовки полей field_names = list(table.field_names) ws.append(field_names) # Записываем данные из DBF файла for record in records: row_data = [record[field_name] for field_name in field_names] ws.append(row_data) # Сохраняем XLSX файл wb.save(xlsx_file) # Перемещаем XLSX файл в папку xlsx_files new_xlsx_file = os.path.join(dbf_folder, os.path.basename(xlsx_file)) os.rename(xlsx_file, new_xlsx_file) except Exception as e: print('Error:', e) continue # Обновляем прогресс и прогресс-бар total_progress += 1 current_progress = total_progress / max_progress * 100 update_progress(current_progress) # Завершаем процесс и выводим сообщение update_progress(100) show_completion_message() # Запускаем главный цикл обработки событий tkinter window.mainloop() def url_py(): ######################################################################################## ### Программа на Питоне url_py.exe, запускающая сайт, адрес которого в файле: url_py.txt ######################################################################################## # Считываем интернет-адрес из файла with open('url_py.txt', 'r') as file: url = file.read().strip() # print(url) try: # Открываем URL в браузере по умолчанию webbrowser.open(url) except Exception as e: # В случае ошибки выводим сообщение print(f'Error: {e}') def dbf_to_html_py(): ################################################################################ # Функция dbf_to_html_py для преобразования каталога интеллектуальных облачных # Эйдос-приложений WebAppls.dbf в WebAppls.html ################################################################################ # print("Это функция 7") # -*- coding: utf-8 -*- import os from dbfread import DBF def dbf_to_html(input_file, output_file): # Read the DBF file with the specified encoding table = DBF(input_file, encoding='cp866') # Set CSS styling for the HTML table css = """ """ # Count the number of applications num_of_apps = sum(1 for _ in table) # HTML header with CSS styling and title header = f"""DBF to HTML Conversion {css}

Интеллектуальные облачные Эйдос-приложения
Любое из {num_of_apps} приведенных в данном каталоге приложений можно установить в режиме 1.3 системы Эйдос.
Систему Эйдос можно скачать на странице: http://lc.kubagro.ru/aidos/_Aidos-X.htm.
Задание-инструкция по разработке собственного интеллектуального облачного Эйдос-приложения: http://lc.kubagro.ru/aidos/How_to_make_your_own_cloud_Eidos-application.pdf.
Если в гиперссылках ниже заменить имя файла описания readme.pdf на readme.docx, readme.doc, или на файл исходных данных Inp_data.xlsx или Inp_data.xls, то этот файл загрузится, если он есть в облаке.

""" # Save HTML header # with open(output_file, 'w', encoding='utf-8') as f: with open(output_file, 'w', encoding='utf-8', errors='replace') as f: f.write(header) # Write table headers headers = table.field_names for header in headers: if header == 'APPL_NAME': f.write( f'') # Apply special class for APPL_NAME header else: f.write(f'') f.write('') # Write table rows for record in table: f.write('') for field, value in record.items(): if field == 'E_MAIL': f.write(f'') # Create hyperlink for E_MAIL field elif field == 'APPL_NAME': f.write(f'') # Apply special class for APPL_NAME column else: f.write(f'') f.write('') f.write('
{header}{header}
{value}{value}{value}
') def main(): # DBF file name input_file = "WebAppls.dbf" # Determine the path and name of the HTML file to save output_file = os.path.splitext(input_file)[0] + ".html" # Convert DBF to HTML dbf_to_html(input_file, output_file) if __name__ == "__main__": main() def _5_11py_results(): # ################################################################################################################### # _5_11py_results.py. (c°) проф.Е.В.Луценко. Программа вывода результатов тестирования по АСК-анализу и системе Эйдос # ################################################################################################################### URL_Eidos_cloud = "http://lc.kubagro.ru" # Адрес Эйдос-облака в Internet FTP_access_to_the_Eidos_cloud() # print("Это функция 8") # -*- coding: utf-8 -*- def is_internet_available(): try: socket.create_connection(("www.google.com", 80)) return True except OSError: return False def is_ftp_available(host, user, password): try: ftp = ftplib.FTP(host, user, password) ftp.quit() return True except ftplib.all_errors as e: print(f"Error: {e}") return False def download_file(ftp, filename): with open(filename, 'wb') as file: field_names = ', '.join(f'f{i}' for i in range(1, 28)) file.write(f"{field_names}\n".encode()) ftp.retrbinary('RETR ' + filename, file.write) def add_field_names(file_path): data = pd.read_csv(file_path, delimiter=',') if 'f1' not in data.columns: field_names = ', '.join(f'f{i}' for i in range(1, len(data.columns) + 1)) with open(file_path, 'a') as file: file.write(f"{field_names}\n") class DisplayTableWindow(QMainWindow): def __init__(self, data): super().__init__() self.data = data self.setWindowTitle("Результаты тестирования по АСК-анализу и системе \"Эйдос\" в мире") self.setGeometry(100, 100, 800, 600) # Получаем абсолютный путь к иконке icon_path = os.path.join(sys._MEIPASS, '_Aidos.ico') if getattr(sys, 'frozen', False) else os.path.join( os.path.dirname(os.path.abspath(__file__)), '_Aidos.ico') self.setWindowIcon(QIcon(icon_path)) self.table_widget = QTableWidget() self.table_widget.setEditTriggers(QTableWidget.NoEditTriggers) self.setup_table(data) self.scroll_area = QScrollArea(self) self.scroll_area.setWidgetResizable(True) self.scroll_area.setWidget(self.table_widget) self.central_widget = QWidget() self.central_layout = QVBoxLayout(self.central_widget) self.central_layout.addWidget(self.scroll_area) self.search_button = QPushButton("Искать контент в строке", self.central_widget) self.search_button.clicked.connect(self.search_content) self.show_card_button = QPushButton("Показать карточку тестируемого", self.central_widget) self.show_card_button.clicked.connect(self.show_card) self.filter_button = QPushButton("Установить фильтр", self.central_widget) self.filter_button.clicked.connect(self.set_filter) self.visualize_button = QPushButton("Картографическая визуализация отфильтрованных данных", self.central_widget) self.visualize_button.clicked.connect(self.visualize_data) self.button_layout = QHBoxLayout() self.button_layout.addWidget(self.search_button) self.button_layout.addWidget(self.show_card_button) self.button_layout.addWidget(self.filter_button) self.button_layout.addWidget(self.visualize_button) self.central_layout.addLayout(self.button_layout) self.central_widget.setLayout(self.central_layout) self.setCentralWidget(self.central_widget) self.search_records_window = None self.filter_query = None def setup_table(self, data): self.table_widget.setRowCount(data.shape[0]) self.table_widget.setColumnCount(data.shape[1]) self.table_widget.setHorizontalHeaderLabels(data.columns) for i in range(data.shape[0]): for j in range(data.shape[1]): item = QTableWidgetItem(str(data.iloc[i, j])) self.table_widget.setItem(i, j, item) self.table_widget.resizeColumnsToContents() def search_content(self): search_query, ok = QInputDialog.getText(self, 'Поиск контента', 'Введите контент для поиска:') if ok: if search_query.strip(): if self.search_content_in_rows(search_query): QMessageBox.information(self, "Поиск", "Строка найдена.") else: QMessageBox.information(self, "Поиск", "Совпадений не найдено.") else: QMessageBox.information(self, "Поиск", "Введите контент для поиска.") def show_card(self): selected_row_index = self.table_widget.currentRow() if selected_row_index != -1: row_data = [self.table_widget.item(selected_row_index, j).text() for j in range(self.table_widget.columnCount())] show_card_window(self.data.columns, row_data) def set_filter(self): self.filter_query, ok = QInputDialog.getText(self, 'Фильтр', 'Введите контент для фильтра:') if ok: self.filter_rows() def filter_rows(self): try: if self.filter_query.strip(): filtered_rows = self.data[ self.data.apply( lambda row: any(str(cell).lower().find(self.filter_query.lower()) != -1 for cell in row), axis=1)] else: filtered_rows = self.data.copy() self.table_widget.setRowCount(filtered_rows.shape[0]) self.setup_table(filtered_rows) filter_file_name = "test_strings_5_11_filter.txt" filtered_rows.to_csv(filter_file_name, index=False, header=False) except Exception as e: print(f"Error during filtering: {e}") self.show_error_message("Ошибка при фильтрации данных") def visualize_data(self): self.upload_filtered_data_to_ftp("test_strings_5_11_filter.txt") self.launch_php_visualization() def upload_filtered_data_to_ftp(self, file_name): URL_Eidos_cloud = "public_html" FTP_access_to_the_Eidos_cloud() with ftplib.FTP(ftp_host, ftp_user, ftp_pass) as ftp: ftp.cwd(URL_Eidos_cloud) with open(file_name, 'rb') as file: ftp.storbinary('STOR ' + file_name, file) def launch_php_visualization(self): php_file_name = "http://lc.kubagro.ru/map_5_11_filter.php" webbrowser.open(php_file_name) def search_content_in_rows(self, content): current_row = self.table_widget.currentRow() current_column = self.table_widget.currentColumn() for row in range(current_row, self.table_widget.rowCount()): for column in range(current_column if row == current_row else 0, self.table_widget.columnCount()): item = self.table_widget.item(row, column) if item and content.lower() in item.text().lower(): self.table_widget.setCurrentCell(row, column) self.table_widget.setFocus() return True return False def show_error_message(self, message): QMessageBox.critical(self, "Ошибка", message) def show_card_window(field_names, row_data): try: field_descriptions = { 'f1': 'Дата формирования записи', 'f2': 'Время формирования записи', 'f3': 'IP-адрес тестируемого', 'f4': 'Домен', 'f5': 'Страна', 'f6': 'Краткое условное наименование региона', 'f7': 'Информация о тестируемом и его результате на английском языке', 'f8': 'Город', 'f9': 'Почтовый индекс', 'f10': 'Часовой пояс', 'f11': 'Географическая широта, определенная по IP-адресу', 'f12': 'Географическая долгота, определенная по IP-адресу', 'f13': 'nan', 'f14': 'Провайдер', 'f15': 'Наименование сети', 'f16': 'nan', 'f17': 'Провайдер', 'f18': 'nan', 'f19': 'nan', 'f20': 'nan', 'f21': 'Фамилия, имя, отчество тестируемого, номер группы и вуз', 'f22': 'Дата и время начала тестирования', 'f23': 'Дата и время окончания тестирования', 'f24': 'Продолжительность тестирования', 'f25': 'Среднее время на один ответ', 'f26': 'Процент верных ответов', 'f27': 'Итоговая оценка в 5-бальной шкале', } card_window = QMessageBox() card_window.setWindowTitle("Карточка записи") # Получаем абсолютный путь к иконке icon_path = os.path.join(sys._MEIPASS, '_Aidos.ico') if getattr(sys, 'frozen', False) else os.path.join( os.path.dirname(os.path.abspath(__file__)), '_Aidos.ico') card_window.setWindowIcon(QIcon(icon_path)) card_window.setGeometry(100, 100, 1800, 400) # Используем field_descriptions для отображения смысла полей text = "\n".join([f"{field}: {field_descriptions[field.strip()]}: {row_data[i]}" for i, field in enumerate(field_names) if row_data[i].lower() != 'nan']) card_window.setText(text.replace('\n', '
') + '
') # Оценки цветом grade_index = field_names.index('f27') if 'f27' in field_names else -1 if grade_index != -1: grade = int(row_data[grade_index]) if grade == 2: card_window.setStyleSheet("QLabel { color : black; }") elif grade == 3: card_window.setStyleSheet("QLabel { color : brown; }") elif grade == 4: card_window.setStyleSheet("QLabel { color : blue; }") elif grade == 5: card_window.setStyleSheet("QLabel { color : red; }") card_window.exec_() except Exception as e: print(f"Error in show_card_window: {e}") def main(): URL_Eidos_cloud = "public_html" FTP_access_to_the_Eidos_cloud() file_name = "test_strings_5_11.txt" if not is_internet_available(): QMessageBox.critical(None, "Ошибка", "Нет доступа к интернету. Пожалуйста, проверьте подключение.") return if not is_ftp_available(ftp_host, ftp_user, ftp_pass): QMessageBox.critical(None, "Ошибка", "Нет доступа к FTP серверу. Пожалуйста, проверьте настройки.") return try: with ftplib.FTP(ftp_host, ftp_user, ftp_pass) as ftp: ftp.cwd(URL_Eidos_cloud) download_file(ftp, file_name) add_field_names(file_name) with warnings.catch_warnings(): warnings.simplefilter("ignore", category=FutureWarning) data = pd.read_csv(file_name, delimiter=',') app = QApplication([]) display_table_window = DisplayTableWindow(data) display_table_window.show() app.exec_() except ftplib.error_perm as e: QMessageBox.critical(None, "Ошибка FTP", f"Ошибка при изменении директории на FTP сервере: {e}") print(f"FTP Error: {e}") if __name__ == "__main__": main() ####################################################################################### # _3_5py(). СИНТЕЗ НЕЙРОСЕТЕВЫХ МОДЕЛЕЙ ПИТОН НА ОСНОВЕ ОБУЧАЮЩЕЙ ВЫБОРКИ СИСТЕМЫ ЭЙДОС ####################################################################################### def _3_5py(): def get_model_info(): try: file_path = os.path.abspath('Appls.dbf') with DBF(file_path, encoding="cp866") as table: records = list(table) for record in records: if record['BY_DEFAULT'].strip(): name_appl = record['NAME_APPL'].strip() model_db_path = record['PATH_APPL'].strip() print(f"Model database path found: {model_db_path}") return model_db_path except Exception as e: print(f"Error in get_model_info: {e}") return None class ModelMatrixGenerator(QMainWindow): def __init__(self): super().__init__() self.setWindowTitle('Режим 3_5py: "Создание нейросетевых Эйдос-моделей"') self.setGeometry(100, 100, 480, 300) self.central_widget = QWidget() self.setCentralWidget(self.central_widget) self.layout = QVBoxLayout() self.central_widget.setLayout(self.layout) self.status_label = QLabel("", self) self.layout.insertWidget(0, self.status_label) self.df_obizag = None self.df_obkcl = None self.df_obikpr = None self.load_data() script_dir = os.path.dirname(__file__) icon_path = os.path.join(script_dir, '_Aidos.ico') self.setWindowIcon(QIcon(icon_path)) self.model_type_message = QLabel("Задайте типы нейронных сетей для генерации:", self) self.layout.addWidget(self.model_type_message) self.select_all_checkbox = QCheckBox("Все нейросети", self) self.select_all_checkbox.stateChanged.connect(self.select_all_models) self.layout.addWidget(self.select_all_checkbox) self.model_type_checkboxes = [] model_types = [ "1. ABS - Нейронная сеть прямого распространения (FFNN)", "2. PRC1 - Сверточная нейронная сеть (CNN)", "3. PRC2 - Рекуррентная нейронная сеть (RNN)", "4. INF1 - Сеть LSTM", "5. INF2 - Сеть GRU", "6. INF3 - Сеть с архитектурой ResNet", "7. INF4 - Сеть с архитектурой Inception", "8. INF5 - Сеть с архитектурой VGG", "9. INF6 - Сеть с архитектурой MobileNet", "10. INF7 - Сеть с архитектурой DenseNet" ] for model_type in model_types: checkbox = QCheckBox(model_type, self) checkbox.setChecked(True) self.layout.addWidget(checkbox) self.model_type_checkboxes.append(checkbox) self.help_button = QPushButton("Помощь", self) self.help_button.clicked.connect(self.show_help_dialog) self.layout.addWidget(self.help_button) self.generate_button = QPushButton("Создать заданные нейросетевые Эйдос-модели", self) self.generate_button.clicked.connect(self.generate_matrices) self.layout.addWidget(self.generate_button) self.progress_bar = QProgressBar(self) self.progress_bar.setAlignment(Qt.AlignCenter) self.layout.addWidget(self.progress_bar) self.status_message = QLabel("", self) self.layout.addWidget(self.status_message) self.ok_button = QPushButton("Завершить", self) self.ok_button.clicked.connect(self.close) self.ok_button.setVisible(False) self.layout.addWidget(self.ok_button) self.adjust_progress_bar_width() def load_data(self): try: self.model_folder_path = get_model_info() print(f"Model folder path: {self.model_folder_path}") if self.model_folder_path is None: raise FileNotFoundError("Путь к папке с данными не найден") obizag_path = os.path.join(self.model_folder_path, 'Obi_Zag.dbf') obkcl_path = os.path.join(self.model_folder_path, 'ObI_Kcl.dbf') obikpr_path = os.path.join(self.model_folder_path, 'Obi_Kpr.dbf') if not os.path.exists(obizag_path): raise FileNotFoundError(f"Файл не найден: {obizag_path}") if not os.path.exists(obkcl_path): raise FileNotFoundError(f"Файл не найден: {obkcl_path}") if not os.path.exists(obikpr_path): raise FileNotFoundError(f"Файл не найден: {obikpr_path}") self.df_obizag = pd.DataFrame(iter(DBF(obizag_path, encoding='cp866'))) self.df_obkcl = pd.DataFrame(iter(DBF(obkcl_path, encoding='cp866'))) self.df_obikpr = pd.DataFrame(iter(DBF(obikpr_path, encoding='cp866'))) print("DataFrames successfully loaded:") if not self.df_obizag.empty: print(f"df_obizag: {self.df_obizag.head()}") if not self.df_obkcl.empty: print(f"df_obkcl: {self.df_obkcl.head()}") if not self.df_obikpr.empty: print(f"df_obikpr: {self.df_obikpr.head()}") if self.df_obizag.empty: raise ValueError(f"Файл данных пуст: {obizag_path}") if self.df_obkcl.empty: raise ValueError(f"Файл данных пуст: {obkcl_path}") if self.df_obikpr.empty: raise ValueError(f"Файл данных пуст: {obikpr_path}") self.status_label.setText("Обучающая выборка успешно загружена!") except Exception as e: self.status_label.setText(f"Ошибка загрузки обучающей выборки: {str(e)}") print(f"Error in load_data: {e}") def Numb_cls_atr(self, model_folder_path): try: classes_dbf_path = os.path.join(model_folder_path, 'Classes.dbf') with DBF(classes_dbf_path, encoding='cp866') as classes_table: class_names = [f"{record['KOD_CLS']}-{record['NAME_CLS']}" for record in classes_table] N_Cls = len(class_names) attributes_dbf_path = os.path.join(model_folder_path, 'Attributes.dbf') with DBF(attributes_dbf_path, encoding='cp866') as attributes_table: attribute_names = [record['NAME_ATR'] for record in attributes_table] N_Atr = len(attribute_names) return N_Cls, N_Atr, class_names, attribute_names except Exception as e: print(f"Error in Numb_cls_atr: {e}") return None, None, [], [] def create_ffnn(self, model_folder_path): N_Cls, N_Atr, class_names, attribute_names = self.Numb_cls_atr(self.model_folder_path) model = nn.Sequential( nn.Linear(N_Atr, N_Cls), nn.Softmax(dim=1) ) print("FFNN создана") return model def prepare_data(self): X = [] Y = [] for index, row in self.df_obizag.iterrows(): kod_obj = row['KOD_OBJ'] obkcl_rows = self.df_obkcl[self.df_obkcl['KOD_OBJ'] == kod_obj] obikpr_rows = self.df_obikpr[self.df_obikpr['KOD_OBJ'] == kod_obj] if obkcl_rows.empty or obikpr_rows.empty: continue for obkcl_row in obkcl_rows.itertuples(index=False): for obikpr_row in obikpr_rows.itertuples(index=False): features = [] for feature_column in ['ATR1', 'ATR2', 'ATR3', 'ATR4', 'ATR5', 'ATR6', 'ATR7']: feature_value = getattr(obikpr_row, feature_column) if pd.notna(feature_value): features.append(feature_value) class_values = [] for class_column in ['CLS1', 'CLS2', 'CLS3', 'CLS4']: class_value = getattr(obkcl_row, class_column) if pd.notna(class_value): class_values.append(class_value) if features and class_values: X.append(features) Y.append(class_values[0]) if not X or not Y: raise ValueError("Нет доступных данных для подготовки") X = np.array(X, dtype=object) # Ensure homogeneous shape max_len = max(len(features) for features in X) X = np.array([np.pad(features, (0, max_len - len(features)), constant_values=0) for features in X]) Y = np.array(Y) return X, Y def generate_matrices(self): self.progress_bar.setValue(0) try: self.status_message.setText("Инициализация генерации матриц данных...") self.status_message.repaint() model_folder_path = get_model_info() if model_folder_path is None: raise FileNotFoundError("Путь к модели не найден") selected_model_types = [ checkbox.text().split(' ')[0] for checkbox in self.model_type_checkboxes if checkbox.isChecked() ] if not selected_model_types: raise ValueError("Не выбраны типы нейросетей для генерации") X, Y = self.prepare_data() for model_type in selected_model_types: if model_type == "1.": model = self.create_ffnn(model_folder_path) print("FFNN создана") elif model_type == "2.": print("Создание CNN") elif model_type == "3.": print("Создание RNN") elif model_type.startswith("4.") or model_type.startswith("5.") or model_type.startswith( "6.") or model_type.startswith("7.") or model_type.startswith( "8.") or model_type.startswith("9.") or model_type.startswith("10."): print(f"Создание модели: {model_type}") else: print(f"Неизвестный тип модели: {model_type}") self.progress_bar.setValue(self.progress_bar.value() + 10) self.status_message.setText("Генерация матриц данных завершена") self.ok_button.setVisible(True) except Exception as e: self.status_message.setText(f"Ошибка генерации матриц данных: {str(e)}") print(f"Error in generate_matrices: {e}") self.ok_button.setVisible(False) def select_all_models(self, state): for checkbox in self.model_type_checkboxes: checkbox.setChecked(state == Qt.Checked) def show_help_dialog(self): help_dialog = QDialog(self) help_dialog.setWindowTitle('"Помощь режима 3_5py: "Синтез нейросетевых Эйдос-моделей"') help_dialog.setGeometry(100, 100, 480, 300) help_layout = QVBoxLayout() help_label = QLabel( "Для создания заданных нейросетевых Эйдос-моделей:\n" "1. Выберите типы моделей, которые вы хотите создать.\n" "2. Нажмите 'Создать заданные нейросетевые Эйдос-модели'.\n" "3. Дождитесь завершения процесса генерации моделей.\n" "4. Нажмите 'Завершить' для выхода.\n\n" "НЕЙРОСЕТЕВЫЕ ЭЙДОС-МОДЕЛИ:\n\n" "1. ABS - Нейронная сеть прямого распространения (Feedforward Neural Network, FFNN)\n" " FFNN являются базовым типом искусственной нейронной сети. В такой сети информация\n" " проходит только в одном направлении - от входов к выходам через скрытые слои.\n\n" "2. PRC1 - Сверточная нейронная сеть (Convolutional Neural Network, CNN)\n" " CNN применяются для обработки изображений и видео, классификации объектов\n" " и анализа временных рядов. Основное отличие от других сетей - наличие\n" " сверточных слоев, которые автоматически выделяют важные признаки из данных.\n\n" "3. PRC2 - Рекуррентная нейронная сеть (Recurrent Neural Network, RNN)\n" " RNN широко используются для анализа последовательных данных, таких как текст,\n" " речь и временные ряды. В отличие от FFNN, RNN имеют внутренние петли,\n" " позволяющие информации сохраняться между элементами последовательности.\n\n" "4. INF1 - Сеть LSTM\n" " Долгосрочная краткосрочная память (Long Short-Term Memory, LSTM) - это\n" " тип RNN, способный обучаться долгосрочным зависимостям. LSTM были разработаны\n" " для решения проблемы исчезающего градиента, характерной для традиционных RNN.\n\n" "5. INF2 - Сеть GRU\n" " GRU (Gated Recurrent Unit) - это упрощенная версия LSTM, которая также\n" " решает проблему исчезающего градиента, но имеет меньше параметров,\n" " что делает её вычислительно более эффективной.\n\n" "6. INF3 - Сеть с архитектурой ResNet\n" " Резидуальные сети (Residual Networks, ResNet) используют пропускные соединения\n" " или <прямые пути> для пропускания градиентов напрямую через сеть. Это позволяет\n" " обучать очень глубокие нейронные сети.\n\n" "7. INF4 - Сеть с архитектурой Inception\n" " Архитектура Inception использует концепцию <сетей внутри сети> для улучшения\n" " точности и производительности. Inception-сети применяются для классификации\n" " изображений и обнаружения объектов.\n\n" "8. INF5 - Сеть с архитектурой VGG\n" " VGG (Visual Geometry Group) сети характеризуются использованием очень глубоких\n" " сетей с небольшими (3x3) сверточными фильтрами. Они демонстрируют высокую\n" " производительность в задачах распознавания изображений.\n\n" "9. INF6 - Сеть с архитектурой MobileNet\n" " MobileNet разработаны для работы на мобильных и встроенных устройствах.\n" " Эти сети используют глубинные сверточные слои для уменьшения числа параметров\n" " и вычислительных затрат, сохраняя при этом высокую точность.\n\n" "10. INF7 - Сеть с архитектурой DenseNet\n" " DenseNet (Densely Connected Convolutional Networks) отличаются тем, что каждый\n" " слой получает входные данные со всех предыдущих слоев, что способствует\n" " улучшению распространения градиента и более эффективному использованию параметров.", help_dialog ) help_layout.addWidget(help_label) ok_button = QPushButton("Закрыть помощь", help_dialog) ok_button.clicked.connect(help_dialog.accept) help_layout.addWidget(ok_button) help_dialog.setLayout(help_layout) help_dialog.exec_() def adjust_progress_bar_width(self): progress_bar_width = self.progress_bar.width() font_metrics = self.progress_bar.fontMetrics() text_width = font_metrics.width(self.progress_bar.text()) if text_width > progress_bar_width: self.progress_bar.setFixedWidth(text_width + 10) app = QApplication(sys.argv) window = ModelMatrixGenerator() window.show() sys.exit(app.exec_()) def _4221py(): ###################################################################################################################### # _4221py.py. 4.2.2.1. Расчет матриц сходства, кластеров и конструктов классов в Питоне. ###################################################################################################################### # Функция для создания и автоматического обновления текста в GUI для кластеризации def create_or_update_gui(root, label, model_name, progress, total_models, current_model): if root is None or label is None: raise ValueError("root и label не должны быть None") root.title(f"Преобразование БД модели {model_name} из txt файла в xlsx и расчет матрицы сходства классов") label.config( text=f"Преобразование БД модели {model_name} из txt файла в xlsx и расчет матрицы сходства классов") progress['value'] = current_model / total_models * 100 root.update() # Инициализация GUI root = Tk() root.geometry("550x130") root.title('4.2.2.1. Расчет матриц сходства, кластеров и конструктов классов в Питоне') root.iconbitmap("_Aidos.ico") label = Label(root, text="") label.pack(pady=20) progress = ttk.Progressbar(root, orient="horizontal", length=450, mode="determinate") progress.pack(pady=10) # Получить абсолютный путь к базе данных DBF Appls.dbf file_path = os.path.abspath('Appls.dbf') # print(file_path) # Открыть файл DBF и получить все записи из него with DBF(file_path, encoding='cp866') as table: name_appl = None dbf_folder = None for record in table: if record.get('BY_DEFAULT').strip(): dbf_folder = record.get('PATH_APPL').strip() name_appl = record.get('NAME_APPL').strip() break if not dbf_folder or not name_appl: raise ValueError("Не удалось найти базовый путь или имя приложения") # Массив с данными criteria = [ "ABS - частный критерий: количество встреч сочетаний: \"класс-признак\" у объектов обуч.выборки", "PRC1 - частный критерий: усл. вероятность i-го признака среди признаков объектов j-го класса", "PRC2 - частный критерий: условная вероятность i-го признака у объектов j-го класса", "INF1 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC1", "INF2 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC2", "INF3 - частный критерий: Xи-квадрат, разности между фактическими и ожидаемыми абс.частотами", "INF4 - частный критерий: ROI (Return On Investment); вероятности из PRC1", "INF5 - частный критерий: ROI (Return On Investment); вероятности из PRC2", "INF6 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC1", "INF7 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC2" ] total_models = len(criteria) # Формирование данных для записи в CSV файл для каждой модели for index, model in enumerate(criteria, start=1): data = [ f"Наименование приложения: #{name_appl}", f"Наименование модели: #{model}", f"Код модели: #{index}" ] # Определить путь к файлу CSV в указанной папке csv_file_path = os.path.join(dbf_folder, "4221Param.CSV") # Записать данные в CSV файл (создать или перезаписать файл) with open(csv_file_path, mode='w', encoding='utf-8') as file: for line in data: file.write(line + '\n') # Создание xlsx-файла текущей модели и ее матрицы сходства with open(csv_file_path, 'r', encoding='utf-8') as param_file: param_file_content = param_file.readlines() model_code = None for line in param_file_content: if 'Код модели' in line: model_code = line.split('#')[1].strip() break if model_code is None: raise ValueError("Код модели не найден в файле 4221Param.CSV") Ar_Model = { "1": "Abs", "2": "Prc1", "3": "Prc2", "4": "Inf1", "5": "Inf2", "6": "Inf3", "7": "Inf4", "8": "Inf5", "9": "Inf6", "10": "Inf7" } model_name = Ar_Model.get(model_code) create_or_update_gui(root, label, model_name, progress, total_models, index) if model_name is None: raise ValueError(f"Модель с кодом {model_code} не найдена в Ar_Model") wb = Workbook() ws = wb.active ws.title = model_name # Определение пути к файлу Attributes.dbf Attributes_dbf_path = os.path.join(dbf_folder, 'Attributes.dbf') # Инициализация массивов для хранения данных по полям kod_atr_list = [] name_atr_list = [] kod_pr_values = [] # Инициализация пустого списка max_name_atr_width = 0 num_Attributes = 0 # Открытие и чтение таблицы Attributes.dbf with DBF(Attributes_dbf_path, encoding='cp866') as Attributes_table: for record in Attributes_table: kod_atr_list.append(record['KOD_ATR']) name_atr = record['NAME_ATR'].rstrip() # Удаление концевых пробелов name_atr_list.append(name_atr) # Обновление максимальной ширины значения поля name_cls if len(name_atr) > max_name_atr_width: max_name_atr_width = len(name_atr) num_Attributes += 1 classes_dbf_path = os.path.join(dbf_folder, 'Classes.dbf') with DBF(classes_dbf_path, encoding='cp866') as classes_table: N_Cls = sum(1 for _ in classes_table) field_names = ['kod_pr', 'name'] class_info = [] for record in classes_table: kod_cls = record['KOD_CLS'] name_cls = record['NAME_CLS'].strip() # убираем концевые пробелы class_info.append(f"{kod_cls}-{name_cls}") field_names.extend(class_info) # Добавляем имена классов в field_names field_names.extend(['summa', 'sredn', 'disp']) ws.append(field_names) for col in ws.iter_cols(max_col=len(field_names)): for cell in col: cell.alignment = Alignment(horizontal='center', vertical='bottom', text_rotation=90) # Нумерация полей cls с 1 aInfStruct = [['kod_pr', 'N', 15, 0], ['name', 'C', max_name_atr_width, 0]] aInfStruct.extend( [[f"cls{i}", 'N', 19, 1] for i in range(1, N_Cls + 1)]) # Изменение нумерации полей cls aInfStruct.extend([['summa', 'N', 19, 0], ['sredn', 'N', 19, 7], ['disp', 'N', 19, 7]]) excel_file_path = os.path.join(dbf_folder, f'{model_name}.xlsx') model_txt_file_path = os.path.join(dbf_folder, f'{model_name}.txt') with open(model_txt_file_path, 'r', encoding='cp866') as model_txt_file: lines = model_txt_file.read().splitlines() for row_idx, line in enumerate(lines, start=2): values = [] start_pos = 0 for field_info in aInfStruct: field_length = field_info[2] field_value = line[start_pos:start_pos + field_length].strip() if field_info[0] == 'kod_pr': kod_pr_values.append(field_value) else: if field_info[0] != 'name': if field_info[1] == 'N': try: field_value = float(field_value.replace(' ', '0').replace(',', '.')) except ValueError: field_value = 0 values.append(field_value) start_pos += field_length for col_idx, value in enumerate(values, start=1): ws.cell(row=row_idx, column=col_idx).value = value if 'Sheet' in wb.sheetnames: sheet = wb['Sheet'] wb.remove(sheet) try: wb.save(excel_file_path) except PermissionError: print( "Ошибка: Файл Excel используется другой программой.") # Используйте messagebox, если требуется # ФОРМАТИРОВАНИЕ XLSX ФАЙЛА МОДЕЛИ def align_columns(excel_file_path): # Открытие существующего файла Excel wb = load_workbook(excel_file_path) ws = wb.active # Минимизация ширины первой колонки по реальным данным (исключая заголовок) max_length_first_col = max(len(str(cell.value)) for cell in ws['A'][1:]) for cell in ws['A']: cell.alignment = Alignment(horizontal='left', vertical='bottom') ws.column_dimensions['A'].width = max_length_first_col + 1 # Выравнивание второй колонки по левому краю max_length_second_col = max(len(str(cell.value)) for cell in ws['B']) for cell in ws['B']: cell.alignment = Alignment(horizontal='left', vertical='bottom') ws.column_dimensions[cell.column_letter].width = max_length_second_col + 1 # Выравнивание остальных колонок for col in ws.iter_cols(min_col=3, max_col=ws.max_column, min_row=1, max_row=1): for cell in col: cell.alignment = Alignment(horizontal='center', vertical='bottom', text_rotation=90) for col in ws.iter_cols(min_col=3, max_col=ws.max_column, min_row=2, max_row=ws.max_row): max_length_other_cols = max(len(str(cell.value)) for cell in col) for cell in col: cell.alignment = Alignment(horizontal='center', vertical='bottom') ws.column_dimensions[cell.column_letter].width = max_length_other_cols + 1 # Выделение жирным и выравнивание первой строки for cell in ws[1]: cell.alignment = Alignment(horizontal='center', vertical='bottom', text_rotation=90) # Сохранение изменений wb.save(excel_file_path) align_columns(excel_file_path) # РАСЧЕТ И ЗАПИСЬ XLSX МАТРИЦЫ СХОДСТВА КЛАССОВ data = pd.read_excel(excel_file_path) # Исключаем строки: 1-ю (в Питоне она считается нулевой) и последние 4 # И исключаем колонки: 2 первые и 3 последние data = data.iloc[:-4, 2:-3] # Вычисление корреляции Пирсона между колонками correlation_matrix = data.corr() # Замена нечисловых значений на 0 correlation_matrix = correlation_matrix.apply(pd.to_numeric, errors='coerce').fillna(0) # Умножение всех значений матрицы на 100 correlation_matrix *= 100 # Создание нового файла Excel с матрицей сходства output_file_path = os.path.join(os.path.dirname(excel_file_path), f"Classes_similarity_matrix_{model_name}.xlsx") try: # Запись данных в Excel с использованием openpyxl для форматирования with pd.ExcelWriter(output_file_path, engine='openpyxl') as writer: correlation_matrix.to_excel(writer, index=True, sheet_name='Correlation') # Получаем объект книги Excel wb = writer.book ws = wb['Correlation'] # Устанавливаем выравнивание для наименований колонок for cell in ws[1]: cell.alignment = Alignment(horizontal='center', vertical='bottom') cell.font = Font(bold=True) # Устанавливаем обычный шрифт для всех ячеек for row in ws.iter_rows(): for cell in row: cell.font = Font(name='Arial', size=10) # Создаем новый лист ws_new = wb.create_sheet(title='Summary') # Вставляем текст заголовка в новый лист title_text = ( f"МАТРИЦА СХОДСТВА КЛАССОВ\n" f"(С°) Персональная интеллектуальная on-line среда 'Эйдос'\n" f"Приложение: {name_appl}\n" f"Модель: {model}\n" f"Дата и время создания формы: {pd.Timestamp.now()}\n" ) for i, line in enumerate(title_text.split('\n')): cell = ws_new.cell(row=i + 1, column=1, value=line) cell.font = Font(bold=True) # Переносим наименования строк и столбцов с форматированием for col_idx, col_name in enumerate(correlation_matrix.columns): cell = ws_new.cell(row=6, column=col_idx + 2, value=col_name) cell.alignment = Alignment(horizontal='center', vertical='bottom', text_rotation=90) for row_idx, row_name in enumerate(correlation_matrix.index): cell = ws_new.cell(row=row_idx + 7, column=1, value=row_name) cell.alignment = Alignment(horizontal='left', vertical='bottom') # Переносим матрицу сходства на новый лист со смещением вниз на 6 строк for row_idx, row in enumerate(correlation_matrix.values): for col_idx, value in enumerate(row): ws_new.cell(row=row_idx + 7, column=col_idx + 2, value=value) # Размеры первой колонки max_length = max(len(str(cell.value)) for row in ws_new.iter_rows(min_row=7, max_row=ws_new.max_row, min_col=1, max_col=1) for cell in row) ws_new.column_dimensions['A'].width = max_length + 8 # Увеличиваем ширину на 8 символов для запаса # Удаляем старый лист del wb['Correlation'] # Сохраняем изменения wb.save(output_file_path) except PermissionError: # Если файл занят другим приложением, выводим сообщение об ошибке в GUI окне root = tk.Tk() root.withdraw() # Скрыть основное окно messagebox.showerror("Ошибка", f"Файл {output_file_path} занят другим приложением. Закройте его и повторите попытку.") root.destroy() # Закрыть GUI окно после закрытия сообщения об ошибке # СОЗДАНИЕ XLSX МАТРИЦЫ СХОДСТВА КЛАССОВ ДЛЯ КОНВЕРТАЦИИ В DBF ФАЙЛ МАТРИЦЫ СХОДСТВА # Загрузка данных из базы данных Classes.dbf с использованием dbfread и кодировки cp866 with DBF(classes_dbf_path, encoding='cp866') as classes_table: classes = list(classes_table) class_df = pd.DataFrame(classes) # Создание нового файла Excel с матрицей сходства output_file_path = os.path.join(os.path.dirname(excel_file_path), f"SxodCls{model_name}.xlsx") # Подготовка данных для записи в Excel columns = ['kod_cls', 'kod_clsc', 'name_cls'] + [f'n{i + 1}' for i in range(len(class_df))] data = [] # Заполнение данными из базы данных и корреляционной матрицы for idx, class_row in class_df.iterrows(): row = [class_row['KOD_CLS'], class_row['KOD_CLSC'], class_row['NAME_CLS']] + list( correlation_matrix.iloc[idx]) data.append(row) # Создание DataFrame для записи в Excel result_df = pd.DataFrame(data, columns=columns) # Запись данных в Excel с использованием openpyxl для форматирования with pd.ExcelWriter(output_file_path, engine='openpyxl') as writer: result_df.to_excel(writer, index=False, sheet_name='SimilarityMatrix') # Получаем объект книги Excel wb = writer.book ws = wb['SimilarityMatrix'] # Устанавливаем выравнивание для наименований колонок for cell in ws[1]: cell.alignment = Alignment(horizontal='center', vertical='bottom') cell.font = Font(bold=True) # Устанавливаем обычный шрифт для всех ячеек for row in ws.iter_rows(): for cell in row: cell.font = Font(name='Arial', size=10) # Выравнивание третьей колонки по левому краю max_length_third_col = max(len(str(cell.value)) for cell in ws['C']) for cell in ws['C']: cell.alignment = Alignment(horizontal='left', vertical='bottom') ws.column_dimensions[get_column_letter(cell.column)].width = max_length_third_col + 1 # Устанавливаем ширину колонок ws.column_dimensions['A'].width = 15 # kod_cls ws.column_dimensions['B'].width = 15 # kod_clsc ws.column_dimensions['C'].width = max_length_third_col # name_cls for i in range(4, len(columns) + 1): ws.column_dimensions[get_column_letter(i)].width = 19 # n1, n2, ..., n14 # Удаляем старый лист, если он существует if 'Correlation' in wb.sheetnames: del wb['Correlation'] # Сохраняем изменения wb.save(output_file_path) # СОЗДАЕМ DBF ФАЙЛ ДЛЯ МАТРИЦЫ СХОДСТВА КЛАССОВ В ТЕКУЩЕЙ МОДЕЛИ def calculate_checksum(file_path): sha256 = hashlib.sha256() with open(file_path, 'rb') as f: for byte_block in iter(lambda: f.read(4096), b''): sha256.update(byte_block) return sha256.hexdigest() # Получить абсолютный путь к файлу: Converter_xlsx_to_dbf.exe path_exe_Converter_xlsx_to_dbf = os.path.abspath('ConverterClust.exe') # Вычисление контрольной суммы expected_checksum = '4ff3487a448903163633e17988d7eac4523b183c3549281facff4d05c9ad38ce' # Укажите здесь реальную контрольную сумму из файла: checksum_error.txt # expected_checksum = '4ff3487a44890313633e17988d7eac4523b183c3549281facff4d05c9ad38ce' # Укажите здесь реальную контрольную сумму из файла: checksum_error.txt actual_checksum = calculate_checksum(path_exe_Converter_xlsx_to_dbf) # Проверка контрольной суммы if actual_checksum == expected_checksum: # Получить абсолютный путь к файлу: Converter_xlsx_to_dbf.txt path_txt_Converter_xlsx_to_dbf = os.path.abspath('Converter_xlsx_to_dbf.txt') # Открываем файл в режиме записи и записываем в него значение переменной with open(path_txt_Converter_xlsx_to_dbf, 'w') as file: file.write(output_file_path) # Запустить конвертер subprocess.run(path_exe_Converter_xlsx_to_dbf, stdout=subprocess.PIPE) # ЗАПУСТИТЬ КОНВЕРТОР else: print(f"Контрольная сумма не совпадает: {actual_checksum}. Исполняемый файл не будет запущен.") with open("checksum_error.txt", "w", encoding="utf-8") as file: # actual_checksum = "123456789" # Пример значения контрольной суммы file.write(f"Контрольная сумма не совпадает: {actual_checksum}. Исполняемый файл: ConverterClust.exe не был запущен.") print( f"xlsx матрица модели {model_name} и xlsx и dbf матрицы сходства классов и база конструктов успешно созданы.") # Поясняющий текст if actual_checksum == expected_checksum: message = f""" Расчет матриц сходства классов и конструктов классов успешно завершен! Матрицы сходства классов содержатся в папке текущего приложения: {dbf_folder} в следующих таблицах MS Excel, созданных на основе статистических и системно-когнитивных моделей: "Classes_similarity_matrix_Abs.xlsx", "Classes_similarity_matrix_Prc#.xlsx", #={{1,2}}, "Classes_similarity_matrix_Inf#.xlsx" (где: #={{1,2,3,4,5,6,7}}). Эти таблицы создаются в режиме 4.2.2.1, реализованном на Питоне, и уже отформатированы для включения в отчеты. Если использовался режим 4.2.2.1 на xBase++ то формируются файлы: "SxodClsAbs.xlsx", "SxodClsPrc#.xlsx", #={{1,2}}, "SxodClsInf#.xlsx", #={{1,2,3,4,5,6,7}}. Для преобразования dbf => xlsx можно использовать режим 5.12. В этом случае xlsx файлы рекомендуется еще немного их отформатировать. Наименования колонок в матрице сходства классов являются наименованиями классов, которые есть в каждой строке. Поэтому можно взять их из строк и вставить с транспонированием в строку наименований колонок, придав им вертикальную ориентацию и выровняв их по центру. Сходство дано в процентах, поэтому можно задать формат ячеек без десятичных знаков и отображать отрицательные значения красным цветом. Ширину колонок есть смысл минимизировать по реальным данным, а также сделать сетку в таблице. Режим 4.2.2.1, реализованный на Питоне, не только конвертирует выходные формы в xlsx и форматирует их для отчетов, но и работает значительно быстрее, чем реализованный на xBase++. """ else: message = f""" Контрольная сумма не совпадает: {actual_checksum}. Исполняемый файл: ConverterClust.exe не был запущен! Необходимо обратиться к разработчику проф.Е.В.Луценко или скачать актуальную версию системы Эйдос с сайта разработчика: http://lc.kubagro.ru/Installation_Eidos.php """ def show_custom_message(title, message): # Создаем новое окно message_window = tk.Toplevel(root) message_window.title(title) # Устанавливаем иконку icon_path = "_Aidos.ico" message_window.iconbitmap(icon_path) # Создаем текстовый виджет и скроллбар if actual_checksum == expected_checksum: text_widget = tk.Text(message_window, wrap="none", width=125, height=23) else: text_widget = tk.Text(message_window, wrap="none", width=125, height=10) scrollbar_y = tk.Scrollbar(message_window, orient="vertical", command=text_widget.yview) scrollbar_x = tk.Scrollbar(message_window, orient="horizontal", command=text_widget.xview) text_widget.configure(yscrollcommand=scrollbar_y.set, xscrollcommand=scrollbar_x.set) # Заполняем текстовый виджет сообщением text_widget.insert(tk.END, message) text_widget.config(state=tk.DISABLED) # Сделать текстовый виджет только для чтения # Создаем кнопку Ok ok_button = tk.Button(message_window, text="Ok", command=message_window.destroy, width=15, height=2) # Размещаем виджеты в окне text_widget.grid(row=0, column=0, sticky="nsew") scrollbar_y.grid(row=0, column=1, sticky="ns") scrollbar_x.grid(row=1, column=0, sticky="ew") ok_button.grid(row=2, column=0, columnspan=2, pady=10) # Настроить растягивание виджета message_window.grid_rowconfigure(0, weight=1) message_window.grid_columnconfigure(0, weight=1) # Установить размер и позицию окна по центру экрана message_window.update_idletasks() width = message_window.winfo_width() height = message_window.winfo_height() x = (message_window.winfo_screenwidth() // 2) - (width // 2) y = (message_window.winfo_screenheight() // 2) - (height // 2) message_window.geometry('{}x{}+{}+{}'.format(width, height, x, y)) # Дождаться закрытия окна message_window.grab_set() root.wait_window(message_window) # Показываем сообщение в зависимости от результата сравнения if actual_checksum == expected_checksum: show_custom_message("Процесс 4.2.2.1 успешно завершен", f" Все модели успешно преобразованы и сохранены в папке текущего приложения:\n {dbf_folder}.\n\n{message}") else: show_custom_message("Процесс 4.2.2.1 не завершен из-за нарушения целостности системы", f" Модели не преобразованы и не сохранены в папке текущего приложения:\n {dbf_folder}.\n\n{message}") root.destroy() root.mainloop() def _4321py(): ###################################################################################################################### # _4321py.py. 4.3.2.1. Расчет матриц сходства, кластеров и конструктов признаков в Питоне. ###################################################################################################################### # Функция для создания и автоматического обновления текста в GUI для кластеризации def create_or_update_gui(root, label, model_name, progress, total_models, current_model): if root is None or label is None: raise ValueError("root и label не должны быть None") root.title(f"Преобразование БД модели {model_name} из txt файла в xlsx и расчет матрицы сходства признаков") label.config( text=f"Преобразование БД модели {model_name} из txt файла в xlsx и расчет матрицы сходства признаков") progress['value'] = current_model / total_models * 100 root.update() # Инициализация GUI root = Tk() root.geometry("550x130") root.title('4.3.2.1. Расчет матриц сходства, кластеров и конструктов признаков в Питоне') root.iconbitmap("_Aidos.ico") label = Label(root, text="") label.pack(pady=20) progress = ttk.Progressbar(root, orient="horizontal", length=450, mode="determinate") progress.pack(pady=10) # Получить абсолютный путь к базе данных DBF Appls.dbf file_path = os.path.abspath('Appls.dbf') # print(file_path) # Открыть файл DBF и получить все записи из него with DBF(file_path, encoding='cp866') as table: name_appl = None dbf_folder = None for record in table: if record.get('BY_DEFAULT').strip(): dbf_folder = record.get('PATH_APPL').strip() name_appl = record.get('NAME_APPL').strip() break if not dbf_folder or not name_appl: raise ValueError("Не удалось найти базовый путь или имя приложения") # Массив с данными criteria = [ "ABS - частный критерий: количество встреч сочетаний: \"класс-признак\" у объектов обуч.выборки", "PRC1 - частный критерий: усл. вероятность i-го признака среди признаков объектов j-го класса", "PRC2 - частный критерий: условная вероятность i-го признака у объектов j-го класса", "INF1 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC1", "INF2 - частный критерий: количество знаний по А.Харкевичу; вероятности из PRC2", "INF3 - частный критерий: Xи-квадрат, разности между фактическими и ожидаемыми абс.частотами", "INF4 - частный критерий: ROI (Return On Investment); вероятности из PRC1", "INF5 - частный критерий: ROI (Return On Investment); вероятности из PRC2", "INF6 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC1", "INF7 - частный критерий: разн.усл.и безусл.вероятностей; вероятности из PRC2" ] total_models = len(criteria) # Формирование данных для записи в CSV файл для каждой модели for index, model in enumerate(criteria, start=1): data = [ f"Наименование приложения: #{name_appl}", f"Наименование модели: #{model}", f"Код модели: #{index}" ] # Определить путь к файлу CSV в указанной папке csv_file_path = os.path.join(dbf_folder, "4321Param.CSV") # Записать данные в CSV файл (создать или перезаписать файл) with open(csv_file_path, mode='w', encoding='utf-8') as file: for line in data: file.write(line + '\n') # Создание xlsx-файла текущей модели и ее матрицы сходства with open(csv_file_path, 'r', encoding='utf-8') as param_file: param_file_content = param_file.readlines() model_code = None for line in param_file_content: if 'Код модели' in line: model_code = line.split('#')[1].strip() break if model_code is None: raise ValueError("Код модели не найден в файле 4321Param.CSV") Ar_Model = { "1": "Abs", "2": "Prc1", "3": "Prc2", "4": "Inf1", "5": "Inf2", "6": "Inf3", "7": "Inf4", "8": "Inf5", "9": "Inf6", "10": "Inf7" } model_name = Ar_Model.get(model_code) create_or_update_gui(root, label, model_name, progress, total_models, index) if model_name is None: raise ValueError(f"Модель с кодом {model_code} не найдена в Ar_Model") wb = Workbook() ws = wb.active ws.title = model_name # Определение пути к файлу Attributes.dbf Attributes_dbf_path = os.path.join(dbf_folder, 'Attributes.dbf') # Инициализация массивов для хранения данных по полям kod_atr_list = [] name_atr_list = [] kod_pr_values = [] # Инициализация пустого списка max_name_atr_width = 0 num_Attributes = 0 # Открытие и чтение таблицы Attributes.dbf with DBF(Attributes_dbf_path, encoding='cp866') as Attributes_table: for record in Attributes_table: kod_atr_list.append(record['KOD_ATR']) name_atr = record['NAME_ATR'].rstrip() # Удаление концевых пробелов name_atr_list.append(name_atr) # Обновление максимальной ширины значения поля name_cls if len(name_atr) > max_name_atr_width: max_name_atr_width = len(name_atr) num_Attributes += 1 # print(f"Количество признаков: {num_Attributes}") classes_dbf_path = os.path.join(dbf_folder, 'Classes.dbf') with DBF(classes_dbf_path, encoding='cp866') as classes_table: N_Cls = sum(1 for _ in classes_table) field_names = ['kod_pr', 'name'] class_info = [] for record in classes_table: kod_cls = record['KOD_CLS'] name_cls = record['NAME_CLS'].strip() # убираем концевые пробелы class_info.append(f"{kod_cls}-{name_cls}") field_names.extend(class_info) # Добавляем имена классов в field_names field_names.extend(['summa', 'sredn', 'disp']) ws.append(field_names) for col in ws.iter_cols(max_col=len(field_names)): for cell in col: cell.alignment = Alignment(horizontal='center', vertical='bottom', text_rotation=90) # Нумерация полей cls с 1 aInfStruct = [['kod_pr', 'N', 15, 0], ['name', 'C', max_name_atr_width, 0]] aInfStruct.extend( [[f"cls{i}", 'N', 19, 1] for i in range(1, N_Cls + 1)]) # Изменение нумерации полей cls aInfStruct.extend([['summa', 'N', 19, 0], ['sredn', 'N', 19, 7], ['disp', 'N', 19, 7]]) excel_file_path = os.path.join(dbf_folder, f'{model_name}.xlsx') model_txt_file_path = os.path.join(dbf_folder, f'{model_name}.txt') with open(model_txt_file_path, 'r', encoding='cp866') as model_txt_file: lines = model_txt_file.read().splitlines() for row_idx, line in enumerate(lines, start=2): values = [] start_pos = 0 for field_info in aInfStruct: field_length = field_info[2] field_value = line[start_pos:start_pos + field_length].strip() if field_info[0] == 'kod_pr': kod_pr_values.append(field_value) else: if field_info[0] != 'name': if field_info[1] == 'N': try: field_value = float(field_value.replace(' ', '0').replace(',', '.')) except ValueError: field_value = 0 values.append(field_value) start_pos += field_length for col_idx, value in enumerate(values, start=1): ws.cell(row=row_idx, column=col_idx).value = value if 'Sheet' in wb.sheetnames: sheet = wb['Sheet'] wb.remove(sheet) try: wb.save(excel_file_path) except PermissionError: print( "Ошибка: Файл Excel используется другой программой.") # Используйте messagebox, если требуется # ФОРМАТИРОВАНИЕ XLSX ФАЙЛА МОДЕЛИ def align_columns(excel_file_path): # Открытие существующего файла Excel wb = load_workbook(excel_file_path) ws = wb.active # Минимизация ширины первой колонки по реальным данным (исключая заголовок) max_length_first_col = max(len(str(cell.value)) for cell in ws['A'][1:]) for cell in ws['A']: cell.alignment = Alignment(horizontal='left', vertical='bottom') ws.column_dimensions['A'].width = max_length_first_col + 1 # Выравнивание второй колонки по левому краю max_length_second_col = max(len(str(cell.value)) for cell in ws['B']) for cell in ws['B']: cell.alignment = Alignment(horizontal='left', vertical='bottom') ws.column_dimensions[cell.column_letter].width = max_length_second_col + 1 # Выравнивание остальных колонок for col in ws.iter_cols(min_col=3, max_col=ws.max_column, min_row=1, max_row=1): for cell in col: cell.alignment = Alignment(horizontal='center', vertical='bottom', text_rotation=90) for col in ws.iter_cols(min_col=3, max_col=ws.max_column, min_row=2, max_row=ws.max_row): max_length_other_cols = max(len(str(cell.value)) for cell in col) for cell in col: cell.alignment = Alignment(horizontal='center', vertical='bottom') ws.column_dimensions[cell.column_letter].width = max_length_other_cols + 1 # Выделение жирным и выравнивание первой строки for cell in ws[1]: cell.alignment = Alignment(horizontal='center', vertical='bottom', text_rotation=90) # Сохранение изменений wb.save(excel_file_path) align_columns(excel_file_path) # РАСЧЕТ И ЗАПИСЬ XLSX МАТРИЦЫ СХОДСТВА ПРИЗНАКОВ # Функция для создания имен строк и колонок в виде "код признака - наименование признака" def create_named_index(index, kod_atr_list, name_atr_list): return [f"{kod_atr_list[i]} - {name_atr_list[i]}" for i in range(len(index))] # Загрузка данных из файла Excel data = pd.read_excel(excel_file_path) # Выводим количество строк и столбцов до удаления # print(f"Initial data shape: {data.shape}") # Исключаем строки: 1 (она в Питоне считается нулевой) и последние 4, и исключаем колонки: 2 первые и 3 последние data = data.iloc[:-4, 2:-3] # Выводим количество строк и столбцов после удаления # print(f"Data shape after exclusion: {data.shape}") # print(data) # Обновляем индексы строк и колонок с использованием функции create_named_index data.index = create_named_index(data.index, kod_atr_list, name_atr_list) data.columns = create_named_index(data.columns, kod_atr_list, name_atr_list) # Транспонируем DataFrame transposed_data = data.transpose() # Вычисляем корреляцию между строками (теперь строки стали столбцами после транспонирования) correlation_matrix = transposed_data.corr() # Умножение всех значений матрицы на 100 correlation_matrix *= 100 # Замена пустых ячеек на 0 correlation_matrix.fillna(0, inplace=True) # Преобразование всех значений в числовые correlation_matrix = correlation_matrix.apply(pd.to_numeric, errors='coerce').fillna(0) # Выводим размерность матрицы корреляции # print(f"Correlation matrix shape: {correlation_matrix.shape}") # Создание нового файла Excel с матрицей сходства output_file_path = os.path.join(os.path.dirname(excel_file_path), f"Attributes_similarity_matrix_{model_name}.xlsx") try: # Запись данных в Excel с использованием openpyxl для форматирования with pd.ExcelWriter(output_file_path, engine='openpyxl') as writer: correlation_matrix.to_excel(writer, index=True, sheet_name='Correlation') # Получаем объект книги Excel wb = writer.book ws = wb['Correlation'] # Устанавливаем выравнивание для наименований колонок for cell in ws[1]: cell.alignment = Alignment(horizontal='center', vertical='bottom') cell.font = Font(bold=True) # Устанавливаем обычный шрифт для всех ячеек for row in ws.iter_rows(): for cell in row: cell.font = Font(name='Arial', size=10) # Создаем новый лист ws_new = wb.create_sheet(title='Summary') # Вставляем текст заголовка в новый лист title_text = ( f"МАТРИЦА СХОДСТВА ПРИЗНАКОВ\n" f"(С°) Персональная интеллектуальная on-line среда 'Эйдос'\n" f"Приложение: {name_appl}\n" f"Модель: {model}\n" f"Дата и время создания формы: {pd.Timestamp.now()}\n" ) for i, line in enumerate(title_text.split('\n')): cell = ws_new.cell(row=i + 1, column=1, value=line) cell.font = Font(bold=True) # Переносим наименования строк и столбцов с форматированием for col_idx, col_name in enumerate(correlation_matrix.columns): cell = ws_new.cell(row=6, column=col_idx + 2, value=col_name) cell.alignment = Alignment(horizontal='center', vertical='bottom', text_rotation=90) for row_idx, row_name in enumerate(correlation_matrix.index): cell = ws_new.cell(row=row_idx + 7, column=1, value=row_name) cell.alignment = Alignment(horizontal='left', vertical='bottom') # Переносим матрицу сходства на новый лист со смещением вниз на 6 строк for row_idx, row in enumerate(correlation_matrix.values): for col_idx, value in enumerate(row): ws_new.cell(row=row_idx + 7, column=col_idx + 2, value=value) # Размеры первой колонки max_length = max(len(str(cell.value)) for row in ws_new.iter_rows(min_row=7, max_row=ws_new.max_row, min_col=1, max_col=1) for cell in row) ws_new.column_dimensions['A'].width = max_length + 8 # Увеличиваем ширину на 8 символов для запаса # Удаляем старый лист del wb['Correlation'] # Сохраняем изменения wb.save(output_file_path) except PermissionError: # Если файл занят другим приложением, выводим сообщение об ошибке в GUI окне root = tk.Tk() root.withdraw() # Скрыть основное окно messagebox.showerror("Ошибка", f"Файл {output_file_path} занят другим приложением. Закройте его и повторите попытку.") root.destroy() # Закрыть GUI окно после закрытия сообщения об ошибке # СОЗДАНИЕ XLSX МАТРИЦЫ СХОДСТВА ПРИЗНАКОВ ДЛЯ КОНВЕРТАЦИИ В DBF ФАЙЛ МАТРИЦЫ СХОДСТВА # Загрузка данных из базы данных Classes.dbf с использованием dbfread и кодировки cp866 with DBF(Attributes_dbf_path, encoding='cp866') as Attributes_table: Attributes = list(Attributes_table) Attributes_df = pd.DataFrame(Attributes) # Создание нового файла Excel с матрицей сходства output_file_path = os.path.join(os.path.dirname(excel_file_path), f"SxodAtr{model_name}.xlsx") # Подготовка данных для записи в Excel columns = ['kod_atr', 'kod_opsc', 'name_atr'] + [f'n{i + 1}' for i in range(len(Attributes_df))] data = [] # Заполнение данными из базы данных и корреляционной матрицы for idx, Attributes_row in Attributes_df.iterrows(): row = [Attributes_row['KOD_ATR'], Attributes_row['KOD_OPSC'], Attributes_row['NAME_ATR']] + list( correlation_matrix.iloc[idx]) data.append(row) # Создание DataFrame для записи в Excel result_df = pd.DataFrame(data, columns=columns) # Запись данных в Excel с использованием openpyxl для форматирования with pd.ExcelWriter(output_file_path, engine='openpyxl') as writer: result_df.to_excel(writer, index=False, sheet_name='SimilarityMatrix') # Получаем объект книги Excel wb = writer.book ws = wb['SimilarityMatrix'] # Устанавливаем выравнивание для наименований колонок for cell in ws[1]: cell.alignment = Alignment(horizontal='center', vertical='bottom') cell.font = Font(bold=True) # Устанавливаем обычный шрифт для всех ячеек for row in ws.iter_rows(): for cell in row: cell.font = Font(name='Arial', size=10) # Выравнивание третьей колонки по левому краю max_length_third_col = max(len(str(cell.value)) for cell in ws['C']) for cell in ws['C']: cell.alignment = Alignment(horizontal='left', vertical='bottom') ws.column_dimensions[get_column_letter(cell.column)].width = max_length_third_col + 1 # Устанавливаем ширину колонок ws.column_dimensions['A'].width = 15 # kod_cls ws.column_dimensions['B'].width = 15 # kod_clsc ws.column_dimensions['C'].width = max_length_third_col # name_cls for i in range(4, len(columns) + 1): ws.column_dimensions[get_column_letter(i)].width = 19 # n1, n2, ..., n14 # Удаляем старый лист, если он существует if 'Correlation' in wb.sheetnames: del wb['Correlation'] # Сохраняем изменения wb.save(output_file_path) # СОЗДАЕМ DBF ФАЙЛ ДЛЯ МАТРИЦЫ СХОДСТВА ПРИЗНАКОВ В ТЕКУЩЕЙ МОДЕЛИ def calculate_checksum(file_path): sha256 = hashlib.sha256() with open(file_path, 'rb') as f: for byte_block in iter(lambda: f.read(4096), b''): sha256.update(byte_block) return sha256.hexdigest() # Получить абсолютный путь к файлу: Converter_xlsx_to_dbf.exe path_exe_Converter_xlsx_to_dbf = os.path.abspath('ConverterClust.exe') # print(path_exe_Converter_xlsx_to_dbf) # Вычисление контрольной суммы expected_checksum = '4ff3487a448903163633e17988d7eac4523b183c3549281facff4d05c9ad38ce' # Укажите здесь актуальную контрольную сумму из файла: checksum_error.txt # expected_checksum = '4f3487a448903163633e17988d7eac4523b183c3549281facff4d05c9ad38ce' # Укажите здесь актуальную контрольную сумму из файла: checksum_error.txt actual_checksum = calculate_checksum(path_exe_Converter_xlsx_to_dbf) # Проверка контрольной суммы if actual_checksum == expected_checksum: # Получить абсолютный путь к файлу: Converter_xlsx_to_dbf.txt path_txt_Converter_xlsx_to_dbf = os.path.abspath('Converter_xlsx_to_dbf.txt') # Открываем файл в режиме записи и записываем в него значение переменной with open(path_txt_Converter_xlsx_to_dbf, 'w') as file: file.write(output_file_path) # Запустить конвертер subprocess.run(path_exe_Converter_xlsx_to_dbf, stdout=subprocess.PIPE) # ЗАПУСТИТЬ КОНВЕРТОР else: print(f"Контрольная сумма не совпадает: {actual_checksum}. Исполняемый файл не будет запущен.") with open("checksum_error.txt", "w", encoding="utf-8") as file: # actual_checksum = "123456789" # Пример значения контрольной суммы file.write(f"Контрольная сумма не совпадает: {actual_checksum}. Исполняемый файл: ConverterClust.exe не был запущен.") print( f"xlsx матрица модели {model_name} и xlsx и dbf матрицы сходства признаков и база конструктов успешно созданы.") # Поясняющий текст if actual_checksum == expected_checksum: message = f""" Расчет матриц сходства классов и конструктов признаков успешно завершен! Матрицы сходства признаков содержатся в папке текущего приложения: {dbf_folder} в следующих таблицах MS Excel, созданных на основе статистических и системно-когнитивных моделей: "Attributes_similarity_matrix_Abs.xlsx", "Attributes_similarity_matrix_Prc#.xlsx", #={{1,2}}, "Attributes_similarity_matrix_Inf#.xlsx" (где: #={{1,2,3,4,5,6,7}}). Эти таблицы создаются в режиме 4.3.2.1, реализованном на Питоне, и уже отформатированы для включения в отчеты. Если использовался режим 4.2.2.1 на xBase++ то формируются файлы: "SxodAtrAbs.xlsx", "SxodAtrPrc#.xlsx", #={{1,2}}, "SxodAtrInf#.xlsx", #={{1,2,3,4,5,6,7}}. Для преобразования dbf => xlsx можно использовать режим 5.12. В этом случае xlsx файлы рекомендуется еще немного их отформатировать. Наименования колонок в матрице сходства признаков являются наименованиями признаков, которые есть в каждой строке. Поэтому можно взять их из строк и вставить с транспонированием в строку наименований колонок, придав им вертикальную ориентацию и выровняв их по центру. Сходство дано в процентах, поэтому можно задать формат ячеек без десятичных знаков и отображать отрицательные значения красным цветом. Ширину колонок есть смысл минимизировать по реальным данным, а также сделать сетку в таблице. Режим 4.3.2.1, реализованный на Питоне, не только конвертирует выходные формы в xlsx и форматирует их для отчетов, но и работает значительно быстрее, чем реализованный на xBase++. """ else: message = f""" Контрольная сумма не совпадает: {actual_checksum}. Исполняемый файл: ConverterClust.exe не был запущен! Необходимо обратиться к разработчику проф.Е.В.Луценко или скачать актуальную версию системы Эйдос с сайта разработчика: http://lc.kubagro.ru/Installation_Eidos.php """ def show_custom_message(title, message): # Создаем новое окно message_window = tk.Toplevel(root) message_window.title(title) # Устанавливаем иконку icon_path = "_Aidos.ico" message_window.iconbitmap(icon_path) # Создаем текстовый виджет и скроллбар if actual_checksum == expected_checksum: text_widget = tk.Text(message_window, wrap="none", width=125, height=23) else: text_widget = tk.Text(message_window, wrap="none", width=125, height=10) scrollbar_y = tk.Scrollbar(message_window, orient="vertical", command=text_widget.yview) scrollbar_x = tk.Scrollbar(message_window, orient="horizontal", command=text_widget.xview) text_widget.configure(yscrollcommand=scrollbar_y.set, xscrollcommand=scrollbar_x.set) # Заполняем текстовый виджет сообщением text_widget.insert(tk.END, message) text_widget.config(state=tk.DISABLED) # Сделать текстовый виджет только для чтения # Создаем кнопку Ok ok_button = tk.Button(message_window, text="Ok", command=message_window.destroy, width=15, height=2) # Размещаем виджеты в окне text_widget.grid(row=0, column=0, sticky="nsew") scrollbar_y.grid(row=0, column=1, sticky="ns") scrollbar_x.grid(row=1, column=0, sticky="ew") ok_button.grid(row=2, column=0, columnspan=2, pady=10) # Настроить растягивание виджета message_window.grid_rowconfigure(0, weight=1) message_window.grid_columnconfigure(0, weight=1) # Установить размер и позицию окна по центру экрана message_window.update_idletasks() width = message_window.winfo_width() height = message_window.winfo_height() x = (message_window.winfo_screenwidth() // 2) - (width // 2) y = (message_window.winfo_screenheight() // 2) - (height // 2) message_window.geometry('{}x{}+{}+{}'.format(width, height, x, y)) # Дождаться закрытия окна message_window.grab_set() root.wait_window(message_window) # Показываем сообщение show_custom_message("Процесс 4.3.2.1 успешно завершен", f" Все модели успешно преобразованы и сохранены в папке текущего приложения:\n {dbf_folder}.\n\n{message}") root.destroy() root.mainloop() def csv_to_dbf_py(): ###################################################################################################################### # csv_to_dbf_py. 2.3.2.2. Универсальный API импорта данных в систему Эйдос - CSV to DBF Converter в Питоне. ###################################################################################################################### root = tk.Tk() root.title("2.3.2.2. Универсальный API импорта данных в систему Эйдос - CSV to DBF Converter") root.iconbitmap("_Aidos.ico") # Добавление иконки # Create a frame for the progress bar and status label frame = tk.Frame(root) frame.pack(pady=20, padx=10) # Add horizontal padding to the frame # Progress bar with a fixed height style = ttk.Style() style.configure("TProgressbar", thickness=20) # Set the thickness of the progress bar progress = ttk.Progressbar(frame, orient="horizontal", length=440, mode="determinate", style="TProgressbar") progress.pack(padx=10) # Add padding to the progress bar itself # Status message label status_label = tk.Label(frame, text="") status_label.pack(pady=10) progress_percentage_label = tk.Label(frame, text="0.0000000%") progress_percentage_label.pack(pady=10) def update_progress(step, total_steps): percentage = (step / total_steps) * 100 progress["value"] = percentage progress_percentage_label.config(text=f"{percentage:.7f}%") root.update_idletasks() def generate_csv(csv_path): # Для отладки num_columns = 10 # уменьшим количество колонок для упрощения num_rows = 100 # уменьшим количество строк для упрощения # Create the model CSV data data_numeric = np.add.outer(np.arange(num_rows), np.arange(num_columns)) data_text = np.array([f"строка {i}, колонка {j}" for i in range(num_rows) for j in range(num_columns)]) data_text = data_text.reshape(num_rows, num_columns) # Combine numeric and text data data_combined = np.hstack((data_numeric, data_text)) # Create a DataFrame and save to CSV columns_numeric = [f"Col{i}" for i in range(num_columns)] columns_text = [f"TextCol{i}" for i in range(num_columns)] columns = columns_numeric + columns_text df = pd.DataFrame(data_combined, columns=columns) df.to_csv(csv_path, index=False, encoding='cp866') def sanitize_column_name(name, index): # Truncate or modify the column name to ensure it's unique and within 10 characters name = ''.join(char if char.isalnum() or char == '_' else '_' for char in name) if not name[0].isalpha(): name = 'F' + name if len(name) > 10: name = name[:8] + str(index % 10) # Ensure the name is unique and within 10 characters return name def create_dbf(fields, dbf_path): try: # Создание таблицы table = dbf.Table(dbf_path, fields, codepage='cp866') table.open(mode=dbf.READ_WRITE) table.close() except Exception as e: print(f"Ошибка при создании DBF файла: {e}") def validate_row_data(row, sanitized_columns, df): record = [] for col in row.index: sanitized_col = sanitized_columns[col] val = row[col] # Проверка типа данных для текстовых полей if 'TextCol' in col or df[col].dtype == object: if isinstance(val, str): if len(val) > 254: val = val[:254] else: val = str(val)[:254] # Проверка типа данных для числовых полей elif df[col].dtype in [int, float]: try: val = float(val) # Валидация длины чисел if len(f"{val:.10f}") > 20: # Length including decimal part val = f"{val:.10f}"[:20] except ValueError: val = '' # Замена на пустую строку при ошибке преобразования # Заменяем NaN значения на пустые строки if pd.isna(val): val = '' record.append(val) return record def write_to_dbf(df, sanitized_columns, dbf_path, error_csv_path): try: table = dbf.Table(dbf_path) table.open(mode=dbf.READ_WRITE) total_rows = len(df) errors = [] for index, row in df.iterrows(): record = validate_row_data(row, sanitized_columns, df) # Проверка на количество полей if len(record) == len(sanitized_columns): try: table.append(tuple(record)) except Exception as e: error_message = f"Ошибка при записи строки {index} в DBF: {e}" error_row = ';'.join([str(val) for val in record]) error_details = f"Ошибка в строке {index}: {error_row} - {error_message}" # Append error details to list and print to console errors.append(error_details) print(error_details) # Запись ошибки в файл исключений with open(error_csv_path, "a", encoding='cp866', newline='') as error_file: writer = csv.writer(error_file, delimiter=';') writer.writerow([error_row, error_message]) else: error_message = "Количество полей не совпадает" error_row = ';'.join([str(val) for val in record]) error_details = f"Ошибка в строке {index}: {error_row} - {error_message}" # Append error details to list and print to console errors.append(error_details) print(error_details) # Запись ошибки в файл исключений with open(error_csv_path, "a", encoding='cp866', newline='') as error_file: writer = csv.writer(error_file, delimiter=';') writer.writerow([error_row, error_message]) # Update progress after processing each row update_progress(index + 1, total_rows) # Закрытие таблицы table.close() except Exception as e: print(f"Ошибка при записи в DBF: {e}") def find_errors_in_csv(csv_path): error_rows = [] def check_row_for_errors(row, sanitized_columns): record = [] for col in row.index: sanitized_col = sanitized_columns[col] val = str(row[col]) if len(val) > 254: val = val[:254] elif pd.isna(val): val = '' record.append(val) if len(record) != len(sanitized_columns): return "Количество полей не совпадает" return None try: df = pd.read_csv(csv_path, encoding='cp866', on_bad_lines='skip', low_memory=False) sanitized_columns = {} for index, col in enumerate(df.columns): sanitized_col = sanitize_column_name(col, index) sanitized_columns[col] = sanitized_col for index, row in df.iterrows(): error = check_row_for_errors(row, sanitized_columns) if error: error_row = ';'.join([str(row[col]) for col in df.columns]) error_rows.append((index, error_row, error)) except Exception as e: print(f"Общая ошибка: {e}") return error_rows def start_conversion(): try: # Определение пути к CSV и DBF файлам base_dir = os.path.join(os.getcwd(), "AID_DATA", "Inp_data") if not os.path.exists(base_dir): os.makedirs(base_dir) csv_path = os.path.join(base_dir, "Inp_data.csv") dbf_path = os.path.join(base_dir, "Inp_data.dbf") global error_csv_path error_csv_path = os.path.join(base_dir, "error_csv.csv") # Обновленный путь для error_csv.csv # Вывод путей для отладки print(f"Файлы находятся в директории: {base_dir}") print(f"CSV файл: {csv_path}") print(f"DBF файл: {dbf_path}") print(f"Файл исключений: {error_csv_path}") # Step 1: Generate the CSV file progress["value"] = 0 root.update_idletasks() # generate_csv(csv_path) # Ensure CSV is generated update_progress(0, 1) # Step 2: Create or recreate the error log file if os.path.exists(error_csv_path): os.remove(error_csv_path) # Удаление старого файла, если он существует with open(error_csv_path, "w", encoding='cp866', newline='') as error_file: # writer = csv.writer(error_file, delimiter=';') # writer.writerow(["Ошибка в строке", "Описание ошибки"]) pass # Step 3: Read and sanitize CSV data df = pd.read_csv(csv_path, encoding='cp866', on_bad_lines='skip', low_memory=False) sanitized_columns = {} for index, col in enumerate(df.columns): sanitized_col = sanitize_column_name(col, index) sanitized_columns[col] = sanitized_col fields = [] for col in df.columns: sanitized_col = sanitized_columns[col] if 'TextCol' in col or df[col].dtype == object: field_type = f'{sanitized_col} C(254)' # Truncate all text fields to max length 254 else: field_type = f'{sanitized_col} N(20,10)' # Example length and decimal places for numeric fields fields.append(field_type) # Step 4: Create the DBF file create_dbf(fields, dbf_path) update_progress(0, 1) # Step 5: Write data to the DBF file, handling errors write_to_dbf(df, sanitized_columns, dbf_path, error_csv_path) # Write data with error handling # Step 6: Check CSV for errors error_rows = find_errors_in_csv(csv_path) if error_rows: print("Ошибки найдены в следующих строках:") for error_row in error_rows: print(f"Строка {error_row[0]}: {error_row[2]}") with open(error_csv_path, "a", encoding='cp866', newline='') as error_file: writer = csv.writer(error_file, delimiter=';') writer.writerow([error_row[1], error_row[2]]) # Step 7: Final update and completion message update_progress(1, 1) # Check error file size and display appropriate message if os.path.getsize(error_csv_path) == 0: status_label.config(text="Конвертация Inp_data.csv => Inp_data.dbf прошла успешно") else: status_label.config( text="При конвертации Inp_data.csv => Inp_data.dbf были ошибки, отраженные в файле error_csv.csv") except Exception as e: error_message = f"Общая ошибка: {e}" print(error_message) status_label.config(text=error_message) # Окно с кнопкой "ОК" def on_ok(): root.destroy() # Закрытие окна и завершение программы # Создание кнопки "ОК" с увеличенными отступами ok_button = tk.Button(root, text="ОК", command=on_ok, padx=20) # Добавляем 20 пикселей по горизонтали ok_button.pack(pady=10) # Добавляем отступы по вертикали # Start the conversion process after a delay root.after(100, start_conversion) # Add a delay of 0.1 second (100 milliseconds) root.mainloop() def LC_Excel2WorkArea(): print("LC_Excel2WorkArea") def show_message_in_window(message, color='black', bold=False): """Отображение сообщения в окне.""" font = ('Arial', 12, 'bold') if bold else ('Arial', 12) result_label.config(text=message, foreground=color, font=font) root.after(5000, root.quit) # Закрыть приложение через 5 секунд def show_error_and_exit(message): """Вывод сообщения об ошибке в консоль и завершение программы.""" print(f"Ошибка: {message}") sys.exit() def read_file_name(): txt_file_path = os.path.join(os.getcwd(), 'LC_Excel2WorkArea.txt') if not os.path.isfile(txt_file_path): show_error_and_exit('Отсутствует файл: "LC_Excel2WorkArea.txt" с именем Excel-файла для конвертации в DBF') try: with open(txt_file_path, 'rb') as f: content = f.read() if content.startswith(b'\xef\xbb\xbf'): content = content[3:] file_name = content.decode('cp866').strip().split('\n')[0] # Преобразуем содержимое в строку except (UnicodeDecodeError, LookupError) as e: show_error_and_exit(f"Ошибка чтения LC_Excel2WorkArea.txt: {str(e)}") return file_name def convert_to_dbf(file_name, start_time): directory = os.path.join(os.getcwd(), 'AID_DATA', 'Inp_data') excel_file_path = os.path.join(directory, file_name) if not os.path.isfile(excel_file_path): show_error_and_exit(f"Файл {file_name} отсутствует в директории {directory}!") base_filename = os.path.splitext(file_name)[0] output_dbf_path = os.path.join(directory, f"{base_filename}.dbf") inp_name_path = os.path.join(directory, f"Inp_name.txt") inp_name_all_path = os.path.join(directory, f"Inp_nameAll.txt") try: if not os.access(excel_file_path, os.R_OK): show_error_and_exit( f"Файл {file_name} занят другим процессом. Попробуйте закрыть все программы, использующие этот файл.") # Чтение Excel и обработка данных if file_name.endswith('.xls'): df = pd.read_excel(excel_file_path, engine='xlrd', dtype=str) elif file_name.endswith('.xlsx'): df = pd.read_excel(excel_file_path, engine='openpyxl', dtype=str) else: show_error_and_exit(f"Ошибка: неподдерживаемый формат файла {file_name}!") # Убедимся, что нет пустых строк и обрабатываем типы данных df.fillna('', inplace=True) # Определение полей и их типов с обновлением прогресс-бара field_specs = [] total_columns = len(df.columns) for index, col in enumerate(df.columns): # Обновление прогресс-бара для определения полей progress['value'] = (index / total_columns) * 50 # Половина прогресса для определения полей root.update_idletasks() field_name = f"n{index + 1}" # Проверка на числовые и текстовые значения is_numeric = df[col].apply(lambda x: pd.to_numeric(x, errors='coerce')).notna().all() if is_numeric: # Определяем максимальную длину целой и дробной части max_integer_length = 0 max_decimal_length = 0 for value in df[col]: if pd.notna(value) and value != '': try: float_value = float(value) integer_part, decimal_part = str(float_value).split(".") max_integer_length = max(max_integer_length, len(integer_part)) max_decimal_length = max(max_decimal_length, len(decimal_part)) except ValueError: pass # Определяем общую длину поля для числовых значений total_length = max_integer_length + max_decimal_length + 1 # +1 для точки if max_decimal_length > 0: field_type = f'N({total_length + 2},{max_decimal_length})' # +2 для знака и точки else: field_type = f'N({total_length + 1},0)' # +1 для знака else: # Текстовые поля max_length = df[col].astype(str).map(len).max() if len(df[col]) > 0 else 10 field_type = f'C({max_length})' field_specs.append(f"{field_name} {field_type}") # Создание DBF таблицы с кодировкой cp866 field_definitions = '; '.join(field_specs) table = Table(output_dbf_path, field_definitions, codepage='cp866') # Открытие таблицы для записи try: table.open(mode=READ_WRITE) # Записываем строки из DataFrame в DBF таблицу total_rows = len(df) for index, (_, row) in enumerate(df.iterrows()): row_data = [] for value in row: row_data.append(str(value).strip() if isinstance(value, str) else value) table.append(tuple(row_data)) # Обновление прогресс-бара percent_complete = 50 + (index + 1) / total_rows * 50 # Оставшаяся часть прогресса progress['value'] = percent_complete elapsed_time = time.time() - start_time remaining_time = (total_rows - (index + 1)) * elapsed_time / (index + 1) # Обновление оставшегося времени в формате "часы:минуты:секунды" hours, remainder = divmod(int(remaining_time), 3600) minutes, seconds = divmod(remainder, 60) time_left_label.config( text=f"Время до окончания конвертации: {hours:02d} час {minutes:02d} мин {seconds:02d} сек") # Обновление процента исполнения percent_label.config(text=f"{percent_complete:.7f} %") # Обновление GUI 10 раз в секунду root.update_idletasks() finally: # Обязательно закрываем таблицу, даже если возникла ошибка table.close() # Создание текстовых файлов с названиями колонок try: with open(inp_name_path, 'w', encoding='cp866') as f1, open(inp_name_all_path, 'w', encoding='cp866') as f2: # Записываем во второй файл все колонки for column in df.columns: f2.write(f"{column}\n") # Записываем в первый файл колонки, начиная со 2-й for column in df.columns[1:]: f1.write(f"{column}\n") except Exception as e: show_error_and_exit(f"Ошибка записи текстовых файлов: {str(e)}") return f"Файл {base_filename}.dbf успешно создан!" except (pd.errors.EmptyDataError, pd.errors.ParserError) as e: show_error_and_exit(f"Ошибка чтения Excel файла: {str(e)}") except Exception as e: show_error_and_exit(f"Ошибка конвертации: {str(e)}") def start_conversion(): """Запуск конвертации в фоновом потоке.""" start_time = time.time() # Получаем время начала конвертации file_name = read_file_name() progress['maximum'] = 100 progress['value'] = 0 progress_label.config(text=f"Идет конвертация файла: {file_name} в dbf") # Запуск конвертации в отдельном потоке conversion_thread = threading.Thread(target=perform_conversion, args=(file_name, start_time)) conversion_thread.start() def perform_conversion(file_name, start_time): """Выполнение конвертации и обновление GUI.""" result_message = "" try: result_message = convert_to_dbf(file_name, start_time) # Передаем start_time progress['value'] = 100 show_message_in_window(result_message, color='black', bold=True) except Exception as e: print(f"Ошибка: {str(e)}") show_message_in_window(f"Ошибка: {str(e)}", color='red', bold=True) root = tk.Tk() root.title("Xlsx => dbf конвертер") root.geometry("900x250") # Увеличение высоты окна для новых элементов icon_path = os.path.join(os.getcwd(), '_Aidos.ico') if os.path.isfile(icon_path): root.iconbitmap(icon_path) progress = ttk.Progressbar(root, orient="horizontal", length=860, mode="determinate") # Длина прогресс-бара progress.pack(pady=20, padx=20) # Отступы по 20 пикселей progress_label = tk.Label(root, text="", font=('Arial', 12)) progress_label.pack(pady=10) # Добавление метки для отображения времени выполнения percent_label = tk.Label(root, text="0.0000000 %", font=('Arial', 12)) # Процент исполнения percent_label.pack(pady=5) time_left_label = tk.Label(root, text="Время до окончания конвертации: 00 час 00 мин 00 сек", font=('Arial', 12)) # Время до окончания конвертации time_left_label.pack(pady=5) result_label = tk.Label(root, text="", font=('Arial', 12)) # Добавляем Label для вывода сообщений result_label.pack(pady=20) # Изменение цвета прогресс-бара style = ttk.Style() style.configure("TProgressbar", troughcolor="lightgray", background="blue") # Запуск конвертации при старте start_conversion() root.mainloop() def function14(): print("Это функция 14") def function15(): print("Это функция 15") def function16(): print("Это функция 16") ###################################################################### # Основная функция, которая читает имя функции из файла и запускает ее ###################################################################### def main(): with open("Python_function_to_run.txt", 'r', encoding='utf-8-sig') as file: function_name = file.read().strip() print('Python_function_to_run.txt: ', function_name) # Проверка на специальную строку для выхода из программы if function_name == 'the module "__AIDOS-PY.exe" completed the work and you can run it again': print("The program has completed its work. Exit...") return # Выход из функции (и программы) if function_name == "_4_5py": _4_5py() elif function_name == "_4221py": _4221py() elif function_name == "_4321py": _4321py() elif function_name == "_4224py": _4224py() elif function_name == "_4324py": _4324py() elif function_name == "_5_11py_testing": _5_11py_testing() elif function_name == "_5_11py_results": _5_11py_results() elif function_name == "_5_12py": _5_12py() elif function_name == "dbf_to_html_py": dbf_to_html_py() elif function_name == "csv_to_dbf_py": csv_to_dbf_py() elif function_name == "url_py": url_py() elif function_name == "_3_5py": _3_5py() elif function_name == "LC_Excel2WorkArea": LC_Excel2WorkArea() elif function_name == "Color_name": Color_name() else: raise ValueError(f"Неизвестная функция: {function_name}") if __name__ == "__main__": main()