Skip to content
Permalink
master
Switch branches/tags

Name already in use

A tag already exists with the provided branch name. Many Git commands accept both tag and branch names, so creating this branch may cause unexpected behavior. Are you sure you want to create this branch?
Go to file
 
 
Cannot retrieve contributors at this time
\ 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