Forth и другие саморасширяющиеся системы программирования Locations of visitors to this page
Текущее время: Ср ноя 21, 2018 21:52

...
Google Search
Forth-FAQ Spy Grafic

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




Ответить
Имя пользователя:
Заголовок:
Текст сообщения:
Введите текст вашего сообщения. Длина сообщения в символах не более: 60000

Размер шрифта:
Цвет шрифта
Настройки:
BBCode ВКЛЮЧЕН
[img] ВЫКЛЮЧЕН
[flash] ВЫКЛЮЧЕН
[url] ВКЛЮЧЕН
Смайлики ВЫКЛЮЧЕНЫ
Отключить в этом сообщении BBCode
Не преобразовывать адреса URL в ссылки
Вопрос
Теперь гостю придется вводить здесь пароль. Не от своей учетной записи, а ПАРОЛЬ ДЛЯ ГОСТЯ, получить который можно после регистрации на форуме через ЛС.:
Этот вопрос предназначен для выявления и предотвращения автоматических регистраций.
   

Обзор темы - *простой текстовый viewer
Автор Сообщение
  Заголовок сообщения:  Re: *простой текстовый viewer  Ответить с цитатой
KPG писал(а):
Возможно имеет смысл создать DLL библиотеку, для подключения в рамках произвольной Форт системы,по примеру проекта Scintilla c предоставлением соответствующего сервиса.

c DLL много возни, не хочется.
Сообщение Добавлено: Пн авг 05, 2013 18:44
  Заголовок сообщения:  Re: *простой текстовый viewer  Ответить с цитатой
Возможно имеет смысл создать DLL библиотеку, для подключения в рамках произвольной Форт системы,
по примеру проекта Scintilla c предоставлением соответствующего сервиса.

P.S. В Win32Forth один из представленных проектов сделан для использования scintilla.dll в качестве ядра редактора.
Сообщение Добавлено: Пт июл 26, 2013 17:06
  Заголовок сообщения:  Re: *простой текстовый viewer  Ответить с цитатой
Продолжаю баловаться.
Теперь правила раскраски в отдельном файле, имена, определенные в просматриватриваемом файле автоматически расцвечиваются, правда есть побочные эффекты в случае повторного определения слов.
Вообще, так как файл по сути интерпретируестя правила расцветки ограничиваются фантазией.
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
Сообщение Добавлено: Чт июл 25, 2013 21:35
  Заголовок сообщения:  Re: *простой текстовый viewer  Ответить с цитатой
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
Сообщение Добавлено: Сб июл 06, 2013 22:54
  Заголовок сообщения:  Re: *простой текстовый viewer  Ответить с цитатой
предыдущий вариант не сработает если файл будет с 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>
Сообщение Добавлено: Сб июл 06, 2013 21:13
  Заголовок сообщения:  Re: *простой текстовый viewer  Ответить с цитатой
Alex писал(а):
мож кто искать будетрешение, и этот вариант подойдет

да, конечно.
Сообщение Добавлено: Пт июл 05, 2013 20:07
  Заголовок сообщения:  Re: *простой текстовый viewer  Ответить с цитатой
добавил выход по клавише ESC, прошу таки оставить в этой теме, мож кто искать будет
решение, и этот вариант подойдет
Сообщение Добавлено: Пт июл 05, 2013 19:58
  Заголовок сообщения:  Re: *простой текстовый viewer  Ответить с цитатой
gudleifr писал(а):
Как было сказано выше

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

Если еще остались вопросы, пожалуйста, задавайте их где-нибудь в другом месте, мне на вас нет желания тратить время. Троли мне не симпатичны, в данном разделе я стролями нянчиться не намерен.
Сообщение Добавлено: Пт июл 05, 2013 16:42
  Заголовок сообщения:  Re: *простой текстовый viewer  Ответить с цитатой
mOleg писал(а):
Задача решается с отступлением от задания, а, значит, не решена.
Как было сказано выше, задача была решена столько раз, что Ваши "перламутровые пуговицы" никому не интересны. (Если угодно, в мое решение выход по Esc втюхать легко. Но зачем?). Это как прийти к спортсменам прыгунам и поставить задачу - прыгать в зеленых кедах. Зачем?

Кстати, вопрос по Вашему решению. Если мы после выполнения вертикального смещения из позиции "в хвостовой части длинной строки" попадаем на фрагмент коротких строк, окно уходит в пустоту или идет влево - пока не найдет текст?
Сообщение Добавлено: Пт июл 05, 2013 16:30
  Заголовок сообщения:  Re: *простой текстовый viewer  Ответить с цитатой
gudleifr писал(а):
В Вашем задании про это - ни слова.

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

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

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

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

Задача решается с отступлением от задания, а, значит, не решена.
Сообщение Добавлено: Пт июл 05, 2013 16:24
  Заголовок сообщения:  Re: *простой текстовый viewer  Ответить с цитатой
mOleg писал(а):
Смысл задания не в том, чтоб вызывать сторонний компонент, а чтобы использовать штатные.
Вы что-то путаете. В Вашем задании про это - ни слова. (Про "смысл" - это, пожалуйста, в мое задание). Поэтому в решении коллеги Alex, как и у меня, задача решается минимумом затрат, что можно только приветствовать.
(Разве что, имело заменить тег <br> на <pre>).

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

Оффтоп. Когда-то я поминал 6 этапов разработки программы по Кнуту. Видимо, каждый программист подсознательно тяготеет к одному из этапов, начиная со временем остальные считать чем-то второстепенным. Любители сверхмощных ОО и прочих визуальных монстров, которые мы здесь наблюдаем, очевидно, тяготеют к пункту (4) - "Начальные установки".
Сообщение Добавлено: Пт июл 05, 2013 16:12
  Заголовок сообщения:  Re: *простой текстовый viewer  Ответить с цитатой
Alex писал(а):
используем для реализации просмотрщика сторонние

Смысл задания не в том, чтоб вызывать сторонний компонент, а чтобы использовать штатные.
Сообщение Добавлено: Пт июл 05, 2013 14:55
  Заголовок сообщения:  Re: *простой текстовый viewer  Ответить с цитатой
используем для реализации просмотрщика сторонние (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
;
Сообщение Добавлено: Пт июл 05, 2013 13:11
  Заголовок сообщения:  Re: *простой текстовый viewer  Ответить с цитатой
Цитата:
Он показал нам блок-схему программы, предназначавшейся для решения этой задачи, но стрелки, которые вели от одного квадратика к другому, были так беспорядочно расположены, что мы оба решили не рассматривать это решение (если оно было решением, что мы так и не смогли выяснить!).

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

А, если серьезно, я вижу несколько важных ошибок:
1. Программа написана не на Forth, а на плохом C (с механической заменой операторов на слова). Коробит, наше отношение к Броуди. Мы его чтим, но то, что он писал, пропускаем мимо ушей.
2. Программа, очевидно, очень сильно ОС-зависима (ср. мое решение), но эти зависимости в решении не обособлены.
3. Разбиение на слова было произведено по-чайниковски: по командам интерфейса, а не по правилам организации вычислений и/или доказательства корректности.
4. Заодно видны недостатки выбранного средства программирования: обилие не нужных для решения танцев с бубном. Зачем писать сверхмощный Forth, если половина листинга полностью состоит из его настроек? Был бы умный, сам бы настроился.
Сообщение Добавлено: Чт июл 04, 2013 09:18
  Заголовок сообщения:  Re: *простой текстовый viewer  Ответить с цитатой
написано для форка используемая версия 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
} ;
Сообщение Добавлено: Чт июл 04, 2013 08:56

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


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