GSFORTH-ROM/edit.txt at master · perfectconsulting/GSFORTH-ROM · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
vocabulary screen
screen definitions decimal

6 constant xoffset
3 constant yoffset

: (tab) ( x y -- )
    swap 31 (emit) (emit) (emit) ;

: tab ( x y -- )
    yoffset + swap xoffset + swap (tab) ;

: <tab> ( x y -- )
    2 + swap 4 + swap tab ;

: cursor/on ( -- )
    0 1 4 osbyte 2drop drop ;

: cursor/off ( -- )
    0 0 4 osbyte 2drop drop ;

: line ( n -- a )
    64 * scr @ block + ;

: key! ( c x y -- )
    line + c! ;

: key@ ( x y -- c )
    line + c@ ;

0 variable x
0 variable y
0 variable insmod
0 variable exit

: xyaddr ( -- a )
    y @ line x @ + ;

: characters ( c n -- )
    0 do dup (emit) loop drop ;

: ## ( n -- )
    0 <# # # #> (type) ;

: ruler ( -- )
    ascii - 69 characters ;

: .scr ( -- )
    0 0 tab ." Scr " scr @ ## ." /" blks @ 1- ## ;

: .mode ( -- )
    61 0 tab ." Mode " insmod @ if ." INS" else ." OVR" endif ;

: .pad ( -- )
    4 19 tab pad 64 (type) ;

: .xy ( -- )
    10 0 tab x @ ## ascii : (emit) y @ ## ;

: panel ( -- )
    cls
    .scr .xy .mode
    0 1 tab ruler
    16 0 do
    0 i 2+ tab ascii | (emit) i ##
    space ascii . 64 characters ascii | (emit)
    loop
    0 18 tab ruler
    0 19 tab ." |PD " ascii . 64 characters ascii | (emit)
    0 20 tab ruler .pad ;

: .line ( y -- )
    dup 0 swap <tab> line 64 (type) ;

: .list ( -- )
    16 0 do i .line loop ;

: slide> ( x y -- )
    line 63 + swap 64 swap - 0
    do dup c@  over 1+ c! 1- loop drop ;

: <slide ( x y -- )
    line over + swap 63 swap
    do dup 1+ c@  over c! 1+ loop drop ;

: insertline ( y -- )
     1- 14 do i line i 1+ line 64 cmove  -1 +loop ;

: deleteline ( y -- )
     15 swap do i 1+ line i line 64 cmove loop ;

: ctrl ( c -- c)
    64 - ;

: delete ( -- )
    insmod @ if
        x @ 1- 0 max  y @ <slide bl 63 y @ key!
    else
        bl x @ y @ key!
    endif -1 x +! y @ .line ;

: insert ( -- )
    insmod @ if
      x @ y @ slide> y @ .line
    endif
    x @ y @ <tab> dup dup (emit) x @ y @ key! 1 x +! ;

: movementkeys ( c -- f )
    dup 136 = if  -1 x +! -1 else
    dup 137 = if 1 x +! -1 else
    dup 139 = if -1 y +! -1 else
    dup 138 = if 1 y +! -1 else
    dup 13 = if 0 x ! 1 y +! -1 else
    dup 9 = if x @ 4 / 1+ 4 * x ! -1 else
    dup 127 = if delete -1 else
    0
    endif endif endif endif endif endif endif ;

: systemkeys ( c -- f )
    dup ascii X ctrl = if 1 exit !  -1 else
    dup ascii R ctrl = if .list -1 else
    dup ascii S ctrl = if update flush -1 else
    dup ascii T ctrl = if insmod @ not insmod ! .mode -1 else
    dup ascii N ctrl = if 0 blks @ 1- scr @ 1+ min max scr !
      .scr .list -1 else
    dup ascii L ctrl = if 0 blks @ 1- scr @ 1- min max scr !
      .scr .list -1 else
		0
		endif endif endif endif endif endif ;

: blockkeys ( c -- f )
    dup ascii C ctrl = if y @ line pad
      64 cmove .pad -1 else
    dup ascii V ctrl = if pad y @ line
      64 cmove y @ .line -1 else
    dup ascii D ctrl = if y @ insertline y @ line
      64 blanks .list -1 else
    dup ascii U ctrl = if y @ deleteline 15 line
      64 blanks .list -1 else
		dup ascii B ctrl = if y @ line 64 blanks
      y @ .line -1 else
    0
    endif endif endif endif endif  ;

: allkeys ( -- )
    key
    movementkeys not if
      systemkeys not if
        blockkeys not if
            insert
        endif
      endif
    endif ;

: keyscan ( -- )
    0 63 x @ min max x !
    0 15 y @ min max y !
    0 blks @ 1- scr @ min max scr !
    .xy x @ y @ <tab> allkeys
   	drop ;

: init ( -- )
    empty-buffers
    0 x ! 0 y ! cls
    0 insmod !
    pad 64 blanks
    0 exit !  ;

: edit ( n -- )
   scr !
   cursor/on
   init panel .list
   begin keyscan exit @ until
   cursor/off empty-buffers cls ;

forth definitions