345 lines
11 KiB
Scheme
345 lines
11 KiB
Scheme
|
;;This addition provides the capability of displaying a list.
|
||
|
|
;;There is only one list-item per line - if the item is too long for one
|
||
|
|
;;single line it's symbolic representation is seperated into more
|
||
|
|
;;than one lines.
|
||
|
|
;;The user can scroll up and down in the list and he can select the items
|
||
|
|
;;and later paste this newly-created list into the upper buffer.
|
||
|
|
|
||
|
|
|
||
|
|
;;Result-Object-Data-Type
|
||
|
|
(define-record-type browse-list-res-obj browse-list-res-obj
|
||
|
|
(make-browse-list-res-obj pos-y
|
||
|
|
pos-x
|
||
|
|
line
|
||
|
|
col-in-line
|
||
|
|
list
|
||
|
|
result-text
|
||
|
|
width
|
||
|
|
marked-items
|
||
|
|
marked-pos
|
||
|
|
c-x-pressed)
|
||
|
|
browse-list-res-obj?
|
||
|
|
(pos-y browse-list-res-obj-pos-y)
|
||
|
|
(pos-x browse-list-res-obj-pos-x)
|
||
|
|
(line browse-list-res-obj-line)
|
||
|
|
(col-in-line browse-list-res-obj-col-in-line)
|
||
|
|
(list browse-list-res-obj-file-list)
|
||
|
|
(result-text browse-list-res-obj-result-text)
|
||
|
|
(width browse-list-res-obj-width)
|
||
|
|
(marked-items browse-list-res-obj-marked-items)
|
||
|
|
(marked-pos browse-list-res-obj-marked-pos)
|
||
|
|
(c-x-pressed browse-list-res-obj-c-x-pressed))
|
||
|
|
|
||
|
|
|
||
|
|
;;The layout-function
|
||
|
|
;;All lines are seperated
|
||
|
|
(define layout-result-browse-list
|
||
|
|
(lambda (lst width)
|
||
|
|
(let loop ((pos-list 0)
|
||
|
|
(buffer '()))
|
||
|
|
(if (= pos-list (length lst))
|
||
|
|
buffer
|
||
|
|
(loop (+ pos-list 1)
|
||
|
|
(append buffer
|
||
|
|
(seperated-line (list-ref lst pos-list) width)))))))
|
||
|
|
|
||
|
|
;;seperate one line -> return a list of the single lines
|
||
|
|
(define seperated-line
|
||
|
|
(lambda (el width)
|
||
|
|
(let loop ((old el)
|
||
|
|
(new '()))
|
||
|
|
(if (<= (string-length old) 0)
|
||
|
|
new
|
||
|
|
(if (>= (string-length old) width)
|
||
|
|
(let* ((old-cut (substring old width (string-length old)))
|
||
|
|
(new-app (string-append " " (substring old 0 width))))
|
||
|
|
(loop old-cut (append new (list new-app))))
|
||
|
|
(append new (list (string-append " " old))))))))
|
||
|
|
|
||
|
|
;;compute where the Cursor has to be put.
|
||
|
|
;;The cursor is always located in the last line of one item of the list
|
||
|
|
(define compute-pos-y
|
||
|
|
(lambda (pos lst width)
|
||
|
|
(let* ((before-pos (sublist lst 0 pos))
|
||
|
|
(seperated-before (layout-result-browse-list before-pos width))
|
||
|
|
(pos-before (length seperated-before)))
|
||
|
|
pos-before)))
|
||
|
|
|
||
|
|
;;Find out which lines of the buffer are to highlight.
|
||
|
|
;;Only those lines are highlighted, which contain the active item.
|
||
|
|
(define get-highlighted-browse-list
|
||
|
|
(lambda (line lst pos-y width)
|
||
|
|
(let* ((act-line (list-ref lst (- line 1)))
|
||
|
|
(seperated (seperated-line act-line width))
|
||
|
|
(length-seperated (length seperated))
|
||
|
|
(first-pos (- pos-y length-seperated)))
|
||
|
|
(let loop ((count 1)
|
||
|
|
(res '()))
|
||
|
|
(if (> count length-seperated)
|
||
|
|
res
|
||
|
|
(loop (+ count 1)
|
||
|
|
(append res (list (+ count first-pos)))))))))
|
||
|
|
|
||
|
|
;;find out which lines are to be marked. Lines are marked if they have
|
||
|
|
;;recently been selected
|
||
|
|
(define get-marked-pos-browse
|
||
|
|
(lambda (marked lst width)
|
||
|
|
(let loop ((m marked)
|
||
|
|
(new '()))
|
||
|
|
(if (null? m)
|
||
|
|
new
|
||
|
|
(let* ((pos (car m)))
|
||
|
|
(loop (cdr m)
|
||
|
|
(append (get-marked-browse-list pos lst width)
|
||
|
|
new )))))))
|
||
|
|
|
||
|
|
(define get-marked-browse-list
|
||
|
|
(lambda (pos lst width)
|
||
|
|
(let* ((act-line (list-ref lst (- pos 1)))
|
||
|
|
(seperated (seperated-line act-line width))
|
||
|
|
(length-seperated (length seperated))
|
||
|
|
(before-pos (sublist lst 0 pos))
|
||
|
|
(seperated-before (layout-result-browse-list before-pos width))
|
||
|
|
(length-before (- (length seperated-before) length-seperated)))
|
||
|
|
(let loop ((res '())
|
||
|
|
(count 1))
|
||
|
|
(if (> count length-seperated)
|
||
|
|
res
|
||
|
|
(loop (cons (+ length-before count) res)
|
||
|
|
(+ count 1)))))))
|
||
|
|
|
||
|
|
|
||
|
|
;;Receiving-Function, that answers to incomming messages and changes state
|
||
|
|
;;of the passed "browse-list-res-obj"
|
||
|
|
(define browse-list-receiver
|
||
|
|
(lambda (message)
|
||
|
|
(cond
|
||
|
|
((next-command-message? message)
|
||
|
|
(let* ((command (next-command-string message))
|
||
|
|
(parameters (next-command-message-parameters message))
|
||
|
|
(result #f)
|
||
|
|
(width (next-command-message-width message)))
|
||
|
|
(if (< (length parameters) 1)
|
||
|
|
(begin
|
||
|
|
(set! result (list "forgot parameter?"))
|
||
|
|
(let* ((text
|
||
|
|
(layout-result-standard "forgot parameters?"
|
||
|
|
result width))
|
||
|
|
(browse-obj
|
||
|
|
(make-browse-list-res-obj 1 1 1 1 result text
|
||
|
|
width '() '() #f)))
|
||
|
|
browse-obj))
|
||
|
|
|
||
|
|
(let ((lst
|
||
|
|
(evaluate (list-ref parameters 0))))
|
||
|
|
(if (not (null? lst))
|
||
|
|
(let*
|
||
|
|
((result-string (map exp->string lst))
|
||
|
|
(text
|
||
|
|
(layout-result-browse-list result-string
|
||
|
|
(- width 1)))
|
||
|
|
(sep-line-1 (seperated-line
|
||
|
|
(exp->string (list-ref lst 0)) width))
|
||
|
|
(pos-y (length sep-line-1))
|
||
|
|
(browse-obj
|
||
|
|
(make-browse-list-res-obj pos-y 1 1 1 lst text width
|
||
|
|
'() '() #f)))
|
||
|
|
browse-obj)
|
||
|
|
(let
|
||
|
|
((browse-obj
|
||
|
|
(make-browse-list-res-obj 1 1 1 1 '("") '("") width
|
||
|
|
'() '() #f)))
|
||
|
|
browse-obj))))))
|
||
|
|
|
||
|
|
((print-message? message)
|
||
|
|
(let* ((model (print-message-object message))
|
||
|
|
(pos-y (browse-list-res-obj-pos-y model))
|
||
|
|
(pos-x (browse-list-res-obj-pos-x model))
|
||
|
|
(text (browse-list-res-obj-result-text model))
|
||
|
|
(line (browse-list-res-obj-line model))
|
||
|
|
(lst (map exp->string (browse-list-res-obj-file-list model)))
|
||
|
|
(width (browse-list-res-obj-width model))
|
||
|
|
(marked (browse-list-res-obj-marked-items model))
|
||
|
|
(marked-pos (browse-list-res-obj-marked-pos model))
|
||
|
|
(real-marked-pos (get-marked-pos-browse
|
||
|
|
marked-pos
|
||
|
|
lst
|
||
|
|
width))
|
||
|
|
(highlighted (get-highlighted-browse-list line lst pos-y width)))
|
||
|
|
(make-print-object pos-y pos-x text highlighted real-marked-pos)))
|
||
|
|
|
||
|
|
((key-pressed-message? message)
|
||
|
|
(let* ((model (key-pressed-message-result-model message))
|
||
|
|
(key (key-pressed-message-key message))
|
||
|
|
(c-x-pressed (browse-list-res-obj-c-x-pressed model)))
|
||
|
|
|
||
|
|
|
||
|
|
(if c-x-pressed
|
||
|
|
|
||
|
|
(cond
|
||
|
|
;;Ctrl+x s ->selection
|
||
|
|
((= key 115)
|
||
|
|
(let* ((marked-items (browse-list-res-obj-marked-items model))
|
||
|
|
(actual-pos (browse-list-res-obj-line model))
|
||
|
|
(all-items (browse-list-res-obj-file-list model)))
|
||
|
|
(if (< actual-pos 1)
|
||
|
|
model
|
||
|
|
(let* ((actual-item (list-ref all-items (- actual-pos 1))))
|
||
|
|
(begin
|
||
|
|
(if (member actual-item marked-items)
|
||
|
|
model
|
||
|
|
(let*
|
||
|
|
((new-marked-items (append marked-items
|
||
|
|
(list actual-item)))
|
||
|
|
(new-marked-pos (append
|
||
|
|
(list actual-pos)
|
||
|
|
(browse-list-res-obj-marked-pos
|
||
|
|
model)))
|
||
|
|
(new-model (make-browse-list-res-obj
|
||
|
|
(browse-list-res-obj-pos-y model)
|
||
|
|
(browse-list-res-obj-pos-x model)
|
||
|
|
(browse-list-res-obj-line model)
|
||
|
|
(browse-list-res-obj-col-in-line
|
||
|
|
model)
|
||
|
|
(browse-list-res-obj-file-list
|
||
|
|
model)
|
||
|
|
(browse-list-res-obj-result-text
|
||
|
|
model)
|
||
|
|
(browse-list-res-obj-width model)
|
||
|
|
new-marked-items
|
||
|
|
new-marked-pos
|
||
|
|
#f)))
|
||
|
|
new-model)))))))
|
||
|
|
|
||
|
|
|
||
|
|
;;Ctrl+x u -> unselect
|
||
|
|
((= key 117)
|
||
|
|
(let* ((marked-items (browse-list-res-obj-marked-items model))
|
||
|
|
(marked-pos (browse-list-res-obj-marked-pos model))
|
||
|
|
(actual-pos (browse-list-res-obj-line model))
|
||
|
|
(all-items (browse-list-res-obj-file-list model)))
|
||
|
|
(if (< actual-pos 1)
|
||
|
|
model
|
||
|
|
(let* ((actual-item (list-ref all-items (- actual-pos 1)))
|
||
|
|
(rest (member actual-item marked-items))
|
||
|
|
(rest-pos (member actual-pos marked-pos)))
|
||
|
|
(if (not rest)
|
||
|
|
model
|
||
|
|
(let* ((after-item (length rest))
|
||
|
|
(after-marked (length rest-pos))
|
||
|
|
(all-items (length marked-items))
|
||
|
|
(all-marked (length marked-pos))
|
||
|
|
(before-item (sublist marked-items
|
||
|
|
0
|
||
|
|
(- all-items
|
||
|
|
after-item )))
|
||
|
|
(before-marked (sublist marked-pos
|
||
|
|
0
|
||
|
|
(- all-marked
|
||
|
|
after-marked)))
|
||
|
|
(new-marked-items (append before-item
|
||
|
|
(list-tail rest 1)))
|
||
|
|
(new-marked-pos (append before-marked
|
||
|
|
(list-tail rest-pos 1)))
|
||
|
|
(new-model (make-browse-list-res-obj
|
||
|
|
(browse-list-res-obj-pos-y model)
|
||
|
|
(browse-list-res-obj-pos-x model)
|
||
|
|
(browse-list-res-obj-line model)
|
||
|
|
(browse-list-res-obj-col-in-line
|
||
|
|
model)
|
||
|
|
(browse-list-res-obj-file-list
|
||
|
|
model)
|
||
|
|
(browse-list-res-obj-result-text
|
||
|
|
model)
|
||
|
|
(browse-list-res-obj-width model)
|
||
|
|
new-marked-items
|
||
|
|
new-marked-pos
|
||
|
|
#f)))
|
||
|
|
new-model))))))
|
||
|
|
|
||
|
|
(else
|
||
|
|
(make-browse-list-res-obj
|
||
|
|
(browse-list-res-obj-pos-y model)
|
||
|
|
(browse-list-res-obj-pos-x model)
|
||
|
|
(browse-list-res-obj-line model)
|
||
|
|
(browse-list-res-obj-col-in-line
|
||
|
|
model)
|
||
|
|
(browse-list-res-obj-file-list
|
||
|
|
model)
|
||
|
|
(browse-list-res-obj-result-text
|
||
|
|
model)
|
||
|
|
(browse-list-res-obj-width model)
|
||
|
|
(browse-list-res-obj-marked-items model)
|
||
|
|
(browse-list-res-obj-marked-pos model)
|
||
|
|
#f)))
|
||
|
|
|
||
|
|
(cond
|
||
|
|
|
||
|
|
;;ctrl+x
|
||
|
|
((= key 24)
|
||
|
|
(make-browse-list-res-obj
|
||
|
|
(browse-list-res-obj-pos-y model)
|
||
|
|
(browse-list-res-obj-pos-x model)
|
||
|
|
(browse-list-res-obj-line model)
|
||
|
|
(browse-list-res-obj-col-in-line
|
||
|
|
model)
|
||
|
|
(browse-list-res-obj-file-list
|
||
|
|
model)
|
||
|
|
(browse-list-res-obj-result-text
|
||
|
|
model)
|
||
|
|
(browse-list-res-obj-width model)
|
||
|
|
(browse-list-res-obj-marked-items model)
|
||
|
|
(browse-list-res-obj-marked-pos model)
|
||
|
|
#t))
|
||
|
|
|
||
|
|
|
||
|
|
((= key key-up)
|
||
|
|
(let ((line (browse-list-res-obj-line model))
|
||
|
|
(lst (map exp->string (browse-list-res-obj-file-list model)))
|
||
|
|
(width (browse-list-res-obj-width model)))
|
||
|
|
(if (<= line 1)
|
||
|
|
model
|
||
|
|
(let* ((new-line (- line 1))
|
||
|
|
(pos-y (compute-pos-y new-line lst width)))
|
||
|
|
(make-browse-list-res-obj
|
||
|
|
pos-y 1 new-line 1
|
||
|
|
(browse-list-res-obj-file-list model)
|
||
|
|
(browse-list-res-obj-result-text model)
|
||
|
|
(browse-list-res-obj-width model)
|
||
|
|
(browse-list-res-obj-marked-items model)
|
||
|
|
(browse-list-res-obj-marked-pos model)
|
||
|
|
#f)))))
|
||
|
|
|
||
|
|
((= key key-down)
|
||
|
|
(let ((line (browse-list-res-obj-line model))
|
||
|
|
(lst (map exp->string (browse-list-res-obj-file-list model)))
|
||
|
|
(width (browse-list-res-obj-width model)))
|
||
|
|
(if (>= line (length lst))
|
||
|
|
model
|
||
|
|
(let* ((new-line (+ line 1))
|
||
|
|
(pos-y (compute-pos-y new-line lst width)))
|
||
|
|
(make-browse-list-res-obj
|
||
|
|
pos-y 1 new-line 1
|
||
|
|
(browse-list-res-obj-file-list model)
|
||
|
|
(browse-list-res-obj-result-text model)
|
||
|
|
(browse-list-res-obj-width model)
|
||
|
|
(browse-list-res-obj-marked-items model)
|
||
|
|
(browse-list-res-obj-marked-pos model)
|
||
|
|
#f)))))
|
||
|
|
|
||
|
|
(else model)))))
|
||
|
|
|
||
|
|
|
||
|
|
((selection-message? message)
|
||
|
|
(let* ((model (selection-message-object message))
|
||
|
|
(marked-items (browse-list-res-obj-marked-items model)))
|
||
|
|
(string-append "'" (exp->string marked-items))))
|
||
|
|
|
||
|
|
)))
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
(define browse-list-rec (make-receiver "browse-list"
|
||
|
|
browse-list-receiver))
|
||
|
|
|
||
|
|
(set! receivers (cons browse-list-rec receivers))
|