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

Kill `browse-list' plugin. Introduce module `select-list', a library 

for programming multi-page menus in the result-buffer. Remove the
print-object and make plugins return a function to paint the
result-buffer instead.
This commit is contained in:
eknauel 2005-05-25 09:44:27 +00:00
parent 4e7e1301cb
commit 0447ccfa3e
10 changed files with 474 additions and 223 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -161,7 +161,11 @@
(marked-pos (get-marked-positions-3
(browse-dir-list-res-obj-file-list model)
(browse-dir-list-res-obj-marked-items model))))
(make-print-object pos-y pos-x text (list pos-y) marked-pos)))
(debug-message "browse-dir-list-receiver "
"pos-y " pos-y " pos-x " pos-x
" marked-pos " marked-pos)
(make-simple-result-buffer-printer
pos-y pos-x text (list pos-y) marked-pos)))
((key-pressed-message? message)
(let* ((model (message-result-object message))

12
scheme/eval.scm
View File

@ -1,3 +1,15 @@
(define-syntax run/strings-status
(syntax-rules ()
((_ epf)
(call-with-values
(lambda ()
(run/port+proc epf))
(lambda (port proc)
(let ((string-list (port->string-list port))
(status (wait proc)))
(close-input-port port)
(values string-list status)))))))
(define (directory-files . optional-args)
(let-optionals optional-args
((dir (cwd))

5
scheme/inspector.scm
View File

@ -23,8 +23,9 @@
(let ((val (inspector-state-val (message-result-object message))))
(let ((head-line (format #f "~a" val))
(menu (map (lambda (val) (format #f "~a" val)) (prepare-menu val))))
(make-print-object 1 1 (cons head-line menu)
'() '()))))
(make-simple-result-buffer-printer
1 1 (cons head-line menu) '() '()))))
((key-pressed-message? message)
(let ((old-state (message-result-object message))
(key (key-pressed-message-key message)))

126
scheme/layout.scm
View File

@ -61,3 +61,129 @@
(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)))))))))))

207
scheme/nuit-engine.scm
View File

@ -56,31 +56,11 @@
;;state of the lower window (Result-Window)
;;----------------------------
;;Text
(define text-result (list "Type 'shortcuts' for help"))
;;line of the result-window
(define pos-result 0)
;;column
(define pos-result-col 0)
;;y-coordinate of the cursor in the result-buffer
(define result-buffer-pos-y 0)
;;x-coordinate of the cursor in the result-buffer
(define result-buffer-pos-x 0)
;;lines of the lower window
(define result-lines 0)
;;columns in the lower window
(define result-cols 0)
;;lines to be highlighted
(define highlighted-lines '())
;;lines to be marked
(define marked-lines '())
(define result-buffer
(make-result-buffer 0 0 0 0
#f #f ; set in INIT-WINDOWS
'() '()))
;;miscelaneous state
;;-------------------
@ -221,7 +201,7 @@
(refresh-result-window))
(else
(focus-command-buffer!)
(move-cursor command-buffer)
(move-cursor command-buffer result-buffer)
(refresh-command-window))))
(define (toggle-command/scheme-mode)
@ -232,7 +212,7 @@
(enter-command-mode!)))
(paint-command-frame-window)
(paint-command-window-contents)
(move-cursor command-buffer)
(move-cursor command-buffer result-buffer)
(refresh-command-window))
(define (handle-return-key)
@ -323,6 +303,7 @@
(let ((key-message
(make-key-pressed-message
(active-command) (current-result)
result-buffer
ch key-control-x)))
(update-current-result!
(post-message
@ -373,8 +354,10 @@
(history-entry-plugin (entry-data (current-history-item)))
(make-key-pressed-message
(active-command) (current-result)
result-buffer
ch c-x-pressed?)))
(paint-result-window (entry-data (current-history-item)))
(move-cursor command-buffer result-buffer)
(refresh-result-window))
(loop (wait-for-input) #f))
(else
@ -382,7 +365,7 @@
(werase (app-window-curses-win command-window))
(print-command-buffer (app-window-curses-win command-window)
command-buffer)
(move-cursor command-buffer)
(move-cursor command-buffer result-buffer)
(refresh-command-window)
(loop (wait-for-input) c-x-pressed?)))))))
@ -427,6 +410,11 @@
command-frame-window command-window
result-frame-window result-window)))
(for-each window-init-curses-win! all-windows)
(set-result-buffer-num-lines!
result-buffer (- (app-window-height result-window) 2))
(set-result-buffer-num-cols!
result-buffer (- (app-window-width result-window) 3))
(debug-message "init-windows!: bar-1 " bar-1
" active-command-window " active-command-window
@ -480,9 +468,6 @@
(let ((win (app-window-curses-win result-frame-window)))
(wclear win)
(box win (ascii->char 0) (ascii->char 0))
;;; EK: wtf is going on here?
(set! result-lines (- (app-window-height result-window) 2))
(set! result-cols (- (app-window-width result-window) 3))
(wrefresh win)))
(define (paint-result-window entry)
@ -502,7 +487,7 @@
(paint-active-command-window)
(scroll-command-buffer)
(paint-command-window-contents)
(move-cursor command-buffer)
(move-cursor command-buffer result-buffer)
(refresh-result-window)
(refresh-command-window))
@ -514,7 +499,7 @@
(paint-active-command-window)
(paint-result-frame-window)
;(paint-result-window)
(move-cursor command-buffer)
(move-cursor command-buffer result-buffer)
(refresh-command-window)
(refresh-result-window))
@ -665,17 +650,6 @@
(add-to-command-buffer (char->ascii first-ch))
(loop (substring str 1 (string-length str)))))))
;;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))))
;;; FIXME: I guess s48 knows a better way to do this (see ,inspect)
(define (maybe-shorten-string string width)
(if (> (string-length string) width)
@ -696,115 +670,35 @@
(history-entry-command (entry-data entry)) width)))))
(wrefresh win)))
(define (paint-result-buffer print-object)
(let* ((window (app-window-curses-win result-window))
(text (print-object-text print-object))
(pos-y (print-object-pos-y print-object))
(pos-x (print-object-pos-x print-object))
(highlighted-lns (print-object-highlighted-lines print-object))
(marked-lns (print-object-marked-lines print-object)))
(set! text-result text)
(set! pos-result pos-y)
(set! pos-result-col pos-x)
(set! highlighted-lines highlighted-lns)
(set! marked-lines marked-lns)
(right-highlighted-lines)
(right-marked-lines)
(let ((lines (get-right-result-lines)))
(let loop ((pos 1))
(if (> pos result-lines)
(values)
(let ((line (list-ref lines (- pos 1))))
(begin
(if (not (standard-result-obj? (current-result)))
(set! 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 (member pos highlighted-lines)
(focus-on-result-buffer?))
(begin
(wattron window (A-REVERSE))
(mvwaddstr window pos 1 line)
(wattrset window (A-NORMAL))
;(wrefresh window)
(loop (+ pos 1)))
(if (member pos marked-lines)
(begin
(wattron window (A-BOLD))
(mvwaddstr window pos 1 line)
(wattrset window (A-NORMAL))
;(wrefresh window)
(loop (+ pos 1)))
(begin
(mvwaddstr window pos 1 line)
;(wrefresh window)
(loop (+ pos 1))))))))))))
(define (paint-result-buffer paint-proc)
(paint-proc (app-window-curses-win result-window)
result-buffer
(focus-on-result-buffer?)))
;;visible lines
(define (get-right-result-lines)
(prepare-lines text-result result-lines pos-result))
;;marked and highlighted lines
(define (right-highlighted-lines)
(let loop ((old highlighted-lines)
(new '()))
(if (null? old)
(set! highlighted-lines 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 (right-marked-lines)
(let loop ((old marked-lines)
(new '()))
(if (null? old)
(set! marked-lines 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)))))))))
;;Cursor
;;move cursor to the corrct position
(define (move-cursor buffer)
(if (focus-on-command-buffer?)
(cursor-right-pos (app-window-curses-win command-window)
buffer)
(begin
(compute-y-x)
(wmove (app-window-curses-win result-window)
result-buffer-pos-y result-buffer-pos-x)
(wrefresh (app-window-curses-win result-window))
buffer)))
(define (move-cursor command-buffer result-buffer)
(cond
((focus-on-command-buffer?)
(cursor-right-pos
(app-window-curses-win command-window)
command-buffer))
(else
(compute-y-x result-buffer)
(wmove (app-window-curses-win result-window)
(result-buffer-y result-buffer)
(result-buffer-x result-buffer))
(wrefresh (app-window-curses-win result-window)))))
;;compue pos-x and pos-y
(define (compute-y-x)
(if (>= pos-result result-lines)
(set! result-buffer-pos-y result-lines)
(set! result-buffer-pos-y pos-result))
(set! result-buffer-pos-x pos-result-col))
(define (compute-y-x result-buffer)
(let ((pos-result (result-buffer-line result-buffer))
(pos-result-col (result-buffer-column result-buffer))
(result-lines (result-buffer-num-lines result-buffer)))
(if (>= pos-result result-lines)
(set-result-buffer-y! result-buffer result-lines)
(set-result-buffer-y! result-buffer pos-result))
(set-result-buffer-x! result-buffer pos-result-col)))
(define (sublist l pos k)
(let ((tmp (list-tail l pos)))
@ -814,15 +708,6 @@
;;When NUIT is closed the state has to be restored, in order to let the
;;user start again from scratch
(define (restore-state)
(set! text-result (list "Start entering commands."))
(set! pos-result 0)
(set! pos-result-col 0)
(set! result-buffer-pos-y 0)
(set! result-buffer-pos-x 0)
(set! result-lines 0)
(set! result-cols 0)
(set! highlighted-lines '())
(set! marked-lines '())
(set! history '())
(set! history-pos 0)
(set! active-keyboard-interrupt #f))
@ -846,8 +731,8 @@
(result-text standard-result-obj-result-text)
(result standard-result-obj-result))
(define init-std-res (make-standard-result-obj 1 1 text-result
(car text-result)))
(define init-std-res
(make-standard-result-obj 1 1 '("") ""))
;;Standard-Receiver:
(define (standard-receiver-rec message)
@ -873,8 +758,10 @@
(width (print-message-width message))
(result (standard-result-obj-result model))
(text (layout-result-standard
(exp->string result) width)))
(make-print-object pos-y pos-x text '() '())))
(exp->string result) width)))
(make-simple-result-buffer-printer
pos-y pos-x text '() '())))
((key-pressed-message? message)
(message-result-object message))
((restore-message? message)

80
scheme/nuit-packages.scm
View File

@ -26,12 +26,36 @@
get-marked-positions-2
get-marked-positions-3
exp->string
sublist))
sublist
;; old drawing cruft
make-result-buffer
result-buffer?
result-buffer-line
set-result-buffer-line!
result-buffer-column
set-result-buffer-column!
result-buffer-y
set-result-buffer-y!
result-buffer-x
set-result-buffer-x!
result-buffer-num-lines
set-result-buffer-num-lines!
result-buffer-num-cols
set-result-buffer-num-cols!
result-buffer-highlighted
set-result-buffer-highlighted!
result-buffer-marked
set-result-buffer-marked!
make-simple-result-buffer-printer))
(define-structure layout layout-interface
(open scheme
srfi-6 ;; basic string ports
)
define-record-types
tty-debug
ncurses)
(files layout))
;;; process viewer plugin
@ -39,10 +63,14 @@
(define-structure process-view-plugin
(export)
(open scheme
define-record-types
srfi-1
srfi-13
formats
pps
plugin
select-list
tty-debug)
(files process))
@ -60,17 +88,6 @@
tty-debug)
(files browse-directory-list))
;;; browse-list plugin
(define-structure browse-list-plugin
(export)
(open scheme
define-record-types
ncurses
plugin
layout)
(files browse-list))
;;; standard command plugin
(define-structure standard-command-plugin
@ -92,6 +109,31 @@
define-record-types)
(files fs-object))
;;; browse list stuff
(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))
(define-structure select-list select-list-interface
(open scheme
srfi-1
define-record-types
tty-debug
plugin
layout
ncurses)
(files select-list))
;;; inspector
(define-interface nuit-inspector-interface
@ -104,6 +146,7 @@
formats
define-record-types
layout
tty-debug
plugin)
(files inspector))
@ -138,14 +181,6 @@
register-plugin!
make-print-object
print-object?
print-object-pos-y
print-object-pos-x
print-object-text
print-object-highlighted-lines
print-object-marked-lines
next-command-message?
next-command-string
next-command-message-parameters
@ -156,6 +191,7 @@
init-with-result-message-width
key-pressed-message?
key-pressed-message-result-buffer
key-pressed-message-result-object
key-pressed-message-key
key-pressed-message-prefix-key
@ -223,11 +259,9 @@
pps
history
;; the following modules are plugins
browse-list-plugin
dirlist-view-plugin
process-view-plugin
standard-command-plugin
nuit-inspector-plugin)
(files nuit-engine
handle-fatal-error))

17
scheme/plugins.scm
View File

@ -29,21 +29,6 @@
(set! *view-plugins* (cons plugin *view-plugins*)))
(error "unknown plugin type" plugin)))
;; answers
(define-record-type print-object :print-object
(make-print-object pos-y
pos-x
text
highlighted-lines
marked-lines)
print-object?
(pos-y print-object-pos-y)
(pos-x print-object-pos-x)
(text print-object-text)
(highlighted-lines print-object-highlighted-lines)
(marked-lines print-object-marked-lines))
;; messages
(define-record-type next-command-message :next-command-message
@ -67,10 +52,12 @@
(define-record-type key-pressed-message :key-pressed-message
(make-key-pressed-message command-string
result-object
result-buffer
key prefix-key)
key-pressed-message?
(command-string key-pressed-command-string)
(result-object key-pressed-message-result-object)
(result-buffer key-pressed-message-result-buffer)
(key key-pressed-message-key)
(prefix-key key-pressed-message-prefix-key))

74
scheme/process.scm
View File

@ -1,37 +1,69 @@
(define-record-type plugin-state :plugin-state
(make-plugin-state processes selection-list cursor-x)
plugin-state?
(processes plugin-state-processes)
(selection-list plugin-state-selection-list)
(cursor-x plugin-state-cursor-x))
(define-record-discloser :plugin-state
(lambda (r)
`(plugin-state ,(plugin-state-selection-list r))))
(define (list-of-processes? thing)
(and (proper-list? thing)
(every process-info? thing)))
(define (print-processes processes)
(map (lambda (pi)
(apply format
(append
(list #f
"~A ~A ~A ~A '~A ~A'~%")
(map (lambda (s) (s pi))
(list process-info-pid
process-info-ppid
process-info-real-uid
process-info-%cpu
process-info-executable
process-info-command-line)))))
processes))
(define (string-take-max s nchars)
(if (>= nchars (string-length s))
s
(string-take s nchars)))
(define (layout-process width p)
(string-take-max
(apply format
(append
(list #f "~A ~A ~A ~A '~A ~A'~%")
(map (lambda (s) (s p))
(list process-info-pid
process-info-ppid
process-info-real-uid
process-info-%cpu
process-info-executable
process-info-command-line))))
width))
(define (make-process-selection-list width processes)
(let ((layout (lambda (p) (layout-process width p))))
(make-select-list
(zip processes (map layout processes)))))
(define (pps-receiver message)
(debug-message "pps-receiver " message)
(cond
((next-command-message? message)
(pps))
((init-with-result-message? message)
(init-with-result-message-result message))
(let ((processes (init-with-result-message-result message))
(width (init-with-result-message-width message)))
(make-plugin-state
processes (make-process-selection-list width processes) 1)))
((print-message? message)
(let ((processes (message-result-object message)))
(make-print-object 1 1 (print-processes processes)
'() '())))
(paint-selection-list
(plugin-state-selection-list
(message-result-object message))))
((key-pressed-message? message)
(pps))
(let ((old-state (message-result-object message)))
(make-plugin-state
(plugin-state-processes old-state)
(select-list-handle-key-press
(plugin-state-selection-list old-state)
message)
(plugin-state-cursor-x old-state))))
((restore-message? message)
(values))
((selection-message? message)
"'()")))

168
scheme/select-list.scm Normal file
View File

@ -0,0 +1,168 @@
(define-record-type element :element
(make-element marked? value text)
element?
(marked? element-marked? set-element-marked?!)
(value element-value)
(text element-text))
(define-record-discloser :element
(lambda (r)
`(element ,(element-marked? r) ,(element-text r))))
(define (make-unmarked-element value text)
(make-element #f value text))
(define-record-type select-list :select-list
(really-make-select-list elements view-index cursor-index cursor-y)
select-list?
(elements select-list-elements)
(view-index select-list-view-index)
(cursor-index select-list-cursor-index)
(cursor-y select-list-cursor-y))
(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)))))
(define (make-select-list value/text-tuples)
(really-make-select-list
(map (lambda (value/text)
(apply make-unmarked-element value/text))
value/text-tuples)
0 0 1))
(define key-m 109)
(define key-u 117)
(define (select-list-handle-key-press select-list key-message)
(let ((key (key-pressed-message-key key-message))
(result-buffer (key-pressed-message-result-buffer key-message)))
(cond
((= key key-m)
(mark-current-line select-list))
((= key key-u)
(unmark-current-line select-list))
((= key key-up)
(move-cursor-up select-list result-buffer))
((= key key-down)
(move-cursor-down select-list result-buffer))
(else
select-list))))
(define (mark/unmark-current-line-maker mark)
(lambda (select-list)
(let* ((index (select-list-cursor-index select-list))
(elements (select-list-elements select-list)))
(really-make-select-list
(fold-right
(lambda (element.i result)
(let ((el (car element.i))
(i (cadr element.i)))
(cons (make-element
(if (= index i) mark (element-marked? el))
(element-value el)
(element-text el))
result)))
'() (zip elements (iota (length elements))))
(select-list-view-index select-list)
index (select-list-cursor-y select-list)))))
(define unmark-current-line
(mark/unmark-current-line-maker #f))
(define mark-current-line
(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)
(let ((new-index (index-move cursor-index))
(max-index (- (length elements) 1)))
(cond
((< new-index 0)
(values 0 0 view-index))
((> new-index max-index)
(values y max-index view-index))
((and (>= (- new-index view-index) num-lines)
(> new-index cursor-index))
(values 1 new-index (+ view-index num-lines)))
((and (< new-index cursor-index)
(>= view-index cursor-index))
(values num-lines new-index (- view-index num-lines)))
(else
(values (cursor-move y) (index-move cursor-index) view-index)))))
(define (copy-element-list elements)
(fold-right
(lambda (el result)
(cons
(make-element (element-marked? el)
(element-value el)
(element-text el))
result))
'() elements))
(define (move-cursor-maker index-move cursor-move)
(lambda (select-list result-buffer)
(let* ((elements (select-list-elements select-list))
(old-index (select-list-cursor-index select-list)))
(call-with-values
(lambda ()
(calculate-view index-move cursor-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)
(really-make-select-list
(copy-element-list elements)
view-index
cursor-index
y))))))
(define move-cursor-up
(let ((sub-one (lambda (y) (- y 1))))
(move-cursor-maker sub-one sub-one)))
(define move-cursor-down
(let ((add-one (lambda (y) (+ y 1))))
(move-cursor-maker add-one add-one)))
(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 (paint-selection-list select-list)
(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)))))))

2
scheme/std-command.scm
View File

@ -2,7 +2,7 @@
#f)
(define (standard-command-plugin-evaluater command args)
(directory-files))
(run/strings (,command ,@args)))
(define standard-command-plugin
(make-command-plugin #f