238 lines
7.0 KiB
Scheme
238 lines
7.0 KiB
Scheme
;;seperate a long line into pieces, each fitting into a smaller line.
|
|
(define (seperate-line line width)
|
|
(let loop ((new '())
|
|
(old line))
|
|
(if (> width (string-length old))
|
|
(if (= 0 (string-length old))
|
|
(if (equal? new '())
|
|
'("")
|
|
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)))))
|
|
|
|
;;the result is the "answer" of scsh
|
|
(define (layout-result-standard result-str width)
|
|
(reverse (seperate-line result-str width)))
|
|
|
|
;useful helpers
|
|
;;; EK: useful for what=
|
|
(define (get-marked-positions-1 all-items marked-items)
|
|
(let loop ((count 0)
|
|
(result '()))
|
|
(if (>= count (length all-items))
|
|
result
|
|
(let ((act-item (list-ref all-items count)))
|
|
(if (member act-item marked-items)
|
|
(loop (+ count 1)
|
|
(append result (list (+ count 1))))
|
|
(loop (+ count 1) result))))))
|
|
|
|
(define (get-marked-positions-2 all-items marked-items)
|
|
(let loop ((count 0)
|
|
(result '()))
|
|
(if (>= count (length all-items))
|
|
result
|
|
(let ((act-item (list-ref all-items count)))
|
|
(if (member act-item marked-items)
|
|
(loop (+ count 1)
|
|
(append result (list (+ count 2))))
|
|
(loop (+ count 1) result))))))
|
|
|
|
(define (get-marked-positions-3 all-items marked-items)
|
|
(let loop ((count 0)
|
|
(result '()))
|
|
(if (>= count (length all-items))
|
|
result
|
|
(let ((act-item (list-ref all-items count)))
|
|
(if (member act-item marked-items)
|
|
(loop (+ count 1)
|
|
(append result (list (+ count 3))))
|
|
(loop (+ count 1) result))))))
|
|
|
|
(define (sublist l pos k)
|
|
(let ((tmp (list-tail l pos)))
|
|
(reverse (list-tail (reverse tmp)
|
|
(- (length tmp) k)))))
|
|
|
|
;; crappy redrawing code
|
|
|
|
(define-record-type result-buffer :result-buffer
|
|
(make-result-buffer line column y x num-lines num-cols highlighted marked)
|
|
result-buffer?
|
|
(line result-buffer-line
|
|
set-result-buffer-line!)
|
|
(column result-buffer-column
|
|
set-result-buffer-column!)
|
|
(y result-buffer-y set-result-buffer-y!)
|
|
(x result-buffer-x set-result-buffer-x!)
|
|
(num-lines result-buffer-num-lines
|
|
set-result-buffer-num-lines!)
|
|
(num-cols result-buffer-num-cols
|
|
set-result-buffer-num-cols!)
|
|
(highlighted result-buffer-highlighted
|
|
set-result-buffer-highlighted!)
|
|
(marked result-buffer-marked
|
|
set-result-buffer-marked!))
|
|
|
|
;;selection of the visible area of the buffer
|
|
(define (prepare-lines l height pos)
|
|
(if (< (length l) height)
|
|
(let loop ((tmp-list l))
|
|
(if (= height (length tmp-list))
|
|
tmp-list
|
|
(loop (append tmp-list (list "")))))
|
|
(if (< pos height)
|
|
(sublist l 0 height)
|
|
(sublist l (- pos height) height))))
|
|
|
|
(define (get-right-result-lines result-buffer text)
|
|
(prepare-lines text
|
|
(result-buffer-num-lines result-buffer)
|
|
(result-buffer-line result-buffer)))
|
|
|
|
;;marked and highlighted lines
|
|
(define (right-highlighted-lines result-buffer lines)
|
|
(let ((pos-result (result-buffer-line result-buffer))
|
|
(result-lines (result-buffer-num-lines result-buffer)))
|
|
(let loop ((lines lines) (new '()))
|
|
(if (null? lines)
|
|
new
|
|
(let ((el (car lines)))
|
|
(if (<= pos-result result-lines)
|
|
;;auf der ersten Seite
|
|
(loop (cdr lines)
|
|
(append new (list el)))
|
|
(let* ((offset (- pos-result result-lines))
|
|
(new-el (- el offset)))
|
|
(loop (cdr lines)
|
|
(append new (list new-el))))))))))
|
|
|
|
(define (right-marked-lines result-buffer lines)
|
|
(let ((pos-result (result-buffer-column result-buffer))
|
|
(result-lines (result-buffer-num-lines result-buffer))
|
|
(marked-lines (result-buffer-marked result-buffer)))
|
|
(let loop ((old marked-lines)
|
|
(new '()))
|
|
(if (null? old)
|
|
new
|
|
(let ((el (car old)))
|
|
(if (<= pos-result result-lines)
|
|
;;auf der ersten Seite
|
|
(loop (cdr old)
|
|
(append new (list el)))
|
|
(let* ((offset (- pos-result result-lines))
|
|
(new-el (- el offset )))
|
|
(loop (cdr old)
|
|
(append new (list new-el))))))))))
|
|
|
|
(define (make-simple-result-buffer-printer
|
|
pos-y pos-x text highlighted-lines marked-lines)
|
|
(lambda (window result-buffer result-buffer-has-focus?)
|
|
|
|
(set-result-buffer-y! result-buffer pos-y)
|
|
(set-result-buffer-column! result-buffer pos-x)
|
|
(set-result-buffer-highlighted! result-buffer
|
|
highlighted-lines)
|
|
(set-result-buffer-marked! result-buffer
|
|
marked-lines)
|
|
(set-result-buffer-highlighted!
|
|
result-buffer (right-highlighted-lines result-buffer text))
|
|
(set-result-buffer-marked!
|
|
result-buffer (right-marked-lines result-buffer text))
|
|
|
|
(let ((lines (get-right-result-lines result-buffer text))
|
|
(result-lines (result-buffer-num-lines result-buffer))
|
|
(result-cols (result-buffer-num-cols result-buffer)))
|
|
|
|
(let loop ((pos 1))
|
|
(if (> pos result-lines)
|
|
(values)
|
|
(let* ((line (list-ref lines (- pos 1)))
|
|
(fitting-line
|
|
(if (> (string-length line) result-cols)
|
|
(let ((start-line
|
|
(substring line 0
|
|
(- (ceiling (/ result-cols 2))
|
|
3)))
|
|
(end-line
|
|
(substring line
|
|
(- (string-length line)
|
|
(ceiling
|
|
(/ result-cols 2)))
|
|
(string-length line))))
|
|
(string-append start-line "..." end-line))
|
|
line)))
|
|
(if (and result-buffer-has-focus?
|
|
(member pos highlighted-lines))
|
|
(begin
|
|
(wattron window (A-REVERSE))
|
|
(mvwaddstr window pos 1 line)
|
|
(wattrset window (A-NORMAL))
|
|
(loop (+ pos 1)))
|
|
(if (member pos marked-lines)
|
|
(begin
|
|
(wattron window (A-BOLD))
|
|
(mvwaddstr window pos 1 line)
|
|
(wattrset window (A-NORMAL))
|
|
(loop (+ pos 1)))
|
|
(begin
|
|
(mvwaddstr window pos 1 line)
|
|
(loop (+ pos 1)))))))))))
|
|
|
|
|
|
(define (left-align-string length string)
|
|
(if (> (string-length string) length)
|
|
(substring string 0 length)
|
|
(string-append
|
|
string (make-string (- length (string-length string))
|
|
#\space))))
|
|
|
|
(define (right-align-string length string)
|
|
(if (> (string-length string) length)
|
|
(substring string 0 length)
|
|
(string-append
|
|
(make-string (- length (string-length string))
|
|
#\space)
|
|
string)))
|
|
|
|
(define fill-up-string left-align-string)
|
|
|
|
(define (cut-to-size length string)
|
|
(if (> (string-length string) length)
|
|
(substring string 0 length)
|
|
string))
|
|
|
|
;; ,open let-opt
|
|
(define (wait-for-key . optionals)
|
|
(let-optionals optionals
|
|
((tty-port (current-input-port)))
|
|
(let* ((old (tty-info tty-port))
|
|
(copy (copy-tty-info old)))
|
|
(set-tty-info:local-flags
|
|
copy
|
|
(bitwise-and (tty-info:local-flags copy)
|
|
(bitwise-not ttyl/canonical)))
|
|
(set-tty-info:min copy 1)
|
|
(set-tty-info:time copy 0)
|
|
(set-tty-info/now tty-port copy)
|
|
(let ((c (read-char tty-port)))
|
|
(set-tty-info/now tty-port old)
|
|
c))))
|
|
|
|
(define (show-shell-screen)
|
|
(def-prog-mode)
|
|
(endwin)
|
|
(display "Press any key to return to Commander S")
|
|
(wait-for-key))
|
|
|
|
(define (with-output-to-result-screen thunk)
|
|
(def-prog-mode)
|
|
(endwin)
|
|
(newline)
|
|
(thunk)
|
|
(display "Press any key to return to Commander S...")
|
|
(wait-for-key))
|
|
|
|
(define paint-lock (make-lock)) |