fth/flkinput.fs

   1 \  FLK basic input words
   2 \
   3 \  Copyright (C) 1998 Lars Krueger
   4 \
   5 \  This file is part of FLK.
   6 \
   7 \  FLK is free software; you can redistribute it and/or
   8 \  modify it under the terms of the GNU General Public License
   9 \  as published by the Free Software Foundation; either version 2
  10 \  of the License, or (at your option) any later version.
  11 \
  12 \  This program is distributed in the hope that it will be useful,
  13 \  but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 \  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 \  GNU General Public License for more details.
  16 \
  17 \  You should have received a copy of the GNU General Public License
  18 \  along with this program; if not, write to the Free Software
  19 \  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20
  21 \ $Id: flkinput.fs,v 1.13 1998/08/30 10:50:59 root Exp $
  22 \ $Log: flkinput.fs,v $
  23 \ Revision 1.13  1998/08/30 10:50:59  root
  24 \ new optimizing algorithm
  25 \
  26 \ Revision 1.12  1998/06/01 17:51:42  root
  27 \ SEE shows the sourcefile using VIEW
  28 \
  29 \ Revision 1.11  1998/05/27 18:52:12  root
  30 \ \: commants added for SEE and HELP
  31 \
  32 \ Revision 1.10  1998/05/16 16:19:24  root
  33 \ direct terminfo access
  34 \
  35 \ Revision 1.9  1998/05/03 12:06:37  root
  36 \ added macro support
  37 \
  38 \ Revision 1.8  1998/05/01 18:11:25  root
  39 \ GNU license text added
  40 \ comments checked
  41 \
  42 \ Revision 1.7  1998/04/30 09:42:25  root
  43 \ Comments added.
  44 \
  45 \ Revision 1.6  1998/04/29 18:20:30  root
  46 \ alarm signal (audible/visible)
  47 \
  48 \ Revision 1.5  1998/04/27 18:41:42  root
  49 \ history support added
  50 \
  51 \ Revision 1.4  1998/04/11 11:55:44  root
  52 \ FORGET/MARKER support added
  53 \
  54 \ Revision 1.3  1998/04/10 14:42:50  root
  55 \ bugs corrected
  56 \
  57 \ Revision 1.2  1998/04/09 11:35:03  root
  58 \ all words checked and OK
  59 \
  60 \ Revision 1.1  1998/04/07 20:10:33  root
  61 \ Initial revision
  62 \
  63
  64 \ Loud enough?
  65 0 VALUE audible-signal
  66
  67 \ Ring a bell of flash the screen.
  68 : ALERT       ( -- )
  69   audible-signal IF BELL ELSE FLASH THEN ;
  70
  71 \ List of history lists.
  72 0 VALUE histories
  73
  74 \ Start with an empty history.
  75 : init-history []( TO histories ;
  76
  77 \ Retrieve or create the history list with the given id. All history lists
  78 \ between the last and this one are set to 0.
  79 : get-history       ( id -- hlist )
  80   histories DUP []#     \ id hist cnt
  81   BEGIN
  82     PLUCK OVER      \ id hist cnt id cnt
  83     >=
  84   WHILE       \ id hist cnt
  85     1+ SWAP       \ id cnt+1 hist
  86     0 []+= SWAP     \ id hist cnt
  87   REPEAT DROP       \ id hist
  88   TUCK SWAP       \ hist hist id
  89   []@         \ hist hlist
  90   ?DUP 0= IF ( no hlist yet )   \ hist
  91     [](       \ hist hlist
  92   THEN        \ hist hlist
  93   SWAP TO histories ;
  94
  95 \ Place the history list in the top level list.
  96 : set-history       ( hlist id -- )
  97   histories SWAP ROT []! TO histories ;
  98
  99 \ Allocate a string and append it to the list.
 100 : $[]+=       ( addr len hlist -- hlist )
 101   -ROT $ALLOCOPY []+= ;
 102
 103 -1 VALUE history-id
 104
 105 0 VALUE completer
 106
 107 0 VALUE (ac-maxlen)
 108 0 VALUE (ac-buf)
 109 0 VALUE (ac-ind)
 110 0 VALUE (ac-len)
 111 0 VALUE (ac-hist)
 112 0 VALUE (ac-histind)
 113
 114 -1 CONSTANT BACK_CHAR
 115
 116 \ Set the cursor to position ind.
 117 : (ac-setind)         ( ind -- )
 118   (ac-ind)        \ new old
 119   2DUP -        \ new old move
 120   DUP 0< IF ( backwards)    \ new old move
 121     NEGATE 0 DO
 122       BACK_CHAR EMIT
 123     LOOP DROP
 124   ELSE ( fwd )        \ new old move
 125     (ac-buf) ROT +      \ new move addr
 126     SWAP 0 ?DO        \ new addr
 127       DUP C@ EMIT CHAR+
 128     LOOP DROP
 129   THEN
 130   TO (ac-ind) ;
 131
 132 \ How many characters right of the cursor?
 133 : (ac-rest) (ac-len) (ac-ind) - ;
 134
 135 \ Which address the cursor is over?
 136 : (ac-bufind) (ac-buf) (ac-ind) + ;
 137
 138 \ Insert one character under the cursor.
 139 : (ac-insert)         ( char -- )
 140   (ac-bufind) DUP CHAR+     \ from to
 141   (ac-rest)         \ from to cnt
 142   CMOVE>
 143   TO++ (ac-len)
 144   (ac-ind) CHARS (ac-buf) + C! ;
 145
 146 \ Delete one character under the cursor.
 147 : (ac-delete)         ( -- )
 148   (ac-ind) (ac-len) < IF
 149     (ac-bufind) DUP CHAR+ SWAP    \ from to
 150     (ac-rest) CMOVE
 151     TO-- (ac-len)
 152   THEN ;
 153
 154 \ Move cnt bytes from from-ind to to-ind without overflowing the buffer.
 155 : (ac-move)         ( to-ind from-ind cnt -- )
 156   PLUCK OVER +        \ to-ind from-ind cnt end-ind
 157   (ac-maxlen) OVER      \ to-ind from-ind cnt end-ind max end
 158   < IF          \ to-ind from-ind cnt end-ind
 159     NIP
 160     PLUCK         \ to-ind from-ind end-ind to-ind
 161     (ac-maxlen) SWAP - SWAP     \ to-ind from-ind cnt end-ind
 162   THEN DROP
 163   MOVE
 164 ;
 165
 166 \ Replace the buffer contents from len characters before (ac-ind) with the
 167 \ given string.
 168 : (ac-replace)        ( len addr' len' -- )
 169   DUP FLOCK -         \ len addr' len' growth
 170   DUP (ac-ind) +      \ len addr' len' growth to-ind
 171   (ac-ind)        \ len addr' len' growth to-ind from-ind
 172   (ac-len) (ac-ind) - (ac-move)   \ len addr' len' growth
 173   -TURN         \ growth len addr' len'
 174   (ac-ind) TURN - (ac-buf) +    \ growth addr' len' dst
 175   SWAP MOVE         \ growth
 176   DUP +TO (ac-ind)
 177   +TO (ac-len)
 178 ;
 179
 180 \ One step to the left...
 181 : (ac-moveleft) 0 (ac-ind) 1- MAX (ac-setind) ;
 182
 183 \ One step to the right...
 184 : (ac-advance)        ( -- )
 185   TO++ (ac-ind)
 186   (ac-ind) (ac-len) MAX TO (ac-len) ;
 187
 188 \ Pick last item in history.
 189 : (ac-prevhist)       ( -- )
 190   history-id -1 <> IF
 191     (ac-histind) DUP 0= IF
 192       DROP (ac-hist) []# 1- 0 MAX
 193     ELSE
 194       1-
 195     THEN
 196     TO (ac-histind)
 197   THEN ;
 198
 199 \ Pick next item in history.
 200 : (ac-nexthist)       ( -- )
 201   history-id -1 <> IF
 202     (ac-histind) 1+ (ac-hist) []# OVER =
 203     IF
 204       DROP 0
 205     THEN
 206     TO (ac-histind)
 207   THEN ;
 208
 209 \ Copy the current history item to the buffer.
 210 : (ac-copyhist)       ( -- )
 211   history-id -1 <> IF
 212     (ac-hist) (ac-histind)    \ hlist ind
 213     []@ $COUNT        \ addr cnt
 214     (ac-maxlen) MIN       \ addr cnt
 215     DUP TO (ac-len)
 216     DUP TO (ac-ind)
 217     (ac-buf) SWAP MOVE
 218   THEN ;
 219
 220 \ Hide the displayed string and leave then cursor at the beginning of the
 221 \ line.
 222 : (ac-prep-redisp)      ( -- )
 223   (ac-len) (ac-ind) -  SPACES
 224   (ac-len) 0 ?DO BACK_CHAR EMIT LOOP
 225   (ac-ind) SPACES
 226   (ac-ind) 0 ?DO BACK_CHAR EMIT LOOP
 227 ;
 228
 229 \ Redisplay the buffer and put the cursor to the right position.
 230 : (ac-redisplay)      ( -- )
 231   (ac-buf) (ac-len) TYPE
 232   (ac-len) (ac-ind) - 0 ?DO BACK_CHAR EMIT LOOP
 233 ;
 234
 235 \ Call the completer word if one is set.
 236 : (ac-complete)       ( -- )
 237   completer IF
 238     (ac-prep-redisp)
 239     completer EXECUTE
 240     (ac-redisplay)
 241   THEN ;
 242
 243 \ Show the rest of the line beginning at the current position.
 244 : (ac-disp-rest)      ( -- )
 245   (ac-buf) (ac-ind) +
 246   (ac-len) (ac-ind) -
 247   TYPE SPACE ;
 248
 249 \ Move the cursor backwards from the end to the current position.
 250 : (ac-end-to-ind)       ( -- )
 251   (ac-len) (ac-ind) - 1+ 0
 252   ?DO BACK_CHAR EMIT LOOP ;
 253
 254 \ See standard.
 255 : ACCEPT          ( c-addr +n1 -- +n2 )
 256 ( OK )
 257   TO (ac-maxlen)
 258   TO (ac-buf)
 259   0 TO (ac-len)
 260   0 TO (ac-ind)
 261   history-id DUP -1 <> IF
 262     get-history S" " ROT $[]+= DUP TO (ac-hist)
 263     []# 1- TO (ac-histind)
 264   ELSE
 265     DROP
 266   THEN
 267   BEGIN
 268     FALSE EKEY        \ end? key
 269     CASE
 270       KEY_RET     OF DROP TRUE ENDOF
 271       KEY_HOME    OF 0 (ac-setind) ENDOF
 272       KEY_END     OF (ac-len) (ac-setind) ENDOF
 273       KEY_LEFT    OF (ac-moveleft) ENDOF
 274       KEY_RIGHT   OF (ac-len) (ac-ind) 1+ MIN (ac-setind) ENDOF
 275       KEY_DC    OF (ac-delete) (ac-disp-rest) (ac-end-to-ind) ENDOF
 276       KEY_BACKSPACE   OF
 277         (ac-moveleft) (ac-delete) (ac-disp-rest)
 278         (ac-end-to-ind) ENDOF
 279       KEY_UP    OF
 280         (ac-prep-redisp) (ac-prevhist) (ac-copyhist) (ac-redisplay)
 281       ENDOF
 282       KEY_DOWN    OF
 283         (ac-prep-redisp) (ac-nexthist) (ac-copyhist) (ac-redisplay)
 284       ENDOF
 285       KEY_TAB     OF (ac-complete) ENDOF
 286       DUP 32 256 WITHIN     \ end? key ascii?
 287       IF
 288   (ac-len) (ac-maxlen) < IF
 289     DUP (ac-insert)
 290     (ac-disp-rest)
 291     (ac-advance)
 292     (ac-end-to-ind)
 293   THEN
 294       THEN
 295     ENDCASE         \ end?
 296   UNTIL         \
 297   (ac-disp-rest) (ac-len)     \ len
 298   history-id -1 <> IF
 299     (ac-buf)  OVER  $ALLOCOPY     \ len str
 300     (ac-hist) DUP []# 1-    \ len str hlist ind
 301     []&         \ len str addr
 302     exchange        \ len oldstr
 303     FREE THROW
 304     (ac-hist) history-id set-history
 305   THEN ;
 306
 307 \ See standard.
 308 0 VALUE SOURCE-ID
 309
 310 \ Terminal Input Buffer
 311 CREATE TIB #TIB-LEN CHARS ALLOT
 312 \ File Input Buffer
 313 CREATE FIB #TIB-LEN CHARS ALLOT
 314 #TIB-LEN CONSTANT #TIB-LEN
 315 0 VALUE (fib-ind-h)
 316 0 VALUE (fib-ind-l)
 317 0 VALUE #FIB
 318
 319 0 VALUE (eval-addr)
 320 0 VALUE (eval-len)
 321
 322 \ See standard.
 323 : SOURCE        ( -- addr len )
 324 ( OK )
 325   SOURCE-ID CASE
 326     -1 OF (eval-addr) (eval-len) ENDOF
 327      0 OF TIB #TIB @ ENDOF
 328      FIB #FIB ROT
 329   ENDCASE ;
 330
 331 \ See standard.
 332 : EXPECT        ( c-addr +n -- )
 333 ( OK )
 334   ACCEPT SPAN ! ;
 335
 336 \ find word before cursor in accept buffer
 337 : completer-word      ( -- addr len )
 338   (ac-buf) (ac-ind) + 0     \ addr len
 339   BEGIN
 340     OVER CHAR- C@ whitespace?     \ addr len space?
 341     PLUCK (ac-buf) = OR     \ addr len done?
 342     DUP INVERT IF
 343       -ROT -1 /STRING ROT
 344     THEN
 345   UNTIL ;
 346
 347 \ Starts s1,l1 with l2 characters at s2 ?
 348 : starting?         ( s1 l1 s2 l2 -- flag )
 349   ROT 2DUP        \ s1 s2 l2 l1 l2 l1
 350   > IF          \ s1 s2 l2 l1
 351    ( s1 is shorter than s2 -> can't start with it )
 352    2DROP 2DROP FALSE
 353   ELSE          \ s1 s2 l2 l1
 354     DROP TUCK         \ s1 l s2 l
 355     CAPS @
 356     IF CAPS-COMPARE ELSE COMPARE THEN
 357     0=
 358   THEN ;
 359
 360 \ Return the length of the longest common string of the strings at addr1 and
 361 \ addr2 with the maximum length len1.
 362 : lcs           ( addr1 addr2 len1 -- len2 )
 363   DUP -TURN         \ len s1 s2 len
 364   0 ?DO         \ len s1 s2
 365     2DUP C@ SWAP C@       \ len s1 s2 c2 c1
 366     CAPS @ IF
 367       >UPPER SWAP >UPPER
 368     THEN
 369     <> IF         \ len s1 s2
 370       2DROP DROP I UNLOOP EXIT
 371     THEN        \ len s1 s2
 372     CHAR+ SWAP CHAR+ SWAP
 373   LOOP          \ len s1 s2
 374   2DROP ;
 375
 376 \ Find the len2 first characters that the names of xt1 and xt2 have in common,
 377 \ but only up to len1 chars.
 378 : ((lcs))         ( xt1 len1 xt2 -- xt1 len2 )
 379   PLUCK         \ xt1 len1 xt2 xt1
 380   >NAME CHAR+         \ xt1 len1 xt2 s1
 381   SWAP >NAME CHAR+      \ xt1 len1 s1 s2
 382   ROT           \ xt1 s1 s2 len1
 383   lcs           \ xt1 len2
 384 ;
 385
 386 \ Search through one hash line
 387 : ((find-lcs))    ( addr len xt len' cnt line -- addr len xt len' cnt)
 388   BEGIN
 389     @ DUP IMAGE-BASE <>
 390   WHILE       \ addr len xt len' cnt xt'
 391     DUP >R >NAME COUNT    \ addr len xt len' cnt wrd #wrd / r: xt'
 392     2>R       \ addr len xt len' cnt / r: xt' wrd #wrd
 393     TWIST TWIST     \ xt len' cnt addr len
 394     2R>       \ xt len' cnt addr len wrd #wrd / r: xt'
 395     2OVER starting?       \ xt len' cnt addr len starts?
 396     IF          \ xt len' cnt addr len
 397       ( found a word )
 398       -TWIST -TWIST       \ addr len xt len' cnt
 399       1+ -ROT         \ addr len cnt xt len' / r: xt'
 400       OVER 0= IF
 401         ( first word found )
 402   2DROP R@      \ addr len cnt xt
 403   DUP >NAME C@      \ addr len cnt xt len'
 404       ELSE        \ addr len cnt xt len' / r: xt'
 405         R@        \ addr len cnt xt len' xt' / r: xt'
 406   PLUCK >NAME COUNT TYPE SPACE  \ addr len cnt xt len' xt'
 407   ((lcs))       \ addr len cnt xt len' / r: xt'
 408   NIP R@ SWAP
 409       THEN
 410       ROT TWIST TWIST
 411     THEN        \ xt len' cnt addr len / r: xt'
 412     -TWIST -TWIST R>      \ addr len xt len' cnt xt'
 413   REPEAT DROP
 414 ;
 415
 416 \ Search through one wordlist.
 417 : (find-lcs)  ( addr len xt len' cnt wid -- addr len xt len' cnt )
 418   #BUCKETS 0 DO       \ addr len xt len' cnt line
 419     DUP >R        \ addr len xt len' cnt line
 420     ((find-lcs)) R>       \ addr len xt len' cnt line
 421     CELL+
 422   LOOP DROP
 423 ;
 424
 425 \ Search through all wordlists in search-order and look for words starting
 426 \ with the given string. The number of words found is returned and depending
 427 \ on it the xt of this word or the longest common string of these words.
 428 : find-lcs        ( addr len -- xt 1 / 0 / addr' len' n )
 429   0 0 0         \ addr len xt len' cnt
 430   ((unique-cnt)) @      \ addr len xt len' cnt vocs
 431   0 ?DO         \ addr len xt len' cnt
 432     I CELLS ((unique-order)) + @  \ addr len xt len' cnt wid
 433     (find-lcs)
 434   LOOP          \ addr len xt len' cnt
 435   TWIST TWIST 2DROP       \ xt len' cnt
 436   DUP CASE        \ xt len' cnt cnt
 437     0 OF NIP NIP ENDOF
 438     1 OF NIP ENDOF
 439     TURN        \ len' cnt cnt xt
 440     >NAME COUNT       \ len' cnt cnt addr len
 441     OVER SWAP TYPE SPACE -TURN    \ addr' len' cnt cnt
 442   ENDCASE
 443 ;
 444
 445 \ Find the longest common string of all words in search order beginning at the
 446 \ first space left of the cursor.
 447 : query-completer       ( -- )
 448   completer-word      \ addr len
 449   TUCK          \ len addr len
 450   DUP 0= IF
 451     2DROP DROP
 452   ELSE
 453     find-lcs        \ len ( xt 1 / 0 / addr' len' n )
 454     CASE
 455       0 OF ALERT DROP ENDOF
 456       1 OF >NAME COUNT      \ len addr' len'
 457            (ac-replace)
 458      BL (ac-insert)
 459      (ac-advance)
 460   ENDOF
 461       -TURN         \ n len addr' len'
 462       CR
 463       (ac-replace)      \ n
 464       ALERT ALERT
 465     ENDCASE
 466   THEN ;
 467
 468 \ See standard.
 469 : QUERY         ( -- )
 470 ( OK )
 471   0 TO SOURCE-ID
 472   history-id        \ hid
 473   completer         \ hid compl
 474   0 TO history-id
 475   ['] query-completer TO completer
 476   TIB #TIB-LEN ACCEPT
 477   #TIB !
 478   TO completer
 479   TO history-id
 480   0 >IN ! ;
 481
 482 0 VALUE (refill-line)
 483 0 VALUE (error-line)
 484
 485 \ See standard.
 486 : REFILL        ( -- flag )
 487 ( OK )
 488   SOURCE-ID CASE
 489     -1 OF FALSE ENDOF
 490      0 OF QUERY CR TRUE ENDOF
 491      DUP FILE-POSITION THROW    \ fid fpl fph
 492      TO (fib-ind-h) TO (fib-ind-l)
 493      FIB #TIB-LEN       \ fid buf len
 494      PLUCK READ-LINE THROW    \ fid len !eof?
 495      SWAP TO #FIB       \ fid !eof?
 496      SWAP
 497      TO++ (refill-line)
 498   ENDCASE
 499   DUP IF
 500     0 >IN !
 501   THEN ;
 502
 503 0 VALUE (last-parse-from)
 504 0 VALUE (last-parse-len)
 505 0 VALUE (error-parse-from)
 506 0 VALUE (error-parse-len)
 507
 508 \ See standard.
 509 : SAVE-INPUT          ( -- ... n )
 510 ( OK )
 511   >IN @           \ >in
 512   SOURCE-ID CASE
 513     -1 OF (eval-addr) (eval-len) 4 ENDOF  \ >in eval-addr eval-len 4
 514      0 OF 2 ENDOF         \ >in 2
 515      (fib-ind-l) (fib-ind-h) (refill-line)    \ >in sid fibl fibh line
 516      TURN           \ >in fibl fibh line sid
 517      (last-parse-len) (last-parse-from) 7   \ >in fibl fibh line sid lpl lpf 7
 518      TURN
 519   ENDCASE
 520   SOURCE-ID SWAP
 521   ;
 522
 523 \ See standard.
 524 : RESTORE-INPUT         ( .. n -- flag )
 525 ( OK )
 526   DROP            \ ... sid
 527   (refill-line) TO (error-line)
 528   (last-parse-from) TO (error-parse-from)
 529   (last-parse-len) TO (error-parse-len)
 530   DUP TO SOURCE-ID        \ ... sid
 531   CASE
 532     -1 OF TO (eval-len) TO (eval-addr)
 533           FALSE ENDOF         \ >in flag
 534      0 OF FALSE ENDOF         \ >in flag
 535                 \ >in fibl fibh line lpl lpf fid
 536      SWAP TO (last-parse-from)
 537      SWAP TO (last-parse-len)
 538      SWAP TO (refill-line)
 539      -ROT           \ >in fid fibl fibh
 540      TO (fib-ind-h) TO (fib-ind-l)    \ >in fid
 541      (fib-ind-l) (fib-ind-h) PLUCK    \ >in fid fibl fibh fid
 542      REPOSITION-FILE THROW
 543      TO-- (refill-line)
 544      REFILL INVERT SWAP       \ >in flag fid
 545   ENDCASE SWAP >IN ! ;