// (C) Персональная интеллектуальная онлайн среда "ЭЙДОС-X Professional" (Система "Эйдос-Хpro"), ADS-mADStxt, beta-version, rel: 28.11.2023. // (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/__AidosALL.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 more 392 (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. ******************** #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-серверу отсутствует', '(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.) ********************************************************************************************************************* // Отметка в базе данных test_strings.txt на сайте: http://lc.kubagro.ru реквизитов посетителя // и переход (редирект) на основной сайт: http://lc.kubagro.ru ЕСЛИ ЕСТЬ INTERNET* ********************************************************************************************************************* n=0 IF .NOT. InternetGetConnectedState( @n, 0 ) == 0 * ShellOpenFile( 'http://lc.kubagro.ru/index.php' ) // Решение от Regan Cawkwell * DC_SpawnURL( 'http://lc.kubagro.ru/index.php', .T., .T. ) // Решение Роджера. Не работает под Windows-8, а в 7 и 10 работает но не всегда <<<===################## * Использование маленькой программы на Питоне url_py.exe для обращения к по Internet-адресу, находящемуся в файле: url_py.txt StrFile('http://lc.kubagro.ru/index.php', 'url_py.txt') LC_RunShell("url_py.exe",198530906) // Мой вариант на Питоне 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.php', .T., .T. ) // Решение Роджера. Не работает под Windows-8, а в 7 и 10 работает но не всегда <<<===################## * ShellOpenFile( 'http://lc.kubagro.ru/index.php' ) // Решение от Regan Cawkwell * cFile := LoadFromURL('http://lc.kubagro.ru/index.php') // Считывает страницу сайта в текстовую переменную * MsgBox(cFile) * MsgBox('STOP') * ShellOpenFile( 'http://lc.kubagro.ru/index.php' ) * RECOVER // код обработки ошибки * aMess := {} * AADD(aMess, L('При обращении к Эйдос-облаку возникла ошибка. Это повлияет только на отметку места запуска системы ')) // НАПРИМЕР * AADD(aMess, L('"Эйдос" на карте мира. Можно сделать это вручную, выйдя на сайт: http://lc.kubagro.ru/index.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. Анализ достоверности моделей с двумя инт.критериями') PARENT oMenu3 ACTION {|| IF( !Running(), F3_4(),LB_Warning(sms,cmc))} MESSAGE L('Оценивается достоверность (адекватность) заданных стат.моделей и моделей знаний. Для этого осуществляется синтез заданных моделей, обучающая выборка копируется в распознаваемую и в каждой заданной модели проводится распознавание с использованием двух интегральных критериев, подсчитывается количество верно идентифицированных и не идентифицированных, ошибочно идентифицированных и не идентифицированных объектов (ошибки 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 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('Расчет матриц сходства, кластеров и конструктов') 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('Много различных вариантов классической кластеризации с 7 графическими и 7 табличными видами выходных форм, 10 алгоритмами и 10 мерами расстояний. Когнитивная кластеризация, путем объединения пар классов в матрице абсолютных частот и пересчет матриц условных и безусловных процентных распределений и системно-когнитивных моделей. Построение и визуализация древовидных диаграмм объединения класов (дендрограмм) в графическом виде') * DCMENUITEM L('4.2.2.4. Дивизивная древовидная кластеризация классов') 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 ' ' 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('Много различных вариантов классической кластеризации с 7 графическими и 7 табличными видами выходных форм, 10 алгоритмами и 10 мерами расстояний. Когнитивная кластеризация, путем объединения пар признаков в матрице абсолютных частот и пересчет матриц условных и безусловных процентных распределений и системно-когнитивных моделей. Построение и визуализация древовидных диаграмм объединения признаков (дендрограмм) в графическом виде') 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: 28.11.2023.') ; 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: 28.11.2023. ')) 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 " * @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° Пакетное скачивание публикаций в папку: "'+Disk_dir+'"'; PARENT @oDialog ; FIT ; EXIT ; MODAL oDialog:show() ****************************************************************************************************************************** aSay[ 1]:SetCaption('1/2. Поиск гиперссылок на файлы публикаций '+IF(mDataSource=1,'на странице: "'+mIntAddr+'"','в файле: "'+mFileName+'"')) 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 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) lOk = Time_Progress (++Time_Progress, mNFiles, oProgress, lOk ) DBSKIP(1) ENDDO CLOSE ALL * LB_Warning('Все pdf-файлы скачаны успешно !!!', 'Скачивание pdf-файлов по гиперссылкам с сайта') oSay97:SetCaption('Все pdf и zip файлы статей скачаны успешно !!!') 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 DO CASE CASE m11txt = 1 @9.5,0 DCGROUP oGroup3 CAPTION L('Главное, что делает система:') SIZE 80.0, 19.2 @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, 19.2 @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, 19.2 @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, 19.2 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, 19.2; 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, 19.2 @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 ENDCASE m11txt = IF(m11txt < 6,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 = 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 Гб)') SIZE 76, 1.5 ACTION {||DownloadArticles()} PARENT oGroup3;l=l+d*2 @l,2 DCPUSHBUTTON CAPTION L('СЕРТИФИКАТ об освоении системы "Эйдос" от проф.Е.В.Луценко. ПОДДЕРЖКА') SIZE 76, 1.5 ACTION {||Help11()} 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('в режиме 6.2 системы "Эйдос". Краткая инструкция по разработке интеллектуальных облачных') SAYSIZE 0 @ s++,1 DCSAY L('Эйдос-приложений, включающая информацию об источниках данных для машинного обучения (ML),') SAYSIZE 0 @ s++,1 DCSAY L('шаблоны описания Эйдос-приложений и видео-занятия проф.Е.В.Луценко, находится по ссылке:') SAYSIZE 0 @ s++,1 DCSAY L('http://lc.kubagro.ru/aidos/How_to_make_your_own_cloud_Eidos-application.htm') COLOR GRA_CLR_BLUE SAYSIZE 0 HYPERLINK {|p,c|p := 'url.dll,FileProtocolHandler ' + ; 'http://lc.kubagro.ru/aidos/How_to_make_your_own_cloud_Eidos-application.htm', c := 'Rundll32.exe', RunShell(p,c,.t.,.t.)} @ 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 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.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+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 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") ********************************************************************************************************************** ***** Копирование 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+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 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 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 с информацией о созданных маьтрицах сходства классов ******* и проверить, созданы ли базы данных сходства классов, ******* выдать сообщение и выйти, если нет 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 = "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 **** Проверка, существуют ли БД с результатами кластерно-конструктивного анализа 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 ***** Подготовить БД для визуализации конструктов 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(' Кластерно-конструктивный анализ - это математический метод анализа данных, ')) 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(' Кластерно-конструктивный анализ факторов позволяет сравнить факторы по сходству их ')) 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") ********************************************************************************************************************** ***** Копирование 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+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 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 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 ******* Загрузить массив 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+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 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 ***** Прописать ранги признаков и сделать массивы признаков для отображения в КД ############################################################## 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 // ПРОВЕРКА НА ТО, ЗАДАНА ЛИ ОЧЕРЕДНАЯ МОДЕЛЬ **************** 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,41.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+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 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 ***** Прописать ранги признаков и сделать массивы признаков для отображения в КД ############################################################## 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 // ПРОВЕРКА НА ТО, ЗАДАНА ЛИ ОЧЕРЕДНАЯ МОДЕЛЬ **************** 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[10] 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] = 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] = 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 = 75 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.5 @ 1, 2 DCRADIO aPar[3] VALUE 1 PROMPT L('Слова') PARENT oGroup3 @ 1.3,D*2 DCSAY L("Кол-во симв.в словах >: ") PARENT oGroup3 EDITPROTECT {|| .NOT.aPar[3]=1 } HIDE {|| .NOT.aPar[3]=1 } @ 1 ,D*3-3 DCSAY L(" ") GET aPar[10] 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,D*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 } @ 2, 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, 4.5 @ 1, 2 DCRADIO aPar[9] VALUE 1 PROMPT L('В 1-м стандарте "Эйдос": "id1,...,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('В стандарте "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]) // Если заданы мемы, то мин.длина слов = 3 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 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) aFileName[j] = ALLTRIM(aFileName[j]) 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 ) aAutorName := {} IF aPar[9] = 1 // В стандарте "Эйдос": "id, Class name" брать из номера и имени файла' **** Сформировать массив имен авторов oScrn := DC_WaitOn(L('Формирование массива имен авторов'),,,,,,,,,,,.F.) FOR j=1 TO LEN(aFileName) FOR a=1 TO NUMTOKEN(aFileName[j], ",") // Разделитель между словами - запятая mAutorName = TOKEN(aFileName[j], ",", a) IF ASCAN(aAutorName, mAutorName) = 0 AADD (aAutorName, mAutorName) ENDIF NEXT NEXT DC_Impl(oScrn) *DC_DebugQout( aAutorName ) ENDIF *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 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 USE Rso_zag EXCLUSIVE NEW USE Rso_Kcl EXCLUSIVE NEW USE Rso_Kpr EXCLUSIVE NEW 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) IF aPar[5] = 1 // 1-форм.кл.и оп.шк.и град.и обуч.выборки ****************************** ** В каком стандарте закодированы имена исходных файлов: ** 1: В 1-м стандарте "Эйдос": "id1,...,idn, Имя класса" брать из имени файла ** 2: Во 2-м стандарте "Эйдос": "Имя класса-#########.txt" брать из имени файла ** 3: В стандарте "http://kaggle.com/": "id, Class name" брать из текста файла IF aPar[9] = 1 // В стандарте "Эйдос": "id, Class name" брать из номера и имени файла' ****************************** ****** Классификационные шкалы ****************************** oScrn := DC_WaitOn(L('Создание классификационных шкал'),,,,,,,,,,,.F.) SELECT Class_Sc APPEND BLANK REPLACE Kod_ClSc WITH 1 REPLACE Name_ClSc WITH "ИМЕНА ФАЙЛОВ" 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 ASORT(aFileName) FOR j=1 TO LEN(aFileName) SELECT Gr_ClSc APPEND BLANK REPLACE Kod_ClSc WITH 1 REPLACE Kod_GrCS WITH ++mKodGrClSc REPLACE Name_GrCS WITH aFileName[j] SELECT Classes APPEND BLANK REPLACE Kod_cls WITH mKodGrClSc REPLACE Name_Cls WITH "ИМЕНА ФАЙЛОВ - "+aFileName[j] REPLACE Kod_ClSc WITH 1 NEXT 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) ENDIF // Во 2-м стандарте "Эйдос": Если в конце имени файла есть девятиразрядное число перед которым стоит тире, то весь текст до этого тире рассмаривается как имя класса: "Имя класса-#########.txt" IF aPar[9] = 2 ****************************** ****** Классификационные шкалы ****************************** 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 .AND. VAL(SUBSTR(aFileName[j],mPos+1,9)) > 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) ENDIF IF aPar[9] = 3 // В стандарте "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) ENDIF ENDIF ****************************************** *** ЛЕММАТИЗАЦИЯ ФАЙЛОВ ****************** ****************************************** 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] < 3 oScrn := DC_WaitOn(L('Лемматизация файлов обучающей выборки (слова)'),,,,,,,,,,,.F.) CASE aPar[9] = 3 oScrn := DC_WaitOn(L('Лемматизация файлов обучающей выборки (слова и мемы)'),,,,,,,,,,,.F.) ENDCASE CASE aPar[5] >= 2 // Формирование распознаваемой выборки с имеющимися шкалами и градациями DO CASE CASE aPar[9] < 3 oScrn := DC_WaitOn(L('Лемматизация файлов распознаваемой выборки (слова)'),,,,,,,,,,,.F.) CASE aPar[9] = 3 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] < 3 oScrn := DC_WaitOn(L('Формирование градаций описательных шкал (слова)'),,,,,,,,,,,.F.) CASE aPar[9] = 3 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] < 3 // В стандарте "Эйдос": "id, Class name" брать из номера и имени файла FOR ww=1 TO NUMTOKEN(mLcBuf, ' ') // Цикл по словам mWord = LOWER(TOKEN(mLcBuf,' ', ww)) IF LEN(mWord) > aPar[10] IF ASCAN(aWords1, mWord) = 0 // В справочник второй раз слово не включается, а в обуч.или расп.выборку - включается AADD (aWords1, mWord) ENDIF ENDIF NEXT ENDIF IF aPar[9] = 3 // В стандарте "http://kaggle.com/": "id, Class name" брать из текста файла (при кодировании признаков не использовать 1-й и последний элементы) FOR ww=2 TO NUMTOKEN(mLcBuf, ' ')-1 // Цикл по словам mWord = LOWER(TOKEN(mLcBuf,' ', ww)) IF LEN(mWord) > aPar[10] 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 ************************************************************************************ ***** Формирование обучающей или распознаваемой выборки **************************** ************************************************************************************ 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 ************************************************************************************* *** Отображение стадии и прогноза времени исполнения ******************************** ************************************************************************************* 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] < 3 // В стандарте "Эйдос": "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] = 3 // В стандарте "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 ******* В каком стандарте закодированы имена исходных файлов: IF aPar[9] = 1 // В стандарте "Эйдос": "id, Class name" брать из номера и имени файла mKodCls = ASCAN(aFileName, aFileName[mFile]) IF mKodCls > 0 AADD(aKodCls, mKodCls) ENDIF FOR a=1 TO NUMTOKEN(ConvToOemCP(aFileName[mFile]), ",") // Разделитель между авторами - запятая mAutorName = TOKEN(ConvToOemCP(aFileName[mFile]), ",", 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 .AND. VAL(SUBSTR(ConvToOemCP(aFileName[mFile]),mPos+1,9)) > 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 IF aPar[9] = 3 // В стандарте "http://kaggle.com/": "id, Class name" брать из текста файла * 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] < 3 // В стандарте "Эйдос": "id, Class name" брать из номера и имени файла REPLACE Name_obj WITH ConvToOemCP(STRTRAN(aFileName[mFile],'.txt','')) ENDIF IF aPar[9] = 3 // В стандарте "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 // В стандарте "Эйдос": "id, Class name" брать из номера и имени файла * mKodCls = ASCAN(aFileName1, aFileName[mFile]) * IF mKodCls > 0 * AADD(aKodCls, mKodCls) * ENDIF * FOR a=1 TO NUMTOKEN(ConvToOemCP(aFileName[mFile]), ",") // Разделитель между авторами - запятая * mAutorName = TOKEN(ConvToOemCP(aFileName[mFile]), ",", a) * mKodCls = ASCAN(aAutorName1, mAutorName) * IF mKodCls > 0 * AADD(aKodCls, LEN(aFileName1) + mKodCls) * ENDIF * NEXT * ENDIF * // Во 2-м стандарте "Эйдос": Если в конце имени файла есть девятиразрядное число перед которым стоит тире, то весь текст до этого тире рассмаривается как имя класса: "Имя класса-#########.txt" * IF aPar[9] = 2 * mPos = AT("-" , aFileName[mFile]) * IF mPos > 0 .AND. VAL(SUBSTR(ConvToOemCP(aFileName[mFile]),mPos+1,9)) > 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 LEN(mWord) > aPar[10] mKodAtr = ASCAN(aWords1, mWord) // Почему-то начиная примерно с 800-го объекта обучающей выборки нет признаков <<<===################# IF mKodAtr > 0 AADD(aKodAtr, mKodAtr) ENDIF ENDIF NEXT * MsgBox(STR(mFile)+STR(LEN(aKodAtr))) * IF mFile > 74 // Почему-то начиная примерно с 800-го объекта обучающей выборки нет признаков <<<===################# * DC_DebugQout( aWords1 ) // Отладка <<<===############# * DC_DebugQout( aKodAtr ) // Отладка <<<===############# * ENDIF ********* Запись распознаваемой выборки DIRCHANGE(M_PathAppl) // Перейти в папку текущего приложения SELECT Rso_Zag APPEND BLANK REPLACE Kod_obj WITH ++M_KodObj ******* В каком стандарте закодированы имена исходных файлов: IF aPar[9] < 3 // В стандарте "Эйдос": "id, Class name" брать из номера и имени файла REPLACE Name_obj WITH ConvToOemCP(aFileName[mFile]) ENDIF IF aPar[9] = 3 // В стандарте "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 LEN(mWord) > aPar[10] 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, L('путем импорта данных из текстовых файлов завершено успешно!')) AADD(aMess, L('Теперь необходимо провести синтез и, возможно, верификацию ')) AADD(aMess, L('моделей в режиме 3.5. ')) CASE aPar[5] = 2 // 2-формирование распознаваемой выборки после режима 2.3.2.1 ********************************* AADD(aMess, L('Создание распознаваемой выборки для приложения: ')) AADD(aMess, L('"АСК-анализ мемов и атрибуция текстов в модели 2.3.2.1" ')) AADD(aMess, L('путем импорта данных из текстовых файлов завершено успешно!')) 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, 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). В 1-м стандарте ')) 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(' ')) AADD(aHelp, L('Файлы могут быть различных форматов TXT, DOC, HTML с соответствующими расширениями(последние 2 в разработке) и различной кодировки: ')) AADD(aHelp, L('ANSI (Windows) или ASCII-OEM866 (DOS). В текущей версии системы "Эйдос" реализована только обработка txt-файлов кодировки 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. ')) AADD(aHelp, L(' ')) 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('отмечаются как и их леммы должны быть введены в режиме 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/.')) AADD(aHelp, L(' ')) AADD(aHelp, L('Имена исходных файлов могут быть закодированы в режиме 2.3.2.1 в трех стандартах: ')) AADD(aHelp, L('В 1-м стандарте "Эйдос": "id1,...,idn, Имя класса" брать из имени файла ')) AADD(aHelp, L('Во 2-м стандарте "Эйдос": "Имя класса-#########.txt" брать из имени файла ')) AADD(aHelp, L('В стандарте "http://kaggle.com/": "id, Class name" брать из текста файла. ')) 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+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 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 IF Flag448 SET FILTER TO mKodOpScLeft448 = Kod_OpSc .AND. Znach > 0 ELSE SET FILTER TO ENDIF ReTURN nil ******************************* FUNCTION FiltrRight448(Flag448) SELECT InfPortClsNeg PUBLIC mKodOpScRight448 := Kod_OpSc, mFltrRightFlag448 := Flag448 IF Flag448 SET FILTER TO mKodOpScRight448 = Kod_OpSc .AND. Znach < 0 ELSE SET FILTER TO ENDIF ReTURN nil ****************************** FUNCTION FiltrLeft449(Flag449) SELECT InfPortAtrPos PUBLIC mKodClScLeft449 := Kod_ClSc, mFltrLeftFlag449 := Flag449 IF Flag449 SET FILTER TO mKodClScLeft449 = Kod_ClSc .AND. Znach > 0 ELSE SET FILTER TO ENDIF ReTURN nil ******************************* FUNCTION FiltrRight449(Flag449) SELECT InfPortAtrNeg PUBLIC mKodClScRight449 := Kod_ClSc, mFltrRightFlag449 := Flag449 IF Flag449 SET FILTER TO mKodClScRight449 = Kod_ClSc .AND. Znach < 0 ELSE SET FILTER TO ENDIF 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+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 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+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 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 ***********************************