removed input-buffers -- not needed any more
This commit is contained in:
chetz
parent
303cf30059
commit
df47362d05
|
|
@ -1,447 +0,0 @@
|
|||
;;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!!!
|
||||
|
||||
|
||||
(define first-column 2)
|
||||
|
||||
;;record-type buffer
|
||||
(define-record-type buffer :buffer
|
||||
(make-buffer text
|
||||
pos-line ;; Cursor-Position auf text bezogen
|
||||
pos-col
|
||||
pos-fin-ln ;; ???
|
||||
pos-y ;; Cursor relativ zum Fenster
|
||||
pos-x
|
||||
num-lines
|
||||
num-cols
|
||||
can-write
|
||||
history-pos)
|
||||
(text buffer-text set-buffer-text!)
|
||||
(pos-line buffer-pos-line set-buffer-pos-line!)
|
||||
(pos-col buffer-pos-col set-buffer-pos-col!)
|
||||
(pos-fin-ln buffer-pos-fin-ln set-buffer-pos-fin-ln!)
|
||||
(pos-y buffer-pos-y set-buffer-pos-y!)
|
||||
(pos-x buffer-pos-x set-buffer-pos-x!)
|
||||
(num-lines buffer-num-lines set-buffer-num-lines!)
|
||||
(num-cols buffer-num-cols set-buffer-num-cols!)
|
||||
(can-write buffer-can-write set-buffer-can-write!)
|
||||
(history-pos buffer-history-pos set-buffer-history-pos!))
|
||||
|
||||
(define-record-discloser :buffer
|
||||
(lambda (rec)
|
||||
`(buffer ,@(map (lambda (p)
|
||||
(cons (car p) ((cdr p) rec)))
|
||||
`((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)
|
||||
(history-pos . ,buffer-history-pos)
|
||||
(lines . ,(lambda (b) (length (buffer-text b)))))))))
|
||||
|
||||
(define (buffer-text-current-line buffer)
|
||||
(list-ref (buffer-text buffer)
|
||||
(- (buffer-pos-line buffer) 1)))
|
||||
|
||||
(define (buffer-text-append-new-line! buffer)
|
||||
(set-buffer-text! buffer
|
||||
(append (buffer-text buffer)
|
||||
(list ""))))
|
||||
|
||||
;;handle input
|
||||
(define (input buffer ch)
|
||||
(cond
|
||||
|
||||
;; enter key
|
||||
((= ch 10)
|
||||
(set-buffer-text! buffer
|
||||
(append (buffer-text buffer) (list "")))
|
||||
(set-buffer-pos-line! buffer
|
||||
(+ (buffer-pos-line buffer) 1))
|
||||
(set-buffer-pos-col! buffer first-column)
|
||||
(set-buffer-history-pos! buffer
|
||||
(- (length (buffer-text buffer)) 1)))
|
||||
;; backspace
|
||||
((and (= ch key-backspace)
|
||||
(buffer-can-write buffer)
|
||||
(not (< (buffer-pos-col buffer) 3)))
|
||||
(set-buffer-text! buffer
|
||||
(remove-from-command-buffer
|
||||
(buffer-text buffer)
|
||||
(buffer-pos-col buffer)))
|
||||
(regress-buffer-cursor-column! buffer))
|
||||
|
||||
;; FIXME
|
||||
;; move cursor to previous line Ctrl-p, keycode 16
|
||||
; ((= ch 16)
|
||||
; (if (< pos-fin-ln 2)
|
||||
; (values)
|
||||
; (let ((length-prev-line
|
||||
; (string-length
|
||||
; (list-ref text (- pos-line 2)))))
|
||||
; (set! can-write #f)
|
||||
; (set! pos-line (- pos-line 1))
|
||||
; (set! pos-col (+ length-prev-line 2)))))
|
||||
|
||||
;; FIXME
|
||||
;; move cursor to next line Ctrl-n, keycode 141
|
||||
; ((= ch 141)
|
||||
; (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)))))))
|
||||
|
||||
;; CursorLeft
|
||||
((and (= ch key-left)
|
||||
(> (buffer-pos-col buffer) first-column))
|
||||
(regress-buffer-cursor-column! buffer))
|
||||
|
||||
;; CursorRight
|
||||
((= ch key-right)
|
||||
(let ((line-length (string-length
|
||||
(buffer-text-current-line buffer))))
|
||||
(if (< (buffer-pos-col buffer) (+ line-length first-column))
|
||||
(advance-buffer-cursor-column! buffer))))
|
||||
|
||||
;;Ctrl+a -> Pos 1
|
||||
((= ch 1)
|
||||
(set-buffer-pos-col! buffer first-column))
|
||||
|
||||
;;Ctrl-e -> End
|
||||
((= ch 5)
|
||||
(let ((line-length (string-length
|
||||
(buffer-text-current-line buffer))))
|
||||
(set-buffer-pos-col! buffer
|
||||
(+ line-length first-column))))
|
||||
|
||||
;; Ctrl+k -> Zeile löschen
|
||||
((and (= ch 11)
|
||||
(buffer-can-write buffer))
|
||||
(let ((text-front (sublist (buffer-text buffer)
|
||||
0 (- (length (buffer-text buffer)) 1))))
|
||||
(set-buffer-text! buffer (append text-front '("")))
|
||||
(set-buffer-pos-col! buffer first-column)))
|
||||
|
||||
;; forward in command history -- CursorDown
|
||||
((and (= ch key-down)
|
||||
(buffer-can-write buffer))
|
||||
(if (< (buffer-history-pos buffer)
|
||||
(- (length (buffer-text buffer)) 1))
|
||||
(set-buffer-history-pos! buffer
|
||||
(+ (buffer-history-pos buffer) 1)))
|
||||
(let ((rest (sublist (buffer-text buffer) 0
|
||||
(- (length (buffer-text buffer)) 1)))
|
||||
(hist (if (= (buffer-history-pos buffer)
|
||||
(- (length (buffer-text buffer)) 1))
|
||||
""
|
||||
(list-ref (buffer-text buffer)
|
||||
(buffer-history-pos buffer)))))
|
||||
(set-buffer-text! buffer (append rest (list hist)))
|
||||
(let ((line-length
|
||||
(string-length
|
||||
(list-ref (buffer-text buffer)
|
||||
(- (length (buffer-text buffer)) 1)))))
|
||||
(set-buffer-pos-col! buffer (+ line-length first-column)))))
|
||||
|
||||
;; back in command history -- CursorUp
|
||||
((and (= ch key-up)
|
||||
(buffer-can-write buffer))
|
||||
(if (> (buffer-history-pos buffer) 0)
|
||||
(set-buffer-history-pos! buffer
|
||||
(- (buffer-history-pos buffer) 1)))
|
||||
(let ((rest (sublist (buffer-text buffer) 0
|
||||
(- (length (buffer-text buffer)) 1)))
|
||||
(hist (list-ref (buffer-text buffer)
|
||||
(buffer-history-pos buffer))))
|
||||
(set-buffer-text! buffer
|
||||
(append rest (list hist))))
|
||||
(let ((line-length (string-length
|
||||
(list-ref (buffer-text buffer)
|
||||
(- (length (buffer-text buffer)) 1)))))
|
||||
(set-buffer-pos-col! buffer (+ line-length first-column))))
|
||||
|
||||
((and (buffer-can-write buffer) (<= ch 255))
|
||||
(append-char-to-buffer! ch buffer)
|
||||
(advance-buffer-cursor-column! buffer))
|
||||
|
||||
(values)))
|
||||
|
||||
;;print content of the buffer into the specified window
|
||||
(define (print-command-buffer win buffer)
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(get-right-command-lines buffer))
|
||||
(lambda (lines new-pos-fin-ln)
|
||||
(set-buffer-pos-fin-ln! buffer new-pos-fin-ln)
|
||||
(let lp ((lines lines) (line-count 0))
|
||||
(if (or (null? lines)
|
||||
(> line-count (buffer-num-lines buffer)))
|
||||
(values)
|
||||
(begin
|
||||
(mvwaddstr win line-count 1 (car lines))
|
||||
(lp (cdr lines) (+ line-count 1))))))))
|
||||
|
||||
;;compute the visible lines
|
||||
(define (get-right-command-lines buffer)
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(all-commands-seperated buffer))
|
||||
(lambda (all-lines-seperated pos-fin-ln)
|
||||
(let ((num-all-lines (length all-lines-seperated))
|
||||
(num-lines (buffer-num-lines buffer)))
|
||||
(if (>= pos-fin-ln num-lines)
|
||||
;;aktive Zeile ist die unterste
|
||||
(values (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
|
||||
(values (prepare-lines all-lines-seperated
|
||||
num-lines (- pos-fin-ln 1))
|
||||
pos-fin-ln)
|
||||
;;scrollen auf der ersten Seite
|
||||
(values (sublist all-lines-seperated 0 num-lines)
|
||||
pos-fin-ln)))))))
|
||||
|
||||
;;seperate all statements
|
||||
(define (all-commands-seperated buffer)
|
||||
(let ((num-cols (buffer-num-cols buffer))
|
||||
(pos-fin-ln (buffer-pos-fin-ln buffer))
|
||||
(commands (buffer-text buffer)))
|
||||
(let loop ((act-pos 1) (new '()))
|
||||
(if (= act-pos (buffer-pos-line buffer))
|
||||
(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))
|
||||
(values (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 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 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 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 win buffer)
|
||||
(let ((text-index (- (buffer-pos-col buffer) first-column))
|
||||
(pos-fin-ln (buffer-pos-fin-ln buffer))
|
||||
(pos-x (buffer-pos-x buffer))
|
||||
(num-lines (buffer-num-lines buffer))
|
||||
(num-cols (buffer-num-cols buffer)))
|
||||
|
||||
;; y position
|
||||
(let* ((item-length (string-length (buffer-text-current-line buffer)))
|
||||
(no-wrapped-lines (quotient item-length num-cols))
|
||||
(first-line-offset (quotient text-index num-cols))
|
||||
(new-y (- (+ (- pos-fin-ln no-wrapped-lines)
|
||||
first-line-offset)
|
||||
1)))
|
||||
; (debug-message "num-cols "
|
||||
; num-cols
|
||||
; " no-wrapped-lines "
|
||||
; no-wrapped-lines
|
||||
; " first-line-offset "
|
||||
; first-line-offset
|
||||
; " new-y " new-y
|
||||
; " length "
|
||||
; item-length
|
||||
; " pos-fin-ln "
|
||||
; pos-fin-ln
|
||||
; " text-index "
|
||||
; text-index
|
||||
; " pos-line "
|
||||
; (buffer-pos-line buffer)
|
||||
; " num-lines "
|
||||
; num-lines)
|
||||
|
||||
; (if (and (not (zero? text-index))
|
||||
; (zero? (remainder text-index num-cols))
|
||||
; (= text-index item-length))
|
||||
; (set-buffer-pos-y! buffer (+ new-y 1))
|
||||
; (set-buffer-pos-y! buffer new-y))
|
||||
|
||||
|
||||
(cond
|
||||
((and (>= new-y num-lines)
|
||||
(not (zero? text-index))
|
||||
(zero? (remainder text-index num-cols))
|
||||
(= text-index item-length))
|
||||
(set-buffer-pos-y! buffer num-lines))
|
||||
((and (>= new-y num-lines)
|
||||
(< text-index item-length))
|
||||
(set-buffer-pos-y! buffer
|
||||
(- num-lines
|
||||
(- (+ no-wrapped-lines 1)
|
||||
first-line-offset))))
|
||||
((>= new-y num-lines)
|
||||
(set-buffer-pos-y! buffer (- num-lines 1)))
|
||||
((and (not (zero? text-index))
|
||||
(zero? (remainder text-index num-cols))
|
||||
(= text-index item-length))
|
||||
(set-buffer-pos-y! buffer (+ new-y 1)))
|
||||
(else
|
||||
(set-buffer-pos-y! buffer new-y)))
|
||||
|
||||
;; x position
|
||||
(set-buffer-pos-x! buffer (+ first-column
|
||||
(modulo text-index num-cols)))
|
||||
|
||||
; (debug-message "cursor position "
|
||||
; (buffer-pos-x buffer)
|
||||
; " "
|
||||
; (buffer-pos-y buffer))
|
||||
; (debug-message "num-cols " num-cols
|
||||
; " pos-col " pos-col
|
||||
; " text '" (buffer-text-current-line buffer) "'")
|
||||
|
||||
(wmove win (buffer-pos-y buffer) (buffer-pos-x buffer)))))
|
||||
|
||||
(define (advance-buffer-cursor-column! buffer)
|
||||
(set-buffer-pos-col! buffer
|
||||
(+ 1 (buffer-pos-col buffer))))
|
||||
|
||||
(define (regress-buffer-cursor-column! buffer)
|
||||
(set-buffer-pos-col! buffer
|
||||
(- (buffer-pos-col buffer) 1)))
|
||||
|
||||
;; add one character to the buffer
|
||||
(define (append-char-to-buffer! ch buffer)
|
||||
(let* ((text (buffer-text buffer))
|
||||
(pos-col (buffer-pos-col buffer))
|
||||
(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)))
|
||||
(set-buffer-text! buffer
|
||||
(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 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 height width welcome-message)
|
||||
(if (string=? "" 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) ))
|
||||
|
||||
|
||||
Loading…
Reference in New Issue