scsh-conservatory
/
commander-s
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

new features for selection-lists: list length is now adjustable, may 

be placed at arbitrary position in the result buffer
This commit is contained in:
eknauel 2005-05-25 11:36:12 +00:00
parent 0447ccfa3e
commit 83909af4ac
6 changed files with 77 additions and 69 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
scheme/browse-directory-list.scm
View File

@ -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)))

7
scheme/nuit-engine.scm
View File

@ -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)))

9
scheme/nuit-packages.scm
View File

@ -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

4
scheme/plugins.scm
View File

@ -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

16
scheme/process.scm
View File

@ -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

107
scheme/select-list.scm
View File

@ -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))))))))