diff --git a/scheme/browse-directory-list.scm b/scheme/browse-directory-list.scm index e37634e..05a3cf9 100644 --- a/scheme/browse-directory-list.scm +++ b/scheme/browse-directory-list.scm @@ -148,7 +148,8 @@ (let ((fs-objects (init-with-result-message-result message))) (init-with-list-of-files (map fs-object-name fs-objects) (cwd) - (init-with-result-message-width message)))) + (result-buffer-num-cols + (init-with-result-message-buffer message))))) ((next-command-message? message) (init-with-list-of-files (directory-files) (cwd))) diff --git a/scheme/nuit-engine.scm b/scheme/nuit-engine.scm index f4b954c..247eb63 100644 --- a/scheme/nuit-engine.scm +++ b/scheme/nuit-engine.scm @@ -518,13 +518,13 @@ (values (post-message plugin (make-init-with-result-message - result (buffer-num-cols command-buffer))) + result result-buffer)) plugin))) (else (values (post-message standard-view-plugin (make-init-with-result-message - result (buffer-num-cols command-buffer))) + result result-buffer)) standard-view-plugin)))) ;;Extracts the name of the function and its parameters @@ -742,7 +742,8 @@ 1 1 (layout-result-standard (exp->string (init-with-result-message-result message)) - (init-with-result-message-width message)) + (result-buffer-num-cols + (init-with-result-message-buffer message))) (init-with-result-message-result message))) ((next-command-message? message) (let* ((result (eval-expression (message-command-string message))) diff --git a/scheme/nuit-packages.scm b/scheme/nuit-packages.scm index 6450a80..dedf927 100644 --- a/scheme/nuit-packages.scm +++ b/scheme/nuit-packages.scm @@ -70,6 +70,7 @@ pps plugin + layout select-list tty-debug) (files process)) @@ -114,19 +115,19 @@ (define-interface select-list-interface (export make-select-list select-list? - select-list-cursor-index - select-list-cursor-y select-list-handle-key-press unmark-current-line mark-current-line move-cursor-up move-cursor-down - paint-selection-list)) + paint-selection-list + paint-selection-list-at)) (define-structure select-list select-list-interface (open scheme srfi-1 define-record-types + let-opt tty-debug plugin @@ -188,7 +189,7 @@ init-with-result-message? init-with-result-message-result - init-with-result-message-width + init-with-result-message-buffer key-pressed-message? key-pressed-message-result-buffer diff --git a/scheme/plugins.scm b/scheme/plugins.scm index 39a83e9..d9cad2c 100644 --- a/scheme/plugins.scm +++ b/scheme/plugins.scm @@ -41,10 +41,10 @@ (width next-command-message-width)) (define-record-type init-with-result-message :init-with-result-message - (make-init-with-result-message result width) + (make-init-with-result-message result buffer) init-with-result-message? (result init-with-result-message-result) - (width init-with-result-message-width)) + (buffer init-with-result-message-buffer)) ;;key pressed ;;The object and the key are send to the user-code, who returns the diff --git a/scheme/process.scm b/scheme/process.scm index be1e2a8..cf404a6 100644 --- a/scheme/process.scm +++ b/scheme/process.scm @@ -32,20 +32,24 @@ process-info-command-line)))) width)) -(define (make-process-selection-list width processes) - (let ((layout (lambda (p) (layout-process width p)))) +(define (make-process-selection-list num-cols num-lines processes) + (let ((layout (lambda (p) (layout-process num-cols p)))) (make-select-list - (zip processes (map layout processes))))) + (zip processes (map layout processes)) + num-lines))) (define (pps-receiver message) (debug-message "pps-receiver " message) (cond ((init-with-result-message? message) - (let ((processes (init-with-result-message-result message)) - (width (init-with-result-message-width message))) + (let* ((processes (init-with-result-message-result message)) + (buffer (init-with-result-message-buffer message)) + (num-cols (result-buffer-num-cols buffer)) + (num-lines (result-buffer-num-lines buffer))) (make-plugin-state - processes (make-process-selection-list width processes) 1))) + processes + (make-process-selection-list num-cols num-lines processes) 1))) ((print-message? message) (paint-selection-list diff --git a/scheme/select-list.scm b/scheme/select-list.scm index cee61dd..aca24aa 100644 --- a/scheme/select-list.scm +++ b/scheme/select-list.scm @@ -13,25 +13,25 @@ (make-element #f value text)) (define-record-type select-list :select-list - (really-make-select-list elements view-index cursor-index cursor-y) + (really-make-select-list elements view-index cursor-index num-lines) select-list? (elements select-list-elements) (view-index select-list-view-index) (cursor-index select-list-cursor-index) - (cursor-y select-list-cursor-y)) + (num-lines select-list-num-lines)) (define-record-discloser :select-list (lambda (r) `(select-list (index ,(select-list-cursor-index r)) (view-index ,(select-list-view-index r)) - (y ,(select-list-cursor-y r))))) + (num-lines ,(select-list-num-lines r))))) -(define (make-select-list value/text-tuples) +(define (make-select-list value/text-tuples num-lines) (really-make-select-list (map (lambda (value/text) (apply make-unmarked-element value/text)) value/text-tuples) - 0 0 1)) + 0 0 num-lines)) (define key-m 109) @@ -46,9 +46,9 @@ ((= key key-u) (unmark-current-line select-list)) ((= key key-up) - (move-cursor-up select-list result-buffer)) + (move-cursor-up select-list)) ((= key key-down) - (move-cursor-down select-list result-buffer)) + (move-cursor-down select-list)) (else select-list)))) @@ -68,7 +68,7 @@ result))) '() (zip elements (iota (length elements)))) (select-list-view-index select-list) - index (select-list-cursor-y select-list))))) + index (select-list-num-lines select-list))))) (define unmark-current-line (mark/unmark-current-line-maker #f)) @@ -77,24 +77,24 @@ (mark/unmark-current-line-maker #t)) ;; returns: y cursor-index view-index -(define (calculate-view index-move cursor-move - elements view-index cursor-index - num-lines y) +(define (calculate-view index-move elements + view-index cursor-index + num-lines) (let ((new-index (index-move cursor-index)) (max-index (- (length elements) 1))) (cond ((< new-index 0) - (values 0 0 view-index)) + (values 0 view-index)) ((> new-index max-index) - (values y max-index view-index)) + (values max-index view-index)) ((and (>= (- new-index view-index) num-lines) (> new-index cursor-index)) - (values 1 new-index (+ view-index num-lines))) + (values new-index (+ view-index num-lines))) ((and (< new-index cursor-index) (>= view-index cursor-index)) - (values num-lines new-index (- view-index num-lines))) + (values new-index (- view-index num-lines))) (else - (values (cursor-move y) (index-move cursor-index) view-index))))) + (values (index-move cursor-index) view-index))))) (define (copy-element-list elements) (fold-right @@ -106,63 +106,64 @@ result)) '() elements)) -(define (move-cursor-maker index-move cursor-move) - (lambda (select-list result-buffer) +(define (move-cursor-maker index-move) + (lambda (select-list) (let* ((elements (select-list-elements select-list)) - (old-index (select-list-cursor-index select-list))) + (old-index (select-list-cursor-index select-list)) + (num-lines (select-list-num-lines select-list))) (call-with-values (lambda () - (calculate-view index-move cursor-move + (calculate-view index-move elements (select-list-view-index select-list) old-index - (result-buffer-num-lines result-buffer) - (select-list-cursor-y select-list))) - (lambda (y cursor-index view-index) + num-lines)) + (lambda (cursor-index view-index) (really-make-select-list (copy-element-list elements) view-index cursor-index - y)))))) + num-lines)))))) (define move-cursor-up - (let ((sub-one (lambda (y) (- y 1)))) - (move-cursor-maker sub-one sub-one))) + (move-cursor-maker (lambda (y) (- y 1)))) (define move-cursor-down - (let ((add-one (lambda (y) (+ y 1)))) - (move-cursor-maker add-one add-one))) + (move-cursor-maker (lambda (y) (+ y 1)))) (define (take-max lst num) (if (>= num (length lst)) lst (take lst num))) -(define (select-visible-elements select-list result-buffer) - (let ((num-lines (result-buffer-num-lines result-buffer))) - (take-max (drop (select-list-elements select-list) - (select-list-view-index select-list)) - (+ 1 num-lines)))) ;;; wtf? why this +(define (select-visible-elements select-list num-lines) + (take-max (drop (select-list-elements select-list) + (select-list-view-index select-list)) + (+ 1 num-lines))) (define (paint-selection-list select-list) + (paint-selection-list-at select-list 0 0)) + +(define (paint-selection-list-at select-list x y) (lambda (win result-buffer have-focus?) - (let lp ((elts - (select-visible-elements select-list result-buffer)) - (y 0) - (i (select-list-view-index select-list))) - (cond - ((null? elts) - (values)) - ((= i (select-list-cursor-index select-list)) - (wattron win (A-REVERSE)) - (mvwaddstr win y 0 (element-text (car elts))) - (wattrset win (A-NORMAL)) - (lp (cdr elts) (+ y 1) (+ i 1))) - ((element-marked? (car elts)) - (wattron win (A-BOLD)) - (mvwaddstr win y 0 (element-text (car elts))) - (wattrset win (A-NORMAL)) - (lp (cdr elts) (+ y 1) (+ i 1))) - (else - (mvwaddstr win y 0 (element-text (car elts))) - (lp (cdr elts) (+ y 1) (+ i 1))))))) + (let ((num-lines (select-list-num-lines select-list))) + (let lp ((elts + (select-visible-elements select-list num-lines)) + (y y) + (i (select-list-view-index select-list))) + (cond + ((null? elts) + (values)) + ((= i (select-list-cursor-index select-list)) + (wattron win (A-REVERSE)) + (mvwaddstr win y x (element-text (car elts))) + (wattrset win (A-NORMAL)) + (lp (cdr elts) (+ y 1) (+ i 1))) + ((element-marked? (car elts)) + (wattron win (A-BOLD)) + (mvwaddstr win y x (element-text (car elts))) + (wattrset win (A-NORMAL)) + (lp (cdr elts) (+ y 1) (+ i 1))) + (else + (mvwaddstr win y x (element-text (car elts))) + (lp (cdr elts) (+ y 1) (+ i 1))))))))