Forth и другие саморасширяющиеся системы программирования Locations of visitors to this page
Текущее время: Вс ноя 19, 2017 03:09

...
Google Search
Forth-FAQ Spy Grafic

Часовой пояс: UTC + 3 часа [ Летнее время ]




Начать новую тему Ответить на тему  [ Сообщений: 17 ]  На страницу 1, 2  След.
Автор Сообщение
 Заголовок сообщения: *простой текстовый viewer
СообщениеДобавлено: Вт июл 02, 2013 10:32 
Не в сети
Moderator
Moderator
Аватара пользователя

Зарегистрирован: Чт май 04, 2006 00:53
Сообщения: 4831
Откуда: был Крым, теперь Новосибирск
Благодарил (а): 18 раз.
Поблагодарили: 52 раз.
Написать определение, позволяющее просматривать текст из файла, заданного строкой asc #

VIEW ( asc # --> )

Текст должен отображаться в прямоугольной области на экране (например в консоли),
вылазящие за пределы отображаемой области символы не должны отображаться.
Должна быть реализована реакция на следующие клавиши:
esc - выход из просмотра
up - вверх на одну строку
down - вниз на одну строку
left - влево на один символ (сдвигать все строки)
right - вправо на один символ (сдвигать все строки, позволяя увидеть символы, изначально находящиеся за пределами области отображения текста)
home - в начало текста
end - в конец текста
PgUp - на страницу вверх
PgDn - на страницу вниз

_________________
Мне бы только мой крошечный вклад внести,
За короткую жизнь сплести
Хотя бы ниточку шёлка.
fleur


Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
 Заголовок сообщения: Re: *простой текстовый viewer
СообщениеДобавлено: Вт июл 02, 2013 16:38 
Не в сети

Зарегистрирован: Ср фев 17, 2010 18:10
Сообщения: 322
Откуда: Тверь
Благодарил (а): 13 раз.
Поблагодарили: 10 раз.
Код:
\ Просмотрщик FORTH файлов. Использует цвет для отображения комментариев.
\ Использует Qt библиотеку.
\ MGW 21.01.11

REQUIRE MGW ~mgw/qtlib.f       // Поддержка QT

// В программе много лишних определений, т.к. пришлось изменить алгоритм на ходу.
// В начале я пытался форматировать текст через теги HTML, но при таком подходе
// убираются все ведущие пробелы. От такого форматирования остался только тег HR.
// Раскраска осуществляется втроенным объектом QT. Интересно то, что текст можно редактировать
// прямо в окне (без сохранения) и при этом вся подсветка синтаксиса сохраняется.
// Надо проверить возможность вставки выпад списка, а вообще так и до IDE не далеко ....
// -----------------------------------------------
// Добавлено меню, горячие кнопки. Подключена возможность работы с различными
// кодировками.


fQApplication  NEW app1          // Ссылка на QApplicatin (обязательно)

fQString      NEW qs1     // Строка   - сообщение об ошибке, основная строка

fQString      NEW qKom2   // :
fQString      NEW qKom3   // :
fQString      NEW qHR3    // Шаблон замены 
fQMessageBox  NEW box1    // Окно информации

fQMessageBox  NEW boxviewPath    // Окно для строки с полным путем

fQString      NEW qsTMP   // Строка QString для вывода информации в окно
fQTextEdit    NEW te1     // ЭкранныйРедактор
fQFont        NEW font1   // Шрифт
fQFont        NEW font2   // Шрифт
fSyntaxHL     NEW higl1   // Раскраска текста
fQString      NEW qsTMP2  // Строка QString для вывода информации в окно
fQColor       NEW color1
fQColor       NEW color2
fQChar        NEW qcTek
fQChar        NEW qcTek-1
fQChar        NEW qcTek+1
// --------------------- 2 версия ------ строка сообщений + меню -------

if=W Library@ msvcrt 2 CDECL-Call" strcpy" strcpy // ( Aоткуда Aкуда -- ) Копировать strz
if=L Library@   libc 2 CDECL-Call" strcpy" strcpy // ( Aоткуда Aкуда -- ) Копировать strz
// Функции для вычисления имен файлов
if=W  Library" kernel32.dll" kernel32
if=W  Library@ kernel32 3 WINAPI-Call" GetLongPathNameA" GetLongPathName
if=W  Library@ kernel32 4 WINAPI-Call" GetFullPathNameA" GetFullPathName

0x4000000   CONSTANT     Qt:ControlModifier
0x51        CONSTANT     Qt:Key_Q
0x47        CONSTANT     Qt:Key_G
0x1000000   CONSTANT     Qt:KeyEsc
0x1000030   CONSTANT    Qt:Key_F1
0x1000031   CONSTANT    Qt:Key_F2
0x1000032   CONSTANT    Qt:Key_F3
0x1000033   CONSTANT    Qt:Key_F4

fQMainWindow  NEW wc1
fQStatusBar   NEW sb1
fQMenuBar     NEW menubar1

fQAction      NEW actDOS866
fQAction      NEW actWin1251
fQAction      NEW actUTF8
fQAction      NEW actKOI8R
fQAction      NEW actExit
fQAction      NEW actAboutQT
fQAction      NEW actAbout
fQAction      NEW actviewPath

fQMenu         NEW menuКодировка
fQMenu         NEW menuAbout

fQDialog       NEW aboutDialog
fQTextEdit     NEW aboutText
fQLayout       NEW aboutLayout
fQDialog       NEW viewPath
fQTextEdit     NEW viewPathText
fQLayout       NEW viewPathLayout

256 CONST$ strbuf       // Буфер под прочитанную строку
256 CONST$ NameFile     // Строка под имя файла
VARIABLE fid            // Идентификатор открытого файла

// Буфера для преобразования имен файлов
256 CONSTANT РазмерБуфераИмениФайла
РазмерБуфераИмениФайла CONST$ ВходноеИмяФайла
РазмерБуфераИмениФайла CONST$ ВыходноеИмяФайла
VARIABLE АдресИмяФайла

: msgboxError   // ( Astr u -- ) Отобразить сообщение об ошибке
   DROP qsTMP.set qsTMP.@ S" Внимание ошибка!" DROP qs1.set qs1.@
   1                           // Количество кнопок (см докум по QMessageBox)
   3                           // 3=Критическое 1=информ 2=внимание 4=вопрос
   0 // te1.@                  // Родитель для окна сообщения
   box1.msgbox DROP
   ;

VARIABLE isChange      // Была замена?

: TYPE_te1 // Вот оно, форматирование HTML
   qs1.set                               // Базовая стока в qs1
   FALSE isChange !
   0 qKom3.@ qs1.indexOf DUP
   0<  IF                                // Не найдено
              DROP
       ELSE                              // Найдено
              DUP 0 = IF
                           isChange @  // а замена уже была?
                           IF          // да была замена
                           ELSE
                               S" <hr></hr>" DROP qs1.set
                               strbuf qsTMP.set qsTMP.@ qs1.append
                               TRUE isChange !
                           THEN
                           // 2 0 qHR3.@ qs1.replace   
                      ELSE     
                      THEN DROP
       THEN
   0 qKom2.@ qs1.indexOf DUP
   0<  IF                                // Не найдено
              DROP
       ELSE                              // Найдено
      isChange @  // а замена уже была?
      IF          // да была замена
      ELSE
          S" <hr></hr>" DROP qs1.set
          strbuf qsTMP.set qsTMP.@ qs1.append
          TRUE isChange !
      THEN
                DROP
       THEN
   qs1.@ te1.append                      // Строку в окно te1
   ;

: ОбработатьФайл     // ( -- ) Под влиянием обсуждения на форуме, русский в именах
  NameFile COUNT R/O OPEN-FILE      // Открываем файл
  0= IF fid !                       // Если нет ошибки открытия файла, то запоминаем его хендл
        // Проверим работу кодовой таблицы
        // Поддерживаются: IBM 866, KOI8-R, UTF-8, Windows-1251, UTF-16 и ещё штук 20.

        NameFile 1+ qsTMP.set qsTMP.@ wc1.setwindowtitle
        NameCodec$ qsTMP.set qsTMP.@ sb1.setMes

        BEGIN
            strbuf 255 fid @ READ-LINE
            0<> IF S" Ошибка чтения файла ->  " strbuf A>CS
                 strbuf NameFile COUNT CS+A strbuf COUNT msgboxError BYE
                THEN
        WHILE                                 // Если чтение строки =TRUE
               DUP 0 > IF
                   DUP 1- strbuf + C@ 32 < IF 1- THEN
               THEN
               strbuf + 0 SWAP C!             // Запишем 0 в конец прочитанной строки
               strbuf TYPE_te1                // Строку в окно
        REPEAT DROP           
        fid @ CLOSE-FILE 0<> IF S" Ошибка закрытия файла ->  " strbuf A>CS
                                   strbuf NameFile COUNT CS+A strbuf COUNT msgboxError BYE THEN
        NameFile COUNT DROP qsTMP.set qsTMP.@ te1.setwindowtitle  // Имя файла в заголовок окна
     ELSE
        DROP S" Ошибка открытия файла ->  " strbuf A>CS
                                   strbuf NameFile COUNT CS+A strbuf COUNT msgboxError BYE
     THEN
  ;

VARIABLE ДлинаСтроки 
VARIABLE БылКомментарий          // N - да, был -1 нет 
VARIABLE БылаКавычка             // N - да, был -1 нет 
VARIABLE ТекСимвол

: ТекущийСимвол    // ( Nпозиции -- Char ) Выдать след символ за позицией в строке
   qcTek+1.@ qsTMP2.at qcTek+1.unicode
   ;
: ФорматируемСтроку  // ( НачПоз Длин -- )
   // 2DUP font2.@  higl1.formatFont  // мда, и цвет и шрифт одно и тоже :( а зря ..
   // по одному и тому же участку нельзя применять несколько форматов
   color1.@ higl1.formatColor
   ;
:NONAME    // ( Aqstr -- ) Обработчик раскраски
  qsTMP2.!                                 // Схватили параметр (строку) из Qt
  -1 БылКомментарий !
  -1 БылаКавычка !
  qsTMP2.length ДлинаСтроки !
  ДлинаСтроки @ 0= IF qsTMP2.@ EXIT THEN   // строка пустая, уйди в C++, положив возврат

  ДлинаСтроки @ 0 DO
      I ДлинаСтроки @ = IF S" I=N" _3W _3 THEN
      I qcTek.@ qsTMP2.at qcTek.unicode ТекСимвол !    // Взяли текущий символ
      // Ловим '\'
      ТекСимвол @
      92 = IF                                          // Это '\'
              I 1+ ДлинаСтроки @ < IF
                     I 1+ ТекущийСимвол
                                   ELSE  0  // ( в послед позиции строки
                                   THEN
         33 < IF                                  // След сим пробел
                 I 0 > IF  // ком но не в первой позиции
                           I 1- ТекущийСимвол
            33 < IF
                           I ДлинаСтроки @ ФорматируемСтроку
                          LEAVE
                 ELSE
                 THEN
             ELSE
                // Точно коментарий, стоящий в начале строки
                0 ДлинаСтроки @ ФорматируемСтроку
                LEAVE
             THEN
              ELSE                                 // Привычка писать ELSE THEN сразу
         THEN                                 // меньше ошибок и проще найти алтер. ветку
           ELSE
      THEN
      // Ловим '//'
      ТекСимвол @
      47 = IF                                                 // Это '/'
              I 1+ ДлинаСтроки @ < IF
                     I 1+ ТекущийСимвол
                                ELSE  0  // ( в послед позиции строки
                                THEN
         47 = IF                                         // След сим /
              I 2 + ДлинаСтроки @ < IF
                     I 2 + ТекущийСимвол
                                ELSE  32  // ( в послед позиции строки
                                THEN
            33 < IF
                 I 0 > IF  // ком но не в первой позиции
                           I 1- ТекущийСимвол
            33 < IF
                           I ДлинаСтроки @ ФорматируемСтроку
                          LEAVE
                 ELSE
                 THEN
             ELSE
                // Точно коментарий, стоящий в начале строки
                0 ДлинаСтроки @ ФорматируемСтроку
                LEAVE
             THEN
                 ELSE
            THEN
              ELSE
         THEN
           ELSE
      THEN
      // Ловим '('
      ТекСимвол @
      40 = IF                                                 // Это '('
              I 1+ ДлинаСтроки @ < IF
                     I 1+ ТекущийСимвол
                                ELSE  32  // ( в послед позиции строки
                                THEN
         33 < IF                                         // След сим пробел
                 I 0 > IF  // ком но не в первой позиции
                           I 1- ТекущийСимвол
            33 < IF    // Комм не в пер поз
                     I БылКомментарий !
                 ELSE
                 THEN
             ELSE
                // Точно коментарий, стоящий в начале строки
            0 БылКомментарий !
             THEN
              ELSE
         THEN
           ELSE
      THEN
      // Ловим ')'
      ТекСимвол @
      41 = IF                                                 // Это ')'
              I 1+ ДлинаСтроки @ < IF
                     I 1+ ТекущийСимвол
                                ELSE  32  // ( в послед позиции строки
                                THEN
         33 < IF                                         // След сим пробел
                 I 0 > IF  // ком но не в первой позиции
                           I 1- ТекущийСимвол
            33 < IF    // Комм не в пер поз
                    БылКомментарий @ -1 >
               IF
                            БылКомментарий @ DUP I SWAP - 1+ 
                                          ФорматируемСтроку
                 -1 БылКомментарий !
               ELSE
               THEN
                 ELSE
                 THEN
             ELSE
             THEN
              ELSE
              I 1+ ДлинаСтроки @ = IF
                БылКомментарий @ DUP I SWAP - 1+ ФорматируемСтроку
                         THEN
         THEN
           ELSE
      THEN
      // Ловим ' " '
      ТекСимвол @
      34 = IF                                                 // Это ' " '
          БылаКавычка @ -1 >
     IF                                                  // Да была
        БылаКавычка @ DUP I SWAP - 1+ color2.@ higl1.formatColor
             -1 БылаКавычка ! // Сбросить признак кавычки
     ELSE
              I 1+ ДлинаСтроки @ < IF
                     I 1+ ТекущийСимвол
                                ELSE  0  // Это не кавычка
                                THEN
         32 = IF                                         // След сим Кав
                  I БылаКавычка !
              ELSE
         THEN
        I БылаКавычка !
     THEN
      THEN
  LOOP

  qsTMP2.@
  ; 1 CELLS CALLBACK: onHLparser
VARIABLE aonHLparser ' onHLparser aonHLparser !

: str->qstr DROP qsTMP.set qsTMP.@ ;

// aonviewPath
:NONAME
  NameFile 1+ ВходноеИмяФайла COPYZ  // Имя во входной параметр
  // Вызовем WINAPI функцию для опред полного пути
  АдресИмяФайла ВыходноеИмяФайла РазмерБуфераИмениФайла ВходноеИмяФайла GetFullPathName DROP
  // Заберем вычесленный полный путь и имя
  ВыходноеИмяФайла 0 str->qstr viewPathText.append
  viewPath.exec DROP
  ; 0 CELLS CALLBACK: onviewPath
VARIABLE aonviewPath ' onviewPath aonviewPath !

// aonAboutQt
:NONAME
  S" view.f (v2.0) использует:" DROP qsTMP set qsTMP @ 0 box1.aboutQt
  ; 0 CELLS CALLBACK: onAboutQt
VARIABLE aonAboutQt ' onAboutQt aonAboutQt !

// About view.f
:NONAME
  aboutDialog.exec DROP ; 0 CELLS CALLBACK: onAbout
VARIABLE aonAbout ' onAbout aonAbout !

: ПереключитьКодировку // ( Astr N -- )
   DROP NameCodec$ strcpy DROP // Скопируем символьную строку в глобальный адрес.
   te1.clear   ОбработатьФайл     te1.cursorStart             
   ;

// aonKOI8-R
:NONAME   S" KOI8-R" ПереключитьКодировку  ; 0 CELLS CALLBACK: onKOI8-R
VARIABLE aonKOI8-R ' onKOI8-R aonKOI8-R !
   
// aonUTF-8
:NONAME   S" UTF-8" ПереключитьКодировку  ; 0 CELLS CALLBACK: onUTF-8
VARIABLE aonUTF-8 ' onUTF-8 aonUTF-8 !
   
// aonDOS866
:NONAME   S" IBM 866" ПереключитьКодировку  ; 0 CELLS CALLBACK: onDOS866
VARIABLE aonDOS866 ' onDOS866 aonDOS866 !

// aonWin1251
:NONAME   S" Windows-1251" ПереключитьКодировку  ; 0 CELLS CALLBACK: onWin1251
VARIABLE aonWin1251 ' onWin1251 aonWin1251 !

// aonExit
:NONAME
  BYE ; 0 CELLS CALLBACK: onExit
VARIABLE aonExit ' onExit aonExit !

: aboutAddStr str->qstr aboutText.append ;
: СоздатьМеню_и_СтатусБар  // ( -- )
   wc1.create       // Главное окно
   wc1.@ sb1 create // создадим СтатусСтрока

   // Подпункты меню
   wc1.@ actWin1251.create S" Win-1251" str->qstr actWin1251.setText
   Qt:Key_F1 actWin1251.setHotKey   aonWin1251 @ actWin1251.onClick

   wc1.@  actDOS866.create S" DOS-866"  str->qstr  actDOS866.setText
   Qt:Key_F2 actDOS866.setHotKey   aonDOS866 @ actDOS866.onClick

   wc1.@    actUTF8.create S" UTF-8"    str->qstr    actUTF8.setText
   Qt:Key_F3 actUTF8.setHotKey   aonUTF-8 @ actUTF8.onClick

   wc1.@   actKOI8R.create S" KOI8-R"   str->qstr   actKOI8R.setText
   Qt:Key_F4 actKOI8R.setHotKey  aonKOI8-R @ actKOI8R.onClick

   wc1.@   actAbout.create S" О Программе"   str->qstr   actAbout.setText
   aonAbout @   actAbout.onClick
   wc1.@   actAboutQT.create S" О Qt"   str->qstr   actAboutQT.setText
   Qt:ControlModifier
   Qt:Key_Q + actAboutQT.setHotKey aonAboutQt @   actAboutQT.onClick

   wc1.@  actviewPath.create S" полный путь файла" str->qstr actviewPath.setText
   Qt:ControlModifier
   Qt:Key_G + actviewPath.setHotKey aonviewPath @ actviewPath.onClick

   wc1.@   actExit.create S" Выход"   str->qstr   actExit.setText
   Qt:KeyEsc actExit.setHotKey   aonExit @ actExit.onClick

   // Главная строка меню
   wc1.@ menuКодировка.create S" Кодировка" str->qstr menuКодировка.setTitle
   wc1.@ menuAbout.create S" Справка" str->qstr menuAbout.setTitle
   
   // Добавим подпункты меню в "Кодировка"
   actWin1251.@ menuКодировка.addAction
   actDOS866.@ menuКодировка.addAction
   actUTF8.@ menuКодировка.addAction
   actKOI8R.@ menuКодировка.addAction

   // Добавим подпункты меню в "Справка"
   actAbout.@ menuAbout.addAction
   actAboutQT.@ menuAbout.addAction
   actviewPath.@ menuAbout.addAction
                menuAbout.addSep
   actExit.@ menuAbout.addAction
   
   wc1.@ menubar1.create
   menuКодировка.@ menubar1.addMenu
   menuAbout.@ menubar1.addMenu

   // Делаем диалог для полного имени файла
   0 wc1.@ viewPath.create
   500 40 viewPath.resize
   S" Полный путь редактируемого файла" DROP qsTMP.set qsTMP.@ viewPath.setwindowtitle
   viewPathLayout.createV viewPathText.create viewPathText.@ viewPathLayout.addWidget
   viewPathLayout.@ viewPath.setlayout

   // Делаем окно диалога для About
   0 wc1.@ aboutDialog.create   400 140 aboutDialog.resize
   S" About view ..." DROP qsTMP.set qsTMP.@ aboutDialog.setwindowtitle
   aboutLayout.createV     // Вертикальный выравниватель
   aboutText.create aboutText.@ aboutLayout.addWidget
   aboutLayout.@ aboutDialog.setlayout

   // Установим надпись на About
   S| <font color=red size=5>view.f</font> (v2.3) просмотр исходных текстов форта.| aboutAddStr
   S| Написана на <B>SPF 4.20 + Qt (~mgw\qtdlib.f)</B> для демонстрации работы SPF с Qt.| aboutAddStr
   S| Работает в <font color=blue>Windows</font> и <font color=blue>Linux</font>.| aboutAddStr
   S| <B>mgw</B> - 15.02.2011 | aboutAddStr
   ;

:NONAME  // ( Aapp -- )  // Главная процедура работы с QT. main() в примерах на С++
  app1.create            // Запомнить указатель на Application
  initDebug3             // Инициализировать отладчик _3, он определен в FQT
                         // применение SWAP _3 ( смотрим стек и переменные ) DROP ...
// ---------- Тело программы ----------------
  0 БылКомментарий !
  0 ДлинаСтроки !
 
  qsTMP.create     //
  qsTMP2.create     //
  box1.create      //
  font1.create
  font2.create
  color1.create
  color2.create
  qcTek.create qcTek+1.create qcTek-1.create

  qs1.create       // создадим QString

  // Попытка форматировать через HTML, но не получилось, т.к уничтож ведущие пробелы
  qKom2.create   S" :NONAME" DROP qKom2.set
  qKom3.create   S" : " DROP qKom3.set
  qHR3.create    S" <hr>:" DROP qHR3.set 
 
  te1.create       // создадим QTextEdit
  // Формируем шрифты
if=W  S" Lucida Console" DROP qsTMP.set qsTMP.@ font1.setFamily 10 font1.setPointSize
if=L  S" DejaVu Sans Mono" DROP qsTMP.set qsTMP.@ font1.setFamily 10 font1.setPointSize
  S" Lucida" DROP qsTMP.set qsTMP.@ font2.setFamily 14 font2.setPointSize
  font1.@ te1.setFont
  // Формируем цвета для раскраски
  255 155 155 0 color1.setRGB   // A B G R  - Комментарий
  255 0 50 255 color2.setRGB    // A B G R  - Строки

  te1.document higl1.create     // вычленим из редактора раскраску
 
  aonHLparser @ higl1.onParser  // Жуть ... обработчик на раскраску синтаксиса ... Qt-это супер!!!
 
if=W  GetCommandLineA ASCIIZ> args DROP
if=L    2  \ Моделирование параметров на входе ком строки
    2 = IF             
      qsTMP.@ 1 app1.narg NameFile qsTMP.text // Забрать из комманд строки имя файла
      СоздатьМеню_и_СтатусБар
      menubar1.@ wc1.setMenuBar
      sb1.@ wc1.setStatusBar
      te1.@ wc1.setCentralWidget
     
      700 800 wc1.resize                       // Размер окна
      10 10 wc1.move                           // Где нарисовать
      ОбработатьФайл
      te1.cursorStart             
      wc1.show                                 // Отобразить окно
        ELSE
    S" usage: view.exe file.f" msgboxError
        BYE
        THEN
 
// ---------- Конец программы ----------------

  app1.@                          // Положить на стек параметр из SO
  0                               // возвращаемое значение (треб SPF)
  ; 1 CELLS CALLBACK: onForth     // Сработает на CR в le1:QLineEdit
VARIABLE aonForth ' onForth aonForth !

// Главная функция
: run
if=W    LibraryLoad user32
if=W    LibraryLoad msvcrt           // Проверка на доступность, нужна для QtGui
if=L    LibraryLoad libc   
if=W    LibraryLoad mingwm10         // Проверка на доступность, нужна для QtGui
if=W    LibraryLoad kernel32         // Работа с именами файлов
    LibraryLoad QtGui
    LibraryLoad QtCore
    LibraryLoad libfqt
if=L    aonForth @ ARGV ARGC фСоздатьПриложение
if=W    aonForth @ GetCommandLineA ASCIIZ> args SWAP фСоздатьПриложение
    DROP
    BYE
    ;

\ run

// \EOF
   
  ' run MAINX !
  S" view.exe" SAVE
  BYE


Вызов из программы на форте:
Код:
: view          // ( Astr N -- ) Вызвать view.exe c аргументом
if=W  DROP 0 SWAP S" view.exe" DROP  S" " DROP 0 5 ShellExecute
if=L  DROP NameFileViewEdit ! fork
if=L  DUP 0 = IF 
if=L             0 NameFileViewEdit @ S" view.exe" DROP S" ./view.exe" DROP 4 execl 
if=L          ELSE
if=L  DUP 0 > IF     ELSE
if=L  DUP     IF  ( perror )      ELSE
if=L  THEN
if=L  THEN
if=L  THEN
      DROP


Всё написано на SPF-4.20 Сам текст программы мультиплатформенный (Windows 32 и Linux 32)


Последний раз редактировалось mgw Вт июл 02, 2013 17:06, всего редактировалось 2 раз(а).

Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
 Заголовок сообщения: Re: *простой текстовый viewer
СообщениеДобавлено: Чт июл 04, 2013 08:56 
Не в сети
Moderator
Moderator
Аватара пользователя

Зарегистрирован: Чт май 04, 2006 00:53
Сообщения: 4831
Откуда: был Крым, теперь Новосибирск
Благодарил (а): 18 раз.
Поблагодарили: 52 раз.
написано для форка используемая версия 4-mc10-b750.

source file: view.fts
\ 02.07.2013 ~mOleg
\ Copyright [C] 2013 mOleg mOlegg@ya.ru
\ простой просмотрщик текстовых файлов

vocs/ unit.fts
vocs/ struct.fts
os/ heap.fts
os/ console.fts
os/ ccon.fts
branch/ for-next.fts
memory/ buff.fts

ALSO HIDDEN
ALIAS EKEY SYSKEY
ALIAS EKEY? key?
PREVIOUS

vocs/ unit.fts

Unit: key'

F: esc 0x101001B ;F
F: up 0x1480000 ;F
F: dn 0x1500000 ;F
F: left 0x14B0000 ;F
F: right 0x14D0000 ;F

F: home 0x1470000 ;F
F: end 0x14F0000 ;F
F: pgup 0x1490000 ;F
F: pgdn 0x1510000 ;F
EndUnit


Unit: View{

USER 1stLine \ первая линия текста
USER LastLine \ последняя линия текста
USER TopLine \ первая отображаемая линия текста

70 VALUE Width \ ширина рабочей области экрана
0 VALUE Displ \ смещение первого отображаемого символа от начала строки
0 VALUE Up \ положение первого символа окна просмотра слева
0 VALUE Top \ и сверху
25 VALUE Height \ высота рабочей области экрана
255 VALUE MaxWidth \ максимальная длина строки

\ каждая линия хранится отдельно
0 Struct: line
Addr[] off_prev \ ссылка на предыдущую линию текста
Addr[] off_next \ ссылка на следующую линию текста
Cell[] off_size \ длина строки
Zero[] off_body \ начало текста
EndStruct

\ получить указатель на следующую линию текста
: next ( str --> str | nil ) line off_next A@ ;

\ задать ссылку str2 на следующую строку str1
: !next ( str1 str2 --> ) line off_next A! ;

\ получить указатель на предыдущую линию текста
: prev ( str --> str | nil ) line off_prev A@ ;

\ задать ссылку str2 на предыдущую строку str1
: !prev ( str1 str2 --> ) line off_prev A! ;

\ вернуть начало a2 и a1 конец строки ?
: str> ( str --> asc # )
DUP line off_size @
SWAP line off_body SWAP ;

\ создать новую запись в хипе, скопировать туда содержимое строки ?
: new ( asc # --> str )
DUP line /size + BLOCK >L
TUCK L@ line off_body SWAP CMOVE
L@ line off_size !
nil L@ !prev
nil L@ !next
L> ;

\ добавить строку в конец текста
: push ( str --> )
LastLine A@ OVER !prev
DUP LastLine A@ !next
LastLine A! ;

\ задать начальное состояние
: set ( str --> ) DUP 1stLine A! DUP LastLine A! TopLine A! ;

\ добавить строку в конец списка строк
: add ( str --> ) 1stLine @ IF push ;THEN set ;

\ пропустить u символов с начала строки
: skip ( asc # u --> a1 a2 )
>L OVER + SWAP
BEGIN DDUP > WHILE
L@ WHILE
-1 L+ C+
REPEAT
THEN LDROP ;

\ преобразовать ограниченную a1, a2 строку в строку длиной # символов
\ при необходимости дополненную в конце пробельными символами
: form ( a1 a2 # --> asc # )
<| >L BEGIN L@ WHILE
DDUP > WHILE
-1 L+
DUP C@ KEEP C+
REPEAT
BEGIN L@ WHILE Bl_ KEEP -1 L+ REPEAT
THEN
DDROP LDROP
|> ;

\ подготовить строку addr для отображения
\ u - смещение от начала строки, # - количество символов для отображения
: prep ( # u asc # --> asc # )
ROT skip ROT form TYPE ;

\ отобразить текст в окне начиная с позиции up top размером width height
\ текст сместить от начала строк на x позиций
: show ( width disp TopLine up top height --> )
FOR DDUP setxy D>L
THRID THRID THRID
IF THRID str> prep next
ELSE s" " prep
THEN
DL> 1 +
TILL 5 nDROP ;

\ загрузка строк из файла
: load ( asc # --> )
FILE>HEAP IFNOT ERROR" Invalid file name!" THEN
OVER >L
<: BOUNDS SWAP
BEGIN DDUP < WHILE
DDUP EOL> -ROT THRID ROT TUCK - LTL @ - 0 MAX
new add
REPEAT DDROP
;> CATCH
L> FREE DROP
THROW ;

\ освободить занимаемую память
: free ( 1stLine --> )
A@ BEGIN *WHILE DUP next SWAP FREE DROP REPEAT DROP
nil set ;

\ сместить окно на одну линию вверх
: TopUp ( --> ) TopLine A@ prev *IF TopLine A! ELSE DROP THEN ;

\ сместить окно на одну линию вниз
: TopDn ( --> ) TopLine A@ next *IF TopLine A! ELSE DROP THEN ;

\ на одну страницу вверх
: PgUp ( --> ) Height FOR TopUp TILL ;

\ на одну страницу вниз
: PgDn ( --> ) Height FOR TopDn TILL ;

\ обработка событий нажатий клавиш
: reflex ( key --> )
CASE key' esc OF ERROR" Ok." ENDOF
key' dn OF TopDn ENDOF
key' up OF TopUp ENDOF
key' right OF Displ 1 + MaxWidth Width - MIN TO Displ ENDOF
key' left OF Displ 1 - 0 MAX TO Displ ENDOF
key' pgup OF PgUp ENDOF
key' pgdn OF PgDn ENDOF
key' home OF 1stLine A@ TopLine A! ENDOF
key' end OF LastLine A@ TopLine A! ENDOF
DROP
ENDCASE ;

\ отобразить страницу текста в окне
: ~Page ( --> ) Width Displ TopLine A@ Up Top Height show ;

\ главный рабочий цикл
:> Viewer ( --> ) ~Page BEGIN key? IF SYSKEY reflex ~Page THEN 10 PAUSE AGAIN ;

F: } ;F

EndUnit

\ отобразить содержимое указанного файла
: VIEW ( asc # --> )
View{ DDUP ~title load
HideCur
width TO Width height 1 - TO Height
Viewer CATCH DROP 1stLine free
ShowCur
} ;

_________________
Мне бы только мой крошечный вклад внести,
За короткую жизнь сплести
Хотя бы ниточку шёлка.
fleur



За это сообщение автора mOleg поблагодарил: vikt
Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
 Заголовок сообщения: Re: *простой текстовый viewer
СообщениеДобавлено: Чт июл 04, 2013 09:18 
Не в сети
Аватара пользователя

Зарегистрирован: Чт дек 31, 2009 18:36
Сообщения: 1987
Откуда: Питер
Благодарил (а): 13 раз.
Поблагодарили: 33 раз.
Цитата:
Он показал нам блок-схему программы, предназначавшейся для решения этой задачи, но стрелки, которые вели от одного квадратика к другому, были так беспорядочно расположены, что мы оба решили не рассматривать это решение (если оно было решением, что мы так и не смогли выяснить!).

Цитата:
[Нужны ли константы клавиш?]
Ответ зависит от того, считаете ли Вы, что другим компонентам надо будет "знать" числовое значение, связанное с каждой клавишей. Чаще этого "не" требуется. Простая, более компактная форма здесь поэтому предпочтительнее. Также в первой версии [с константами] добавление нового кода клавиши потребует изменений в двух местах.

А, если серьезно, я вижу несколько важных ошибок:
1. Программа написана не на Forth, а на плохом C (с механической заменой операторов на слова). Коробит, наше отношение к Броуди. Мы его чтим, но то, что он писал, пропускаем мимо ушей.
2. Программа, очевидно, очень сильно ОС-зависима (ср. мое решение), но эти зависимости в решении не обособлены.
3. Разбиение на слова было произведено по-чайниковски: по командам интерфейса, а не по правилам организации вычислений и/или доказательства корректности.
4. Заодно видны недостатки выбранного средства программирования: обилие не нужных для решения танцев с бубном. Зачем писать сверхмощный Forth, если половина листинга полностью состоит из его настроек? Был бы умный, сам бы настроился.

_________________
Когда я говорю "понимаю" - это не значит, что я согласен, не значит, что я понимаю и вообще не значит, что я слушаю тебя. /Чарли, "2 1/2 человека"/


Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
 Заголовок сообщения: Re: *простой текстовый viewer
СообщениеДобавлено: Пт июл 05, 2013 13:11 
Не в сети

Зарегистрирован: Ср июл 05, 2006 14:44
Сообщения: 231
Благодарил (а): 0 раз.
Поблагодарили: 7 раз.
используем для реализации просмотрщика сторонние (html,hta) технологии,
так как поведение на стрелки, начало и конец и листание страниц
такое-же как и требуется. заданный файл обернем в начале и в конце
заготовленными фрагментами для формирования приложения view.hta
при копировании строк исходного файла дополним их hnml символами перевода строки
решение не соответствует полностью заданию, так нет выхода по ESC
но оно здесь и не надо, так как действует как независимое приложение и
закрывается штатно. написано на SPF4, под win.
Код:
mutex.f
process.f
locals.f
str5.f

: VIEW { a u \ buf inpfile outfile -- }
500 ALLOCATE THROW -> buf
a u R/O OPEN-FILE-SHARED THROW -> inpfile
S" view.hta" R/W  CREATE-FILE THROW -> outfile
"
<html>
<head>
<SCRIPT language={''}javascript{''}>
document.onkeydown = function(event){ S' {' }
  events = event || window.event;
  if (events.keyCode == 27) { S' {' }
  window.close();}}
window.resizeTo (480,240);
window.moveTo((screen.width-480)/2,(screen.height-240)/2);
</SCRIPT>
<hta:application id=v_i_e_w applicationName=view
maximizeButton=yes border=thin innerBorder=no
selection=no contextMenu=no singleinstance=yes  WINDOWSTATE={''}normal{''} />
<title>   V I E W  </title>
</head>{CRLF}<body>"  DUP STR@ outfile WRITE-FILE THROW  STRFREE

BEGIN
buf 500 inpfile READ-LINE THROW
WHILE
buf SWAP outfile WRITE-FILE THROW  S" <br>" outfile WRITE-FILE THROW  LT 2 outfile WRITE-FILE THROW
REPEAT  DROP inpfile CLOSE-FILE THROW

" </body>{CRLF}</html>" DUP STR@ outfile WRITE-FILE THROW  outfile CLOSE-FILE THROW STRFREE
S" cmd.exe /c view.hta" StartApp THROW DROP
;


Последний раз редактировалось Alex Пт июл 05, 2013 19:55, всего редактировалось 1 раз.

Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
 Заголовок сообщения: Re: *простой текстовый viewer
СообщениеДобавлено: Пт июл 05, 2013 14:55 
Не в сети
Moderator
Moderator
Аватара пользователя

Зарегистрирован: Чт май 04, 2006 00:53
Сообщения: 4831
Откуда: был Крым, теперь Новосибирск
Благодарил (а): 18 раз.
Поблагодарили: 52 раз.
Alex писал(а):
используем для реализации просмотрщика сторонние

Смысл задания не в том, чтоб вызывать сторонний компонент, а чтобы использовать штатные.

_________________
Мне бы только мой крошечный вклад внести,
За короткую жизнь сплести
Хотя бы ниточку шёлка.
fleur


Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
 Заголовок сообщения: Re: *простой текстовый viewer
СообщениеДобавлено: Пт июл 05, 2013 16:12 
Не в сети
Аватара пользователя

Зарегистрирован: Чт дек 31, 2009 18:36
Сообщения: 1987
Откуда: Питер
Благодарил (а): 13 раз.
Поблагодарили: 33 раз.
mOleg писал(а):
Смысл задания не в том, чтоб вызывать сторонний компонент, а чтобы использовать штатные.
Вы что-то путаете. В Вашем задании про это - ни слова. (Про "смысл" - это, пожалуйста, в мое задание). Поэтому в решении коллеги Alex, как и у меня, задача решается минимумом затрат, что можно только приветствовать.
(Разве что, имело заменить тег <br> на <pre>).

Раздражает только опять наличие плясок с бубном. И, заметьте, это при 4-х подключенных либах. Forth-у в листинге и места не находится.

Оффтоп. Когда-то я поминал 6 этапов разработки программы по Кнуту. Видимо, каждый программист подсознательно тяготеет к одному из этапов, начиная со временем остальные считать чем-то второстепенным. Любители сверхмощных ОО и прочих визуальных монстров, которые мы здесь наблюдаем, очевидно, тяготеют к пункту (4) - "Начальные установки".

_________________
Когда я говорю "понимаю" - это не значит, что я согласен, не значит, что я понимаю и вообще не значит, что я слушаю тебя. /Чарли, "2 1/2 человека"/


Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
 Заголовок сообщения: Re: *простой текстовый viewer
СообщениеДобавлено: Пт июл 05, 2013 16:24 
Не в сети
Moderator
Moderator
Аватара пользователя

Зарегистрирован: Чт май 04, 2006 00:53
Сообщения: 4831
Откуда: был Крым, теперь Новосибирск
Благодарил (а): 18 раз.
Поблагодарили: 52 раз.
gudleifr писал(а):
В Вашем задании про это - ни слова.

Вполне достаточно выхода по 'ESC' - как вы уже заметили в стандартных компонентах этого нет.

gudleifr писал(а):
пожалуйста, в мое задание

ваше "баба Яга против" мне не интересно в принципе.

gudleifr писал(а):
Поэтому в решении коллеги Alex, как и у меня, задача решается минимумом затрат, что можно только приветствовать.

Задача решается с отступлением от задания, а, значит, не решена.

_________________
Мне бы только мой крошечный вклад внести,
За короткую жизнь сплести
Хотя бы ниточку шёлка.
fleur


Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
 Заголовок сообщения: Re: *простой текстовый viewer
СообщениеДобавлено: Пт июл 05, 2013 16:30 
Не в сети
Аватара пользователя

Зарегистрирован: Чт дек 31, 2009 18:36
Сообщения: 1987
Откуда: Питер
Благодарил (а): 13 раз.
Поблагодарили: 33 раз.
mOleg писал(а):
Задача решается с отступлением от задания, а, значит, не решена.
Как было сказано выше, задача была решена столько раз, что Ваши "перламутровые пуговицы" никому не интересны. (Если угодно, в мое решение выход по Esc втюхать легко. Но зачем?). Это как прийти к спортсменам прыгунам и поставить задачу - прыгать в зеленых кедах. Зачем?

Кстати, вопрос по Вашему решению. Если мы после выполнения вертикального смещения из позиции "в хвостовой части длинной строки" попадаем на фрагмент коротких строк, окно уходит в пустоту или идет влево - пока не найдет текст?

_________________
Когда я говорю "понимаю" - это не значит, что я согласен, не значит, что я понимаю и вообще не значит, что я слушаю тебя. /Чарли, "2 1/2 человека"/


Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
 Заголовок сообщения: Re: *простой текстовый viewer
СообщениеДобавлено: Пт июл 05, 2013 16:42 
Не в сети
Moderator
Moderator
Аватара пользователя

Зарегистрирован: Чт май 04, 2006 00:53
Сообщения: 4831
Откуда: был Крым, теперь Новосибирск
Благодарил (а): 18 раз.
Поблагодарили: 52 раз.
gudleifr писал(а):
Как было сказано выше

Смотрим, в каком разделе находится задача 8)

Если еще остались вопросы, пожалуйста, задавайте их где-нибудь в другом месте, мне на вас нет желания тратить время. Троли мне не симпатичны, в данном разделе я стролями нянчиться не намерен.

_________________
Мне бы только мой крошечный вклад внести,
За короткую жизнь сплести
Хотя бы ниточку шёлка.
fleur


Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
 Заголовок сообщения: Re: *простой текстовый viewer
СообщениеДобавлено: Пт июл 05, 2013 19:58 
Не в сети

Зарегистрирован: Ср июл 05, 2006 14:44
Сообщения: 231
Благодарил (а): 0 раз.
Поблагодарили: 7 раз.
добавил выход по клавише ESC, прошу таки оставить в этой теме, мож кто искать будет
решение, и этот вариант подойдет


Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
 Заголовок сообщения: Re: *простой текстовый viewer
СообщениеДобавлено: Пт июл 05, 2013 20:07 
Не в сети
Moderator
Moderator
Аватара пользователя

Зарегистрирован: Чт май 04, 2006 00:53
Сообщения: 4831
Откуда: был Крым, теперь Новосибирск
Благодарил (а): 18 раз.
Поблагодарили: 52 раз.
Alex писал(а):
мож кто искать будетрешение, и этот вариант подойдет

да, конечно.

_________________
Мне бы только мой крошечный вклад внести,
За короткую жизнь сплести
Хотя бы ниточку шёлка.
fleur


Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
 Заголовок сообщения: Re: *простой текстовый viewer
СообщениеДобавлено: Сб июл 06, 2013 21:13 
Не в сети

Зарегистрирован: Ср июл 05, 2006 14:44
Сообщения: 231
Благодарил (а): 0 раз.
Поблагодарили: 7 раз.
предыдущий вариант не сработает если файл будет с html разметкой
для этого надо делать замену некоторых символов нa подстроки
(вот она цена использования сторонних компонентов - мы не только
подгоняем поведение под требуемое, но и еще готовим для него
правильные входные данные!)
Код:
mutex.f
process.f
locals.f
str5.f
case.f

: VIEW { a u \ buf inpfile outfile -- }
1000 ALLOCATE THROW -> buf
a u R/O OPEN-FILE-SHARED THROW -> inpfile
S" view.tmp" R/W  CREATE-FILE THROW -> outfile
BEGIN
   buf 1000 inpfile READ-LINE THROW
WHILE
  buf + buf ?DO  I C@
                     CASE
                        [CHAR] & OF  S" &amp;"  outfile WRITE-FILE THROW  ENDOF
                        [CHAR] ' OF  S" &apos;" outfile WRITE-FILE THROW  ENDOF
                        [CHAR] " OF  S" &quot;" outfile WRITE-FILE THROW  ENDOF
                        [CHAR] < OF  S" &lt;"   outfile WRITE-FILE THROW  ENDOF
                        [CHAR] > OF  S" &gt;"   outfile WRITE-FILE THROW  ENDOF
                       I 1 outfile WRITE-FILE THROW
                      ENDCASE
            LOOP
  LT 2 outfile WRITE-FILE THROW
REPEAT  DROP
inpfile CLOSE-FILE THROW  outfile CLOSE-FILE THROW  buf FREE THROW
S" cmd.exe /c copy /B head.tmp+view.tmp+tail.tmp /B view.hta > null.tmp" StartAppWait THROW
S" cmd.exe /c view.hta" StartApp THROW DROP
;

содержимое файла head.tmp
Цитата:
<html>
<head>
<SCRIPT language="javascript">
document.onkeydown = function(event){
events = event || window.event;
if (events.keyCode == 27) {
window.close();}}
window.resizeTo (480,240);
window.moveTo((screen.width-480)/2,(screen.height-240)/2);
</SCRIPT>
<hta:application id=v_i_e_w applicationName=view
maximizeButton=yes border=thin innerBorder=no
selection=no contextMenu=no singleinstance=yes WINDOWSTATE="normal"/>
<title> V I E W </title>
</head><body><pre>

содержимое файла tail.tmp
Цитата:
</pre></body></html>


Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
 Заголовок сообщения: Re: *простой текстовый viewer
СообщениеДобавлено: Сб июл 06, 2013 22:54 
Не в сети
Moderator
Moderator
Аватара пользователя

Зарегистрирован: Чт май 04, 2006 00:53
Сообщения: 4831
Откуда: был Крым, теперь Новосибирск
Благодарил (а): 18 раз.
Поблагодарили: 52 раз.
source file: view.fts
\ 02.07.2013 ~mOleg
\ Copyright [C] 2013 mOleg mOlegg@ya.ru
\ простой просмотрщик исходных текстов с расцвечиванием лексем

vocs/ unit.fts
vocs/ struct.fts
os/ heap.fts
os/ console.fts
os/ ccon.fts
branch/ for-next.fts
memory/ buff.fts
\ rel/ keys.fts

ALSO HIDDEN
ALIAS EKEY SYSKEY
ALIAS EKEY? key?
PREVIOUS

Unit: key'

F: esc 0x101001B ;F
F: up 0x1480000 ;F
F: dn 0x1500000 ;F
F: left 0x14B0000 ;F
F: right 0x14D0000 ;F

F: home 0x1470000 ;F
F: end 0x14F0000 ;F
F: pgup 0x1490000 ;F
F: pgdn 0x1510000 ;F
EndUnit


Unit: View{

USER 1stLine \ первая линия текста
USER LastLine \ последняя линия текста
USER TopLine \ первая отображаемая линия текста

70 VALUE Width \ ширина рабочей области экрана
0 VALUE Displ \ смещение первого отображаемого символа от начала строки
3 VALUE Up \ положение первого символа окна просмотра слева
3 VALUE Top \ и сверху
25 VALUE Height \ высота рабочей области экрана
255 VALUE MaxWidth \ максимальная длина строки

\ каждая линия хранится отдельно
0 Struct: line
Addr[] off_prev \ ссылка на предыдущую линию текста
Addr[] off_next \ ссылка на следующую линию текста
Cell[] off_size \ длина строки
Zero[] off_body \ начало текста
EndStruct

\ получить указатель на следующую линию текста
: next ( str --> str | nil ) line off_next A@ ;

\ задать ссылку str2 на следующую строку str1
: !next ( str1 str2 --> ) line off_next A! ;

\ получить указатель на предыдущую линию текста
: prev ( str --> str | nil ) line off_prev A@ ;

\ задать ссылку str2 на предыдущую строку str1
: !prev ( str1 str2 --> ) line off_prev A! ;

\ вернуть начало a2 и a1 конец строки ?
: str> ( str --> asc # )
DUP line off_size @
SWAP line off_body SWAP ;


USER-VALUE cbuff \ временный буфер

\ инициализация буфера
: cinit ( --> buff )
cbuff *IF DUP Clean ;THEN
DROP MaxWidth Buffer DUP TO cbuff ;

\ Выделить лидирующие пробельные символы
: skipsp ( a1 a2 --> a1 a2 str # ) DDUP
BEGIN DDUP > WHILE
DUP C@ ?separator WHILE C+
REPEAT
THEN -ROT DROP DDUP - ;

\ Выделить лидирующие непробельные символы
: nextlx ( a1 a2 --> a1 a2 asc # ) DDUP
BEGIN DDUP > WHILE
DUP C@ ?separator WHILENOT C+
REPEAT
THEN -ROT DROP DDUP - ;

\ выделить из строки подстроку, содержащую пару лексем
: _pair ( a1 a2 asc1 # --> a1 a2 asc1 #1 asc2 # )
DROP >L skipsp DDROP nextlx DDROP DUP L@ - L> SWAP ;

\ выделить из строки подстроку, завершенную указанным символом ch
: _toch ( a1 a2 asc1 # ch --> a1 a2 asc1 #1 asc2 # )
>L DROP >R
BEGIN DDUP > WHILE
DUP C@ L@ <> WHILE C+
REPEAT
THEN C+ DUP R@ - R> SWAP LDROP ;

\ выделить из строки подстроку, завершенную переводом строки
: _eol ( a1 a2 asc1 # --> a1 a2 asc1 #1 asc2 # )
DROP >L
BEGIN DDUP > WHILE
DUP ?NewLine WHILENOT
C+
REPEAT
THEN DUP L@ - L> SWAP ;

\ преобразовать цвет в строку
: c>s" ( color --> x asc # ) 8 LSHIFT SP@ 2 ;

USER-VALUE prevcol \ предыдущий цвет

VOCABULARY CVID \ словарь для хранения списка методов расцветки

\ создание правила расцветки
: rule: ( color fone / name --> ) DUP >L c>s" ALSO CVID THIS [COMPILE] : ;

\ завершение правила расцветки
: ;r ( x asc # --> ) SLIT, DROP [COMPILE] ; DEFINITIONS L> TO prevcol ; IMMEDIATE

\ правило для расцветки одиночных имен
: ones: ( color / name --> ) rule: [COMPILE] ;r ;

\ правило для расцветки пары имен
: pair: ( color / name --> ) rule: COMPILE _pair [COMPILE] ;r ;

\ выполнить над всеми словами до конца строки действие name c параметром color
: All ( color / name lex1 lex2 .. lexN --> )
>L ' >L
<: BEGIN SeeForw NIP WHILE DL@ EXECUTE REPEAT LDROP ;>
Cr_ PARSE ROT EVALUATE-WITH ;

Color{

\
: FONE ( color fone --> ) Fone + ;
( a1 a2 asc1 # --> a1 a2 asc1 #1 asc2 # )
Black Gray FONE : undefcode [ c>s" SLIT, DROP ] ;
Gray Gray FONE : spaces [ c>s" SLIT, DROP ] ;
Green Light Gray FONE : litcode [ c>s" SLIT, DROP ] ;

\ --------------------------------------------------------------------------------------------------

Yellow Gray FONE ones: Yellow
Green Gray FONE ones: Green
Red Gray FONE ones: Red
Gray Light Gray FONE ones: Gray
White Gray FONE ones: Light
White Gray FONE ones: White
Black Gray FONE ones: Black
Brown Gray FONE ones: Brown
Cyan Gray FONE ones: Cyan
Blue Gray FONE ones: Blue
Magenta Gray FONE ones: Magenta

Magenta Gray FONE All ones: ALSO ONLY SEAL DEFINITIONS THIS RECENT PREVIOUS
Magenta Gray FONE All ones: ROOT FORTH HIDDEN NUMBERS

White Gray FONE All ones: BEGIN WHILE WHILENOT *WHILE REPEAT AGAIN UNTIL
White Gray FONE All ones: IF -IF *IF IFNOT ELSE THEN
White Gray FONE All ones: CASE OF uOF ENDOF ENDCASE
White Gray FONE All ones: NOW SINCE FOR TILL NEXT

Gray Light Gray FONE All ones: DUP DROP SWAP OVER NIP TUCK ROT -ROT THRID BOUNDS
Gray Light Gray FONE All ones: DDUP DSWAP DDROP DOVER D+ DEPTH TDROP nDROP SLIT,
Gray Light Gray FONE All ones: @ ! A@ A! C@ C! C+ B@ B! W@ W! +! MAX MIN UMAX UMIN
Gray Light Gray FONE All ones: + - < > <> * / MOD /MOD LSHIFT RSHIFT AND OR XOR
Gray Light Gray FONE All ones: CMOVE BLOCK ALLOCATE FREE SP@ SEARCH-NAME LINK>C
Gray Light Gray FONE All ones: FILE>HEAP PAUSE ORDER CONTEXT CURRENT

Brown Gray FONE All ones: >L L> L@ L+ LDROP DL@ D>L DL>

Yellow Gray FONE All ones: ; ;THEN EXIT <: ;> ;F EndStruct EndUnit ;r

Red Light Gray FONE All ones: >R R> R@ RDROP R+ SP! DR> D>R A>R AR> AR@
Red Light Gray FONE All ones: EXECUTE CATCH THROW IMMEDIATE

Green Light Gray FONE All ones: Bl_ Cr_ Lf_ LTL TRUE FALSE nil

Blue Light Gray FONE All ones: {# <# # #S HOLD HOLDS #> #} <| KEEP KEEPS |>

Yellow Gray FONE All pair: : VARIABLE VALUE VECT USER USER-VALUE USER-VECT
Yellow Gray FONE All pair: Struct: Unit: F: rule: VOCABULARY CONTAINER

Brown
Gray FONE All pair: Cell[] Addr[] Zero[]

Cyan Light Gray FONE All pair: TO IS

Green Light Gray FONE All pair: [COMPILE] WHO [']
Green
Light Gray FONE All pair: rel/ vocs/ os/ branch/ memory/

\ более сложные правила расцветки
Cyan Gray FONE rule: \ _eol ;r \ коментарий до конца строки
Green Light Gray FONE rule: s" [CHAR] " _toch ;r \ однострочные строковые литералы
Blue Gray FONE rule: ( [CHAR] ) _toch ;r \ однострочные стековые коментарии
Red Light Gray FONE rule: ERROR" [CHAR] " _toch ;r \ сообщение об ошибке

RECENT \ -----------------------------------------------------------------------

\ вернуть тег расцветки
: ?color ( a1 a2 asc1 #1 --> a1 a2 asc1 #1 asc2 #2 )
DDUP WHO CVID SEARCH-NAME
*IF LINK>C EXECUTE ;THEN DROP
DDUP [ ALSO HIDDEN ] snNumber [ PREVIOUS ]
CASE 0 OF undefcode ENDOF
1 OF DROP litcode ENDOF
2 OF DDROP litcode ENDOF
ERROR" невозможная ошибка!"
ENDCASE
;

\ преобразовать
: colorify ( asc # --> asc # )
BOUNDS
cinit >L
BEGIN DDUP > WHILE
skipsp *IF spaces L@ >Buffer DROP THEN
L@ >Buffer DROP
nextlx ?color L@ >Buffer DROP
L@ >Buffer DROP
REPEAT DDROP
L> Buffer> ;


\ создать новую запись в хипе, скопировать туда содержимое строки ?
: new ( asc # --> str )
colorify
DUP line /size + BLOCK >L
TUCK L@ line off_body SWAP CMOVE
L@ line off_size !
nil L@ !prev
nil L@ !next
L> ;

\ добавить строку в конец текста
: push ( str --> )
LastLine A@ OVER !prev
DUP LastLine A@ !next
LastLine A! ;

\ задать начальное состояние
: set ( str --> ) DUP 1stLine A! DUP LastLine A! TopLine A! ;

\ добавить строку в конец списка строк
: add ( str --> ) 1stLine @ IF push ;THEN set ;

\ вернуть адрес конца подстроки
: part ( a1 a2 --> a3 )
BEGIN DDUP > WHILE
DUP B@ WHILE
1 +
REPEAT
THEN NIP ;

\ вернуть цвет из начала указанной строки, пропустить цветовую информацию
: @col ( a1 --> a2 c ) 1 + DUP B@ 0:1 D+ ;

\ выделить из начала строки, ограниченной адресами a1 a2 раскрашенную в цвет C подстроку asc #
\ исключить из начала исходной строки выделенную подстроку
: lex ( a1 a2 --> a1 a4 asc # c ) @col >L DDUP part TUCK OVER - L> ;

\ указанное количество пробельных символов фонового цвета
: cSpaces ( # --> ) *IF <# FOR Bl_ HOLD TILL #} spaces DROP 1 + B@ CTYPE ;THEN DROP ;

\ вывести строку asc # в консоль максимально допустимая длина строки s символов
: cType] ( asc # s --> )
>L BEGIN DDUP > WHILE
lex L@ THRID -
-IF DROP NIP L> SWAP CTYPE DDROP ;THEN
LDROP >L CTYPE
REPEAT DDROP
L> cSpaces ;

\ вывести строку asc # в консоль длина отображаемой строки u символов
\ если строка длиннее - обрезать, если короче - дополнить пробелами
: >cType] ( asc # s u --> )
>L -ROT BOUNDS THRID >R
BEGIN DDUP > WHILE
lex L@ THRID -
-IF DROP -ROT L> SKIPn DUP >L R> MIN ROT CTYPE
ROT L> - 0 MAX cType]
;THEN
LDROP >L TDROP
REPEAT RDROP LDROP ROT cType] ;

\ отобразить текст в окне начиная с позиции up top размером width height
\ текст сместить от начала строк на x позиций
: show ( width disp TopLine up top height --> )
FOR DDUP setxy D>L
THRID THRID THRID
IF THRID str> DSWAP >cType] next
ELSE spaces DSWAP >cType]
THEN
DL> 1 +
TILL 5 nDROP ;

\ загрузка строк из файла
: load ( asc # --> )
FILE>HEAP IFNOT ERROR" Invalid file name!" THEN
OVER >L
<: BOUNDS SWAP
BEGIN DDUP < WHILE
DDUP EOL> -ROT THRID ROT TUCK - LTL @ - 0 MAX
new add
REPEAT DDROP
;> CATCH
L> FREE DROP
THROW ;

\ освободить занимаемую память
: free ( 1stLine --> )
A@ BEGIN *WHILE DUP next SWAP FREE DROP REPEAT DROP
nil set ;

\ сместить окно на одну линию вверх
: TopUp ( --> ) TopLine A@ prev *IF TopLine A! ELSE DROP THEN ;

\ сместить окно на одну линию вниз
: TopDn ( --> ) TopLine A@ next *IF TopLine A! ELSE DROP THEN ;

\ на одну страницу вверх
: PgUp ( --> ) Height FOR TopUp TILL ;

\ на одну страницу вниз
: PgDn ( --> ) Height FOR TopDn TILL ;

\ обработка событий нажатий клавиш
: reflex ( key --> )
CASE key' esc OF ERROR" Ok." ENDOF
key' dn OF TopDn ENDOF
key' up OF TopUp ENDOF
key' right OF Displ 1 + MaxWidth Width - MIN TO Displ ENDOF
key' left OF Displ 1 - 0 MAX TO Displ ENDOF
key' pgup OF PgUp ENDOF
key' pgdn OF PgDn ENDOF
key' home OF 1stLine A@ TopLine A! ENDOF
key' end OF LastLine A@ TopLine A! ENDOF
DROP
ENDCASE ;

\ отобразить страницу текста в окне
: ~Page ( --> ) Width Displ TopLine A@ Up Top Height show ;

\ главный рабочий цикл
:> Viewer ( --> ) ~Page BEGIN key? IF SYSKEY reflex ~Page THEN 0 PAUSE AGAIN ;

F: } ;F

EndUnit

\ отобразить содержимое указанного файла
: VIEW ( asc # --> )
View{ DDUP ~title load
HideCur
width 80 MIN TO Width
height 25 MIN TO Height
Viewer CATCH DROP 1stLine free
ShowCur
} ;


использовать так:
rel/ view.fts
s" view.fts" VIEW

_________________
Мне бы только мой крошечный вклад внести,
За короткую жизнь сплести
Хотя бы ниточку шёлка.
fleur



За это сообщение автора mOleg поблагодарил: vikt
Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
 Заголовок сообщения: Re: *простой текстовый viewer
СообщениеДобавлено: Чт июл 25, 2013 21:35 
Не в сети
Moderator
Moderator
Аватара пользователя

Зарегистрирован: Чт май 04, 2006 00:53
Сообщения: 4831
Откуда: был Крым, теперь Новосибирск
Благодарил (а): 18 раз.
Поблагодарили: 52 раз.
Продолжаю баловаться.
Теперь правила раскраски в отдельном файле, имена, определенные в просматриватриваемом файле автоматически расцвечиваются, правда есть побочные эффекты в случае повторного определения слов.
Вообще, так как файл по сути интерпретируестя правила расцветки ограничиваются фантазией.
p.s. не делал многострочные строковые литералы и коментарии.
для того, чтобы текст выглядел контрастно нужно в свойствах окна поправить значение серого цвета со 128 128 128 на 80 80 80

source file: view.fts
\ 02.07.2013 ~mOleg
\ Copyright [C] 2013 mOleg mOlegg@ya.ru
\ просмотрщик текстовых файлов с раскраской исходников

vocs/ unit.fts
vocs/ struct.fts
os/ heap.fts
os/ console.fts
os/ ccon.fts
branch/ for-next.fts
memory/ buff.fts
memory/ pocket.fts
\ rel/ keys.fts

ALSO HIDDEN
ALIAS EKEY SYSKEY
ALIAS EKEY? key?
PREVIOUS

Unit: key'

F: esc 0x101001B ;F
F: up 0x1480000 ;F
F: dn 0x1500000 ;F
F: left 0x14B0000 ;F
F: right 0x14D0000 ;F

F: home 0x1470000 ;F
F: end 0x14F0000 ;F
F: pgup 0x1490000 ;F
F: pgdn 0x1510000 ;F
EndUnit

Unit: View{

USER 1stLine \ первая линия текста
USER LastLine \ последняя линия текста
USER TopLine \ первая отображаемая линия текста

70 VALUE Width \ ширина рабочей области экрана
0 VALUE Displ \ смещение первого отображаемого символа от начала строки
2 VALUE Up \ положение первого символа окна просмотра слева
2 VALUE Top \ и сверху
25 VALUE Height \ высота рабочей области экрана
255 VALUE MaxWidth \ максимальная длина строки

\ каждая линия хранится отдельно
0 Struct: line
Addr[] off_prev \ ссылка на предыдущую линию текста
Addr[] off_next \ ссылка на следующую линию текста
Cell[] off_size \ длина строки
Zero[] off_body \ начало текста
EndStruct

\ получить указатель на следующую линию текста
: next ( str --> str | nil ) line off_next A@ ;

\ задать ссылку str2 на следующую строку str1
: !next ( str1 str2 --> ) line off_next A! ;

\ получить указатель на предыдущую линию текста
: prev ( str --> str | nil ) line off_prev A@ ;

\ задать ссылку str2 на предыдущую строку str1
: !prev ( str1 str2 --> ) line off_prev A! ;

\ вернуть начало a2 и a1 конец строки ?
: str> ( str --> asc # )
DUP line off_size @
SWAP line off_body SWAP ;


USER-VALUE cbuff \ временный буфер

\ инициализация буфера
: cinit ( --> buff )
cbuff *IF DUP Clean ;THEN
DROP MaxWidth Buffer DUP TO cbuff ;

\ Выделить лидирующие пробельные символы
: skipsp ( a1 a2 --> a1 a2 str # ) DDUP
BEGIN DDUP > WHILE
DUP C@ ?separator WHILE C+
REPEAT
THEN -ROT DROP DDUP - ;

\ Выделить лидирующие непробельные символы
: nextlx ( a1 a2 --> a1 a2 asc # ) DDUP
BEGIN DDUP > WHILE
DUP C@ ?separator WHILENOT C+
REPEAT
THEN -ROT DROP DDUP - ;

\ выделить из строки подстроку, содержащую пару лексем,
\ вернуть ключевое слово
: _pair> ( a1 a2 asc1 # --> a1 a2 asc1 #1 asc2 # asc3 # )
DROP >L skipsp DDROP
nextlx D>R
DUP L@ - L> SWAP
DR> ;

\ выделить из строки подстроку, содержащую тройку лексем,
\ вернуть последнюю лексему в виде строки asc3 #
: _thre> ( a1 a2 asc1 # --> a1 a2 asc1 #1 asc2 # asc3 # )
DROP >L
skipsp DDROP nextlx DDROP
skipsp DDROP nextlx D>R
DUP L@ - L> SWAP DR> ;

\ выделить из строки подстроку, завершенную указанным символом ch
: _toch ( a1 a2 asc1 # ch --> a1 a2 asc1 #1 asc2 # )
>L DROP >R
BEGIN DDUP > WHILE
DUP C@ L@ <> WHILE
C+
REPEAT C+
THEN
DUP R@ - R> SWAP LDROP ;

\ выделить из строки подстроку, завершенную переводом строки
: _eol ( a1 a2 asc1 # --> a1 a2 asc1 #1 asc2 # )
DROP >L
BEGIN DDUP > WHILE
DUP ?NewLine WHILENOT
C+
REPEAT
THEN DUP L@ - L> SWAP ;

\ преобразовать цвет в строку
: c>s" ( color --> x asc # ) 8 LSHIFT SP@ 2 ;

USER-VALUE prevcol \ предыдущий цвет

\ переменная для хранения vId временного словаря для хранения правил расцветки
USER-VALUE cvid

\ вернуть id временного словаря
: cVid ( --> vID )
cvid *IF ;THEN DROP
ALSO HEAP DEFINITIONS
s" RULES" SVOCAB DUP TO cvid DUP MOUNT
RECENT ;

\ удалить содержимое временного словаря
: Remove ( vId --> )
DUP DUP [ ALSO HIDDEN ] off_umount PERFORM [ PREVIOUS ]
ALSO MOUNT PREVIOUS ;

\ создание правила расцветки
: rule: ( color / name --> ) DUP >L c>s" ALSO cVid WITH THIS [COMPILE] : ;

\ создание правила расцветки имя задается строкой со счетчиком
: ruleS: ( asc # color --> ) >L D>R L@ c>s" ALSO cVid WITH THIS DR> S: NOOP ;

\ завершение правила расцветки
: ;r ( x asc # --> ) SLIT, DROP [COMPILE] ; DEFINITIONS L> TO prevcol ; IMMEDIATE

\ правило для расцветки одиночных имен
: ones: ( color / name --> ) rule: [COMPILE] ;r ;

\ правило для расцветки пары имен
: pair: ( color / name --> ) rule: COMPILE _pair> COMPILE DDROP [COMPILE] ;r ;

\ выполнить над всеми словами до конца строки действие name c параметром color
: All ( color / name lex1 lex2 .. lexN --> )
>L ' >L
<: BEGIN SeeForw NIP WHILE DL@ EXECUTE REPEAT LDROP LDROP ;>
Cr_ PARSE ROT EVALUATE-WITH ;

0 VALUE ?State

Color{

Gray CONSTANT StdBG \ стандартный цвет фона

\ получить цвет из комбинации цвета текста и цвета фона
: FONE ( color fone --> ) Fone + ;

\ добавить к цвету стандартный фон
: OnBG ( color --> color )
StdBG DDUP =
IF 0xF XOR THEN \ если цвета совпадают, инвертировать фон
Fone + ;

\ выбор цветов для различных групп слов
White OnBG CONSTANT control's
Magenta Light OnBG CONSTANT vocab's
Yellow Black FONE CONSTANT vocdef's
Gray Light OnBG CONSTANT simple's
Brown OnBG CONSTANT local's
Brown OnBG CONSTANT filed's
Yellow OnBG CONSTANT def's
Red Light OnBG CONSTANT danger's
Red Light OnBG CONSTANT errmes's
Green Light OnBG CONSTANT literal's
Blue Light Black FONE CONSTANT format's
Cyan Light OnBG CONSTANT confer's
Cyan OnBG CONSTANT comment's
Blue OnBG CONSTANT diagram's

Gray Light Black FONE CONSTANT newdef's

Blue Light Gray Light FONE CONSTANT hilight's

\ автоматическое добавление правил при разборе текста
: dodef _pair> newdef's ruleS: [COMPILE] ;r ;
: dovoc _pair> vocab's ruleS: [COMPILE] ;r ;
: dofld _pair> filed's ruleS: [COMPILE] ;r ;
: donew _pair> newdef's ruleS: [COMPILE] ;r ;
: doals _thre> newdef's ruleS: [COMPILE] ;r ;

( a1 a2 asc1 # --> a1 a2 asc1 #1 asc2 # )
\ цвет имен, правила расцветки для которых не определены
Gray OnBG : undefcode [ c>s" SLIT, DROP ] ;
\ цвет пробельных символов
StdBG 1 + OnBG : spaces [ c>s" SLIT, DROP ] ;
\ цвет литералов (чисел, строк, адресов, символов, т.п.)
literal's : litcode [ c>s" SLIT, DROP ] ;

RECENT

\ вернуть тег расцветки
: ?color ( a1 a2 asc1 #1 -->
a1 a2 asc1 #1 asc2 #2 )

DDUP cVid ( WHO CVID) SEARCH-NAME
*IF LINK>C EXECUTE ;THEN DROP

DDUP [ ALSO HIDDEN ] snNumber [ PREVIOUS ] \ если число
*IF NIP 2 = IF DROP THEN litcode ;THEN DROP

OVER s" off_" TUCK COMPARE IFNOT litcode ;THEN \ если строка начинаестя с "off_"
OVER s" to_" TUCK COMPARE IFNOT litcode ;THEN \ если строка начинаестя с "to_"

OVER C@ [CHAR] / = IF litcode ;THEN \ если строка начинается со "\"

undefcode ;

\ преобразовать
: colorify ( asc # --> asc # )
BOUNDS cinit >L
BEGIN DDUP > WHILE
skipsp *IF spaces L@ >Buffer DROP THEN
L@ >Buffer DROP
nextlx ?color L@ >Buffer DROP
L@ >Buffer DROP
REPEAT DDROP
L> Buffer> ;

\ создать новую запись в хипе, скопировать туда содержимое строки ?
: new ( asc # --> str )
colorify
DUP line /size + BLOCK >L
TUCK L@ line off_body SWAP CMOVE
L@ line off_size !
nil L@ !prev
nil L@ !next
L> ;

\ добавить строку в конец текста
: push ( str --> )
LastLine A@ OVER !prev
DUP LastLine A@ !next
LastLine A! ;

\ задать начальное состояние
: set ( str --> ) DUP 1stLine A! DUP LastLine A! TopLine A! ;

\ добавить строку в конец списка строк
: add ( str --> ) 1stLine @ IF push ;THEN set ;

\ вернуть адрес конца подстроки
: part ( a1 a2 --> a3 )
BEGIN DDUP > WHILE
DUP B@ WHILE
1 +
REPEAT
THEN NIP ;

\ вернуть цвет из начала указанной строки, пропустить цветовую информацию
: @col ( a1 --> a2 c ) 1 + DUP B@ 0:1 D+ ;

\ выделить из начала строки, ограниченной адресами a1 a2 раскрашенную в цвет C подстроку asc #
\ исключить из начала исходной строки выделенную подстроку
: lex ( a1 a2 --> a1 a4 asc # c ) @col >L DDUP part TUCK OVER - L> ;

\ длинная строка пробелов
CREATE spaceS MaxWidth <| FOR Bl_ KEEP TILL |> S, ;CREATE

\ отобразить с текущей позиции курсора указанное количество
\ пробельных символов фонового цвета
: cSpaces ( # --> )
*IF spaceS SWAP spaces DROP 1 + B@ CTYPE ;THEN DROP ;

\ вывести строку asc # в консоль максимально допустимая длина строки s символов
: cType] ( asc # s --> )
>L BEGIN DDUP > WHILE
lex L@ THRID -
-IF DROP NIP L> SWAP CTYPE DDROP ;THEN
LDROP >L CTYPE
REPEAT DDROP
L> cSpaces ;

\ вывести строку asc # в консоль длина отображаемой строки u символов
\ если строка длиннее - обрезать, если короче - дополнить пробелами
: >cType] ( asc # s u --> )
>L -ROT BOUNDS THRID >R
BEGIN DDUP > WHILE
lex L@ THRID -
-IF DROP -ROT L> SKIPn DUP >L R> MIN ROT CTYPE
ROT L> - 0 MAX cType]
;THEN
LDROP >L TDROP
REPEAT RDROP LDROP ROT cType] ;

\ отобразить текст в окне начиная с позиции up top размером width height
\ текст сместить от начала строк на x позиций
: show ( width disp TopLine up top height --> )
FOR DDUP setxy D>L
THRID THRID THRID
IF THRID str> DSWAP >cType] next
ELSE spaces DSWAP >cType]
THEN
DL> 1 +
TILL 5 nDROP ;

\ освободить занимаемую память
: free ( 1stLine --> )
A@ BEGIN *WHILE DUP next SWAP FREE DROP REPEAT DROP
nil set ;

\ загрузка строк из файла
: load ( asc # --> )
FILE>HEAP IFNOT ERROR" Invalid file name!" THEN
OVER >L
<: BOUNDS SWAP
BEGIN DDUP < WHILE
DDUP EOL> -ROT THRID ROT TUCK - -EOL
['] new CATCH IF 1stLine free ERROR" Not enought memory!" THEN
add
REPEAT DDROP
;> CATCH
L> FREE DROP
THROW ;

\ сместить окно на одну линию вверх
: TopUp ( --> ) TopLine A@ prev *IF TopLine A! ELSE DROP THEN ;

\ сместить окно на одну линию вниз
: TopDn ( --> ) TopLine A@ next *IF TopLine A! ELSE DROP THEN ;

\ на одну страницу вверх
: PgUp ( --> ) Height FOR TopUp TILL ;

\ на одну страницу вниз
: PgDn ( --> ) Height FOR TopDn TILL ;

\ отслеживание изменение размеров экрана (отображаемой области)
: scr# ( --> )
width Up - 2 - TO Width
height Top - 2 - TO Height ;

\ обработка событий нажатий клавиш
: reflex ( key --> flag )
CASE key' esc OF ERROR" Ok." ENDOF
key' dn OF TopDn TRUE ENDOF
key' up OF TopUp TRUE ENDOF
key' right OF Displ 1 + MaxWidth Width - MIN TO Displ TRUE ENDOF
key' left OF Displ 1 - 0 MAX TO Displ TRUE ENDOF
key' pgup OF PgUp TRUE ENDOF
key' pgdn OF PgDn TRUE ENDOF
key' home OF 1stLine A@ TopLine A! TRUE ENDOF
key' end OF LastLine A@ TopLine A! TRUE ENDOF
scr#
DROP FALSE
ENDCASE ;

\ отобразить страницу текста в окне
: ~Page ( --> ) Width Displ TopLine A@ Up Top Height show ;

\ главный рабочий цикл
:> Viewer ( --> )
~Page
BEGIN key? IF SYSKEY reflex
IF ~Page THEN \ отрисовка только в случае изменений
THEN
10 PAUSE
AGAIN ;
F: } ;F

\ загрузить файл правил расцветки
: LoadRules ( asc #--> ) Color{ [COMPILE] View{ INCLUDED [ PREVIOUS ] PREVIOUS ;

EndUnit

POCKET FileName \ для хранения имени файла

\ отобразить содержимое указанного файла
: VIEW ( asc # --> )
FileName <| s" file: " KEEPS KEEPS |> ~title
View{ s" color.rule" LoadRules
0 FileName load
HideCur scr#
Viewer CATCH DROP
1stLine free
ShowCur
cVid Remove
} ;


source file: color.rule
\ правила расцветки исходных текстов m0leg 22.07.2013

\ ?init: ?stop ADMIT DEF N?DEFINED init: \ пока не понятно как с ними быть

\ имена словарей и слова работающие с ними
vocab's All ones: FORTH NUMBERS ROOT HIDDEN HEAP IMPORT FORTH-WORDLIST
vocab's All ones: ALSO ONLY only SEAL PREVIOUS WITH INSIDE UNDER
vocab's All ones: CURRENT GET-CURRENT DEFINITIONS RECENT THIS SVOCAB
vocab's All ones: UNMOUNT MOUNT RMVID init-order
vocab's All ones: CONTEXT SAVE-ORDER RESTORE-ORDER SET-CURRENT SET-ORDER

\ подсветка слов управляющих структур
control's All ones: BEGIN WHILE WHILENOT *WHILE REPEAT AGAIN UNTIL
control's All ones: IF -IF *IF IFNOT ELSE THEN
control's All ones: CASE OF uOF ENDOF ENDCASE
control's All ones: NOW SINCE FOR TILL NEXT
control's All ones: DO ?DO LOOP +LOOP LEAVE I J
control's All ones: SWITCH: ;SWITCH

\ простые имена из словаря FORTH
simple's All ones: !voc-flag (1С=) (<C) (ABORT) (ACCEPT) (ALLOCATE) (API-CODE)
simple's All ones: #TIB ! (Allot) (BOX) (BYE) (C!) (C#) (C+) (C@) (CLOSE-FILE)
simple's All ones: (CONSOLE-HANDLES) (CONST) (CR) (DLIT) (DOES) (EMIT) (ENTER)
simple's All ones: (CREATE) (EXC) (INCLUDED) (FREE) (INIT) (INTERPRET) (PAIRS)
simple's All ones: (EvalSrc) (READ-LINE) (QUIT) (JOIN) (LIT) (OPTIONS) (PAUSE)
simple's All ones: (OK) ([) (MESSAGE) (REFILL) (SYSMSG>) (TYPE) (USER) (TITLE)
simple's All ones: (]) (check-voc) (code) (conclude) (flag) (get-attr) (mount)
simple's All ones: (d.) (id>asc) (invalid) (iso-<c) (iso-c!) (iso-c#) (iso-c+)
simple's All ones: (iso-c@) (latest) (link-voc) (name) (prev) (prompt) (vdlit)
simple's All ones: (n.) (sHeader) (set-attr) (uvalue) (size) (switch) (ustore)
simple's All ones: (store) (value) (vlit) (voc-search) (~ERROR) (~EXC) *BRANCH
simple's All ones: (~Place) * + +! , - -1 -BRANCH -ROT . / <BACK <C <> >NUMBER
simple's All ones: < <EOL <EXC-DUMP> <MAIN> <MARK <Node <RESOLVE >List ?BRANCH
simple's All ones: <resolve >ASCIIZ >ASCIIZ> >CIPHER ?ABSENT >MARK >IN >stderr
simple's All ones: > = >UPPER >lower >number >DIGIT ?BIT ?COMP ?LockMutex @API
simple's All ones: ?COMPLETE ?EXEC ?EXISTS ?SMUDGED ?LINES ?SHEADER ?separator
simple's All ones: ?hex-pref ?IMMEDIATE ?SIGN ?STACK ?NewLine ?WORD @ @ATTR A!
simple's All ones: ?NOTFOUND ?UNIQUE A, ABS ACCEPT ACHANGE ALIGN-BYTES ALIGNED
simple's All ones: A@ ADDR, ALIGN ALLOCATE ALLOT ANSI><OEM ANSI>OEM ASCIIZ> B@
simple's All ones: AND API-CALL AR@ ApiAddr ATIB AddExHandler BOUNDS BRANCH C!
simple's All ones: AT-SOURCE B! B, CMOVE BASE@ BETWEEN BIT CLOSE-FILE C# C+ C,
simple's All ones: C@ CALL, CELLS CHANGE CODE-ALIGN CIPHER CONSOLE-HANDLES DS/
simple's All ones: COMPARE COMPARE-NAMES COMPILE COMPILE, CONSIDER CREATE-FILE
simple's All ones: CSTREAM CURSRC CUT-PATH COUNT CharCode CR CharAddr CookLine
simple's All ones: CookAsc D! CONTENT CompBuf D+ D, D. DABS DDROP DECODE-ERROR
simple's All ones: DIGIT DLIT, DOVER DSWAP CloseSource D@ DLITERAL DTUCK ERASE
simple's All ones: dliteral DNEGATE DNIP DP DDUP DROP EVAL-TOKEN EXIT, FREFILL
simple's All ones: DU* FENCE EMIT EOL> ER-A ER-U ERRORS EvalSrcWith ExitSource
simple's All ones: F>HEAP FILE-POSITION FILE>HEAP DUP FileSource FindThread H.
simple's All ones: EvalSource FILL HASH ID>ASC INTERPRET IN-EXCEPTION INCLUDED
simple's All ones: ISO> HANDLER HERE HLD INI-FILE FREE GET-ATTR FRAME INIT-MEM
simple's All ones: INIT? INPUT-STREAM JUMP, LAST-NAME LINK>XTI LIT, LP@ LSHIFT
simple's All ones: LAST LATEST LEXEME LINK-VOC LinkLast LINK> LoadDll MISSTILL
simple's All ones: LoadInit LoadMess MESSAGE MAX LINK>C MissOne MissSeparators
simple's All ones: MOD MissLexeme ModuleDirName NEGATE MIN ModuleName N?BRANCH
simple's All ones: NewSource N. NEW-WORDLIST NIP MAINX NEXT-WORD NOOP NOTFOUND
simple's All ones: NextChar NextOne NextWord MSG-FILE OEM>ANSI OFF OK ON PARSE
simple's All ones: ON-SOURCE-EXIT ON-SOURCE-START PassLexeme OVER QUIT PAD-TOP
simple's All ones: PAUSE PIECE OPTIONS OPEN-FILE OPEN-FILE-SHARED PAD PeekChar
simple's All ones: OR PRESENT PROCESS PROMPT ParseFileName REFILL-STDIN RECOIL
simple's All ones: REGULAR PeekOne ProcessHeap READ-FILE QUEST REPOSITION-FILE
simple's All ones: READ-LINE RSHIFT REF, ROUND RET, REFILL PLACE RESOLVE> REST
simple's All ones: ROT RdLine S", S>VAL S-O REF! REF@ S, SEARCH S>HEAP SA SAVE
simple's All ones: SCNT! SCNT, SET-ATTR SCOPY SDP S>D SIGN SKIP1 SKIPn SOURCE!
simple's All ones: SCNT@ SEARCH-NAME SEEN-ERROR SFIND TLS-INIT SOURCE-NAME SP@
simple's All ones: SLIT, SWAP TOKEN@ TDROP TIB TOKEN! SpaceLine StrSource TUCK
simple's All ones: SetSource SOURCE SYSMSG> USER-HERE TlsIndex@ TranslateFlow
simple's All ones: TYPE U. U< U> U>D UA! UA@ VLISTUM/MOD SkipChar UNLINK-LAST
simple's All ones: USER-ALLOT USER-OFFS USER-PLACE atod UnlockMutex WRITE-FILE
simple's All ones: VIEWPOINT WITHIN VOC-LIST W! WIN-ERR UM* controls WINAPLINK
simple's All ones: WaitUnlock Waiting WithList XOR aGetChar create-file expose
simple's All ones: W, W@ cmdline> cur-err-h entry equivalent is_path_delimiter
simple's All ones: err-handler find-msg-body check-voc suNumber voc-table ~fha
simple's All ones: find-msg-num identify init-input literal last-number linkto
simple's All ones: no-umount last-msg load-messages msg-list reffered no-mount
simple's All ones: num-msg new-msg nDROP prefer restore restore-: s## s?number
simple's All ones: sFindIn sNumLfa save-dp search-thread system_buff source-id
simple's All ones: state stream-type ~ErrPlace snNumber unique-msg vAllot
simple's All ones: THRID setxy getxy

\ литералы
literal's All ones: #compbuf #err-handlers &ALS &DAS &IMM &NON &PRI &SMG &code
literal's All ones: &VOC &name &prev &size &v-dyn &v-std &vinit /cfa /lfa /ffa
literal's All ones: /header /SrcRec /msgRecord /nfa /sList /source /vocabulary
literal's All ones: /chartype /vtable /winrec /wordlist H-STDIN BUILD-DATE Bl_
literal's All ones: IMAGE-BEGIN CELL CFL Cr_ H-STDERR H-STDOUT IMAGE-BASE ADDR
literal's All ones: C/L FALSE REF LIMIT R/W LTL Lf_ MESS? NewLine OS> PAD# R/O
literal's All ones: L0 LT R0 S0 SCNT# THREADS# TLS# TOKEN comma Tab_ WORDLISTS
literal's All ones: TRUE VERSION W/O imm_word point std_word tab# nil

\ слова для работы с локальным стеком данных
local's All ones: >L L> L@ LDUP LDROP DL@ D>L { } AL@ A>L AL> AL+ ALDROP ALDUP
local's All ones: DL> L+

\
def's All ones: EndStruct EndUnit DOES> CREATED ?EXIT <: ;> EXIT ;THEN SHEADER
def's All ones: ;CREATE /struct HEADER WORDLIST

\ потенциально опасные слова, требующие внимания и обработка исключений
danger's All ones: >R R> R@ RDROP R+ DR> D>R A>R AR> DR@ ARDROP N>R NR> rnDROP
danger's All ones: EXECUTE PERFORM JUMP LEAP CATCH THROW DEMAND REJECT ERROR
danger's All ones: IMMEDIATE unfeasible SMUDGE HIDE IT-DOES PRIMITIVE VOC 0>R'
danger's All ones: LITERAL WARNING >STDERR CR>ERR ON-ERROR EXIT-ERROR ON-CATCH
danger's All ones: BYE HALT ERR-EXIT ExitProcess FATAL-HANDLER
danger's All ones: HEX BASE DECIMAL always
danger's All ones: [IF] [ELSE] [THEN] ' [ ]
danger's All ones: ClearDStack ClearLStack LP! SP! RP! RP@ FS! FS@ TlsIndex!

\ подсветка отладочных определений
hilight's All ones: .S DUMP DUMP~ ORDER

\ форматное преобразование чисел и строк
format's All ones: {# <# # #S HOLD HOLDS #> #} <| KEEP KEEPS |> BLANK BLANKS

\ работа с VALUE и VECT переменными
confer's All pair: TO IS FROM HAS

\ литералы
literal's All pair: [CHAR] [COMPILE] WHO ['] LFA CHAR" 1CHAR= ^

\ подключаемые библиотеки
literal's All pair: rel/ root/ vocs/ os/ branch/ memory/ string/ transl/
literal's All pair: math/ exc/ stack/ util/

\
--------------------- более сложные правила расцветки -----------------------
comment's rule: \ _eol ;r \ коментарий до конца строки
hilight's rule: \? _eol ;r \ подсвеченый коментарий
hilight's rule: \! _eol ;r \ подсвеченый коментарий

literal's rule: s" [CHAR] " _toch ;r \ однострочные строковые литералы
literal's rule: S" [CHAR] " _toch ;r \ однострочные строковые литералы

diagram's rule: ( [CHAR] ) _toch ;r \ однострочные стековые коментарии

literal's rule: .( [CHAR] ) _toch ;r \ однострочные сообщения
literal's rule: ." [CHAR] " _toch ;r \ однострочные сообщения

literal's rule: STRING" [CHAR] " _toch ;r \ строка сообщения

errmes's rule: ERROR" [CHAR] " _toch ;r \ сообщение об ошибке
errmes's rule: ABORT" [CHAR] " _toch ;r \ сообщение об ошибке

literal's rule: NOTICE" [CHAR] " _toch ;r \ строка сообщения

\ следущие определения автоматически добавляют в словарь правила раскраски

\ определения различных переменных
s" USER" def's ruleS: dodef ;r
s" VALUE" def's ruleS: dodef ;r
s" DVALUE" def's ruleS: dodef ;r
s" VARIABLE" def's ruleS: dodef ;r
s" DVARIABLE" def's ruleS: dodef ;r
s" USER-VALUE" def's ruleS: dodef ;r
s" USER-DVAL" def's ruleS: dodef ;r
s" CONSTANT" def's ruleS: dodef ;r
s" VECT" def's ruleS: dodef ;r
s" DEFER" def's ruleS: dodef ;r
s" USER-VECT" def's ruleS: dodef ;r
s" USER-CREATE" def's ruleS: dodef ;r
s" CREATE" def's ruleS: dodef ;r
s" POCKET" def's ruleS: dodef ;r

s" ALIAS" def's ruleS: doals ;r

\ создание словарей
s" Unit:" vocdef's ruleS: dovoc ;r
s" VOCABULARY" vocdef's ruleS: dovoc ;r
s" CONTAINER" vocdef's ruleS: dovoc ;r
s" Struct:" vocdef's ruleS: dovoc ;r
s" struct:" vocdef's ruleS: dovoc ;r

\ поля структур
s" Cell[]" filed's ruleS: dofld ;r
s" Addr[]" filed's ruleS: dofld ;r
s" Zero[]" filed's ruleS: dofld ;r
s" addr[]" filed's ruleS: dofld ;r
s" byte[]" filed's ruleS: dofld ;r
s" --" filed's ruleS: dofld ;r

\ определяющие слова
s" :" def's ruleS: ?State IFNOT donew TRUE TO ?State THEN ;r
s" :>" def's ruleS: ?State IFNOT donew TRUE TO ?State THEN ;r
s" S:" def's ruleS: ?State IFNOT donew TRUE TO ?State THEN ;r
s" F:" def's ruleS: ?State IFNOT donew TRUE TO ?State THEN ;r

\ слова завершающие определения
s" ;" def's ruleS: FALSE TO ?State ;r
s" ;F" def's ruleS: FALSE TO ?State ;r
s" ;stop" def's ruleS: FALSE TO ?State ;r

_________________
Мне бы только мой крошечный вклад внести,
За короткую жизнь сплести
Хотя бы ниточку шёлка.
fleur


Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
Показать сообщения за:  Поле сортировки  
Начать новую тему Ответить на тему  [ Сообщений: 17 ]  На страницу 1, 2  След.

Часовой пояс: UTC + 3 часа [ Летнее время ]


Кто сейчас на конференции

Сейчас этот форум просматривают: нет зарегистрированных пользователей и гости: 1


Вы не можете начинать темы
Вы можете отвечать на сообщения
Вы не можете редактировать свои сообщения
Вы не можете удалять свои сообщения
Вы не можете добавлять вложения

Powered by phpBB © 2000, 2002, 2005, 2007 phpBB Group
phpBB сборка от FladeX // Русская поддержка phpBB