fth/history.fth

\ Command Line History
\
\ Author: Phil Burk
\ Copyright 1988 Phil Burk
\ Revised 2001 for pForth

0 [IF]

Requires an ANSI compatible terminal.

To get Windows computers to use ANSI mode in their DOS windows,
Add this line to "C:\CONFIG.SYS" then reboot.

  device=c:\windows\command\ansi.sys

When command line history is on, you can use the UP and DOWN arrow to scroll
through previous commands. Use the LEFT and RIGHT arrows to edit within a line.
   CONTROL-A moves to beginning of line.
   CONTROL-E moves to end of line.
   CONTROL-X erases entire line.


HISTORY#       ( -- , dump history buffer with numbers)
HISTORY        ( -- , dump history buffer )
XX             ( line# -- , execute line x of history )
HISTORY.RESET  ( -- , clear history tables )
HISTORY.ON     ( -- , install history vectors )
HISTORY.OFF    ( -- , uninstall history vectors )

[THEN]

include? ESC[ termio.fth

ANEW TASK-HISTORY.FTH
decimal

private{

\ You can expand the history buffer by increasing this constant!!!!!!!!!!
2048 constant KH_HISTORY_SIZE

create KH-HISTORY kh_history_size allot
KH-HISTORY kh_history_size erase

\ An entry in the history buffer consists of
\   byte  - Count byte = N,
\   chars - N chars,
\   short -  line number in Big Endian format,
\   byte  - another Count byte = N, for reverse scan
\
\ The most recent entry is put at the beginning,
\ older entries are shifted up.

4 constant KH_LINE_EXTRA_SIZE ( 2 count bytes plus 2 line_number bytes )

: KH-END ( -- addr , end of history buffer )
    kh-history kh_history_size +
;

: LINENUM@ ( addr -- w , stores in BigEndian format )
    dup c@ 8 shift
    swap 1+ c@ or
;

: LINENUM! ( w addr -- )
    over -8 shift over c!
    1+ c!
;

variable KH-LOOK      ( cursor offset into history, point to 1st count byte of line )
variable KH-MAX
variable KH-COUNTER       ( 16 bit counter for line # )
variable KH-SPAN          ( total number of characters in line )
variable KH-MATCH-SPAN    ( span for matching on shift-up )
variable KH-CURSOR        ( points to next insertion point )
variable KH-ADDRESS       ( address to store chars )
variable KH-INSIDE        ( true if we are scrolling inside the history buffer )

: KH.MAKE.ROOM ( N -- , make room for N more bytes at beginning)
    >r  ( save N )
    kh-history dup r@ + ( source dest )
    kh_history_size r> - 0 max move
;

: KH.NEWEST.LINE  ( -- addr count , most recent line )
    kh-history count
;

: KH.REWIND ( -- , move cursor to most recent line )
    0 kh-look !
;

: KH.CURRENT.ADDR ( -- $addr , count byte of current line )
    kh-look @ kh-history +
;

: KH.CURRENT.LINE ( -- addr count )
    kh.current.addr count
;

: KH.COMPARE ( addr count -- flag , true if redundant )
    kh.newest.line compare 0=   \ note: ANSI COMPARE is different than JForth days
;

: KH.NUM.ADDR ( -- addr , address of current line's line count )
    kh.current.line +
;

: KH.CURRENT.NUM ( -- # , number of current line )
    kh.num.addr LINENUM@
;

: KH.ADDR++  ( $addr -- $addr' , convert one kh to previous )
    count + 3 +
;
: KH.ADDR--  ( $addr -- $addr' , convert one kh to next )
    dup 1- c@   \ get next lines endcount
    4 +  \ account for lineNum and two count bytes
    -       \ calc previous address
;

: KH.ENDCOUNT.ADDR ( -- addr , address of current end count )
    kh.num.addr 2+
;

: KH.ADD.LINE ( addr count -- )
    dup 256 >
    IF ." KH.ADD.LINE - Too big for history!" 2drop
    ELSE   ( add to end )
\ Compare with most recent line.
        2dup kh.compare
        IF 2drop
        ELSE
            >r ( save count )
\ Set look pointer to point to first count byte of last string.
            0 kh-look !
\ Make room for this line of text and line header.
\ PLB20100823 Was cell+ which broke on 64-bit code.
            r@ KH_LINE_EXTRA_SIZE + kh.make.room
\ Set count bytes at beginning and end.
            r@ kh-history c!  ( start count )
            r@ kh.endcount.addr c!
            kh-counter @ kh.num.addr LINENUM!  ( line )
\ Number lines modulo 1024
            kh-counter @ 1+ $ 3FF and kh-counter !
            kh-history 1+   ( calc destination )
            r> cmove  ( copy chars into space )
        THEN
    THEN
;

: KH.BACKUP.LINE  { | cantmove addr' -- cantmove , advance KH-LOOK if in bounds }
    true -> cantmove ( default flag, at end of history )
\ KH-LOOK points to count at start of current line
    kh.current.addr c@       \ do we have any lines?
    IF
        kh.current.addr kh.addr++ -> addr'
        addr' kh-end U<      \ within bounds?
        IF
            addr' c@     \ older line has chars?
            IF
                addr' kh-history - kh-look !
                false -> cantmove
            THEN
        THEN
    THEN
    cantmove
;

: KH.FORWARD.LINE ( -- cantmove? )
    kh-look @ 0= dup not
    IF  kh.current.addr kh.addr--
    kh-history - kh-look !
    THEN
;

: KH.OLDEST.LINE   ( -- addr count | 0, oldest in buffer )
    BEGIN kh.backup.line
    UNTIL
    kh.current.line dup 0=
    IF
        nip
    THEN
;

: KH.FIND.LINE ( line# -- $addr )
    kh.rewind
    BEGIN kh.current.num over -
    WHILE kh.backup.line
        IF ." Line not in History Buffer!" cr drop 0 exit
        THEN
    REPEAT
    drop kh.current.addr
;


: KH-BUFFER ( -- buffer )
    kh-address @
;

: KH.RETURN ( -- , move to beginning of line )
    0 out !
    13 emit
;

: KH.REPLACE.LINE  ( addr count -- , make this the current line of input )
    kh.return
    tio.erase.eol
    dup kh-span !
    dup kh-cursor !
    2dup kh-buffer swap cmove
    type
;

: KH.GET.MATCH ( -- , search for line with same start )
    kh-match-span @ 0=  ( keep length for multiple matches )
    IF kh-span @ kh-match-span !
    THEN
    BEGIN
        kh.backup.line not
    WHILE
        kh.current.line drop
        kh-buffer kh-match-span @ text=
        IF kh.current.line kh.replace.line
           exit
        THEN
    REPEAT
;

: KH.FAR.RIGHT
    kh-span @ kh-cursor @ - dup 0>
    IF
        tio.forwards
        kh-span @ kh-cursor !
    ELSE drop
    THEN
;

: KH.FAR.LEFT ( -- )
    kh.return
    kh-cursor off
;

: KH.GET.OLDER ( -- , goto previous line )
    kh-inside @
    IF kh.backup.line drop
    THEN
    kh.current.line kh.replace.line
    kh-inside on
;

: KH.GET.NEWER ( -- , next line )
    kh.forward.line
    IF
        kh-inside off
        tib 0
    ELSE  kh.current.line
    THEN
    kh.replace.line
;

: KH.CLEAR.LINE ( -- , rewind history scrolling and clear line )
    kh.rewind
    tib 0 kh.replace.line
    kh-inside off
;

: KH.GO.RIGHT  ( -- )
    kh-cursor @ kh-span @ <
    IF 1 kh-cursor +!
       1 tio.forwards
    THEN
;

: KH.GO.LEFT ( -- )
    kh-cursor @ ?dup
    IF 1- kh-cursor !
       1 tio.backwards
    THEN
;

: KH.REFRESH  ( -- , redraw current line as is )
    kh.return
    kh-buffer kh-span @ type
    tio.erase.eol

    kh.return
    kh-cursor @ ?dup
    IF tio.forwards
    THEN

    kh-span @ out !
;

: KH.BACKSPACE ( -- , backspace character from buffer and screen )
    kh-cursor @ ?dup  ( past 0? )
    IF  kh-span @ <
        IF  ( inside line )
            kh-buffer kh-cursor @ +  ( -- source )
            dup 1- ( -- source dest )
            kh-span @ kh-cursor @ - cmove
\            ." Deleted!" cr
        ELSE
            backspace
        THEN
        -1 kh-span +!
        -1 kh-cursor +!
    ELSE bell
    THEN
    kh.refresh
;

: KH.DELETE ( -- , forward delete )
    kh-cursor @ kh-span @ <  ( before end )
    IF  ( inside line )
        kh-buffer kh-cursor @ + 1+ ( -- source )
        dup 1- ( -- source dest )
        kh-span @ kh-cursor @ - 0 max cmove
        -1 kh-span +!
        kh.refresh
    THEN
;

: KH.HANDLE.WINDOWS.KEY ( char -- , handle fkeys or arrows used by Windows ANSI.SYS )
    CASE
        $ 8D OF kh.get.match    ENDOF
            0 kh-match-span ! ( reset if any other key )
        $ 48 OF kh.get.older    ENDOF
        $ 50 OF kh.get.newer  ENDOF
        $ 4D OF kh.go.right ENDOF
        $ 4B OF kh.go.left  ENDOF
        $ 91 OF kh.clear.line  ENDOF
        $ 74 OF kh.far.right ENDOF
        $ 73 OF kh.far.left  ENDOF
        $ 53 OF kh.delete  ENDOF
    ENDCASE
;

: KH.HANDLE.ANSI.KEY ( char -- , handle fkeys or arrows used by ANSI terminal )
    CASE
        $ 41 OF kh.get.older    ENDOF
        $ 42 OF kh.get.newer  ENDOF
        $ 43 OF kh.go.right ENDOF
        $ 44 OF kh.go.left  ENDOF
    ENDCASE
;

: KH.SPECIAL.KEY ( char  -- true | false , handle fkeys or arrows, true if handled )
    true >r
    CASE

    $ E0 OF key kh.handle.windows.key
    ENDOF

    ASCII_ESCAPE OF
        key dup $ 4F = \ for TELNET
        $ 5B = OR \ for regular ANSI terminals
        IF
            key kh.handle.ansi.key
        ELSE
            rdrop false >r
        THEN
    ENDOF

        ASCII_BACKSPACE OF kh.backspace ENDOF
        ASCII_DELETE    OF kh.backspace ENDOF
        ASCII_CTRL_X    OF kh.clear.line ENDOF
        ASCII_CTRL_A    OF kh.far.left ENDOF
        ASCII_CTRL_E    OF kh.far.right ENDOF

    rdrop false >r

    ENDCASE
    r>
;

: KH.SMART.KEY ( -- char )
    BEGIN
        key dup kh.special.key
    WHILE
        drop
    REPEAT
;

: KH.INSCHAR  { charc | repaint -- }
    false -> repaint
    kh-cursor @ kh-span @ <
    IF
\ Move characters up
        kh-buffer kh-cursor @ +  ( -- source )
        dup 1+ ( -- source dest )
        kh-span @ kh-cursor @ - cmove>
        true -> repaint
    THEN
\ write character to buffer
    charc kh-buffer kh-cursor @ + c!
    1 kh-cursor +!
    1 kh-span +!
    repaint
    IF kh.refresh
    ELSE charc emit
    THEN
;

: EOL? ( char -- flag , true if an end of line character )
    dup 13 =
    swap 10 = OR
;

: KH.GETLINE ( max -- )
    kh-max !
    kh-span off
    kh-cursor off
    kh-inside off
    kh.rewind
    0 kh-match-span !
    BEGIN
        kh-max @ kh-span @ >
        IF  kh.smart.key
            dup EOL? not  ( <cr?> )
        ELSE 0 false
        THEN  ( -- char flag )
    WHILE ( -- char )
        kh.inschar
    REPEAT drop
    kh-span @ kh-cursor @ - ?dup
    IF tio.forwards  ( move to end of line )
    THEN
    space
    flushemit
;

: KH.ACCEPT ( addr max -- numChars )
    swap kh-address !
    kh.getline
    kh-span @ 0>
    IF kh-buffer kh-span @ kh.add.line
    THEN
    kh-span @
;

: TEST.HISTORY
    4 0 DO
        pad 128 kh.accept
        cr pad swap type cr
    LOOP
;

}private


: HISTORY# ( -- , dump history buffer with numbers)
    cr kh.oldest.line ?dup
    IF
        BEGIN kh.current.num 3 .r ." ) " type ?pause cr
            kh.forward.line 0=
        WHILE kh.current.line
        REPEAT
    THEN
;

: HISTORY ( -- , dump history buffer )
    cr kh.oldest.line ?dup
    IF
        BEGIN type ?pause cr
            kh.forward.line 0=
        WHILE kh.current.line
        REPEAT
    THEN
;

: XX  ( line# -- , execute line x of history )
    kh.find.line ?dup
    IF count evaluate
    THEN
;


: HISTORY.RESET  ( -- , clear history tables )
    kh-history kh_history_size erase
    kh-counter off
;

: HISTORY.ON ( -- , install history vectors )
    history.reset
    what's accept ['] (accept) =
    IF ['] kh.accept is accept
    THEN
;

: HISTORY.OFF ( -- , uninstall history vectors )
    what's accept ['] kh.accept =
    IF ['] (accept) is accept
    THEN
;


: AUTO.INIT
    auto.init
    history.on
;
: AUTO.TERM
    history.off
    auto.term
;

if.forgotten history.off

0 [IF]
history.reset
history.on
[THEN]