432 lines
12 KiB
Scheme
432 lines
12 KiB
Scheme
;;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+k -> Zeile l<>schen
|
||
((= ch 11)
|
||
(if can-write
|
||
(let ((text-front (sublist text 0 (- (length text) 1))))
|
||
(begin
|
||
(set! text (append text-front '("")))
|
||
(set! pos-col 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<75>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)))
|
||
(if (= (string-length line) 0)
|
||
0
|
||
(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) )))
|
||
|
||
|