added input-buffer
This commit is contained in:
demattia
parent
124c614bb8
commit
b11e743db7
|
|
@ -0,0 +1,421 @@
|
|||
;;This is an application of the "scsh-ncurses" lib.
|
||||
;;It consists of a buffer with input.
|
||||
;;
|
||||
;;At the beginning we only have an empty buffer for example.
|
||||
;;You pass this buffer an char after char to the input-function,
|
||||
;;which modifies the content of the buffer. In the standard-case
|
||||
;;you get the characters from "wgetch".
|
||||
;;
|
||||
;;One brief example:
|
||||
; ;
|
||||
; ;
|
||||
; ; (begin
|
||||
; ; (define my-buffer (make-buffer-welcome 20 20 "test"))
|
||||
; ; (init-screen)
|
||||
; ; (define win (newwin 20 20 5 5))
|
||||
; ; (box win (ascii->char 0) (ascii->char 0))
|
||||
; ; (noecho)
|
||||
; ; (keypad win #t)
|
||||
; ; (set! my-buffer (print-command-buffer win my-buffer))
|
||||
; ; (let loop ((ch (wgetch win)))
|
||||
; ; (begin
|
||||
; ; (wclear win)
|
||||
; ; (box win (ascii->char 0) (ascii->char 0))
|
||||
; ; (set! my-buffer (input my-buffer ch))
|
||||
; ; (set! my-buffer (print-command-buffer win my-buffer))
|
||||
; ; (if (= ch key-f1)
|
||||
; ; (begin
|
||||
; ; (echo)
|
||||
; ; (endwin))
|
||||
; ; (begin
|
||||
; ; (set! my-buffer (cursor-right-pos win my-buffer))
|
||||
; ; (loop (wgetch win)))))))
|
||||
|
||||
;;It is very esential, that you set keypad to true und call noecho!!!
|
||||
|
||||
|
||||
;;record-type buffer
|
||||
(define-record-type buffer buffer
|
||||
(make-buffer text
|
||||
pos-line
|
||||
pos-col
|
||||
pos-fin-ln
|
||||
pos-y
|
||||
pos-x
|
||||
num-lines
|
||||
num-cols
|
||||
can-write
|
||||
history-pos)
|
||||
(text buffer-text)
|
||||
(pos-line buffer-pos-line)
|
||||
(pos-col buffer-pos-col)
|
||||
(pos-fin-ln buffer-pos-fin-ln)
|
||||
(pos-y buffer-pos-y)
|
||||
(pos-x buffer-pos-x)
|
||||
(num-lines buffer-num-lines)
|
||||
(num-cols buffer-num-cols)
|
||||
(can-write buffer-can-write)
|
||||
(history-pos buffer-history-pos))
|
||||
|
||||
|
||||
;;handle input
|
||||
(define input
|
||||
(lambda (buffer ch)
|
||||
(let ((text (buffer-text buffer))
|
||||
(pos-line (buffer-pos-line buffer))
|
||||
(pos-col (buffer-pos-col buffer))
|
||||
(pos-fin-ln (buffer-pos-fin-ln buffer))
|
||||
(pos-y (buffer-pos-y buffer))
|
||||
(pos-x (buffer-pos-x buffer))
|
||||
(num-lines (buffer-num-lines buffer))
|
||||
(num-cols (buffer-num-cols buffer))
|
||||
(can-write (buffer-can-write buffer))
|
||||
(history-pos (buffer-history-pos buffer)))
|
||||
(begin
|
||||
(cond
|
||||
|
||||
;;Enter
|
||||
((= ch 10)
|
||||
(begin
|
||||
(set! text (append text (list "")))
|
||||
(set! pos-line (+ pos-line 1))
|
||||
(set! history-pos (- (length text) 1))
|
||||
(set! pos-col 2)))
|
||||
|
||||
;;Backspace
|
||||
((= ch key-backspace)
|
||||
(if can-write
|
||||
(if (< pos-col 3)
|
||||
values
|
||||
(begin
|
||||
(set! text (remove-from-command-buffer text pos-col))
|
||||
(set! pos-col (- pos-col 1))))
|
||||
values))
|
||||
|
||||
;;Nav
|
||||
((= ch key-up)
|
||||
(if (< pos-fin-ln 2)
|
||||
values
|
||||
(let ((length-prev-line
|
||||
(string-length
|
||||
(list-ref text (- pos-line 2)))))
|
||||
(begin
|
||||
(set! can-write #f)
|
||||
(set! pos-line (- pos-line 1))
|
||||
(set! pos-col (+ length-prev-line 2))))))
|
||||
|
||||
((= ch key-down)
|
||||
(let ((last-pos (length text)))
|
||||
(if (>= pos-line last-pos)
|
||||
values
|
||||
(let ((length-next-line
|
||||
(string-length
|
||||
(list-ref text pos-line))))
|
||||
(begin
|
||||
(set! pos-col (+ length-next-line 2))
|
||||
(set! pos-line (+ pos-line 1))
|
||||
(if (= pos-line last-pos)
|
||||
(set! can-write #t)))))))
|
||||
|
||||
((= ch key-left)
|
||||
(if (<= pos-col 2)
|
||||
values
|
||||
(begin
|
||||
(set! pos-col (- pos-col 1)))))
|
||||
|
||||
((= ch key-right)
|
||||
(let ((line-length (string-length
|
||||
(list-ref text
|
||||
(- pos-line 1)))))
|
||||
(if (>= pos-col (+ line-length 2))
|
||||
values
|
||||
(begin
|
||||
(set! pos-col (+ pos-col 1))))))
|
||||
|
||||
|
||||
;;Ctrl+a -> Pos 1
|
||||
((= ch 1)
|
||||
(begin
|
||||
(set! pos-col 2)))
|
||||
|
||||
;;Ctrl-e -> End
|
||||
((= ch 5)
|
||||
(let ((line-length (string-length
|
||||
(list-ref text (- pos-line 1)))))
|
||||
(begin
|
||||
(set! pos-col (+ line-length 2)))))
|
||||
|
||||
;;Ctrl+f -> History-forward
|
||||
((= ch 6)
|
||||
(if can-write
|
||||
(begin
|
||||
(if (< history-pos (- (length text) 1))
|
||||
(set! history-pos (+ history-pos 1)))
|
||||
(let ((rest (sublist text 0 (- (length text) 1)))
|
||||
(hist (if (= history-pos (- (length text) 1))
|
||||
""
|
||||
(list-ref text history-pos))))
|
||||
(set! text (append rest (list hist))))
|
||||
(let ((line-length (string-length
|
||||
(list-ref text (- (length text) 1)))))
|
||||
(set! pos-col (+ line-length 2))))))
|
||||
|
||||
;;Ctrl+b -> History-back
|
||||
((= ch 2)
|
||||
(if can-write
|
||||
(begin
|
||||
(if (> history-pos 0)
|
||||
(set! history-pos (- history-pos 1)))
|
||||
(let ((rest (sublist text 0 (- (length text) 1)))
|
||||
(hist (list-ref text history-pos)))
|
||||
(set! text (append rest (list hist))))
|
||||
(let ((line-length (string-length
|
||||
(list-ref text (- (length text) 1)))))
|
||||
(set! pos-col (+ line-length 2))))))
|
||||
|
||||
|
||||
|
||||
(else
|
||||
(if (<= ch 255)
|
||||
(if can-write
|
||||
(begin
|
||||
(begin
|
||||
(set! text (add-to-command-buffer ch text pos-col))
|
||||
(set! pos-col (+ pos-col 1)))
|
||||
values))
|
||||
values)))
|
||||
(make-buffer text pos-line pos-col pos-fin-ln pos-y pos-x
|
||||
num-lines num-cols can-write history-pos)))))
|
||||
|
||||
|
||||
|
||||
;;print content of the buffer into the specified window
|
||||
(define print-command-buffer
|
||||
(lambda (win buffer)
|
||||
(let ((text (buffer-text buffer))
|
||||
(pos-line (buffer-pos-line buffer))
|
||||
(pos-col (buffer-pos-col buffer))
|
||||
(pos-fin-ln (buffer-pos-fin-ln buffer))
|
||||
(pos-y (buffer-pos-y buffer))
|
||||
(pos-x (buffer-pos-x buffer))
|
||||
(num-lines (buffer-num-lines buffer))
|
||||
(num-cols (buffer-num-cols buffer))
|
||||
(can-write (buffer-can-write buffer))
|
||||
(history-pos (buffer-history-pos buffer)))
|
||||
(let* ((l (get-right-command-lines text pos-fin-ln num-lines
|
||||
pos-line num-cols))
|
||||
(lines (car l)))
|
||||
(begin
|
||||
(set! pos-fin-ln (cdr l))
|
||||
(let loop ((pos 1))
|
||||
(if (> pos num-lines)
|
||||
(make-buffer text pos-line pos-col pos-fin-ln pos-y
|
||||
pos-x num-lines num-cols can-write history-pos)
|
||||
(let ((line (list-ref lines (- pos 1))))
|
||||
(begin
|
||||
(mvwaddstr win pos 1 line)
|
||||
(wrefresh win)
|
||||
(loop (+ pos 1)))))))))))
|
||||
|
||||
|
||||
;;compute the visible lines
|
||||
(define get-right-command-lines
|
||||
(lambda (text pos-fin-ln num-lines pos-line num-cols)
|
||||
(let* ((res (all-commands-seperated text pos-line num-cols
|
||||
pos-fin-ln ))
|
||||
(all-lines-seperated (car res))
|
||||
(num-all-lines (length all-lines-seperated)))
|
||||
(begin
|
||||
(set! pos-fin-ln (cdr res))
|
||||
(if (>= pos-fin-ln num-lines)
|
||||
;;aktive Zeile ist die unterste
|
||||
(cons (sublist all-lines-seperated
|
||||
(- pos-fin-ln num-lines)
|
||||
num-lines)
|
||||
pos-fin-ln)
|
||||
(if (<= num-all-lines num-lines)
|
||||
;;noch keine ganze Seite im Buffer
|
||||
(cons (prepare-lines all-lines-seperated
|
||||
num-lines (- pos-fin-ln 1))
|
||||
pos-fin-ln)
|
||||
;;scrollen auf der ersten Seite
|
||||
(cons (sublist all-lines-seperated 0 num-lines)
|
||||
pos-fin-ln)))))))
|
||||
|
||||
|
||||
;;seperate all statements
|
||||
(define all-commands-seperated
|
||||
(lambda (commands pos-line num-cols pos-fin-ln)
|
||||
(let loop ((act-pos 1)
|
||||
(new '()))
|
||||
(begin
|
||||
(if (= act-pos pos-line)
|
||||
(let* ((length-new (length new))
|
||||
(first-el-old (list-ref commands (- act-pos 1)))
|
||||
(seperated-act (seperate-line-com
|
||||
first-el-old num-cols))
|
||||
(length-act (length seperated-act)))
|
||||
(set! pos-fin-ln (+ length-new length-act))))
|
||||
|
||||
(if (> act-pos (length commands))
|
||||
(cons (reverse new) pos-fin-ln)
|
||||
(let* ((first-el-old (list-ref commands (- act-pos 1)))
|
||||
(seperated-fst-el-old
|
||||
(seperate-line-com first-el-old num-cols)))
|
||||
(loop (+ act-pos 1) (append seperated-fst-el-old new))))))))
|
||||
|
||||
|
||||
;;seperate one statement
|
||||
(define seperate-line-com
|
||||
(lambda (line width)
|
||||
(let loop ((new '())
|
||||
(old line))
|
||||
(if (> width (string-length old))
|
||||
(if (= 0 (string-length old))
|
||||
(if (equal? new '())
|
||||
(add-prompts '(""))
|
||||
(add-prompts new))
|
||||
;new
|
||||
(add-prompts (append (list old) new)))
|
||||
;(append (list old) new))
|
||||
(let ((next-line (substring old 0 width))
|
||||
(rest-old (substring old width (string-length old))))
|
||||
(loop (cons next-line new) rest-old))))))
|
||||
|
||||
|
||||
;;add ">"
|
||||
(define add-prompts
|
||||
(lambda (l)
|
||||
(let* ((lr (reverse l))
|
||||
(old-first-el (list-ref lr 0))
|
||||
(new-first-el (string-append ">" old-first-el))
|
||||
(old-rest (list-tail lr 1)))
|
||||
(let loop ((old old-rest)
|
||||
(new (list new-first-el)))
|
||||
(if (> (length old) 0)
|
||||
(let* ((old-first-el (list-ref old 0))
|
||||
(new-first-el (string-append " " old-first-el)))
|
||||
(loop (list-tail old 1) (append new (list new-first-el))))
|
||||
(reverse new))))))
|
||||
|
||||
|
||||
;;Find the lines to print
|
||||
(define prepare-lines
|
||||
(lambda (l height pos)
|
||||
(if (< (length l) height)
|
||||
;; Liste zu kurz -> ""s hinzufügen
|
||||
(let loop ((tmp-list l))
|
||||
(if (= height (length tmp-list))
|
||||
tmp-list
|
||||
(loop (append tmp-list (list "")))))
|
||||
;; Teilliste holen
|
||||
(if (< pos height)
|
||||
;;pos nicht ganz unten
|
||||
(sublist l 0 height)
|
||||
;;standard-Fall
|
||||
(sublist l (- pos height) height)))))
|
||||
|
||||
|
||||
|
||||
;;Cursor
|
||||
;;Put Cursor to the right position
|
||||
(define cursor-right-pos
|
||||
(lambda (win buffer)
|
||||
(let ((text (buffer-text buffer))
|
||||
(pos-line (buffer-pos-line buffer))
|
||||
(pos-col (buffer-pos-col buffer))
|
||||
(pos-fin-ln (buffer-pos-fin-ln buffer))
|
||||
(pos-y (buffer-pos-y buffer))
|
||||
(pos-x (buffer-pos-x buffer))
|
||||
(num-lines (buffer-num-lines buffer))
|
||||
(num-cols (buffer-num-cols buffer))
|
||||
(can-write (buffer-can-write buffer))
|
||||
(history-pos (buffer-history-pos buffer)))
|
||||
(begin
|
||||
;;zuerst mal y
|
||||
(let* ((line (list-ref text (- pos-line 1)))
|
||||
(offset (lines-from-fin-line num-cols pos-col line)))
|
||||
(if (>= pos-fin-ln num-lines)
|
||||
;;unterste Zeile
|
||||
(set! pos-y (- num-lines offset))
|
||||
;;sonst
|
||||
(set! pos-y (- pos-fin-ln offset))))
|
||||
(let ((posx (modulo pos-col num-cols)))
|
||||
(if (<= posx 1)
|
||||
(set! pos-x (+ num-cols posx))
|
||||
(if (and (= posx 2)
|
||||
(> pos-col num-cols))
|
||||
(set! pos-x (+ num-cols 1))
|
||||
(set! pos-x posx)))
|
||||
(wmove win pos-y pos-x)
|
||||
(wrefresh win)
|
||||
(make-buffer text pos-line pos-col pos-fin-ln pos-y pos-x
|
||||
num-lines num-cols can-write history-pos))))))
|
||||
|
||||
(define lines-from-fin-line
|
||||
(lambda (num-cols pos-col line)
|
||||
(let* ((lines (ceiling (/ (string-length line) num-cols)))
|
||||
(end-pos (* lines num-cols)))
|
||||
(let loop ((offset 0)
|
||||
(end end-pos))
|
||||
(if (< (+ end 2) pos-col)
|
||||
(- offset 1)
|
||||
(loop (+ offset 1) (- end num-cols)))))))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
;;Add one character to the buffer
|
||||
(define add-to-command-buffer
|
||||
(lambda (ch text pos-col)
|
||||
(let* ((last-pos (- (length text) 1))
|
||||
(old-last-el (list-ref text last-pos))
|
||||
(old-rest (sublist text 0 last-pos))
|
||||
(before-ch (substring old-last-el 0
|
||||
(max 0 (- pos-col 2))))
|
||||
(after-ch (substring old-last-el
|
||||
(max 0 (- pos-col 2))
|
||||
(string-length old-last-el)))
|
||||
(new-last-el (string-append before-ch
|
||||
(string (ascii->char ch))
|
||||
after-ch)))
|
||||
(append old-rest (list new-last-el)))))
|
||||
|
||||
|
||||
;;Remove one character from the line (backspace)
|
||||
(define remove-from-command-buffer
|
||||
(lambda (text pos-col)
|
||||
(let* ((last-pos (- (length text) 1))
|
||||
(old-last-el (list-ref text last-pos))
|
||||
(old-rest (sublist text 0 last-pos))
|
||||
(before-ch (substring old-last-el 0
|
||||
(max 0 (- pos-col 3))))
|
||||
(after-ch (if (= pos-col
|
||||
(+ (string-length old-last-el) 2))
|
||||
""
|
||||
(substring old-last-el
|
||||
(max 0 (- pos-col 2))
|
||||
(string-length old-last-el))))
|
||||
(new-last-el (if (= pos-col
|
||||
(+ (string-length old-last-el) 2))
|
||||
before-ch
|
||||
(string-append before-ch after-ch))))
|
||||
(append old-rest (list new-last-el)))))
|
||||
|
||||
(define sublist
|
||||
(lambda (l pos k)
|
||||
(let ((tmp (list-tail l pos)))
|
||||
(reverse (list-tail (reverse tmp)
|
||||
(- (length tmp) k))))))
|
||||
|
||||
;;Create a fitting buffer for a window with box and a welcome-Message
|
||||
;;If the message is "", the buffer starts in line one
|
||||
(define make-buffer-welcome
|
||||
(lambda (height width welcome-message)
|
||||
(if (equal? "" welcome-message)
|
||||
(make-buffer (list "") 1 2 1 1 2 (- height 2) (- width 3) #t 1)
|
||||
(make-buffer (list welcome-message "") 2 2 2 2 2
|
||||
(- height 2) (- width 3) #t 1) )))
|
||||
|
||||
|
||||
|
|
@ -337,7 +337,14 @@
|
|||
key-undo
|
||||
key-mouse
|
||||
key-resize
|
||||
key-event))
|
||||
key-event
|
||||
|
||||
|
||||
buffer
|
||||
input
|
||||
print-command-buffer
|
||||
cursor-right-pos
|
||||
make-buffer-welcome))
|
||||
|
||||
(define-structure ncurses ncurses-interface
|
||||
(open scheme-with-scsh
|
||||
|
|
@ -347,4 +354,5 @@
|
|||
signals
|
||||
handle)
|
||||
(files ncurses
|
||||
ncurses-constants))
|
||||
ncurses-constants
|
||||
input-buffer))
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
;; ,load /home/demattia/studium/studienarbeit/scsh-ncurses/scheme/scsh-nui-engine.scm
|
||||
;; ,load /home/demattia/studium/studienarbeit/scsh-ncurses/scheme/nui-engine.scm
|
||||
|
||||
|
||||
;;*************************************************************************
|
||||
|
|
@ -64,6 +64,9 @@
|
|||
(define active-buffer 1)
|
||||
|
||||
|
||||
;;History
|
||||
(define history '())
|
||||
|
||||
;;*************************************************************************
|
||||
;;Verhalten
|
||||
|
||||
|
|
@ -283,8 +286,6 @@
|
|||
(define execute-command
|
||||
(lambda ()
|
||||
(let ((command (list-ref text-command (- (length text-command) 1))))
|
||||
;(command)
|
||||
;(set! text-command (append text-command (list "unknown command")))
|
||||
(layout-result command result-cols)
|
||||
(set! text-command (append text-command (list "")))
|
||||
(scroll-command-buffer))))
|
||||
|
|
@ -304,6 +305,8 @@
|
|||
(lambda (command width)
|
||||
;;standard
|
||||
(begin
|
||||
(let* ((handler (lambda (c m) values))
|
||||
(result (with-fatal-error-handler handler
|
||||
(let ((com (if (> (string-length command) (- width 22))
|
||||
(string-append (substring command 0 (- width 22)) "...")
|
||||
command)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue