\ Problem K, или небольшой такой 'пухленький' кварк-форт-эксель
\ Автор: VoidVolker
\ Дата:  22.03.2008
\ # Различные настриваемые параметры интерфейса
0xAA7755  VALUE цвет_таблицы
BLACK     VALUE цвет_фона
WHITE     VALUE цвет_выделения
0xEEEEEE  VALUE цвет_текста

0x88FF88  VALUE цвет_чисел
0xFFFF88  VALUE цвет_флоатов
0xFF88FF  VALUE цвет_строк
0x88FFFF  VALUE цвет_ячейки

166 VALUE simbol-colorer  \ Символ указывающий

35  VALUE table-x  \ Позиция основной таблицы
105 VALUE table-y

5   26 MIN 1 MAX VALUE COLS  \ Число столбиков
10   38 MIN 1 MAX VALUE ROWS  \ Число строк
130 VALUE CELLA  \ Длина ячейки
20  VALUE CELLB  \ Высота ячейки

35  VALUE ROWS-NAMEA  \ Длина стобца с номерами строк

\ # Status-box  \ (Надо бы его к основной таблице приклеить)
0   VALUE sbox-x
40  VALUE sbox-y
85  8 * VALUE sbox-a
20  VALUE sbox-b
64  VALUE sbox-data-x

64 VALUE STRING-SIZE  \ Размер строк

\ ##### K: begin
\ Различные переменные
table-x VALUE cell-x  \ Координата X текущей ячейки
table-y VALUE cell-y  \ Координата Y текущей ячейки
QUAN cell'            \ Адрес текущей ячейки

QUAN col-buf          \ Буфер цвета для текста

table-x VALUE last-cell-x
table-y VALUE last-cell-y
CELLA 2 - VALUE last-cell-a
CELLB 2 - VALUE last-cell-b

" abcdefghijklmnopqrstuvwxyz" VALUE "az

\ ### 1.0 Разное
: GOTOCONSOLE 0 0 GOTOXY ;
\ # 1.1 Tools
: 2DUP  OVER OVER ;
: --   CREATE OVER , + DOES> @ + ;
: MOUSEX  MOUSE-X @ ;
: MOUSEY  MOUSE-Y @ ;
: 'SWAP  \ ( a: X  a1: Y -- a: Y  a1: X )
  OVER @ OVER @ >R
  SWAP ! R> SWAP !
;
: 'NOOP ['] NOOP ;
\ # 1.2 Графические примитивы
: FBOX   \ x y a b цвет
  SWAP 0 DO
  3 PICK 3 PICK I + 3 PICK 3 PICK HLINE
  LOOP DROP DROP DROP DROP ;
: BOX   \ x y a b цвет
  4 PICK 4 PICK 4 PICK 3 PICK HLINE
  4 PICK 4 PICK 3 PICK 3 PICK VLINE
  4 PICK 4 PICK 1- 3 PICK + 4 PICK 3 PICK HLINE
  >R 3 XCHG 1- SWAP + SWAP ROT R> VLINE
;

\ # 1.3 Текст
: boxed-textxy  \ ( x y -- x1 y1 )
  >R 5 + R> 3 + ;
: box-textxy  \ ( x y -- )
  boxed-textxy TEXTXY ;

\ # 1.4 Графические примитивы отдельно взятой ячейки
: last-inside-box  \ ( -- x1 y1 a1 b1 ) Внутренний прямоугольник предыдущей активированной ячейки
  last-cell-x 1+  last-cell-y 1+  last-cell-a last-cell-b ;
: hlight  \ Подсвечивает ячейку
  cell-x 1+ cell-y 1+ CELLA 2 - CELLB 2 - цвет_выделения BOX ;
: un-hlight  \ Отменяет подсветку
  last-inside-box цвет_фона BOX ;
: clear-cell  \ Очищает ячейку на экране
  last-inside-box цвет_фона FBOX ;
: cell-textxy \ Печатает текст в текущей ячейке
  cell-x cell-y box-textxy ;

\ ### 2.0 Раскраска
: mem-col GETCOLOR TO col-buf ;
: prev-col  col-buf SETCOLOR ;
: num-color  mem-col цвет_чисел SETCOLOR ;
: float-color  mem-col цвет_флоатов SETCOLOR ;
: string-color  mem-col цвет_строк SETCOLOR ;
: cell-name-color  mem-col цвет_ячейки SETCOLOR ;

\ # 2.1 Цветные строки
: sbgr>num  \ ( str -- n ) Конверитрует стpоковое пpедставление числа в 16-pичном виде в число; берется 6 первых символов
  >R 0
  6 0 DO
   R@ C@ DUP 48 57 WITHIN  \ Число?
    IF
     48 -  \ Код числа >> число
    ELSE
     DUP 65 70 WITHIN  \ Буква?
      IF 55 - ELSE 0 THEN   \ Код буквы >> число
    THEN
    5 I - 4 * LSHIFT +  \ Установка разряда
    R> 1+ >R
  LOOP
  RDROP
;

QUAN cprint-colbuf
: sprev-color  cprint-colbuf SETCOLOR ;
: sset-color \ ( s -- s+7 )
  GETCOLOR TO cprint-colbuf
  DUP sbgr>num SETCOLOR
  7 +
;

CREATE colored1 ' sset-color ,
CREATE colored2 ' sprev-color ,
: CPRINT  \ ( str -- )  \ Печатает строку с учетом цвета "подстрок", цвет подстроки указывается после символа ¦ и подстрока
  BEGIN                 \ ограничивается этим-же символом, например: " [ ¦FF3333 F5¦ Int= " CPRINT  подстрока F5 будет цветом FF3333
   DUP C@ DUP
  WHILE  \ a char
   DUP DUP 166 = SWAP simbol-colorer = OR \ Символ ¦ ?
    IF
     DROP 1+
     colored1 @ EXECUTE
     colored1 colored2 'SWAP
    ELSE
     EMIT 1+
    THEN
  REPEAT
  DROP DROP
;

\ ### 3.0 Структура ячеек и таблицы
: for-cells
   ROWS 0 DO
   COLS 0 DO
      IJ #>' calculated? OFF
   LOOP
  LOOP
;

0
1 CELLS     -- #cell
1 CELLS     -- calculated?  \ Для избегания повторного вычисления ячейки (в данный момент не используется)
1 CELLS     -- class
1 CELLS     -- number
1 FLOATS    -- fnumber
STRING-SIZE -- string
VALUE cell-size

QUAN table-size
QUAN table[]

: #>'  cell-size *  table[] + ;
: '>#  #cell @ ;

: CREATE-TABLE
  COLS ROWS * cell-size * TO table-size
  HERE TO table[]
  table-size ALLOT
  0 table[] table-size CFILL
  ROWS 0 DO
   COLS 0 DO
    IJ DUP #>' #cell !
   LOOP
  LOOP
;

CREATE-TABLE

\ # 3.1 Классы содержимого ячеек
: class-number.  \ 'cell --
  number @ num-color . prev-col ;
: class-fnumber. \ 'cell --
  fnumber F@ float-color F. prev-col ;
: class-string.  \ 'cell --
  string string-color CPRINT prev-col ;

0                 VALUE class-null
' class-number.   VALUE class-number
' class-fnumber.  VALUE class-fnumber
' class-string.   VALUE class-string

: print  \ cell' --
  DUP class @ DUP IF clear-cell OPAQUE ON EXECUTE OPAQUE OFF ELSE DROP DROP THEN ;
: cell-print  cell-textxy cell' print hlight ;

\ # 3.2 Изменение класса ячейки
: set-class-number
  cell' class-number SWAP class ! ;
: set-class-fnumber
  cell' class-fnumber SWAP class ! ;
: set-class-string
  cell' class-string SWAP class ! ;
: set-class-null
  cell' class-null SWAP class !
;

\ # 3.3 Вычисление формул
\ Вероятно потребуется переопределять слова работающие с арифметикой
VECT CELLACTION  \ Этот вектор вызывается "ячейкой" и получает в качестве аргумента адрес этой ячейки и возвращает
\ VECT CALCULATE  \ Этот вектор отвечает за обработку непосредственно формулы в строковом виде; вероятно EVALUATE будет достаточно и он не понадобится
: number@  \ 'cell -- D
  number @ ;
: fumber@  \ 'cell -- F@
  number F@ ;
: formula?  \ 'cell -- ?
  string C@ 61 =  \ char =
;

: calculate  \ 'cell -- cell_D
   DUP >R
   formula?
    IF
   \   DUP calculated? @ NOT
     \   IF
        \  DUP calculated? ON
          R@ string 1 + EVALUATE \ CALCULATE
          \ Если формула правильная, то на стеке должен быть результат - его надо сохранить в ячейку (надо бы добавить проверку глубины стека для определения правильности и 'чистоплотности' формулы)
          R@ number !
          R@ set-class-number
      \ THEN
  \  ELSE
    THEN
  R> number @ \ CELLACTION  <-- это что и зачем тут делает?
;

: col-work
  SWAP COLS * + #>' calculate
;
VECT COL-ACTION  \ #row #col --
: a  0 COL-ACTION ;  : b  1 COL-ACTION ;  : c  2 COL-ACTION ;  : d  3 COL-ACTION ;  : e  4 COL-ACTION ;
: f  5 COL-ACTION ;  : g  6 COL-ACTION ;  : h  7 COL-ACTION ;  : i  8 COL-ACTION ;  : j  9 COL-ACTION ;
: k 10 COL-ACTION ;  : l 11 COL-ACTION ;  : m 12 COL-ACTION ;  : n 13 COL-ACTION ;  : o 14 COL-ACTION ;
: p 15 COL-ACTION ;  : q 16 COL-ACTION ;  : r 17 COL-ACTION ;  : s 18 COL-ACTION ;  : t 19 COL-ACTION ;
: u 20 COL-ACTION ;  : v 21 COL-ACTION ;  : w 22 COL-ACTION ;  : x 23 COL-ACTION ;  : y 24 COL-ACTION ;
: z 25 COL-ACTION ;

\ # 3.4 Вычисление функций (небольшой пример)
QUAN 'vect
QUAN #execs
QUAN 'xt
: dalay-execute 
  -1 +TO #execs
  #execs NOT
   IF 'xt 'vect ! THEN
;

: DEXEC \ xt 'vect D -- \ 'Задержанный' вызов вектора, т.е. будет пропущено D вызовов, затем в вектор 'vect будет записан xt
  TO #execs 1+ TO 'vect TO 'xt
  ['] dalay-execute 'vect !
;

QUAN actbuf
QUAN row1 QUAN col1
QUAN row2 QUAN col2
VECT cells-act
: FOR(  \ xt --
  ['] cells-act 1 DEXEC
  FROM COL-ACTION TO actbuf
  'NOOP TO COL-ACTION
;
: )FOR  \ row1 col1 row2 col2 -- 2 1 4 2
  actbuf TO COL-ACTION
  TO col2 TO row2 TO col1 TO row1
  col1 row1 COLS * +
  row2 row1 1- DO
   col2 col1 1- DO
     OVER #>' calculate cells-act
     >R 1+ R>
   LOOP
   >R COLS + col2 col1 - - 1- R>
  LOOP
;

: +(  \ -- D
  ['] + FOR( ;
: )+  )FOR ;

: *(  \ -- D
  ['] * FOR( ;
: )*  )FOR ;

\ Примеры использования:
\ +( 0 a 2 b )+  \ Сложить все числа в ячейках 0a,1a,2a,0b,1b,2b
\ *( 0 a 2 b )*  \ Перемножить все числа в ячейках 0a,1a,2a,0b,1b,2b

\ ### 4.0 Интерфейс
\ # 4.1 Дополнительные элементы
VARIABLE col-name-buf
: col-name  \ n -- str
  "az + C@ col-name-buf ! col-name-buf ;
: BL.  WHERETEXTXY >R 8 + R> TEXTXY ;
: STATUS-BOX.
  OPAQUE ON
  sbox-x 1+  sbox-y 1+  sbox-a 2 -  sbox-b 2 -  цвет_фона  FBOX  \ Очищение
  sbox-x sbox-y sbox-a sbox-b цвет_таблицы BOX  \ Рамка
  sbox-x 1+  sbox-y 1+ sbox-b + 1- sbox-a 2 -  sbox-b 2 -  цвет_фона  FBOX
  sbox-x sbox-y sbox-b + 1- sbox-a sbox-b цвет_таблицы BOX  \ Рамка для строки
  sbox-x sbox-y box-textxy " Status: " PRINT   \ Текст
  WHERETEXTXY
   sbox-data-x sbox-x +  sbox-y  box-textxy
   " [ ¦FF3333 F5¦ Int= " CPRINT   cell' class-number.
   " ] [ ¦FF3333 F6¦ Float= " CPRINT   cell' class-fnumber.
   " ] [ cell: " PRINT
   cell-name-color
   cell-y table-y - CELLB / .
   cell-x table-x - CELLA / col-name PRINT BL.
   prev-col "  ] " PRINT
   sbox-x sbox-y sbox-b + 1- box-textxy
   " [ ¦FF3333 F7¦ Str= " CPRINT   cell' class-string. BL. " ]" PRINT
  TEXTXY
  OPAQUE OFF
;

\ # 4.2 Отрисовка таблицы
: rows-names.
  ROWS 0 DO
   table-x ROWS-NAMEA -  \ x
   table-y I CELLB * +   \ y
   2DUP box-textxy
   ROWS-NAMEA CELLB  цвет_таблицы  BOX
   I .
  LOOP
;
: cols-names.
  COLS 0 DO
   table-x I CELLA * +   \ x
   table-y CELLB -       \ y
   2DUP box-textxy
   CELLA CELLB  цвет_таблицы  BOX
   I col-name PRINT
  LOOP
;
: "#\N".
  table-x ROWS-NAMEA -
  table-y CELLB -
   2DUP box-textxy " #\N" PRINT
  ROWS-NAMEA
  CELLB
  цвет_таблицы BOX
;

: TABLE.  \ Отрисовка таблицы
  OPAQUE ON
  "#\N".
  rows-names.
  cols-names.
  ROWS 0 DO
   COLS 0 DO
     table-x I CELLA * +
     table-y J CELLB * +
      2DUP box-textxy
     CELLA CELLB цвет_таблицы BOX
      IJ #>' print  \ Отрисовывает содержимое ячеек
   LOOP
  LOOP
  OPAQUE OFF
;

\ # 4.3 Отрисовка всего интерфейса целиком
: that-cell  \ Устанавливает номер текущей ячейки в соответствующую переменную
  cell-x table-x -
  CELLA /
  cell-y table-y -
  CELLB / COLS *
  + #>' TO cell'
;

: DRAW-GUI
  0 0 2048 2048 цвет_фона FBOX
  цвет_текста SETCOLOR
  TABLE.
  that-cell cell-print
  hlight
  STATUS-BOX.
;

\ ### 5.0 Перемещение активной ячейки
: last-col-pos   table-x COLS 1- CELLA * + ;
: last-row-pos   table-y ROWS 1- CELLB * + ;

\ # 5.1 Отрисовка активной ячейки
: this  \ Активирует ячейку под курсором
  MOUSEX table-x MAX  table-x -  CELLA / CELLA *  \ Координата ячейки по горизонтали
  table-x +  last-col-pos  MIN
    TO cell-x
  MOUSEY table-y MAX  table-y -  CELLB / CELLB *  \ Координата ячейки по вертикали
  table-y +  last-row-pos  MIN
    TO cell-y
;

\ # 5.2 Перемещение курсором
: activate  \ Активирует ячейку
  that-cell
  un-hlight
  cell-y TO last-cell-y
  cell-x TO last-cell-x
  hlight
  STATUS-BOX.
;

\ ### 6.0 Ввод/вывод данных
: clear-inputbuf
  0 INPUTBUF 258 CFILL
;
\ # 6.1 Ячейки
: cell-input  \ Ввод обычного числа
  GOTOCONSOLE " Input number" PRINT
  activate  set-class-number
  cell' number INPUT
  DRAW-GUI
;
: cell-finput  \ Ввод флоат числа
  GOTOCONSOLE " Input float" PRINT
  activate  set-class-fnumber
  cell' fnumber FINPUT
  DRAW-GUI
;
: cell-sinput  \ Ввод строки
  GOTOCONSOLE " Input string" PRINT
  activate  set-class-string
  clear-inputbuf
  INPUTDIALOG
    IF
      INPUTBUF cell' string STRING-SIZE CMOVE
      set-class-string clear-inputbuf
      cell' calculate
      DRAW-GUI
    THEN
;
: cell-zeroize  \ Обнуление ячейки
  activate
  set-class-null
  0 cell' number 1 CELLS CFILL
  0 cell' fnumber 1 FLOATS CFILL
  0 cell' string STRING-SIZE CFILL
  clear-cell
  DRAW-GUI
;

: input-mouse  this cell-input ;
: finput-mouse  this cell-finput ;
: sinput-mouse  this cell-sinput ;

: cell-set-class-number
  activate clear-cell set-class-number cell-print ;
: cell-set-class-fnumber
  activate clear-cell set-class-fnumber cell-print ;
: cell-set-class-string
  activate clear-cell set-class-string cell-print ;
: cell-set-class-null
  activate clear-cell set-class-null cell-print ;

\ # 6.2 Файловые операции
VARIABLE num>file-buf
: .FILE  \ D -- file: D  \ Печатает число со стека в файл HF-OUT как бинарные данные
  num>file-buf ! HF-OUT num>file-buf 1 CELLS WRITEFILE DROP ;
: FILE.  \ file: D -- D  \ Читает из файла HF-OUT число как бинарные данные на стек
  HF-OUT num>file-buf 1 CELLS READFILE num>file-buf @ ;
: file-name-print
  " '" PRINT INPUTBUF PRINT " '" PRINT
;

0x51465446 VALUE file-type  \ Quark Forth Table File
: SAVE-TABLE
  GOTOCONSOLE " Save table - enter file-name" PRINT
  clear-inputbuf
  INPUTDIALOG
   IF
     DRAW-GUI
     INPUTBUF NEWFILE TO HF-OUT
    \ " test.txt" NEWFILE TO HF-OUT
     file-type .FILE  \ По-хорошему бы это все надо в один массив сделать
     цвет_таблицы .FILE      цвет_фона .FILE      цвет_выделения .FILE   цвет_текста .FILE
     table-x .FILE      table-y .FILE      COLS .FILE      ROWS .FILE
     CELLA .FILE      CELLB .FILE      ROWS-NAMEA .FILE   sbox-x .FILE
     sbox-y .FILE      sbox-a .FILE      sbox-b .FILE      sbox-data-x .FILE
     STRING-SIZE .FILE      cell-x .FILE      cell-y .FILE            cell' .FILE
     col-buf .FILE      last-cell-x .FILE   last-cell-y .FILE      last-cell-a .FILE
     last-cell-b .FILE
    HF-OUT table[] table-size WRITEFILE
    HF-OUT CLOSE
    DRAW-GUI
    GOTOCONSOLE file-name-print " ¦00FF00 saved...¦" CPRINT
   THEN
;
: LOAD-TABLE
  GOTOCONSOLE " Load table - enter file-name" PRINT
  clear-inputbuf
  INPUTDIALOG
   IF
    DRAW-GUI
    INPUTBUF OPEN TO HF-OUT
   \ " test.txt" OPEN TO HF-OUT
     FILE. file-type =
      IF
       FILE. TO цвет_таблицы   FILE. TO цвет_фона   FILE. TO цвет_выделения   FILE. TO цвет_текста
       FILE. TO table-x      FILE. TO table-y   FILE. TO COLS      FILE. TO ROWS
       FILE. TO CELLA      FILE. TO CELLB      FILE. TO ROWS-NAMEA   FILE. TO sbox-x
       FILE. TO sbox-y      FILE. TO sbox-a      FILE. TO sbox-b      FILE. TO sbox-data-x
       FILE. TO STRING-SIZE   FILE. TO cell-x      FILE. TO cell-y      FILE. TO cell'
       FILE. TO col-buf      FILE. TO last-cell-x   FILE. TO last-cell-y    FILE. TO last-cell-a
       FILE. TO last-cell-b
       CREATE-TABLE
       HF-OUT table[] table-size READFILE
       DRAW-GUI
       GOTOCONSOLE file-name-print " ¦00FF00 loaded...¦" CPRINT
     ELSE
       GOTOCONSOLE file-name-print " ¦0000EE not Quark Forth Table File!¦" CPRINT
     THEN
   THEN
  HF-OUT CLOSE
;

\ ### 7.0 Перемещения
\ # 7.1 Перемещение текущей ячейки
: act-cell-left
  last-cell-x  CELLA - table-x  MAX  TO cell-x
  last-cell-y  TO cell-y
  activate ;
: act-cell-right
  last-cell-x  CELLA +  last-col-pos MIN  TO cell-x
  last-cell-y  TO cell-y
  activate ;
: act-cell-up
  last-cell-x  TO cell-x
  last-cell-y  CELLB - table-y  MAX  TO cell-y
  activate ;
: act-cell-down
  last-cell-x  TO cell-x
  last-cell-y  CELLB + last-row-pos MIN  TO cell-y
  activate
;

\ # 7.2 Перемещение таблицы \ TODO: Необходимо "сместить" только отрисовку содержимого ячеек, имена столбиков и номера строк

\ ### 8.0 Хоткеи
' act-cell-left TO K_LEFT
' act-cell-right TO K_RIGHT
' act-cell-up TO K_UP
' act-cell-down TO K_DOWN

' cell-set-class-number  TO K_F1
' cell-set-class-fnumber TO K_F2
' cell-set-class-string TO K_F3
' cell-set-class-null TO K_F4

' cell-input  TO K_F5
' cell-finput TO K_F6
' cell-sinput TO K_F7
' cell-zeroize TO K_F8

' BYE TO K_F9
' DRAW-GUI TO K_HOME
' SAVE-TABLE TO K_F11
' LOAD-TABLE TO K_F12

' input-mouse  TO <MOUSE_LEFT>
' finput-mouse TO <MOUSE_WHEEL>
' sinput-mouse TO <MOUSE_RIGHT>

\ # 8.1 Помощь
: cell-pos-print \ row col --
  SWAP >R CELLA * table-x +
  R> CELLB * table-y +
  box-textxy CPRINT
;

: help
  FROM COL-ACTION
  ['] cell-pos-print TO COL-ACTION
  " [ ¦DD5544 F1¦:"   0 a   " ¦4455DD show number¦ ]"  0 b
  " [ ¦DD5544 F2¦:"   1 a   " ¦4455DD show float¦ ]"   1 b
  " [ ¦DD5544 F3¦:"   2 a   " ¦4455DD show string¦ ]"  2 b
  " [ ¦DD5544 F4¦:"   3 a   " ¦4455DD show null¦ ]"    3 b
  " [ ¦DD5544 F5¦:"   4 a   " ¦4455DD input number¦ ]" 4 b
  " [ ¦DD5544 F6¦:"   5 a   " ¦4455DD input float¦ ]"  5 b
  " [ ¦DD5544 F7¦:"   0 c   " ¦4455DD input string¦ ]" 0 d
  " [ ¦DD5544 F8¦:"   1 c   " ¦4455DD zeroize¦ ]"      1 d
  " [ ¦DD5544 F9¦:"   2 c   " ¦4455DD exit program¦ ]" 2 d
  " [ ¦DD5544 HOME¦:" 3 c   " ¦4455DD redraw gui¦ ]"   3 d
  " [ ¦DD5544 F11¦:"  4 c   " ¦4455DD save table¦ ]"   4 d
  " [ ¦DD5544 F12¦:"  5 c   " ¦4455DD load table¦ ]"   5 d
  " ¦FFFFFF type¦ ¦FFAA22 ?¦ ¦FFFFFF or¦ ¦FFAA22 help¦" 6 a
  " ¦55DD44 HOME¦ - hide" 7 a
  TO COL-ACTION
  hlight
;
: ? help ;
\ ### 9.0 Выполнение программы
\ ' DRAW-GUI TO OK

\ ' number@ TO CELLACTION
' col-work TO COL-ACTION
DRAW-GUI
help