Permalink
Find file
Fetching contributors…
Cannot retrieve contributors at this time
346 lines (267 sloc) 8.75 KB
\ editor.fs --- Real-time display block editor
\ Copyright 2012 (C) David Vazquez
\ This file is part of Eulex.
\ Eulex is free software: you can redistribute it and/or modify
\ it under the terms of the GNU General Public License as published by
\ the Free Software Foundation, either version 3 of the License, or
\ (at your option) any later version.
\ Eulex is distributed in the hope that it will be useful,
\ but WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
\ GNU General Public License for more details.
\ You should have received a copy of the GNU General Public License
\ along with Eulex. If not, see <http://www.gnu.org/licenses/>.
\ TODO: Mark commands with a special flag to allow ordinary Forth
\ words in the EDITOR-CMDS vocabulary.
VOCABULARY EDITOR
VOCABULARY EDITOR-CMDS
EULEX
ALSO EDITOR
ALSO EDITOR DEFINITIONS
require @kernel/console.fs
require @colors.fs
require @blocks.fs
variable nblock
variable buffer
variable &point
: memshift> ( addr u c -- ) swap >r 2dup + swap r> - abs cmove> ;
: <memshift ( addr u c -- ) tuck - abs >r over + swap r> cmove ;
: point &point @ ;
: goto-char &point ! ;
true value visible-bell
: flash invert-screen 50 ms invert-screen ;
: alert visible-bell if flash else beep endif ;
: line-number-at-pos 64 / ;
: column-number-at-pos 64 mod ;
: line point line-number-at-pos ;
: column point column-number-at-pos ;
: right-column 63 column - ;
: line-beginning-position point column - ;
: line-end-position line-beginning-position 63 + ;
: position>addr chars buffer @ + ;
: char-at position>addr c@ ;
: point>addr point position>addr ;
: position>screen 64 /mod 4 + swap 7 + swap ;
: update-cursor point position>screen at-xy update-hardware-cursor ;
: box-corners
06 03 at-xy $da emit-char
71 03 at-xy $bf emit-char
06 20 at-xy $c0 emit-char
71 20 at-xy $d9 emit-char ;
: --- 0 ?do $c4 emit-char loop ;
: | $b3 emit-char ;
: .2 dup 10 < if $20 emit-char then . ;
: box
gray upon black
07 03 at-xy 64 ---
16 00 ?do cr 3 spaces i .2 | 64 spaces | loop
07 20 at-xy 64 ---
box-corners ;
: render-title
upon blue 80 spaces
36 0 at-xy light cyan ." EDITOR " ;
create minibuffer-string 79 chars allot
: render-modeline
attr
00 23 at-xy upon blue 80 spaces
03 23 at-xy light cyan ." Block: " nblock ?
attr! ;
: render-minibuffer
00 24 at-xy light gray upon black minibuffer-string 79 type ;
: render-application
page render-title box render-modeline render-minibuffer ;
\ Bitmap of lines which need to be redrawn
variable lines-to-render
: safe-emit dup 32 < if drop [char] . then emit ;
: safe-type 0 ?do dup c@ safe-emit 1+ loop drop ;
: render-line
64 * dup position>screen at-xy position>addr 64 safe-type ;
: render
lines-to-render @
16 0 ?do dup 1 and if i render-line endif 1 rshift loop
lines-to-render !
render-minibuffer ;
: redraw-line 1 line lshift lines-to-render or! ;
: redraw-buffer -1 lines-to-render ! ;
: redraw-lines ( from to -- )
1 swap 1+ lshift 1- swap
1 swap lshift 1- negate .s
lines-to-render or! ;
create command-name 80 chars allot
: in-editor-cmds: also editor-cmds context @ 1 set-order ;
: read-command
get-order in-editor-cmds:
0 24 at-xy ." M-x " command-name dup 74 accept
c-addr find-cname >r
set-order r> ;
\ Commands
variable editor-loop-quit
variable last-read-key
create keymap 1024 cells zallot
: out-of-range? 0 swap 1023 between not ;
: at-beginning? point 0 = ;
: at-end? point 1023 = ;
: move-char ( n -- )
point + dup out-of-range? if abort else goto-char then ;
: white-string? -trailing nip 0= ;
: empty-line? ( u -- bool )
960 position>addr 64 white-string? ;
: shift> ( addr u c -- )
rot dup >r -rot dup >r memshift> r> r> swap 32 fill ;
: <shift ( addr u c -- )
2 pick 2 pick + over - >r dup >r <memshift r> r> swap 32 fill ;
: [INTERNAL] also editor definitions ;
: [END] previous definitions ;
' point alias <E
' goto-char alias E>
: message ( addr u -- )
minibuffer-string 79 32 fill
79 min minibuffer-string swap move ;
: clear-minibuffer
0 0 message ;
: substring ( position1 position2 -- )
over - >r position>addr r> ;
: open-buffer ( u -- )
dup nblock !
block buffer !
redraw-buffer render-modeline ;
EDITOR-CMDS DEFINITIONS
: beginning-of-line line-beginning-position goto-char ;
' beginning-of-line alias bol
: end-of-line line-end-position goto-char ;
' end-of-line alias eol
[INTERNAL]
: whole-line <E bol point eol point substring 1+ rot E> ;
: rest-of-line <E dup eol point substring 1+ rot E> ;
[END]
: rewind
rest-of-line white-string? if
begin point char-at 32 = column 0<> and while -1 move-char repeat
point char-at 32 <> if 1 move-char then
then ;
: next-line 64 move-char rewind ;
: previous-line -64 move-char rewind ;
: forward-char
rest-of-line tuck white-string? not if drop 1 then
move-char ;
: backward-char
column 0= if previous-line eol rewind else -1 move-char endif ;
: beginning-of-buffer 0 goto-char ; : end-of-buffer 1023 goto-char ;
' beginning-of-buffer alias bob ' end-of-buffer alias eob
: beginning-of-paragraph
bol begin at-beginning? if exit then
point 1- char-at 32 <> while
previous-line
repeat ;
' beginning-of-paragraph alias bop
: end-of-paragraph
eol begin point char-at 32 <> at-end? not and while
next-line
repeat
rewind ;
' end-of-paragraph alias eop
: forward-word
begin point char-at 32 = at-end? not and while 1 move-char repeat
begin point char-at 32 <> at-end? not and while 1 move-char repeat ;
: backward-word
at-beginning? not if -1 move-char then
begin point char-at 32 = at-beginning? not and while -1 move-char repeat
begin point char-at 32 <> at-beginning? not and while -1 move-char repeat
at-beginning? not if 1 move-char then ;
[INTERNAL]
: whole-paragraph <E bop point eop point substring 1+ rot E> ;
: whole-buffer <E bob point eob point substring 1+ rot E> ;
: rest-of-paragraph <E dup eop point substring 1+ rot E> ;
: rest-of-buffer <E dup eob point substring 1+ rot E> ;
[END]
: erase-buffer whole-buffer 32 fill bob ;
: newline
15 empty-line? not if abort then
<E next-line bol rest-of-buffer 64 shift> E>
point>addr right-column 65 + right-column 1+ shift>
eol 1 move-char redraw-buffer ;
: self-insert-command
rest-of-paragraph 1 memshift>
last-read-key @ point>addr c!
1 move-char redraw-buffer ;
: delete-char rest-of-paragraph 1 <shift redraw-buffer ;
: delete-backward-char backward-char delete-char ;
: execute-extended-command
read-command ?dup if nt>xt execute else abort then ;
: load-buffer
save-screen sp >r
light gray upon black
page update-hardware-cursor
nblock @ load
r> sp! restore-screen
redraw-buffer ;
: save-buffer
update flush s" Block changes saved." message ;
: next-buffer nblock @ 1 + open-buffer ;
: previous-buffer nblock @ ?dup if 1- open-buffer then ;
: kill-editor editor-loop-quit on ;
ALSO EDITOR DEFINITIONS
: ekey->kbd
dup alt-mod and if swap $100 + swap then
ctrl-mod and if $200 + then ;
: read-key ekey ekey->kbd dup last-read-key ! ;
: kbd-command cells keymap + @ ;
: M- char $100 + ;
: C- char $200 + ;
: C-M- char $300 + ;
: key-for: nt' swap cells keymap + ! ;
: C-X-dispatcher
read-key case
[ C- s ]L of save-buffer endof
[ C- c ]L of kill-editor endof
abort
endcase ;
UP key-for: previous-line
DOWN key-for: next-line
LEFT key-for: backward-char
RIGHT key-for: forward-char
BACK key-for: delete-backward-char
RET key-for: newline
M- x key-for: execute-extended-command
M- < key-for: beginning-of-buffer
M- > key-for: end-of-buffer
M- f key-for: forward-word
M- b key-for: backward-word
$100 RIGHT + key-for: next-buffer
$100 LEFT + key-for: previous-buffer
C- x key-for: C-X-dispatcher
C- f key-for: forward-char
C- b key-for: backward-char
C- p key-for: previous-line
C- n key-for: next-line
C- d key-for: delete-char
C- a key-for: beginning-of-paragraph
C- e key-for: end-of-paragraph
C- c key-for: load-buffer
:noname
127 32 ?do [nt'] self-insert-command i cells keymap + ! loop
; execute
PREVIOUS EDITOR-CMDS
PREVIOUS EDITOR
DEFINITIONS
\ Command dispatch
: editor-loop
editor-loop-quit off
begin
render update-cursor redraw-line
read-key clear-minibuffer kbd-command ?dup if
nt>xt ['] execute catch if drop alert then
else alert then
redraw-line
editor-loop-quit @ until ;
: edit ( u -- )
dup nblock ! block buffer !
save-screen
clear-minibuffer
0 goto-char
render-application redraw-buffer
editor-loop
restore-screen ;
' EDIT
PREVIOUS DEFINITIONS ALIAS EDIT
\ editor.fs ends here